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
;
4517 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4518 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4520 /* Skip absent members in default initializers. */
4524 /* Handle c_null_(fun)ptr. */
4525 if (c
&& c
->expr
&& c
->expr
->ts
.is_iso_c
)
4527 field
= cm
->backend_decl
;
4528 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
,
4530 dest
, field
, NULL_TREE
);
4531 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (tmp
),
4532 tmp
, fold_convert (TREE_TYPE (tmp
),
4533 null_pointer_node
));
4534 gfc_add_expr_to_block (&block
, tmp
);
4538 field
= cm
->backend_decl
;
4539 tmp
= fold_build3_loc (input_location
, COMPONENT_REF
, TREE_TYPE (field
),
4540 dest
, field
, NULL_TREE
);
4541 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4542 gfc_add_expr_to_block (&block
, tmp
);
4544 return gfc_finish_block (&block
);
4547 /* Build an expression for a constructor. If init is nonzero then
4548 this is part of a static variable initializer. */
4551 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4558 VEC(constructor_elt
,gc
) *v
= NULL
;
4560 gcc_assert (se
->ss
== NULL
);
4561 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4562 type
= gfc_typenode_for_spec (&expr
->ts
);
4566 /* Create a temporary variable and fill it in. */
4567 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4568 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4569 gfc_add_expr_to_block (&se
->pre
, tmp
);
4573 cm
= expr
->ts
.u
.derived
->components
;
4575 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4576 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4578 /* Skip absent members in default initializers and allocatable
4579 components. Although the latter have a default initializer
4580 of EXPR_NULL,... by default, the static nullify is not needed
4581 since this is done every time we come into scope. */
4582 if (!c
->expr
|| cm
->attr
.allocatable
)
4585 if (strcmp (cm
->name
, "_size") == 0)
4587 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4588 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4590 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4591 && strcmp (cm
->name
, "_extends") == 0)
4595 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4596 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4597 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4601 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4602 TREE_TYPE (cm
->backend_decl
),
4603 cm
->attr
.dimension
, cm
->attr
.pointer
,
4604 cm
->attr
.proc_pointer
);
4606 /* Append it to the constructor list. */
4607 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4610 se
->expr
= build_constructor (type
, v
);
4612 TREE_CONSTANT (se
->expr
) = 1;
4616 /* Translate a substring expression. */
4619 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4625 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4627 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4628 expr
->value
.character
.length
,
4629 expr
->value
.character
.string
);
4631 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4632 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4635 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4639 /* Entry point for expression translation. Evaluates a scalar quantity.
4640 EXPR is the expression to be translated, and SE is the state structure if
4641 called from within the scalarized. */
4644 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4646 if (se
->ss
&& se
->ss
->expr
== expr
4647 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4649 /* Substitute a scalar expression evaluated outside the scalarization
4651 se
->expr
= se
->ss
->data
.scalar
.expr
;
4652 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4653 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4654 se
->string_length
= se
->ss
->string_length
;
4655 gfc_advance_se_ss_chain (se
);
4659 /* We need to convert the expressions for the iso_c_binding derived types.
4660 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4661 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4662 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4663 updated to be an integer with a kind equal to the size of a (void *). */
4664 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4665 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4667 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4668 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4670 /* Set expr_type to EXPR_NULL, which will result in
4671 null_pointer_node being used below. */
4672 expr
->expr_type
= EXPR_NULL
;
4676 /* Update the type/kind of the expression to be what the new
4677 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4678 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4679 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4680 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4684 switch (expr
->expr_type
)
4687 gfc_conv_expr_op (se
, expr
);
4691 gfc_conv_function_expr (se
, expr
);
4695 gfc_conv_constant (se
, expr
);
4699 gfc_conv_variable (se
, expr
);
4703 se
->expr
= null_pointer_node
;
4706 case EXPR_SUBSTRING
:
4707 gfc_conv_substring_expr (se
, expr
);
4710 case EXPR_STRUCTURE
:
4711 gfc_conv_structure (se
, expr
, 0);
4715 gfc_conv_array_constructor_expr (se
, expr
);
4724 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4725 of an assignment. */
4727 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4729 gfc_conv_expr (se
, expr
);
4730 /* All numeric lvalues should have empty post chains. If not we need to
4731 figure out a way of rewriting an lvalue so that it has no post chain. */
4732 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4735 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4736 numeric expressions. Used for scalar values where inserting cleanup code
4739 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4743 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4744 gfc_conv_expr (se
, expr
);
4747 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4748 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4750 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4754 /* Helper to translate an expression and convert it to a particular type. */
4756 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4758 gfc_conv_expr_val (se
, expr
);
4759 se
->expr
= convert (type
, se
->expr
);
4763 /* Converts an expression so that it can be passed by reference. Scalar
4767 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4771 if (se
->ss
&& se
->ss
->expr
== expr
4772 && se
->ss
->type
== GFC_SS_REFERENCE
)
4774 /* Returns a reference to the scalar evaluated outside the loop
4776 gfc_conv_expr (se
, expr
);
4780 if (expr
->ts
.type
== BT_CHARACTER
)
4782 gfc_conv_expr (se
, expr
);
4783 gfc_conv_string_parameter (se
);
4787 if (expr
->expr_type
== EXPR_VARIABLE
)
4789 se
->want_pointer
= 1;
4790 gfc_conv_expr (se
, expr
);
4793 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4794 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4795 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4801 if (expr
->expr_type
== EXPR_FUNCTION
4802 && ((expr
->value
.function
.esym
4803 && expr
->value
.function
.esym
->result
->attr
.pointer
4804 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4805 || (!expr
->value
.function
.esym
4806 && expr
->symtree
->n
.sym
->attr
.pointer
4807 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4809 se
->want_pointer
= 1;
4810 gfc_conv_expr (se
, expr
);
4811 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4812 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4818 gfc_conv_expr (se
, expr
);
4820 /* Create a temporary var to hold the value. */
4821 if (TREE_CONSTANT (se
->expr
))
4823 tree tmp
= se
->expr
;
4824 STRIP_TYPE_NOPS (tmp
);
4825 var
= build_decl (input_location
,
4826 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4827 DECL_INITIAL (var
) = tmp
;
4828 TREE_STATIC (var
) = 1;
4833 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4834 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4836 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4838 /* Take the address of that value. */
4839 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4844 gfc_trans_pointer_assign (gfc_code
* code
)
4846 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4850 /* Generate code for a pointer assignment. */
4853 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4864 gfc_start_block (&block
);
4866 gfc_init_se (&lse
, NULL
);
4868 lss
= gfc_walk_expr (expr1
);
4869 rss
= gfc_walk_expr (expr2
);
4870 if (lss
== gfc_ss_terminator
)
4872 /* Scalar pointers. */
4873 lse
.want_pointer
= 1;
4874 gfc_conv_expr (&lse
, expr1
);
4875 gcc_assert (rss
== gfc_ss_terminator
);
4876 gfc_init_se (&rse
, NULL
);
4877 rse
.want_pointer
= 1;
4878 gfc_conv_expr (&rse
, expr2
);
4880 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4881 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4882 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4885 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4886 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4887 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4890 gfc_add_block_to_block (&block
, &lse
.pre
);
4891 gfc_add_block_to_block (&block
, &rse
.pre
);
4893 /* Check character lengths if character expression. The test is only
4894 really added if -fbounds-check is enabled. */
4895 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4896 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4897 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4899 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4900 gcc_assert (lse
.string_length
&& rse
.string_length
);
4901 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4902 lse
.string_length
, rse
.string_length
,
4906 gfc_add_modify (&block
, lse
.expr
,
4907 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4909 gfc_add_block_to_block (&block
, &rse
.post
);
4910 gfc_add_block_to_block (&block
, &lse
.post
);
4917 tree strlen_rhs
= NULL_TREE
;
4919 /* Array pointer. Find the last reference on the LHS and if it is an
4920 array section ref, we're dealing with bounds remapping. In this case,
4921 set it to AR_FULL so that gfc_conv_expr_descriptor does
4922 not see it and process the bounds remapping afterwards explicitely. */
4923 for (remap
= expr1
->ref
; remap
; remap
= remap
->next
)
4924 if (!remap
->next
&& remap
->type
== REF_ARRAY
4925 && remap
->u
.ar
.type
== AR_SECTION
)
4927 remap
->u
.ar
.type
= AR_FULL
;
4930 rank_remap
= (remap
&& remap
->u
.ar
.end
[0]);
4932 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4933 strlen_lhs
= lse
.string_length
;
4936 if (expr2
->expr_type
== EXPR_NULL
)
4938 /* Just set the data pointer to null. */
4939 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4941 else if (rank_remap
)
4943 /* If we are rank-remapping, just get the RHS's descriptor and
4944 process this later on. */
4945 gfc_init_se (&rse
, NULL
);
4946 rse
.direct_byref
= 1;
4947 rse
.byref_noassign
= 1;
4948 gfc_conv_expr_descriptor (&rse
, expr2
, rss
);
4949 strlen_rhs
= rse
.string_length
;
4951 else if (expr2
->expr_type
== EXPR_VARIABLE
)
4953 /* Assign directly to the LHS's descriptor. */
4954 lse
.direct_byref
= 1;
4955 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4956 strlen_rhs
= lse
.string_length
;
4958 /* If this is a subreference array pointer assignment, use the rhs
4959 descriptor element size for the lhs span. */
4960 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4962 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4963 gfc_init_se (&rse
, NULL
);
4964 rse
.descriptor_only
= 1;
4965 gfc_conv_expr (&rse
, expr2
);
4966 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4967 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4968 if (!INTEGER_CST_P (tmp
))
4969 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4970 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4975 /* Assign to a temporary descriptor and then copy that
4976 temporary to the pointer. */
4977 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4980 lse
.direct_byref
= 1;
4981 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4982 strlen_rhs
= lse
.string_length
;
4983 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4986 gfc_add_block_to_block (&block
, &lse
.pre
);
4988 gfc_add_block_to_block (&block
, &rse
.pre
);
4990 /* If we do bounds remapping, update LHS descriptor accordingly. */
4994 gcc_assert (remap
->u
.ar
.dimen
== expr1
->rank
);
4998 /* Do rank remapping. We already have the RHS's descriptor
4999 converted in rse and now have to build the correct LHS
5000 descriptor for it. */
5004 tree lbound
, ubound
;
5007 dtype
= gfc_conv_descriptor_dtype (desc
);
5008 tmp
= gfc_get_dtype (TREE_TYPE (desc
));
5009 gfc_add_modify (&block
, dtype
, tmp
);
5011 /* Copy data pointer. */
5012 data
= gfc_conv_descriptor_data_get (rse
.expr
);
5013 gfc_conv_descriptor_data_set (&block
, desc
, data
);
5015 /* Copy offset but adjust it such that it would correspond
5016 to a lbound of zero. */
5017 offs
= gfc_conv_descriptor_offset_get (rse
.expr
);
5018 for (dim
= 0; dim
< expr2
->rank
; ++dim
)
5020 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5022 lbound
= gfc_conv_descriptor_lbound_get (rse
.expr
,
5024 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5025 gfc_array_index_type
, stride
, lbound
);
5026 offs
= fold_build2_loc (input_location
, PLUS_EXPR
,
5027 gfc_array_index_type
, offs
, tmp
);
5029 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5031 /* Set the bounds as declared for the LHS and calculate strides as
5032 well as another offset update accordingly. */
5033 stride
= gfc_conv_descriptor_stride_get (rse
.expr
,
5035 for (dim
= 0; dim
< expr1
->rank
; ++dim
)
5040 gcc_assert (remap
->u
.ar
.start
[dim
] && remap
->u
.ar
.end
[dim
]);
5042 /* Convert declared bounds. */
5043 gfc_init_se (&lower_se
, NULL
);
5044 gfc_init_se (&upper_se
, NULL
);
5045 gfc_conv_expr (&lower_se
, remap
->u
.ar
.start
[dim
]);
5046 gfc_conv_expr (&upper_se
, remap
->u
.ar
.end
[dim
]);
5048 gfc_add_block_to_block (&block
, &lower_se
.pre
);
5049 gfc_add_block_to_block (&block
, &upper_se
.pre
);
5051 lbound
= fold_convert (gfc_array_index_type
, lower_se
.expr
);
5052 ubound
= fold_convert (gfc_array_index_type
, upper_se
.expr
);
5054 lbound
= gfc_evaluate_now (lbound
, &block
);
5055 ubound
= gfc_evaluate_now (ubound
, &block
);
5057 gfc_add_block_to_block (&block
, &lower_se
.post
);
5058 gfc_add_block_to_block (&block
, &upper_se
.post
);
5060 /* Set bounds in descriptor. */
5061 gfc_conv_descriptor_lbound_set (&block
, desc
,
5062 gfc_rank_cst
[dim
], lbound
);
5063 gfc_conv_descriptor_ubound_set (&block
, desc
,
5064 gfc_rank_cst
[dim
], ubound
);
5067 stride
= gfc_evaluate_now (stride
, &block
);
5068 gfc_conv_descriptor_stride_set (&block
, desc
,
5069 gfc_rank_cst
[dim
], stride
);
5071 /* Update offset. */
5072 offs
= gfc_conv_descriptor_offset_get (desc
);
5073 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5074 gfc_array_index_type
, lbound
, stride
);
5075 offs
= fold_build2_loc (input_location
, MINUS_EXPR
,
5076 gfc_array_index_type
, offs
, tmp
);
5077 offs
= gfc_evaluate_now (offs
, &block
);
5078 gfc_conv_descriptor_offset_set (&block
, desc
, offs
);
5080 /* Update stride. */
5081 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
5082 stride
= fold_build2_loc (input_location
, MULT_EXPR
,
5083 gfc_array_index_type
, stride
, tmp
);
5088 /* Bounds remapping. Just shift the lower bounds. */
5090 gcc_assert (expr1
->rank
== expr2
->rank
);
5092 for (dim
= 0; dim
< remap
->u
.ar
.dimen
; ++dim
)
5096 gcc_assert (remap
->u
.ar
.start
[dim
]);
5097 gcc_assert (!remap
->u
.ar
.end
[dim
]);
5098 gfc_init_se (&lbound_se
, NULL
);
5099 gfc_conv_expr (&lbound_se
, remap
->u
.ar
.start
[dim
]);
5101 gfc_add_block_to_block (&block
, &lbound_se
.pre
);
5102 gfc_conv_shift_descriptor_lbound (&block
, desc
,
5103 dim
, lbound_se
.expr
);
5104 gfc_add_block_to_block (&block
, &lbound_se
.post
);
5109 /* Check string lengths if applicable. The check is only really added
5110 to the output code if -fbounds-check is enabled. */
5111 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
5113 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
5114 gcc_assert (strlen_lhs
&& strlen_rhs
);
5115 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
5116 strlen_lhs
, strlen_rhs
, &block
);
5119 /* If rank remapping was done, check with -fcheck=bounds that
5120 the target is at least as large as the pointer. */
5121 if (rank_remap
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
))
5127 lsize
= gfc_conv_descriptor_size (lse
.expr
, expr1
->rank
);
5128 rsize
= gfc_conv_descriptor_size (rse
.expr
, expr2
->rank
);
5130 lsize
= gfc_evaluate_now (lsize
, &block
);
5131 rsize
= gfc_evaluate_now (rsize
, &block
);
5132 fault
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
5135 msg
= _("Target of rank remapping is too small (%ld < %ld)");
5136 gfc_trans_runtime_check (true, false, fault
, &block
, &expr2
->where
,
5140 gfc_add_block_to_block (&block
, &lse
.post
);
5142 gfc_add_block_to_block (&block
, &rse
.post
);
5145 return gfc_finish_block (&block
);
5149 /* Makes sure se is suitable for passing as a function string parameter. */
5150 /* TODO: Need to check all callers of this function. It may be abused. */
5153 gfc_conv_string_parameter (gfc_se
* se
)
5157 if (TREE_CODE (se
->expr
) == STRING_CST
)
5159 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
5160 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5164 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
5166 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
5168 type
= TREE_TYPE (se
->expr
);
5169 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
5173 type
= gfc_get_character_type_len (gfc_default_character_kind
,
5175 type
= build_pointer_type (type
);
5176 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
5180 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
5181 gcc_assert (se
->string_length
5182 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
5186 /* Generate code for assignment of scalar variables. Includes character
5187 strings and derived types with allocatable components.
5188 If you know that the LHS has no allocations, set dealloc to false. */
5191 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
5192 bool l_is_temp
, bool r_is_var
, bool dealloc
)
5198 gfc_init_block (&block
);
5200 if (ts
.type
== BT_CHARACTER
)
5205 if (lse
->string_length
!= NULL_TREE
)
5207 gfc_conv_string_parameter (lse
);
5208 gfc_add_block_to_block (&block
, &lse
->pre
);
5209 llen
= lse
->string_length
;
5212 if (rse
->string_length
!= NULL_TREE
)
5214 gcc_assert (rse
->string_length
!= NULL_TREE
);
5215 gfc_conv_string_parameter (rse
);
5216 gfc_add_block_to_block (&block
, &rse
->pre
);
5217 rlen
= rse
->string_length
;
5220 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
5221 rse
->expr
, ts
.kind
);
5223 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
5227 /* Are the rhs and the lhs the same? */
5230 cond
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
,
5231 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
5232 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
5233 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
5236 /* Deallocate the lhs allocated components as long as it is not
5237 the same as the rhs. This must be done following the assignment
5238 to prevent deallocating data that could be used in the rhs
5240 if (!l_is_temp
&& dealloc
)
5242 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
5243 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
5245 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5247 gfc_add_expr_to_block (&lse
->post
, tmp
);
5250 gfc_add_block_to_block (&block
, &rse
->pre
);
5251 gfc_add_block_to_block (&block
, &lse
->pre
);
5253 gfc_add_modify (&block
, lse
->expr
,
5254 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5256 /* Do a deep copy if the rhs is a variable, if it is not the
5260 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
5261 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
5263 gfc_add_expr_to_block (&block
, tmp
);
5266 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
5268 gfc_add_block_to_block (&block
, &lse
->pre
);
5269 gfc_add_block_to_block (&block
, &rse
->pre
);
5270 tmp
= fold_build1_loc (input_location
, VIEW_CONVERT_EXPR
,
5271 TREE_TYPE (lse
->expr
), rse
->expr
);
5272 gfc_add_modify (&block
, lse
->expr
, tmp
);
5276 gfc_add_block_to_block (&block
, &lse
->pre
);
5277 gfc_add_block_to_block (&block
, &rse
->pre
);
5279 gfc_add_modify (&block
, lse
->expr
,
5280 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
5283 gfc_add_block_to_block (&block
, &lse
->post
);
5284 gfc_add_block_to_block (&block
, &rse
->post
);
5286 return gfc_finish_block (&block
);
5290 /* There are quite a lot of restrictions on the optimisation in using an
5291 array function assign without a temporary. */
5294 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
5297 bool seen_array_ref
;
5299 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
5301 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
5302 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
5305 /* Elemental functions are scalarized so that they don't need a
5306 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
5307 they would need special treatment in gfc_trans_arrayfunc_assign. */
5308 if (expr2
->value
.function
.esym
!= NULL
5309 && expr2
->value
.function
.esym
->attr
.elemental
)
5312 /* Need a temporary if rhs is not FULL or a contiguous section. */
5313 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
5316 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
5317 if (gfc_ref_needs_temporary_p (expr1
->ref
))
5320 /* Functions returning pointers need temporaries. */
5321 if (expr2
->symtree
->n
.sym
->attr
.pointer
5322 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
5325 /* Character array functions need temporaries unless the
5326 character lengths are the same. */
5327 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
5329 if (expr1
->ts
.u
.cl
->length
== NULL
5330 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5333 if (expr2
->ts
.u
.cl
->length
== NULL
5334 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5337 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5338 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5342 /* Check that no LHS component references appear during an array
5343 reference. This is needed because we do not have the means to
5344 span any arbitrary stride with an array descriptor. This check
5345 is not needed for the rhs because the function result has to be
5347 seen_array_ref
= false;
5348 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5350 if (ref
->type
== REF_ARRAY
)
5351 seen_array_ref
= true;
5352 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5356 /* Check for a dependency. */
5357 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5358 expr2
->value
.function
.esym
,
5359 expr2
->value
.function
.actual
,
5363 /* If we have reached here with an intrinsic function, we do not
5364 need a temporary. */
5365 if (expr2
->value
.function
.isym
)
5368 /* If the LHS is a dummy, we need a temporary if it is not
5370 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
5373 /* A PURE function can unconditionally be called without a temporary. */
5374 if (expr2
->value
.function
.esym
!= NULL
5375 && expr2
->value
.function
.esym
->attr
.pure
)
5378 /* TODO a function that could correctly be declared PURE but is not
5379 could do with returning false as well. */
5381 if (!sym
->attr
.use_assoc
5382 && !sym
->attr
.in_common
5383 && !sym
->attr
.pointer
5384 && !sym
->attr
.target
5385 && expr2
->value
.function
.esym
)
5387 /* A temporary is not needed if the function is not contained and
5388 the variable is local or host associated and not a pointer or
5390 if (!expr2
->value
.function
.esym
->attr
.contained
)
5393 /* A temporary is not needed if the lhs has never been host
5394 associated and the procedure is contained. */
5395 else if (!sym
->attr
.host_assoc
)
5398 /* A temporary is not needed if the variable is local and not
5399 a pointer, a target or a result. */
5401 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
5405 /* Default to temporary use. */
5410 /* Provide the loop info so that the lhs descriptor can be built for
5411 reallocatable assignments from extrinsic function calls. */
5414 realloc_lhs_loop_for_fcn_call (gfc_se
*se
, locus
*where
, gfc_ss
**ss
)
5417 /* Signal that the function call should not be made by
5418 gfc_conv_loop_setup. */
5419 se
->ss
->is_alloc_lhs
= 1;
5420 gfc_init_loopinfo (&loop
);
5421 gfc_add_ss_to_loop (&loop
, *ss
);
5422 gfc_add_ss_to_loop (&loop
, se
->ss
);
5423 gfc_conv_ss_startstride (&loop
);
5424 gfc_conv_loop_setup (&loop
, where
);
5425 gfc_copy_loopinfo_to_se (se
, &loop
);
5426 gfc_add_block_to_block (&se
->pre
, &loop
.pre
);
5427 gfc_add_block_to_block (&se
->pre
, &loop
.post
);
5428 se
->ss
->is_alloc_lhs
= 0;
5433 realloc_lhs_bounds_for_intrinsic_call (gfc_se
*se
, int rank
)
5440 /* Use the allocation done by the library. */
5441 desc
= build_fold_indirect_ref_loc (input_location
, se
->expr
);
5442 tmp
= gfc_conv_descriptor_data_get (desc
);
5443 tmp
= gfc_call_free (fold_convert (pvoid_type_node
, tmp
));
5444 gfc_add_expr_to_block (&se
->pre
, tmp
);
5445 gfc_conv_descriptor_data_set (&se
->pre
, desc
, null_pointer_node
);
5446 /* Unallocated, the descriptor does not have a dtype. */
5447 tmp
= gfc_conv_descriptor_dtype (desc
);
5448 gfc_add_modify (&se
->pre
, tmp
, gfc_get_dtype (TREE_TYPE (desc
)));
5450 offset
= gfc_index_zero_node
;
5451 tmp
= gfc_index_one_node
;
5452 /* Now reset the bounds from zero based to unity based. */
5453 for (n
= 0 ; n
< rank
; n
++)
5455 /* Accumulate the offset. */
5456 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
5457 gfc_array_index_type
,
5459 /* Now do the bounds. */
5460 gfc_conv_descriptor_offset_set (&se
->post
, desc
, tmp
);
5461 tmp
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]);
5462 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5463 gfc_array_index_type
,
5464 tmp
, gfc_index_one_node
);
5465 gfc_conv_descriptor_lbound_set (&se
->post
, desc
,
5467 gfc_index_one_node
);
5468 gfc_conv_descriptor_ubound_set (&se
->post
, desc
,
5469 gfc_rank_cst
[n
], tmp
);
5471 /* The extent for the next contribution to offset. */
5472 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
5473 gfc_array_index_type
,
5474 gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[n
]),
5475 gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[n
]));
5476 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5477 gfc_array_index_type
,
5478 tmp
, gfc_index_one_node
);
5480 gfc_conv_descriptor_offset_set (&se
->post
, desc
, offset
);
5485 /* Try to translate array(:) = func (...), where func is a transformational
5486 array function, without using a temporary. Returns NULL if this isn't the
5490 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
5494 gfc_component
*comp
= NULL
;
5496 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
5499 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5501 gcc_assert (expr2
->value
.function
.isym
5502 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5503 && comp
&& comp
->attr
.dimension
)
5504 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5505 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5507 ss
= gfc_walk_expr (expr1
);
5508 gcc_assert (ss
!= gfc_ss_terminator
);
5509 gfc_init_se (&se
, NULL
);
5510 gfc_start_block (&se
.pre
);
5511 se
.want_pointer
= 1;
5513 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5515 if (expr1
->ts
.type
== BT_DERIVED
5516 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5519 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5521 gfc_add_expr_to_block (&se
.pre
, tmp
);
5524 se
.direct_byref
= 1;
5525 se
.ss
= gfc_walk_expr (expr2
);
5526 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5528 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
5529 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
5530 Clearly, this cannot be done for an allocatable function result, since
5531 the shape of the result is unknown and, in any case, the function must
5532 correctly take care of the reallocation internally. For intrinsic
5533 calls, the array data is freed and the library takes care of allocation.
5534 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
5536 if (gfc_option
.flag_realloc_lhs
5537 && gfc_is_reallocatable_lhs (expr1
)
5538 && !gfc_expr_attr (expr1
).codimension
5539 && !gfc_is_coindexed (expr1
)
5540 && !(expr2
->value
.function
.esym
5541 && expr2
->value
.function
.esym
->result
->attr
.allocatable
))
5543 if (!expr2
->value
.function
.isym
)
5545 realloc_lhs_loop_for_fcn_call (&se
, &expr1
->where
, &ss
);
5546 ss
->is_alloc_lhs
= 1;
5549 realloc_lhs_bounds_for_intrinsic_call (&se
, expr1
->rank
);
5552 gfc_conv_function_expr (&se
, expr2
);
5553 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5555 return gfc_finish_block (&se
.pre
);
5559 /* Try to efficiently translate array(:) = 0. Return NULL if this
5563 gfc_trans_zero_assign (gfc_expr
* expr
)
5565 tree dest
, len
, type
;
5569 sym
= expr
->symtree
->n
.sym
;
5570 dest
= gfc_get_symbol_decl (sym
);
5572 type
= TREE_TYPE (dest
);
5573 if (POINTER_TYPE_P (type
))
5574 type
= TREE_TYPE (type
);
5575 if (!GFC_ARRAY_TYPE_P (type
))
5578 /* Determine the length of the array. */
5579 len
= GFC_TYPE_ARRAY_SIZE (type
);
5580 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5583 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5584 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5585 fold_convert (gfc_array_index_type
, tmp
));
5587 /* If we are zeroing a local array avoid taking its address by emitting
5589 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5590 return build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5591 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5593 /* Convert arguments to the correct types. */
5594 dest
= fold_convert (pvoid_type_node
, dest
);
5595 len
= fold_convert (size_type_node
, len
);
5597 /* Construct call to __builtin_memset. */
5598 tmp
= build_call_expr_loc (input_location
,
5599 built_in_decls
[BUILT_IN_MEMSET
],
5600 3, dest
, integer_zero_node
, len
);
5601 return fold_convert (void_type_node
, tmp
);
5605 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5606 that constructs the call to __builtin_memcpy. */
5609 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5613 /* Convert arguments to the correct types. */
5614 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5615 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5617 dst
= fold_convert (pvoid_type_node
, dst
);
5619 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5620 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5622 src
= fold_convert (pvoid_type_node
, src
);
5624 len
= fold_convert (size_type_node
, len
);
5626 /* Construct call to __builtin_memcpy. */
5627 tmp
= build_call_expr_loc (input_location
,
5628 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5629 return fold_convert (void_type_node
, tmp
);
5633 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5634 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5635 source/rhs, both are gfc_full_array_ref_p which have been checked for
5639 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5641 tree dst
, dlen
, dtype
;
5642 tree src
, slen
, stype
;
5645 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5646 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5648 dtype
= TREE_TYPE (dst
);
5649 if (POINTER_TYPE_P (dtype
))
5650 dtype
= TREE_TYPE (dtype
);
5651 stype
= TREE_TYPE (src
);
5652 if (POINTER_TYPE_P (stype
))
5653 stype
= TREE_TYPE (stype
);
5655 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5658 /* Determine the lengths of the arrays. */
5659 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5660 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5662 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5663 dlen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5664 dlen
, fold_convert (gfc_array_index_type
, tmp
));
5666 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5667 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5669 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5670 slen
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5671 slen
, fold_convert (gfc_array_index_type
, tmp
));
5673 /* Sanity check that they are the same. This should always be
5674 the case, as we should already have checked for conformance. */
5675 if (!tree_int_cst_equal (slen
, dlen
))
5678 return gfc_build_memcpy_call (dst
, src
, dlen
);
5682 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5683 this can't be done. EXPR1 is the destination/lhs for which
5684 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5687 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5689 unsigned HOST_WIDE_INT nelem
;
5695 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5699 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5700 dtype
= TREE_TYPE (dst
);
5701 if (POINTER_TYPE_P (dtype
))
5702 dtype
= TREE_TYPE (dtype
);
5703 if (!GFC_ARRAY_TYPE_P (dtype
))
5706 /* Determine the lengths of the array. */
5707 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5708 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5711 /* Confirm that the constructor is the same size. */
5712 if (compare_tree_int (len
, nelem
) != 0)
5715 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5716 len
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
, len
,
5717 fold_convert (gfc_array_index_type
, tmp
));
5719 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5720 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5722 stype
= TREE_TYPE (src
);
5723 if (POINTER_TYPE_P (stype
))
5724 stype
= TREE_TYPE (stype
);
5726 return gfc_build_memcpy_call (dst
, src
, len
);
5730 /* Tells whether the expression is to be treated as a variable reference. */
5733 expr_is_variable (gfc_expr
*expr
)
5737 if (expr
->expr_type
== EXPR_VARIABLE
)
5740 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
5743 gcc_assert (expr
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
);
5744 return expr_is_variable (arg
);
5751 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5752 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5753 init_flag indicates initialization expressions and dealloc that no
5754 deallocate prior assignment is needed (if in doubt, set true). */
5757 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5763 gfc_ss
*lss_section
;
5770 bool scalar_to_array
;
5774 /* Assignment of the form lhs = rhs. */
5775 gfc_start_block (&block
);
5777 gfc_init_se (&lse
, NULL
);
5778 gfc_init_se (&rse
, NULL
);
5781 lss
= gfc_walk_expr (expr1
);
5782 if (gfc_is_reallocatable_lhs (expr1
)
5783 && !(expr2
->expr_type
== EXPR_FUNCTION
5784 && expr2
->value
.function
.isym
!= NULL
))
5785 lss
->is_alloc_lhs
= 1;
5787 if (lss
!= gfc_ss_terminator
)
5789 /* Allow the scalarizer to workshare array assignments. */
5790 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5791 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5793 /* The assignment needs scalarization. */
5796 /* Find a non-scalar SS from the lhs. */
5797 while (lss_section
!= gfc_ss_terminator
5798 && lss_section
->type
!= GFC_SS_SECTION
)
5799 lss_section
= lss_section
->next
;
5801 gcc_assert (lss_section
!= gfc_ss_terminator
);
5803 /* Initialize the scalarizer. */
5804 gfc_init_loopinfo (&loop
);
5807 rss
= gfc_walk_expr (expr2
);
5808 if (rss
== gfc_ss_terminator
)
5810 /* The rhs is scalar. Add a ss for the expression. */
5811 rss
= gfc_get_ss ();
5812 rss
->next
= gfc_ss_terminator
;
5813 rss
->type
= GFC_SS_SCALAR
;
5816 /* Associate the SS with the loop. */
5817 gfc_add_ss_to_loop (&loop
, lss
);
5818 gfc_add_ss_to_loop (&loop
, rss
);
5820 /* Calculate the bounds of the scalarization. */
5821 gfc_conv_ss_startstride (&loop
);
5822 /* Enable loop reversal. */
5823 for (n
= 0; n
< loop
.dimen
; n
++)
5824 loop
.reverse
[n
] = GFC_REVERSE_NOT_SET
;
5825 /* Resolve any data dependencies in the statement. */
5826 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5827 /* Setup the scalarizing loops. */
5828 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5830 /* Setup the gfc_se structures. */
5831 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5832 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5835 gfc_mark_ss_chain_used (rss
, 1);
5836 if (loop
.temp_ss
== NULL
)
5839 gfc_mark_ss_chain_used (lss
, 1);
5843 lse
.ss
= loop
.temp_ss
;
5844 gfc_mark_ss_chain_used (lss
, 3);
5845 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5848 /* Start the scalarized loop body. */
5849 gfc_start_scalarized_body (&loop
, &body
);
5852 gfc_init_block (&body
);
5854 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5856 /* Translate the expression. */
5857 gfc_conv_expr (&rse
, expr2
);
5859 /* Stabilize a string length for temporaries. */
5860 if (expr2
->ts
.type
== BT_CHARACTER
)
5861 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5863 string_length
= NULL_TREE
;
5867 gfc_conv_tmp_array_ref (&lse
);
5868 if (expr2
->ts
.type
== BT_CHARACTER
)
5869 lse
.string_length
= string_length
;
5872 gfc_conv_expr (&lse
, expr1
);
5874 /* Assignments of scalar derived types with allocatable components
5875 to arrays must be done with a deep copy and the rhs temporary
5876 must have its components deallocated afterwards. */
5877 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5878 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5879 && !expr_is_variable (expr2
)
5880 && !gfc_is_constant_expr (expr2
)
5881 && expr1
->rank
&& !expr2
->rank
);
5882 if (scalar_to_array
&& dealloc
)
5884 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5885 gfc_add_expr_to_block (&loop
.post
, tmp
);
5888 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5889 l_is_temp
|| init_flag
,
5890 expr_is_variable (expr2
) || scalar_to_array
,
5892 gfc_add_expr_to_block (&body
, tmp
);
5894 if (lss
== gfc_ss_terminator
)
5896 /* Use the scalar assignment as is. */
5897 gfc_add_block_to_block (&block
, &body
);
5901 gcc_assert (lse
.ss
== gfc_ss_terminator
5902 && rse
.ss
== gfc_ss_terminator
);
5906 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5908 /* We need to copy the temporary to the actual lhs. */
5909 gfc_init_se (&lse
, NULL
);
5910 gfc_init_se (&rse
, NULL
);
5911 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5912 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5914 rse
.ss
= loop
.temp_ss
;
5917 gfc_conv_tmp_array_ref (&rse
);
5918 gfc_conv_expr (&lse
, expr1
);
5920 gcc_assert (lse
.ss
== gfc_ss_terminator
5921 && rse
.ss
== gfc_ss_terminator
);
5923 if (expr2
->ts
.type
== BT_CHARACTER
)
5924 rse
.string_length
= string_length
;
5926 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5927 false, false, dealloc
);
5928 gfc_add_expr_to_block (&body
, tmp
);
5931 /* Allocate or reallocate lhs of allocatable array. */
5932 if (gfc_option
.flag_realloc_lhs
5933 && gfc_is_reallocatable_lhs (expr1
)
5934 && !gfc_expr_attr (expr1
).codimension
5935 && !gfc_is_coindexed (expr1
))
5937 tmp
= gfc_alloc_allocatable_for_assignment (&loop
, expr1
, expr2
);
5938 if (tmp
!= NULL_TREE
)
5939 gfc_add_expr_to_block (&loop
.code
[expr1
->rank
- 1], tmp
);
5942 /* Generate the copying loops. */
5943 gfc_trans_scalarizing_loops (&loop
, &body
);
5945 /* Wrap the whole thing up. */
5946 gfc_add_block_to_block (&block
, &loop
.pre
);
5947 gfc_add_block_to_block (&block
, &loop
.post
);
5949 gfc_cleanup_loop (&loop
);
5952 return gfc_finish_block (&block
);
5956 /* Check whether EXPR is a copyable array. */
5959 copyable_array_p (gfc_expr
* expr
)
5961 if (expr
->expr_type
!= EXPR_VARIABLE
)
5964 /* First check it's an array. */
5965 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5968 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5971 /* Next check that it's of a simple enough type. */
5972 switch (expr
->ts
.type
)
5984 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5993 /* Translate an assignment. */
5996 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
6001 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.deferred
)
6003 gfc_error ("Assignment to deferred-length character variable at %L "
6004 "not implemented", &expr1
->where
);
6008 /* Special case a single function returning an array. */
6009 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
6011 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
6016 /* Special case assigning an array to zero. */
6017 if (copyable_array_p (expr1
)
6018 && is_zero_initializer_p (expr2
))
6020 tmp
= gfc_trans_zero_assign (expr1
);
6025 /* Special case copying one array to another. */
6026 if (copyable_array_p (expr1
)
6027 && copyable_array_p (expr2
)
6028 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
6029 && !gfc_check_dependency (expr1
, expr2
, 0))
6031 tmp
= gfc_trans_array_copy (expr1
, expr2
);
6036 /* Special case initializing an array from a constant array constructor. */
6037 if (copyable_array_p (expr1
)
6038 && expr2
->expr_type
== EXPR_ARRAY
6039 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
6041 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
6046 /* Fallback to the scalarizer to generate explicit loops. */
6047 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
6051 gfc_trans_init_assign (gfc_code
* code
)
6053 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
6057 gfc_trans_assign (gfc_code
* code
)
6059 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
6063 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
6064 A MEMCPY is needed to copy the full data from the default initializer
6065 of the dynamic type. */
6068 gfc_trans_class_init_assign (gfc_code
*code
)
6072 gfc_se dst
,src
,memsz
;
6073 gfc_expr
*lhs
,*rhs
,*sz
;
6075 gfc_start_block (&block
);
6077 lhs
= gfc_copy_expr (code
->expr1
);
6078 gfc_add_data_component (lhs
);
6080 rhs
= gfc_copy_expr (code
->expr1
);
6081 gfc_add_vptr_component (rhs
);
6082 gfc_add_def_init_component (rhs
);
6084 sz
= gfc_copy_expr (code
->expr1
);
6085 gfc_add_vptr_component (sz
);
6086 gfc_add_size_component (sz
);
6088 gfc_init_se (&dst
, NULL
);
6089 gfc_init_se (&src
, NULL
);
6090 gfc_init_se (&memsz
, NULL
);
6091 gfc_conv_expr (&dst
, lhs
);
6092 gfc_conv_expr (&src
, rhs
);
6093 gfc_conv_expr (&memsz
, sz
);
6094 gfc_add_block_to_block (&block
, &src
.pre
);
6095 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
.expr
);
6096 gfc_add_expr_to_block (&block
, tmp
);
6098 return gfc_finish_block (&block
);
6102 /* Translate an assignment to a CLASS object
6103 (pointer or ordinary assignment). */
6106 gfc_trans_class_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, gfc_exec_op op
)
6113 gfc_start_block (&block
);
6115 if (expr2
->ts
.type
!= BT_CLASS
)
6117 /* Insert an additional assignment which sets the '_vptr' field. */
6118 lhs
= gfc_copy_expr (expr1
);
6119 gfc_add_vptr_component (lhs
);
6120 if (expr2
->ts
.type
== BT_DERIVED
)
6124 vtab
= gfc_find_derived_vtab (expr2
->ts
.u
.derived
);
6126 rhs
= gfc_get_expr ();
6127 rhs
->expr_type
= EXPR_VARIABLE
;
6128 gfc_find_sym_tree (vtab
->name
, vtab
->ns
, 1, &st
);
6132 else if (expr2
->expr_type
== EXPR_NULL
)
6133 rhs
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
6137 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
6138 gfc_add_expr_to_block (&block
, tmp
);
6140 gfc_free_expr (lhs
);
6141 gfc_free_expr (rhs
);
6144 /* Do the actual CLASS assignment. */
6145 if (expr2
->ts
.type
== BT_CLASS
)
6148 gfc_add_data_component (expr1
);
6150 if (op
== EXEC_ASSIGN
)
6151 tmp
= gfc_trans_assignment (expr1
, expr2
, false, true);
6152 else if (op
== EXEC_POINTER_ASSIGN
)
6153 tmp
= gfc_trans_pointer_assignment (expr1
, expr2
);
6157 gfc_add_expr_to_block (&block
, tmp
);
6159 return gfc_finish_block (&block
);