1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return fold_build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
159 /* Create a temporary and convert it to the correct type. */
160 tmp
= gfc_get_int_type (kind
);
161 tmp
= fold_convert (tmp
, build_fold_indirect_ref (se
->expr
));
163 /* Test for a NULL value. */
164 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
,
165 fold_convert (TREE_TYPE (tmp
), integer_one_node
));
166 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
167 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
171 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
172 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
173 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
177 if (ts
.type
== BT_CHARACTER
)
179 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
180 tmp
= fold_build3 (COND_EXPR
, gfc_charlen_type_node
,
181 present
, se
->string_length
, tmp
);
182 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
183 se
->string_length
= tmp
;
189 /* Get the character length of an expression, looking through gfc_refs
193 gfc_get_expr_charlen (gfc_expr
*e
)
198 gcc_assert (e
->expr_type
== EXPR_VARIABLE
199 && e
->ts
.type
== BT_CHARACTER
);
201 length
= NULL
; /* To silence compiler warning. */
203 if (is_subref_array (e
) && e
->ts
.cl
->length
)
206 gfc_init_se (&tmpse
, NULL
);
207 gfc_conv_expr_type (&tmpse
, e
->ts
.cl
->length
, gfc_charlen_type_node
);
208 e
->ts
.cl
->backend_decl
= tmpse
.expr
;
212 /* First candidate: if the variable is of type CHARACTER, the
213 expression's length could be the length of the character
215 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
216 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
218 /* Look through the reference chain for component references. */
219 for (r
= e
->ref
; r
; r
= r
->next
)
224 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
225 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
233 /* We should never got substring references here. These will be
234 broken down by the scalarizer. */
240 gcc_assert (length
!= NULL
);
245 /* For each character array constructor subexpression without a ts.cl->length,
246 replace it by its first element (if there aren't any elements, the length
247 should already be set to zero). */
250 flatten_array_ctors_without_strlen (gfc_expr
* e
)
252 gfc_actual_arglist
* arg
;
258 switch (e
->expr_type
)
262 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
263 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
267 /* TODO: Implement as with EXPR_FUNCTION when needed. */
271 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
272 flatten_array_ctors_without_strlen (arg
->expr
);
277 /* We've found what we're looking for. */
278 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.cl
->length
)
281 gcc_assert (e
->value
.constructor
);
283 new_expr
= e
->value
.constructor
->expr
;
284 e
->value
.constructor
->expr
= NULL
;
286 flatten_array_ctors_without_strlen (new_expr
);
287 gfc_replace_expr (e
, new_expr
);
291 /* Otherwise, fall through to handle constructor elements. */
293 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
294 flatten_array_ctors_without_strlen (c
->expr
);
304 /* Generate code to initialize a string length variable. Returns the
305 value. For array constructors, cl->length might be NULL and in this case,
306 the first element of the constructor is needed. expr is the original
307 expression so we can access it but can be NULL if this is not needed. */
310 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
314 gfc_init_se (&se
, NULL
);
316 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
317 "flatten" array constructors by taking their first element; all elements
318 should be the same length or a cl->length should be present. */
324 expr_flat
= gfc_copy_expr (expr
);
325 flatten_array_ctors_without_strlen (expr_flat
);
326 gfc_resolve_expr (expr_flat
);
328 gfc_conv_expr (&se
, expr_flat
);
329 gfc_add_block_to_block (pblock
, &se
.pre
);
330 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
332 gfc_free_expr (expr_flat
);
336 /* Convert cl->length. */
338 gcc_assert (cl
->length
);
340 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
341 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
342 build_int_cst (gfc_charlen_type_node
, 0));
343 gfc_add_block_to_block (pblock
, &se
.pre
);
345 if (cl
->backend_decl
)
346 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
348 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
353 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
354 const char *name
, locus
*where
)
364 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
365 type
= build_pointer_type (type
);
368 gfc_init_se (&start
, se
);
369 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
370 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
372 if (integer_onep (start
.expr
))
373 gfc_conv_string_parameter (se
);
376 /* Avoid multiple evaluation of substring start. */
377 if (!CONSTANT_CLASS_P (start
.expr
) && !DECL_P (start
.expr
))
378 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
380 /* Change the start of the string. */
381 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
384 tmp
= build_fold_indirect_ref (se
->expr
);
385 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
386 se
->expr
= gfc_build_addr_expr (type
, tmp
);
389 /* Length = end + 1 - start. */
390 gfc_init_se (&end
, se
);
391 if (ref
->u
.ss
.end
== NULL
)
392 end
.expr
= se
->string_length
;
395 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
396 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
398 if (!CONSTANT_CLASS_P (end
.expr
) && !DECL_P (end
.expr
))
399 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
401 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
403 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
404 start
.expr
, end
.expr
);
406 /* Check lower bound. */
407 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
408 build_int_cst (gfc_charlen_type_node
, 1));
409 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
412 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
413 "is less than one", name
);
415 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
417 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
418 fold_convert (long_integer_type_node
,
422 /* Check upper bound. */
423 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
425 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
428 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
429 "exceeds string length (%%ld)", name
);
431 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
432 "exceeds string length (%%ld)");
433 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
434 fold_convert (long_integer_type_node
, end
.expr
),
435 fold_convert (long_integer_type_node
,
440 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
441 build_int_cst (gfc_charlen_type_node
, 1),
443 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
444 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
445 build_int_cst (gfc_charlen_type_node
, 0));
446 se
->string_length
= tmp
;
450 /* Convert a derived type component reference. */
453 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
460 c
= ref
->u
.c
.component
;
462 gcc_assert (c
->backend_decl
);
464 field
= c
->backend_decl
;
465 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
467 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
471 if (c
->ts
.type
== BT_CHARACTER
)
473 tmp
= c
->ts
.cl
->backend_decl
;
474 /* Components must always be constant length. */
475 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
476 se
->string_length
= tmp
;
479 if ((c
->attr
.pointer
&& c
->attr
.dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
480 || c
->attr
.proc_pointer
)
481 se
->expr
= build_fold_indirect_ref (se
->expr
);
485 /* This function deals with component references to components of the
486 parent type for derived type extensons. */
488 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
496 c
= ref
->u
.c
.component
;
498 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
499 parent
.type
= REF_COMPONENT
;
502 parent
.u
.c
.component
= dt
->components
;
504 if (dt
->attr
.extension
&& dt
->components
)
506 /* Return if the component is not in the parent type. */
507 for (cmp
= dt
->components
->next
; cmp
; cmp
= cmp
->next
)
508 if (strcmp (c
->name
, cmp
->name
) == 0)
511 /* Otherwise build the reference and call self. */
512 gfc_conv_component_ref (se
, &parent
);
513 parent
.u
.c
.sym
= dt
->components
->ts
.derived
;
514 parent
.u
.c
.component
= c
;
515 conv_parent_component_references (se
, &parent
);
519 /* Return the contents of a variable. Also handles reference/pointer
520 variables (all Fortran pointer references are implicit). */
523 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
530 bool alternate_entry
;
533 sym
= expr
->symtree
->n
.sym
;
536 /* Check that something hasn't gone horribly wrong. */
537 gcc_assert (se
->ss
!= gfc_ss_terminator
);
538 gcc_assert (se
->ss
->expr
== expr
);
540 /* A scalarized term. We already know the descriptor. */
541 se
->expr
= se
->ss
->data
.info
.descriptor
;
542 se
->string_length
= se
->ss
->string_length
;
543 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
544 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
549 tree se_expr
= NULL_TREE
;
551 se
->expr
= gfc_get_symbol_decl (sym
);
553 /* Deal with references to a parent results or entries by storing
554 the current_function_decl and moving to the parent_decl. */
555 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
556 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
557 && sym
->result
== sym
;
558 entry_master
= sym
->attr
.result
559 && sym
->ns
->proc_name
->attr
.entry_master
560 && !gfc_return_by_reference (sym
->ns
->proc_name
);
561 parent_decl
= DECL_CONTEXT (current_function_decl
);
563 if ((se
->expr
== parent_decl
&& return_value
)
564 || (sym
->ns
&& sym
->ns
->proc_name
566 && sym
->ns
->proc_name
->backend_decl
== parent_decl
567 && (alternate_entry
|| entry_master
)))
572 /* Special case for assigning the return value of a function.
573 Self recursive functions must have an explicit return value. */
574 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
575 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
577 /* Similarly for alternate entry points. */
578 else if (alternate_entry
579 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
582 gfc_entry_list
*el
= NULL
;
584 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
587 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
592 else if (entry_master
593 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
595 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
600 /* Procedure actual arguments. */
601 else if (sym
->attr
.flavor
== FL_PROCEDURE
602 && se
->expr
!= current_function_decl
)
604 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
606 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
607 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
613 /* Dereference the expression, where needed. Since characters
614 are entirely different from other types, they are treated
616 if (sym
->ts
.type
== BT_CHARACTER
)
618 /* Dereference character pointer dummy arguments
620 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
622 || sym
->attr
.function
623 || sym
->attr
.result
))
624 se
->expr
= build_fold_indirect_ref (se
->expr
);
627 else if (!sym
->attr
.value
)
629 /* Dereference non-character scalar dummy arguments. */
630 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
631 se
->expr
= build_fold_indirect_ref (se
->expr
);
633 /* Dereference scalar hidden result. */
634 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
635 && (sym
->attr
.function
|| sym
->attr
.result
)
636 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
637 && !sym
->attr
.always_explicit
)
638 se
->expr
= build_fold_indirect_ref (se
->expr
);
640 /* Dereference non-character pointer variables.
641 These must be dummies, results, or scalars. */
642 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
644 || sym
->attr
.function
646 || !sym
->attr
.dimension
))
647 se
->expr
= build_fold_indirect_ref (se
->expr
);
653 /* For character variables, also get the length. */
654 if (sym
->ts
.type
== BT_CHARACTER
)
656 /* If the character length of an entry isn't set, get the length from
657 the master function instead. */
658 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
659 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
661 se
->string_length
= sym
->ts
.cl
->backend_decl
;
662 gcc_assert (se
->string_length
);
670 /* Return the descriptor if that's what we want and this is an array
671 section reference. */
672 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
674 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
675 /* Return the descriptor for array pointers and allocations. */
677 && ref
->next
== NULL
&& (se
->descriptor_only
))
680 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
681 /* Return a pointer to an element. */
685 if (ref
->u
.c
.sym
->attr
.extension
)
686 conv_parent_component_references (se
, ref
);
688 gfc_conv_component_ref (se
, ref
);
692 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
693 expr
->symtree
->name
, &expr
->where
);
702 /* Pointer assignment, allocation or pass by reference. Arrays are handled
704 if (se
->want_pointer
)
706 if (expr
->ts
.type
== BT_CHARACTER
)
707 gfc_conv_string_parameter (se
);
709 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
714 /* Unary ops are easy... Or they would be if ! was a valid op. */
717 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
722 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
723 /* Initialize the operand. */
724 gfc_init_se (&operand
, se
);
725 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
726 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
728 type
= gfc_typenode_for_spec (&expr
->ts
);
730 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
731 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
732 All other unary operators have an equivalent GIMPLE unary operator. */
733 if (code
== TRUTH_NOT_EXPR
)
734 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
735 build_int_cst (type
, 0));
737 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
741 /* Expand power operator to optimal multiplications when a value is raised
742 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
743 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
744 Programming", 3rd Edition, 1998. */
746 /* This code is mostly duplicated from expand_powi in the backend.
747 We establish the "optimal power tree" lookup table with the defined size.
748 The items in the table are the exponents used to calculate the index
749 exponents. Any integer n less than the value can get an "addition chain",
750 with the first node being one. */
751 #define POWI_TABLE_SIZE 256
753 /* The table is from builtins.c. */
754 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
756 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
757 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
758 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
759 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
760 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
761 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
762 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
763 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
764 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
765 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
766 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
767 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
768 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
769 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
770 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
771 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
772 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
773 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
774 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
775 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
776 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
777 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
778 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
779 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
780 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
781 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
782 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
783 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
784 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
785 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
786 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
787 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
790 /* If n is larger than lookup table's max index, we use the "window
792 #define POWI_WINDOW_SIZE 3
794 /* Recursive function to expand the power operator. The temporary
795 values are put in tmpvar. The function returns tmpvar[1] ** n. */
797 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
804 if (n
< POWI_TABLE_SIZE
)
809 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
810 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
814 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
815 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
816 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
820 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
824 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
825 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
827 if (n
< POWI_TABLE_SIZE
)
834 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
835 return 1. Else return 0 and a call to runtime library functions
836 will have to be built. */
838 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
843 tree vartmp
[POWI_TABLE_SIZE
];
845 unsigned HOST_WIDE_INT n
;
848 /* If exponent is too large, we won't expand it anyway, so don't bother
849 with large integer values. */
850 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
853 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
854 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
855 of the asymmetric range of the integer type. */
856 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
858 type
= TREE_TYPE (lhs
);
859 sgn
= tree_int_cst_sgn (rhs
);
861 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
862 || optimize_size
) && (m
> 2 || m
< -1))
868 se
->expr
= gfc_build_const (type
, integer_one_node
);
872 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
873 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
875 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
876 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
877 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
878 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
881 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
884 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
885 se
->expr
= fold_build3 (COND_EXPR
, type
,
886 tmp
, build_int_cst (type
, 1),
887 build_int_cst (type
, 0));
891 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
892 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
893 build_int_cst (type
, 0));
894 se
->expr
= fold_build3 (COND_EXPR
, type
,
895 cond
, build_int_cst (type
, 1), tmp
);
899 memset (vartmp
, 0, sizeof (vartmp
));
903 tmp
= gfc_build_const (type
, integer_one_node
);
904 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
907 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
913 /* Power op (**). Constant integer exponent has special handling. */
916 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
918 tree gfc_int4_type_node
;
925 gfc_init_se (&lse
, se
);
926 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
927 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
928 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
930 gfc_init_se (&rse
, se
);
931 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
932 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
934 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
935 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
936 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
939 gfc_int4_type_node
= gfc_get_int_type (4);
941 kind
= expr
->value
.op
.op1
->ts
.kind
;
942 switch (expr
->value
.op
.op2
->ts
.type
)
945 ikind
= expr
->value
.op
.op2
->ts
.kind
;
950 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
972 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
973 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
998 switch (expr
->value
.op
.op1
->ts
.type
)
1001 if (kind
== 3) /* Case 16 was not handled properly above. */
1003 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1007 /* Use builtins for real ** int4. */
1013 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1017 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1022 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1030 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1034 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1046 fndecl
= built_in_decls
[BUILT_IN_POWF
];
1049 fndecl
= built_in_decls
[BUILT_IN_POW
];
1053 fndecl
= built_in_decls
[BUILT_IN_POWL
];
1064 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
1067 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
1071 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
1083 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
1087 /* Generate code to allocate a string temporary. */
1090 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1095 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
1097 if (gfc_can_put_var_on_stack (len
))
1099 /* Create a temporary variable to hold the result. */
1100 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1101 build_int_cst (gfc_charlen_type_node
, 1));
1102 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1104 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1105 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1107 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1109 var
= gfc_create_var (tmp
, "str");
1110 var
= gfc_build_addr_expr (type
, var
);
1114 /* Allocate a temporary to hold the result. */
1115 var
= gfc_create_var (type
, "pstr");
1116 tmp
= gfc_call_malloc (&se
->pre
, type
,
1117 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
1118 fold_convert (TREE_TYPE (len
),
1119 TYPE_SIZE (type
))));
1120 gfc_add_modify (&se
->pre
, var
, tmp
);
1122 /* Free the temporary afterwards. */
1123 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1124 gfc_add_expr_to_block (&se
->post
, tmp
);
1131 /* Handle a string concatenation operation. A temporary will be allocated to
1135 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1138 tree len
, type
, var
, tmp
, fndecl
;
1140 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1141 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1142 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1144 gfc_init_se (&lse
, se
);
1145 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1146 gfc_conv_string_parameter (&lse
);
1147 gfc_init_se (&rse
, se
);
1148 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1149 gfc_conv_string_parameter (&rse
);
1151 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1152 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1154 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
1155 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1156 if (len
== NULL_TREE
)
1158 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1159 lse
.string_length
, rse
.string_length
);
1162 type
= build_pointer_type (type
);
1164 var
= gfc_conv_string_tmp (se
, type
, len
);
1166 /* Do the actual concatenation. */
1167 if (expr
->ts
.kind
== 1)
1168 fndecl
= gfor_fndecl_concat_string
;
1169 else if (expr
->ts
.kind
== 4)
1170 fndecl
= gfor_fndecl_concat_string_char4
;
1174 tmp
= build_call_expr (fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1175 rse
.string_length
, rse
.expr
);
1176 gfc_add_expr_to_block (&se
->pre
, tmp
);
1178 /* Add the cleanup for the operands. */
1179 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1180 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1183 se
->string_length
= len
;
1186 /* Translates an op expression. Common (binary) cases are handled by this
1187 function, others are passed on. Recursion is used in either case.
1188 We use the fact that (op1.ts == op2.ts) (except for the power
1190 Operators need no special handling for scalarized expressions as long as
1191 they call gfc_conv_simple_val to get their operands.
1192 Character strings get special handling. */
1195 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1197 enum tree_code code
;
1206 switch (expr
->value
.op
.op
)
1208 case INTRINSIC_PARENTHESES
:
1209 if (expr
->ts
.type
== BT_REAL
1210 || expr
->ts
.type
== BT_COMPLEX
)
1212 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1213 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1218 case INTRINSIC_UPLUS
:
1219 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1222 case INTRINSIC_UMINUS
:
1223 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1227 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1230 case INTRINSIC_PLUS
:
1234 case INTRINSIC_MINUS
:
1238 case INTRINSIC_TIMES
:
1242 case INTRINSIC_DIVIDE
:
1243 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1244 an integer, we must round towards zero, so we use a
1246 if (expr
->ts
.type
== BT_INTEGER
)
1247 code
= TRUNC_DIV_EXPR
;
1252 case INTRINSIC_POWER
:
1253 gfc_conv_power_op (se
, expr
);
1256 case INTRINSIC_CONCAT
:
1257 gfc_conv_concat_op (se
, expr
);
1261 code
= TRUTH_ANDIF_EXPR
;
1266 code
= TRUTH_ORIF_EXPR
;
1270 /* EQV and NEQV only work on logicals, but since we represent them
1271 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1273 case INTRINSIC_EQ_OS
:
1281 case INTRINSIC_NE_OS
:
1282 case INTRINSIC_NEQV
:
1289 case INTRINSIC_GT_OS
:
1296 case INTRINSIC_GE_OS
:
1303 case INTRINSIC_LT_OS
:
1310 case INTRINSIC_LE_OS
:
1316 case INTRINSIC_USER
:
1317 case INTRINSIC_ASSIGN
:
1318 /* These should be converted into function calls by the frontend. */
1322 fatal_error ("Unknown intrinsic op");
1326 /* The only exception to this is **, which is handled separately anyway. */
1327 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1329 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1333 gfc_init_se (&lse
, se
);
1334 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1335 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1338 gfc_init_se (&rse
, se
);
1339 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1340 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1344 gfc_conv_string_parameter (&lse
);
1345 gfc_conv_string_parameter (&rse
);
1347 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1348 rse
.string_length
, rse
.expr
,
1349 expr
->value
.op
.op1
->ts
.kind
);
1350 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1351 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1354 type
= gfc_typenode_for_spec (&expr
->ts
);
1358 /* The result of logical ops is always boolean_type_node. */
1359 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1360 se
->expr
= convert (type
, tmp
);
1363 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1365 /* Add the post blocks. */
1366 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1367 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1370 /* If a string's length is one, we convert it to a single character. */
1373 string_to_single_character (tree len
, tree str
, int kind
)
1375 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1377 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1378 && TREE_INT_CST_HIGH (len
) == 0)
1380 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1381 return build_fold_indirect_ref (str
);
1389 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1392 if (sym
->backend_decl
)
1394 /* This becomes the nominal_type in
1395 function.c:assign_parm_find_data_types. */
1396 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1397 /* This becomes the passed_type in
1398 function.c:assign_parm_find_data_types. C promotes char to
1399 integer for argument passing. */
1400 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1402 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1407 /* If we have a constant character expression, make it into an
1409 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1414 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1415 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1417 /* The expr needs to be compatible with a C int. If the
1418 conversion fails, then the 2 causes an ICE. */
1419 ts
.type
= BT_INTEGER
;
1420 ts
.kind
= gfc_c_int_kind
;
1421 gfc_convert_type (*expr
, &ts
, 2);
1424 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1426 if ((*expr
)->ref
== NULL
)
1428 se
->expr
= string_to_single_character
1429 (build_int_cst (integer_type_node
, 1),
1430 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1432 ((*expr
)->symtree
->n
.sym
)),
1437 gfc_conv_variable (se
, *expr
);
1438 se
->expr
= string_to_single_character
1439 (build_int_cst (integer_type_node
, 1),
1440 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1449 /* Compare two strings. If they are all single characters, the result is the
1450 subtraction of them. Otherwise, we build a library call. */
1453 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1459 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1460 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1462 sc1
= string_to_single_character (len1
, str1
, kind
);
1463 sc2
= string_to_single_character (len2
, str2
, kind
);
1465 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1467 /* Deal with single character specially. */
1468 sc1
= fold_convert (integer_type_node
, sc1
);
1469 sc2
= fold_convert (integer_type_node
, sc2
);
1470 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1474 /* Build a call for the comparison. */
1478 fndecl
= gfor_fndecl_compare_string
;
1480 fndecl
= gfor_fndecl_compare_string_char4
;
1484 tmp
= build_call_expr (fndecl
, 4, len1
, str1
, len2
, str2
);
1491 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1495 if (is_proc_ptr_comp (expr
, NULL
))
1496 tmp
= gfc_get_proc_ptr_comp (se
, expr
);
1497 else if (sym
->attr
.dummy
)
1499 tmp
= gfc_get_symbol_decl (sym
);
1500 if (sym
->attr
.proc_pointer
)
1501 tmp
= build_fold_indirect_ref (tmp
);
1502 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1503 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1507 if (!sym
->backend_decl
)
1508 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1510 tmp
= sym
->backend_decl
;
1512 if (sym
->attr
.cray_pointee
)
1514 /* TODO - make the cray pointee a pointer to a procedure,
1515 assign the pointer to it and use it for the call. This
1517 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1518 gfc_get_symbol_decl (sym
->cp_pointer
));
1519 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1522 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1524 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1525 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1532 /* Initialize MAPPING. */
1535 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1537 mapping
->syms
= NULL
;
1538 mapping
->charlens
= NULL
;
1542 /* Free all memory held by MAPPING (but not MAPPING itself). */
1545 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1547 gfc_interface_sym_mapping
*sym
;
1548 gfc_interface_sym_mapping
*nextsym
;
1550 gfc_charlen
*nextcl
;
1552 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1554 nextsym
= sym
->next
;
1555 sym
->new_sym
->n
.sym
->formal
= NULL
;
1556 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1557 gfc_free_expr (sym
->expr
);
1558 gfc_free (sym
->new_sym
);
1561 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1564 gfc_free_expr (cl
->length
);
1570 /* Return a copy of gfc_charlen CL. Add the returned structure to
1571 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1573 static gfc_charlen
*
1574 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1577 gfc_charlen
*new_charlen
;
1579 new_charlen
= gfc_get_charlen ();
1580 new_charlen
->next
= mapping
->charlens
;
1581 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1583 mapping
->charlens
= new_charlen
;
1588 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1589 array variable that can be used as the actual argument for dummy
1590 argument SYM. Add any initialization code to BLOCK. PACKED is as
1591 for gfc_get_nodesc_array_type and DATA points to the first element
1592 in the passed array. */
1595 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1596 gfc_packed packed
, tree data
)
1601 type
= gfc_typenode_for_spec (&sym
->ts
);
1602 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1604 var
= gfc_create_var (type
, "ifm");
1605 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1611 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1612 and offset of descriptorless array type TYPE given that it has the same
1613 size as DESC. Add any set-up code to BLOCK. */
1616 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1623 offset
= gfc_index_zero_node
;
1624 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1626 dim
= gfc_rank_cst
[n
];
1627 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1628 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1630 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1631 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1632 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1633 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1635 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1637 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1638 gfc_conv_descriptor_ubound_get (desc
, dim
),
1639 gfc_conv_descriptor_lbound_get (desc
, dim
));
1640 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1641 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1643 tmp
= gfc_evaluate_now (tmp
, block
);
1644 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1646 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1647 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1648 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1649 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1651 offset
= gfc_evaluate_now (offset
, block
);
1652 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1656 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1657 in SE. The caller may still use se->expr and se->string_length after
1658 calling this function. */
1661 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1662 gfc_symbol
* sym
, gfc_se
* se
,
1665 gfc_interface_sym_mapping
*sm
;
1669 gfc_symbol
*new_sym
;
1671 gfc_symtree
*new_symtree
;
1673 /* Create a new symbol to represent the actual argument. */
1674 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1675 new_sym
->ts
= sym
->ts
;
1676 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1677 new_sym
->attr
.referenced
= 1;
1678 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1679 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1680 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1681 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1682 new_sym
->attr
.function
= sym
->attr
.function
;
1684 /* Ensure that the interface is available and that
1685 descriptors are passed for array actual arguments. */
1686 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1688 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1689 new_sym
->attr
.always_explicit
1690 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1693 /* Create a fake symtree for it. */
1695 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1696 new_symtree
->n
.sym
= new_sym
;
1697 gcc_assert (new_symtree
== root
);
1699 /* Create a dummy->actual mapping. */
1700 sm
= XCNEW (gfc_interface_sym_mapping
);
1701 sm
->next
= mapping
->syms
;
1703 sm
->new_sym
= new_symtree
;
1704 sm
->expr
= gfc_copy_expr (expr
);
1707 /* Stabilize the argument's value. */
1708 if (!sym
->attr
.function
&& se
)
1709 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1711 if (sym
->ts
.type
== BT_CHARACTER
)
1713 /* Create a copy of the dummy argument's length. */
1714 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1715 sm
->expr
->ts
.cl
= new_sym
->ts
.cl
;
1717 /* If the length is specified as "*", record the length that
1718 the caller is passing. We should use the callee's length
1719 in all other cases. */
1720 if (!new_sym
->ts
.cl
->length
&& se
)
1722 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1723 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1730 /* Use the passed value as-is if the argument is a function. */
1731 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1734 /* If the argument is either a string or a pointer to a string,
1735 convert it to a boundless character type. */
1736 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1738 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1739 tmp
= build_pointer_type (tmp
);
1740 if (sym
->attr
.pointer
)
1741 value
= build_fold_indirect_ref (se
->expr
);
1744 value
= fold_convert (tmp
, value
);
1747 /* If the argument is a scalar, a pointer to an array or an allocatable,
1749 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1750 value
= build_fold_indirect_ref (se
->expr
);
1752 /* For character(*), use the actual argument's descriptor. */
1753 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1754 value
= build_fold_indirect_ref (se
->expr
);
1756 /* If the argument is an array descriptor, use it to determine
1757 information about the actual argument's shape. */
1758 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1759 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1761 /* Get the actual argument's descriptor. */
1762 desc
= build_fold_indirect_ref (se
->expr
);
1764 /* Create the replacement variable. */
1765 tmp
= gfc_conv_descriptor_data_get (desc
);
1766 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1769 /* Use DESC to work out the upper bounds, strides and offset. */
1770 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1773 /* Otherwise we have a packed array. */
1774 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1775 PACKED_FULL
, se
->expr
);
1777 new_sym
->backend_decl
= value
;
1781 /* Called once all dummy argument mappings have been added to MAPPING,
1782 but before the mapping is used to evaluate expressions. Pre-evaluate
1783 the length of each argument, adding any initialization code to PRE and
1784 any finalization code to POST. */
1787 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1788 stmtblock_t
* pre
, stmtblock_t
* post
)
1790 gfc_interface_sym_mapping
*sym
;
1794 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1795 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1796 && !sym
->new_sym
->n
.sym
->ts
.cl
->backend_decl
)
1798 expr
= sym
->new_sym
->n
.sym
->ts
.cl
->length
;
1799 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1800 gfc_init_se (&se
, NULL
);
1801 gfc_conv_expr (&se
, expr
);
1802 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1803 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1804 gfc_add_block_to_block (pre
, &se
.pre
);
1805 gfc_add_block_to_block (post
, &se
.post
);
1807 sym
->new_sym
->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1812 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1816 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1817 gfc_constructor
* c
)
1819 for (; c
; c
= c
->next
)
1821 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1824 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1825 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1826 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1832 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1836 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1841 for (; ref
; ref
= ref
->next
)
1845 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1847 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1848 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1849 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1851 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1858 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1859 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1865 /* Convert intrinsic function calls into result expressions. */
1868 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
1876 arg1
= expr
->value
.function
.actual
->expr
;
1877 if (expr
->value
.function
.actual
->next
)
1878 arg2
= expr
->value
.function
.actual
->next
->expr
;
1882 sym
= arg1
->symtree
->n
.sym
;
1884 if (sym
->attr
.dummy
)
1889 switch (expr
->value
.function
.isym
->id
)
1892 /* TODO figure out why this condition is necessary. */
1893 if (sym
->attr
.function
1894 && (arg1
->ts
.cl
->length
== NULL
1895 || (arg1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
1896 && arg1
->ts
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
1899 new_expr
= gfc_copy_expr (arg1
->ts
.cl
->length
);
1906 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1908 dup
= mpz_get_si (arg2
->value
.integer
);
1913 dup
= sym
->as
->rank
;
1917 for (; d
< dup
; d
++)
1921 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
1923 gfc_free_expr (new_expr
);
1927 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
1928 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1930 new_expr
= gfc_multiply (new_expr
, tmp
);
1936 case GFC_ISYM_LBOUND
:
1937 case GFC_ISYM_UBOUND
:
1938 /* TODO These implementations of lbound and ubound do not limit if
1939 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1944 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1945 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1947 /* TODO: If the need arises, this could produce an array of
1951 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
1953 if (sym
->as
->lower
[d
])
1954 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
1958 if (sym
->as
->upper
[d
])
1959 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
1967 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
1971 gfc_replace_expr (expr
, new_expr
);
1977 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
1978 gfc_interface_mapping
* mapping
)
1980 gfc_formal_arglist
*f
;
1981 gfc_actual_arglist
*actual
;
1983 actual
= expr
->value
.function
.actual
;
1984 f
= map_expr
->symtree
->n
.sym
->formal
;
1986 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
1991 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
1994 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
1999 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2001 for (d
= 0; d
< as
->rank
; d
++)
2003 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2004 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2007 expr
->value
.function
.esym
->as
= as
;
2010 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2012 expr
->value
.function
.esym
->ts
.cl
->length
2013 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.cl
->length
);
2015 gfc_apply_interface_mapping_to_expr (mapping
,
2016 expr
->value
.function
.esym
->ts
.cl
->length
);
2021 /* EXPR is a copy of an expression that appeared in the interface
2022 associated with MAPPING. Walk it recursively looking for references to
2023 dummy arguments that MAPPING maps to actual arguments. Replace each such
2024 reference with a reference to the associated actual argument. */
2027 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2030 gfc_interface_sym_mapping
*sym
;
2031 gfc_actual_arglist
*actual
;
2036 /* Copying an expression does not copy its length, so do that here. */
2037 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
2039 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
2040 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
2043 /* Apply the mapping to any references. */
2044 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2046 /* ...and to the expression's symbol, if it has one. */
2047 /* TODO Find out why the condition on expr->symtree had to be moved into
2048 the loop rather than being outside it, as originally. */
2049 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2050 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2052 if (sym
->new_sym
->n
.sym
->backend_decl
)
2053 expr
->symtree
= sym
->new_sym
;
2055 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2058 /* ...and to subexpressions in expr->value. */
2059 switch (expr
->expr_type
)
2064 case EXPR_SUBSTRING
:
2068 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2069 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2073 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2074 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2076 if (expr
->value
.function
.esym
== NULL
2077 && expr
->value
.function
.isym
!= NULL
2078 && expr
->value
.function
.actual
->expr
->symtree
2079 && gfc_map_intrinsic_function (expr
, mapping
))
2082 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2083 if (sym
->old
== expr
->value
.function
.esym
)
2085 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2086 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2087 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2092 case EXPR_STRUCTURE
:
2093 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2106 /* Evaluate interface expression EXPR using MAPPING. Store the result
2110 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2111 gfc_se
* se
, gfc_expr
* expr
)
2113 expr
= gfc_copy_expr (expr
);
2114 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2115 gfc_conv_expr (se
, expr
);
2116 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2117 gfc_free_expr (expr
);
2121 /* Returns a reference to a temporary array into which a component of
2122 an actual argument derived type array is copied and then returned
2123 after the function call. */
2125 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
2126 int g77
, sym_intent intent
)
2142 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2144 gfc_init_se (&lse
, NULL
);
2145 gfc_init_se (&rse
, NULL
);
2147 /* Walk the argument expression. */
2148 rss
= gfc_walk_expr (expr
);
2150 gcc_assert (rss
!= gfc_ss_terminator
);
2152 /* Initialize the scalarizer. */
2153 gfc_init_loopinfo (&loop
);
2154 gfc_add_ss_to_loop (&loop
, rss
);
2156 /* Calculate the bounds of the scalarization. */
2157 gfc_conv_ss_startstride (&loop
);
2159 /* Build an ss for the temporary. */
2160 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.cl
->backend_decl
)
2161 gfc_conv_string_length (expr
->ts
.cl
, expr
, &parmse
->pre
);
2163 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2164 if (GFC_ARRAY_TYPE_P (base_type
)
2165 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2166 base_type
= gfc_get_element_type (base_type
);
2168 loop
.temp_ss
= gfc_get_ss ();;
2169 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2170 loop
.temp_ss
->data
.temp
.type
= base_type
;
2172 if (expr
->ts
.type
== BT_CHARACTER
)
2173 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
2175 loop
.temp_ss
->string_length
= NULL
;
2177 parmse
->string_length
= loop
.temp_ss
->string_length
;
2178 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2179 loop
.temp_ss
->next
= gfc_ss_terminator
;
2181 /* Associate the SS with the loop. */
2182 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2184 /* Setup the scalarizing loops. */
2185 gfc_conv_loop_setup (&loop
, &expr
->where
);
2187 /* Pass the temporary descriptor back to the caller. */
2188 info
= &loop
.temp_ss
->data
.info
;
2189 parmse
->expr
= info
->descriptor
;
2191 /* Setup the gfc_se structures. */
2192 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2193 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2196 lse
.ss
= loop
.temp_ss
;
2197 gfc_mark_ss_chain_used (rss
, 1);
2198 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2200 /* Start the scalarized loop body. */
2201 gfc_start_scalarized_body (&loop
, &body
);
2203 /* Translate the expression. */
2204 gfc_conv_expr (&rse
, expr
);
2206 gfc_conv_tmp_array_ref (&lse
);
2207 gfc_advance_se_ss_chain (&lse
);
2209 if (intent
!= INTENT_OUT
)
2211 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2212 gfc_add_expr_to_block (&body
, tmp
);
2213 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2214 gfc_trans_scalarizing_loops (&loop
, &body
);
2218 /* Make sure that the temporary declaration survives by merging
2219 all the loop declarations into the current context. */
2220 for (n
= 0; n
< loop
.dimen
; n
++)
2222 gfc_merge_block_scope (&body
);
2223 body
= loop
.code
[loop
.order
[n
]];
2225 gfc_merge_block_scope (&body
);
2228 /* Add the post block after the second loop, so that any
2229 freeing of allocated memory is done at the right time. */
2230 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2232 /**********Copy the temporary back again.*********/
2234 gfc_init_se (&lse
, NULL
);
2235 gfc_init_se (&rse
, NULL
);
2237 /* Walk the argument expression. */
2238 lss
= gfc_walk_expr (expr
);
2239 rse
.ss
= loop
.temp_ss
;
2242 /* Initialize the scalarizer. */
2243 gfc_init_loopinfo (&loop2
);
2244 gfc_add_ss_to_loop (&loop2
, lss
);
2246 /* Calculate the bounds of the scalarization. */
2247 gfc_conv_ss_startstride (&loop2
);
2249 /* Setup the scalarizing loops. */
2250 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2252 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2253 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2255 gfc_mark_ss_chain_used (lss
, 1);
2256 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2258 /* Declare the variable to hold the temporary offset and start the
2259 scalarized loop body. */
2260 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2261 gfc_start_scalarized_body (&loop2
, &body
);
2263 /* Build the offsets for the temporary from the loop variables. The
2264 temporary array has lbounds of zero and strides of one in all
2265 dimensions, so this is very simple. The offset is only computed
2266 outside the innermost loop, so the overall transfer could be
2267 optimized further. */
2268 info
= &rse
.ss
->data
.info
;
2270 tmp_index
= gfc_index_zero_node
;
2271 for (n
= info
->dimen
- 1; n
> 0; n
--)
2274 tmp
= rse
.loop
->loopvar
[n
];
2275 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2276 tmp
, rse
.loop
->from
[n
]);
2277 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2280 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2281 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2282 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2283 tmp_str
, gfc_index_one_node
);
2285 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2289 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2290 tmp_index
, rse
.loop
->from
[0]);
2291 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2293 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2294 rse
.loop
->loopvar
[0], offset
);
2296 /* Now use the offset for the reference. */
2297 tmp
= build_fold_indirect_ref (info
->data
);
2298 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2300 if (expr
->ts
.type
== BT_CHARACTER
)
2301 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
2303 gfc_conv_expr (&lse
, expr
);
2305 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2307 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2308 gfc_add_expr_to_block (&body
, tmp
);
2310 /* Generate the copying loops. */
2311 gfc_trans_scalarizing_loops (&loop2
, &body
);
2313 /* Wrap the whole thing up by adding the second loop to the post-block
2314 and following it by the post-block of the first loop. In this way,
2315 if the temporary needs freeing, it is done after use! */
2316 if (intent
!= INTENT_IN
)
2318 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2319 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2322 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2324 gfc_cleanup_loop (&loop
);
2325 gfc_cleanup_loop (&loop2
);
2327 /* Pass the string length to the argument expression. */
2328 if (expr
->ts
.type
== BT_CHARACTER
)
2329 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
2331 /* We want either the address for the data or the address of the descriptor,
2332 depending on the mode of passing array arguments. */
2334 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2336 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2342 /* Generate the code for argument list functions. */
2345 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2347 /* Pass by value for g77 %VAL(arg), pass the address
2348 indirectly for %LOC, else by reference. Thus %REF
2349 is a "do-nothing" and %LOC is the same as an F95
2351 if (strncmp (name
, "%VAL", 4) == 0)
2352 gfc_conv_expr (se
, expr
);
2353 else if (strncmp (name
, "%LOC", 4) == 0)
2355 gfc_conv_expr_reference (se
, expr
);
2356 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2358 else if (strncmp (name
, "%REF", 4) == 0)
2359 gfc_conv_expr_reference (se
, expr
);
2361 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2365 /* Generate code for a procedure call. Note can return se->post != NULL.
2366 If se->direct_byref is set then se->expr contains the return parameter.
2367 Return nonzero, if the call has alternate specifiers.
2368 'expr' is only needed for procedure pointer components. */
2371 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2372 gfc_actual_arglist
* arg
, gfc_expr
* expr
,
2375 gfc_interface_mapping mapping
;
2389 gfc_formal_arglist
*formal
;
2390 int has_alternate_specifier
= 0;
2391 bool need_interface_mapping
;
2398 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2399 gfc_component
*comp
= NULL
;
2401 arglist
= NULL_TREE
;
2402 retargs
= NULL_TREE
;
2403 stringargs
= NULL_TREE
;
2408 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
)
2410 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2412 if (arg
->expr
->rank
== 0)
2413 gfc_conv_expr_reference (se
, arg
->expr
);
2417 /* This is really the actual arg because no formal arglist is
2418 created for C_LOC. */
2419 fsym
= arg
->expr
->symtree
->n
.sym
;
2421 /* We should want it to do g77 calling convention. */
2423 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2424 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2425 f
= f
|| !sym
->attr
.always_explicit
;
2427 argss
= gfc_walk_expr (arg
->expr
);
2428 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2432 /* TODO -- the following two lines shouldn't be necessary, but
2433 they're removed a bug is exposed later in the codepath.
2434 This is workaround was thus introduced, but will have to be
2435 removed; please see PR 35150 for details about the issue. */
2436 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2437 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2441 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2443 arg
->expr
->ts
.type
= sym
->ts
.derived
->ts
.type
;
2444 arg
->expr
->ts
.f90_type
= sym
->ts
.derived
->ts
.f90_type
;
2445 arg
->expr
->ts
.kind
= sym
->ts
.derived
->ts
.kind
;
2446 gfc_conv_expr_reference (se
, arg
->expr
);
2450 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2451 && arg
->next
->expr
->rank
== 0)
2452 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2454 /* Convert c_f_pointer if fptr is a scalar
2455 and convert c_f_procpointer. */
2459 gfc_init_se (&cptrse
, NULL
);
2460 gfc_conv_expr (&cptrse
, arg
->expr
);
2461 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2462 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2464 gfc_init_se (&fptrse
, NULL
);
2465 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2466 || is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2467 fptrse
.want_pointer
= 1;
2469 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2470 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2471 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2473 if (is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2474 tmp
= gfc_get_ppc_type (arg
->next
->expr
->ref
->u
.c
.component
);
2476 tmp
= TREE_TYPE (arg
->next
->expr
->symtree
->n
.sym
->backend_decl
);
2477 se
->expr
= fold_build2 (MODIFY_EXPR
, tmp
, fptrse
.expr
,
2478 fold_convert (tmp
, cptrse
.expr
));
2482 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2487 /* Build the addr_expr for the first argument. The argument is
2488 already an *address* so we don't need to set want_pointer in
2490 gfc_init_se (&arg1se
, NULL
);
2491 gfc_conv_expr (&arg1se
, arg
->expr
);
2492 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2493 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2495 /* See if we were given two arguments. */
2496 if (arg
->next
== NULL
)
2497 /* Only given one arg so generate a null and do a
2498 not-equal comparison against the first arg. */
2499 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2500 fold_convert (TREE_TYPE (arg1se
.expr
),
2501 null_pointer_node
));
2507 /* Given two arguments so build the arg2se from second arg. */
2508 gfc_init_se (&arg2se
, NULL
);
2509 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2510 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2511 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2513 /* Generate test to compare that the two args are equal. */
2514 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2515 arg1se
.expr
, arg2se
.expr
);
2516 /* Generate test to ensure that the first arg is not null. */
2517 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2518 arg1se
.expr
, null_pointer_node
);
2520 /* Finally, the generated test must check that both arg1 is not
2521 NULL and that it is equal to the second arg. */
2522 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2523 not_null_expr
, eq_expr
);
2532 if (!sym
->attr
.elemental
)
2534 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2535 if (se
->ss
->useflags
)
2537 gcc_assert (gfc_return_by_reference (sym
)
2538 && sym
->result
->attr
.dimension
);
2539 gcc_assert (se
->loop
!= NULL
);
2541 /* Access the previously obtained result. */
2542 gfc_conv_tmp_array_ref (se
);
2543 gfc_advance_se_ss_chain (se
);
2547 info
= &se
->ss
->data
.info
;
2552 gfc_init_block (&post
);
2553 gfc_init_interface_mapping (&mapping
);
2554 is_proc_ptr_comp (expr
, &comp
);
2555 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2556 && sym
->ts
.cl
->length
2557 && sym
->ts
.cl
->length
->expr_type
2559 || (comp
&& comp
->attr
.dimension
)
2560 || (!comp
&& sym
->attr
.dimension
));
2561 formal
= sym
->formal
;
2562 /* Evaluate the arguments. */
2563 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2566 fsym
= formal
? formal
->sym
: NULL
;
2567 parm_kind
= MISSING
;
2571 if (se
->ignore_optional
)
2573 /* Some intrinsics have already been resolved to the correct
2577 else if (arg
->label
)
2579 has_alternate_specifier
= 1;
2584 /* Pass a NULL pointer for an absent arg. */
2585 gfc_init_se (&parmse
, NULL
);
2586 parmse
.expr
= null_pointer_node
;
2587 if (arg
->missing_arg_type
== BT_CHARACTER
)
2588 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2591 else if (se
->ss
&& se
->ss
->useflags
)
2593 /* An elemental function inside a scalarized loop. */
2594 gfc_init_se (&parmse
, se
);
2595 gfc_conv_expr_reference (&parmse
, e
);
2596 parm_kind
= ELEMENTAL
;
2600 /* A scalar or transformational function. */
2601 gfc_init_se (&parmse
, NULL
);
2602 argss
= gfc_walk_expr (e
);
2604 if (argss
== gfc_ss_terminator
)
2606 if (e
->expr_type
== EXPR_VARIABLE
2607 && e
->symtree
->n
.sym
->attr
.cray_pointee
2608 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2610 /* The Cray pointer needs to be converted to a pointer to
2611 a type given by the expression. */
2612 gfc_conv_expr (&parmse
, e
);
2613 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2614 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2615 parmse
.expr
= convert (type
, tmp
);
2617 else if (fsym
&& fsym
->attr
.value
)
2619 if (fsym
->ts
.type
== BT_CHARACTER
2620 && fsym
->ts
.is_c_interop
2621 && fsym
->ns
->proc_name
!= NULL
2622 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2625 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2626 if (parmse
.expr
== NULL
)
2627 gfc_conv_expr (&parmse
, e
);
2630 gfc_conv_expr (&parmse
, e
);
2632 else if (arg
->name
&& arg
->name
[0] == '%')
2633 /* Argument list functions %VAL, %LOC and %REF are signalled
2634 through arg->name. */
2635 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2636 else if ((e
->expr_type
== EXPR_FUNCTION
)
2637 && e
->symtree
->n
.sym
->attr
.pointer
2638 && fsym
&& fsym
->attr
.target
)
2640 gfc_conv_expr (&parmse
, e
);
2641 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2645 gfc_conv_expr_reference (&parmse
, e
);
2646 if (fsym
&& e
->expr_type
!= EXPR_NULL
2647 && ((fsym
->attr
.pointer
2648 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
2649 || (fsym
->attr
.proc_pointer
2650 && !(e
->expr_type
== EXPR_VARIABLE
2651 && e
->symtree
->n
.sym
->attr
.dummy
))))
2653 /* Scalar pointer dummy args require an extra level of
2654 indirection. The null pointer already contains
2655 this level of indirection. */
2656 parm_kind
= SCALAR_POINTER
;
2657 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2663 /* If the procedure requires an explicit interface, the actual
2664 argument is passed according to the corresponding formal
2665 argument. If the corresponding formal argument is a POINTER,
2666 ALLOCATABLE or assumed shape, we do not use g77's calling
2667 convention, and pass the address of the array descriptor
2668 instead. Otherwise we use g77's calling convention. */
2671 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2672 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2673 f
= f
|| !sym
->attr
.always_explicit
;
2675 if (e
->expr_type
== EXPR_VARIABLE
2676 && is_subref_array (e
))
2677 /* The actual argument is a component reference to an
2678 array of derived types. In this case, the argument
2679 is converted to a temporary, which is passed and then
2680 written back after the procedure call. */
2681 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2682 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2684 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
2687 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2688 allocated on entry, it must be deallocated. */
2689 if (fsym
&& fsym
->attr
.allocatable
2690 && fsym
->attr
.intent
== INTENT_OUT
)
2692 tmp
= build_fold_indirect_ref (parmse
.expr
);
2693 tmp
= gfc_trans_dealloc_allocated (tmp
);
2694 gfc_add_expr_to_block (&se
->pre
, tmp
);
2700 /* The case with fsym->attr.optional is that of a user subroutine
2701 with an interface indicating an optional argument. When we call
2702 an intrinsic subroutine, however, fsym is NULL, but we might still
2703 have an optional argument, so we proceed to the substitution
2705 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2707 /* If an optional argument is itself an optional dummy argument,
2708 check its presence and substitute a null if absent. */
2709 if (e
->expr_type
== EXPR_VARIABLE
2710 && e
->symtree
->n
.sym
->attr
.optional
)
2711 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2712 e
->representation
.length
);
2717 /* Obtain the character length of an assumed character length
2718 length procedure from the typespec. */
2719 if (fsym
->ts
.type
== BT_CHARACTER
2720 && parmse
.string_length
== NULL_TREE
2721 && e
->ts
.type
== BT_PROCEDURE
2722 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2723 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
2724 && e
->symtree
->n
.sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2726 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2727 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2731 if (fsym
&& need_interface_mapping
&& e
)
2732 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2734 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2735 gfc_add_block_to_block (&post
, &parmse
.post
);
2737 /* Allocated allocatable components of derived types must be
2738 deallocated for non-variable scalars. Non-variable arrays are
2739 dealt with in trans-array.c(gfc_conv_array_parameter). */
2740 if (e
&& e
->ts
.type
== BT_DERIVED
2741 && e
->ts
.derived
->attr
.alloc_comp
2742 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
2743 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
2746 tmp
= build_fold_indirect_ref (parmse
.expr
);
2747 parm_rank
= e
->rank
;
2755 case (SCALAR_POINTER
):
2756 tmp
= build_fold_indirect_ref (tmp
);
2760 if (e
->expr_type
== EXPR_OP
2761 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
2762 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
2765 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
2766 local_tmp
= gfc_copy_alloc_comp (e
->ts
.derived
, local_tmp
, tmp
, parm_rank
);
2767 gfc_add_expr_to_block (&se
->post
, local_tmp
);
2770 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2772 gfc_add_expr_to_block (&se
->post
, tmp
);
2775 /* Add argument checking of passing an unallocated/NULL actual to
2776 a nonallocatable/nonpointer dummy. */
2778 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
)
2784 if (e
->expr_type
== EXPR_VARIABLE
)
2785 sym
= e
->symtree
->n
.sym
;
2786 else if (e
->expr_type
== EXPR_FUNCTION
)
2787 sym
= e
->symtree
->n
.sym
->result
;
2789 goto end_pointer_check
;
2791 if (sym
->attr
.allocatable
2792 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
2793 asprintf (&msg
, "Allocatable actual argument '%s' is not "
2794 "allocated", sym
->name
);
2795 else if (sym
->attr
.pointer
2796 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
2797 asprintf (&msg
, "Pointer actual argument '%s' is not "
2798 "associated", sym
->name
);
2799 else if (sym
->attr
.proc_pointer
2800 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
2801 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
2802 "associated", sym
->name
);
2804 goto end_pointer_check
;
2806 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
2807 fold_convert (TREE_TYPE (parmse
.expr
),
2808 null_pointer_node
));
2810 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
2817 /* Character strings are passed as two parameters, a length and a
2818 pointer - except for Bind(c) which only passes the pointer. */
2819 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
2820 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2822 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2824 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2827 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
2828 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
2829 else if (ts
.type
== BT_CHARACTER
)
2831 if (sym
->ts
.cl
->length
== NULL
)
2833 /* Assumed character length results are not allowed by 5.1.1.5 of the
2834 standard and are trapped in resolve.c; except in the case of SPREAD
2835 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2836 we take the character length of the first argument for the result.
2837 For dummies, we have to look through the formal argument list for
2838 this function and use the character length found there.*/
2839 if (!sym
->attr
.dummy
)
2840 cl
.backend_decl
= TREE_VALUE (stringargs
);
2843 formal
= sym
->ns
->proc_name
->formal
;
2844 for (; formal
; formal
= formal
->next
)
2845 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2846 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2853 /* Calculate the length of the returned string. */
2854 gfc_init_se (&parmse
, NULL
);
2855 if (need_interface_mapping
)
2856 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2858 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2859 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2860 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2862 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2863 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2864 build_int_cst (gfc_charlen_type_node
, 0));
2865 cl
.backend_decl
= tmp
;
2868 /* Set up a charlen structure for it. */
2873 len
= cl
.backend_decl
;
2876 byref
= (comp
&& comp
->attr
.dimension
)
2877 || (!comp
&& gfc_return_by_reference (sym
));
2880 if (se
->direct_byref
)
2882 /* Sometimes, too much indirection can be applied; e.g. for
2883 function_result = array_valued_recursive_function. */
2884 if (TREE_TYPE (TREE_TYPE (se
->expr
))
2885 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
2886 && GFC_DESCRIPTOR_TYPE_P
2887 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
2888 se
->expr
= build_fold_indirect_ref (se
->expr
);
2890 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2892 else if (sym
->result
->attr
.dimension
)
2894 gcc_assert (se
->loop
&& info
);
2896 /* Set the type of the array. */
2897 tmp
= gfc_typenode_for_spec (&ts
);
2898 info
->dimen
= se
->loop
->dimen
;
2900 /* Evaluate the bounds of the result, if known. */
2901 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2903 /* Create a temporary to store the result. In case the function
2904 returns a pointer, the temporary will be a shallow copy and
2905 mustn't be deallocated. */
2906 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2907 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2908 NULL_TREE
, false, !sym
->attr
.pointer
,
2909 callee_alloc
, &se
->ss
->expr
->where
);
2911 /* Pass the temporary as the first argument. */
2912 tmp
= info
->descriptor
;
2913 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
2914 retargs
= gfc_chainon_list (retargs
, tmp
);
2916 else if (ts
.type
== BT_CHARACTER
)
2918 /* Pass the string length. */
2919 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2920 type
= build_pointer_type (type
);
2922 /* Return an address to a char[0:len-1]* temporary for
2923 character pointers. */
2924 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2926 var
= gfc_create_var (type
, "pstr");
2928 /* Provide an address expression for the function arguments. */
2929 var
= gfc_build_addr_expr (NULL_TREE
, var
);
2932 var
= gfc_conv_string_tmp (se
, type
, len
);
2934 retargs
= gfc_chainon_list (retargs
, var
);
2938 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2940 type
= gfc_get_complex_type (ts
.kind
);
2941 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
2942 retargs
= gfc_chainon_list (retargs
, var
);
2945 /* Add the string length to the argument list. */
2946 if (ts
.type
== BT_CHARACTER
)
2947 retargs
= gfc_chainon_list (retargs
, len
);
2949 gfc_free_interface_mapping (&mapping
);
2951 /* Add the return arguments. */
2952 arglist
= chainon (retargs
, arglist
);
2954 /* Add the hidden string length parameters to the arguments. */
2955 arglist
= chainon (arglist
, stringargs
);
2957 /* We may want to append extra arguments here. This is used e.g. for
2958 calls to libgfortran_matmul_??, which need extra information. */
2959 if (append_args
!= NULL_TREE
)
2960 arglist
= chainon (arglist
, append_args
);
2962 /* Generate the actual call. */
2963 conv_function_val (se
, sym
, expr
);
2965 /* If there are alternate return labels, function type should be
2966 integer. Can't modify the type in place though, since it can be shared
2967 with other functions. For dummy arguments, the typing is done to
2968 to this result, even if it has to be repeated for each call. */
2969 if (has_alternate_specifier
2970 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2972 if (!sym
->attr
.dummy
)
2974 TREE_TYPE (sym
->backend_decl
)
2975 = build_function_type (integer_type_node
,
2976 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2977 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
2980 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2983 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2984 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2986 /* If we have a pointer function, but we don't want a pointer, e.g.
2989 where f is pointer valued, we have to dereference the result. */
2990 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
2991 && !is_proc_ptr_comp (expr
, NULL
))
2992 se
->expr
= build_fold_indirect_ref (se
->expr
);
2994 /* f2c calling conventions require a scalar default real function to
2995 return a double precision result. Convert this back to default
2996 real. We only care about the cases that can happen in Fortran 77.
2998 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2999 && sym
->ts
.kind
== gfc_default_real_kind
3000 && !sym
->attr
.always_explicit
)
3001 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3003 /* A pure function may still have side-effects - it may modify its
3005 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3007 if (!sym
->attr
.pure
)
3008 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3013 /* Add the function call to the pre chain. There is no expression. */
3014 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3015 se
->expr
= NULL_TREE
;
3017 if (!se
->direct_byref
)
3019 if (sym
->attr
.dimension
)
3021 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3023 /* Check the data pointer hasn't been modified. This would
3024 happen in a function returning a pointer. */
3025 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3026 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3028 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3031 se
->expr
= info
->descriptor
;
3032 /* Bundle in the string length. */
3033 se
->string_length
= len
;
3035 else if (sym
->ts
.type
== BT_CHARACTER
)
3037 /* Dereference for character pointer results. */
3038 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3039 se
->expr
= build_fold_indirect_ref (var
);
3043 se
->string_length
= len
;
3047 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3048 se
->expr
= build_fold_indirect_ref (var
);
3053 /* Follow the function call with the argument post block. */
3055 gfc_add_block_to_block (&se
->pre
, &post
);
3057 gfc_add_block_to_block (&se
->post
, &post
);
3059 return has_alternate_specifier
;
3063 /* Fill a character string with spaces. */
3066 fill_with_spaces (tree start
, tree type
, tree size
)
3068 stmtblock_t block
, loop
;
3069 tree i
, el
, exit_label
, cond
, tmp
;
3071 /* For a simple char type, we can call memset(). */
3072 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3073 return build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3074 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3075 lang_hooks
.to_target_charset (' ')),
3078 /* Otherwise, we use a loop:
3079 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3083 /* Initialize variables. */
3084 gfc_init_block (&block
);
3085 i
= gfc_create_var (sizetype
, "i");
3086 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3087 el
= gfc_create_var (build_pointer_type (type
), "el");
3088 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3089 exit_label
= gfc_build_label_decl (NULL_TREE
);
3090 TREE_USED (exit_label
) = 1;
3094 gfc_init_block (&loop
);
3096 /* Exit condition. */
3097 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3098 fold_convert (sizetype
, integer_zero_node
));
3099 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3100 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3101 build_empty_stmt (input_location
));
3102 gfc_add_expr_to_block (&loop
, tmp
);
3105 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3106 build_int_cst (type
,
3107 lang_hooks
.to_target_charset (' ')));
3109 /* Increment loop variables. */
3110 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3111 TYPE_SIZE_UNIT (type
)));
3112 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3114 TYPE_SIZE_UNIT (type
)));
3116 /* Making the loop... actually loop! */
3117 tmp
= gfc_finish_block (&loop
);
3118 tmp
= build1_v (LOOP_EXPR
, tmp
);
3119 gfc_add_expr_to_block (&block
, tmp
);
3121 /* The exit label. */
3122 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3123 gfc_add_expr_to_block (&block
, tmp
);
3126 return gfc_finish_block (&block
);
3130 /* Generate code to copy a string. */
3133 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3134 int dkind
, tree slength
, tree src
, int skind
)
3136 tree tmp
, dlen
, slen
;
3145 stmtblock_t tempblock
;
3147 gcc_assert (dkind
== skind
);
3149 if (slength
!= NULL_TREE
)
3151 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3152 ssc
= string_to_single_character (slen
, src
, skind
);
3156 slen
= build_int_cst (size_type_node
, 1);
3160 if (dlength
!= NULL_TREE
)
3162 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3163 dsc
= string_to_single_character (slen
, dest
, dkind
);
3167 dlen
= build_int_cst (size_type_node
, 1);
3171 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3172 ssc
= string_to_single_character (slen
, src
, skind
);
3173 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3174 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3177 /* Assign directly if the types are compatible. */
3178 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3179 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3181 gfc_add_modify (block
, dsc
, ssc
);
3185 /* Do nothing if the destination length is zero. */
3186 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3187 build_int_cst (size_type_node
, 0));
3189 /* The following code was previously in _gfortran_copy_string:
3191 // The two strings may overlap so we use memmove.
3193 copy_string (GFC_INTEGER_4 destlen, char * dest,
3194 GFC_INTEGER_4 srclen, const char * src)
3196 if (srclen >= destlen)
3198 // This will truncate if too long.
3199 memmove (dest, src, destlen);
3203 memmove (dest, src, srclen);
3205 memset (&dest[srclen], ' ', destlen - srclen);
3209 We're now doing it here for better optimization, but the logic
3212 /* For non-default character kinds, we have to multiply the string
3213 length by the base type size. */
3214 chartype
= gfc_get_char_type (dkind
);
3215 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3216 fold_convert (size_type_node
, slen
),
3217 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3218 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3219 fold_convert (size_type_node
, dlen
),
3220 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3223 dest
= fold_convert (pvoid_type_node
, dest
);
3225 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3228 src
= fold_convert (pvoid_type_node
, src
);
3230 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3232 /* Truncate string if source is too long. */
3233 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3234 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3235 3, dest
, src
, dlen
);
3237 /* Else copy and pad with spaces. */
3238 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
3239 3, dest
, src
, slen
);
3241 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3242 fold_convert (sizetype
, slen
));
3243 tmp4
= fill_with_spaces (tmp4
, chartype
,
3244 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3247 gfc_init_block (&tempblock
);
3248 gfc_add_expr_to_block (&tempblock
, tmp3
);
3249 gfc_add_expr_to_block (&tempblock
, tmp4
);
3250 tmp3
= gfc_finish_block (&tempblock
);
3252 /* The whole copy_string function is there. */
3253 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3254 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3255 build_empty_stmt (input_location
));
3256 gfc_add_expr_to_block (block
, tmp
);
3260 /* Translate a statement function.
3261 The value of a statement function reference is obtained by evaluating the
3262 expression using the values of the actual arguments for the values of the
3263 corresponding dummy arguments. */
3266 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3270 gfc_formal_arglist
*fargs
;
3271 gfc_actual_arglist
*args
;
3274 gfc_saved_var
*saved_vars
;
3280 sym
= expr
->symtree
->n
.sym
;
3281 args
= expr
->value
.function
.actual
;
3282 gfc_init_se (&lse
, NULL
);
3283 gfc_init_se (&rse
, NULL
);
3286 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3288 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3289 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3291 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3293 /* Each dummy shall be specified, explicitly or implicitly, to be
3295 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3298 /* Create a temporary to hold the value. */
3299 type
= gfc_typenode_for_spec (&fsym
->ts
);
3300 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3302 if (fsym
->ts
.type
== BT_CHARACTER
)
3304 /* Copy string arguments. */
3307 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
3308 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3310 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3311 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3314 gfc_conv_expr (&rse
, args
->expr
);
3315 gfc_conv_string_parameter (&rse
);
3316 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3317 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3319 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3320 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3321 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3322 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3326 /* For everything else, just evaluate the expression. */
3327 gfc_conv_expr (&lse
, args
->expr
);
3329 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3330 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3331 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3337 /* Use the temporary variables in place of the real ones. */
3338 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3339 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3341 gfc_conv_expr (se
, sym
->value
);
3343 if (sym
->ts
.type
== BT_CHARACTER
)
3345 gfc_conv_const_charlen (sym
->ts
.cl
);
3347 /* Force the expression to the correct length. */
3348 if (!INTEGER_CST_P (se
->string_length
)
3349 || tree_int_cst_lt (se
->string_length
,
3350 sym
->ts
.cl
->backend_decl
))
3352 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
3353 tmp
= gfc_create_var (type
, sym
->name
);
3354 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3355 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
3356 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3360 se
->string_length
= sym
->ts
.cl
->backend_decl
;
3363 /* Restore the original variables. */
3364 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3365 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3366 gfc_free (saved_vars
);
3370 /* Return the backend_decl for a procedure pointer component. */
3373 gfc_get_proc_ptr_comp (gfc_se
*se
, gfc_expr
*e
)
3376 gfc_init_se (&comp_se
, NULL
);
3377 e
->expr_type
= EXPR_VARIABLE
;
3378 gfc_conv_expr (&comp_se
, e
);
3379 comp_se
.expr
= build_fold_addr_expr (comp_se
.expr
);
3380 return gfc_evaluate_now (comp_se
.expr
, &se
->pre
);
3384 /* Translate a function expression. */
3387 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3391 if (expr
->value
.function
.isym
)
3393 gfc_conv_intrinsic_function (se
, expr
);
3397 /* We distinguish statement functions from general functions to improve
3398 runtime performance. */
3399 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3401 gfc_conv_statement_function (se
, expr
);
3405 /* expr.value.function.esym is the resolved (specific) function symbol for
3406 most functions. However this isn't set for dummy procedures. */
3407 sym
= expr
->value
.function
.esym
;
3409 sym
= expr
->symtree
->n
.sym
;
3411 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3417 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3419 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3420 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3422 gfc_conv_tmp_array_ref (se
);
3423 gfc_advance_se_ss_chain (se
);
3427 /* Build a static initializer. EXPR is the expression for the initial value.
3428 The other parameters describe the variable of the component being
3429 initialized. EXPR may be null. */
3432 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3433 bool array
, bool pointer
)
3437 if (!(expr
|| pointer
))
3440 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3441 (these are the only two iso_c_binding derived types that can be
3442 used as initialization expressions). If so, we need to modify
3443 the 'expr' to be that for a (void *). */
3444 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3445 && expr
->ts
.is_iso_c
&& expr
->ts
.derived
)
3447 gfc_symbol
*derived
= expr
->ts
.derived
;
3449 expr
= gfc_int_expr (0);
3451 /* The derived symbol has already been converted to a (void *). Use
3453 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3454 expr
->ts
.kind
= derived
->ts
.kind
;
3459 /* Arrays need special handling. */
3461 return gfc_build_null_descriptor (type
);
3463 return gfc_conv_array_initializer (type
, expr
);
3466 return fold_convert (type
, null_pointer_node
);
3472 gfc_init_se (&se
, NULL
);
3473 gfc_conv_structure (&se
, expr
, 1);
3477 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
3480 gfc_init_se (&se
, NULL
);
3481 gfc_conv_constant (&se
, expr
);
3488 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3500 gfc_start_block (&block
);
3502 /* Initialize the scalarizer. */
3503 gfc_init_loopinfo (&loop
);
3505 gfc_init_se (&lse
, NULL
);
3506 gfc_init_se (&rse
, NULL
);
3509 rss
= gfc_walk_expr (expr
);
3510 if (rss
== gfc_ss_terminator
)
3512 /* The rhs is scalar. Add a ss for the expression. */
3513 rss
= gfc_get_ss ();
3514 rss
->next
= gfc_ss_terminator
;
3515 rss
->type
= GFC_SS_SCALAR
;
3519 /* Create a SS for the destination. */
3520 lss
= gfc_get_ss ();
3521 lss
->type
= GFC_SS_COMPONENT
;
3523 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3524 lss
->next
= gfc_ss_terminator
;
3525 lss
->data
.info
.dimen
= cm
->as
->rank
;
3526 lss
->data
.info
.descriptor
= dest
;
3527 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3528 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3529 for (n
= 0; n
< cm
->as
->rank
; n
++)
3531 lss
->data
.info
.dim
[n
] = n
;
3532 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3533 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3535 mpz_init (lss
->shape
[n
]);
3536 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3537 cm
->as
->lower
[n
]->value
.integer
);
3538 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3541 /* Associate the SS with the loop. */
3542 gfc_add_ss_to_loop (&loop
, lss
);
3543 gfc_add_ss_to_loop (&loop
, rss
);
3545 /* Calculate the bounds of the scalarization. */
3546 gfc_conv_ss_startstride (&loop
);
3548 /* Setup the scalarizing loops. */
3549 gfc_conv_loop_setup (&loop
, &expr
->where
);
3551 /* Setup the gfc_se structures. */
3552 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3553 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3556 gfc_mark_ss_chain_used (rss
, 1);
3558 gfc_mark_ss_chain_used (lss
, 1);
3560 /* Start the scalarized loop body. */
3561 gfc_start_scalarized_body (&loop
, &body
);
3563 gfc_conv_tmp_array_ref (&lse
);
3564 if (cm
->ts
.type
== BT_CHARACTER
)
3565 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3567 gfc_conv_expr (&rse
, expr
);
3569 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3570 gfc_add_expr_to_block (&body
, tmp
);
3572 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3574 /* Generate the copying loops. */
3575 gfc_trans_scalarizing_loops (&loop
, &body
);
3577 /* Wrap the whole thing up. */
3578 gfc_add_block_to_block (&block
, &loop
.pre
);
3579 gfc_add_block_to_block (&block
, &loop
.post
);
3581 for (n
= 0; n
< cm
->as
->rank
; n
++)
3582 mpz_clear (lss
->shape
[n
]);
3583 gfc_free (lss
->shape
);
3585 gfc_cleanup_loop (&loop
);
3587 return gfc_finish_block (&block
);
3591 /* Assign a single component of a derived type constructor. */
3594 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3604 gfc_start_block (&block
);
3606 if (cm
->attr
.pointer
)
3608 gfc_init_se (&se
, NULL
);
3609 /* Pointer component. */
3610 if (cm
->attr
.dimension
)
3612 /* Array pointer. */
3613 if (expr
->expr_type
== EXPR_NULL
)
3614 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3617 rss
= gfc_walk_expr (expr
);
3618 se
.direct_byref
= 1;
3620 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3621 gfc_add_block_to_block (&block
, &se
.pre
);
3622 gfc_add_block_to_block (&block
, &se
.post
);
3627 /* Scalar pointers. */
3628 se
.want_pointer
= 1;
3629 gfc_conv_expr (&se
, expr
);
3630 gfc_add_block_to_block (&block
, &se
.pre
);
3631 gfc_add_modify (&block
, dest
,
3632 fold_convert (TREE_TYPE (dest
), se
.expr
));
3633 gfc_add_block_to_block (&block
, &se
.post
);
3636 else if (cm
->attr
.dimension
)
3638 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
3639 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
3640 else if (cm
->attr
.allocatable
)
3644 gfc_init_se (&se
, NULL
);
3646 rss
= gfc_walk_expr (expr
);
3647 se
.want_pointer
= 0;
3648 gfc_conv_expr_descriptor (&se
, expr
, rss
);
3649 gfc_add_block_to_block (&block
, &se
.pre
);
3651 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
3652 gfc_add_modify (&block
, dest
, tmp
);
3654 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
3655 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
3658 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
3659 TREE_TYPE(cm
->backend_decl
),
3662 gfc_add_expr_to_block (&block
, tmp
);
3663 gfc_add_block_to_block (&block
, &se
.post
);
3665 if (expr
->expr_type
!= EXPR_VARIABLE
)
3666 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
3668 /* Shift the lbound and ubound of temporaries to being unity, rather
3669 than zero, based. Calculate the offset for all cases. */
3670 offset
= gfc_conv_descriptor_offset_get (dest
);
3671 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
3672 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
3673 for (n
= 0; n
< expr
->rank
; n
++)
3675 if (expr
->expr_type
!= EXPR_VARIABLE
3676 && expr
->expr_type
!= EXPR_CONSTANT
)
3679 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
3680 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
3681 gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
3682 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
3683 span
, gfc_index_one_node
);
3684 gfc_conv_descriptor_ubound_set (&block
, dest
, gfc_rank_cst
[n
],
3686 gfc_conv_descriptor_lbound_set (&block
, dest
, gfc_rank_cst
[n
],
3687 gfc_index_one_node
);
3689 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
3690 gfc_conv_descriptor_lbound_get (dest
,
3692 gfc_conv_descriptor_stride_get (dest
,
3694 gfc_add_modify (&block
, tmp2
, tmp
);
3695 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
3696 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
3699 if (expr
->expr_type
== EXPR_FUNCTION
3700 && expr
->value
.function
.isym
3701 && expr
->value
.function
.isym
->conversion
3702 && expr
->value
.function
.actual
->expr
3703 && expr
->value
.function
.actual
->expr
->expr_type
3706 /* If a conversion expression has a null data pointer
3707 argument, nullify the allocatable component. */
3711 s
= expr
->value
.function
.actual
->expr
->symtree
->n
.sym
;
3712 if (s
->attr
.allocatable
|| s
->attr
.pointer
)
3714 non_null_expr
= gfc_finish_block (&block
);
3715 gfc_start_block (&block
);
3716 gfc_conv_descriptor_data_set (&block
, dest
,
3718 null_expr
= gfc_finish_block (&block
);
3719 tmp
= gfc_conv_descriptor_data_get (s
->backend_decl
);
3720 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
3721 fold_convert (TREE_TYPE (tmp
),
3722 null_pointer_node
));
3723 return build3_v (COND_EXPR
, tmp
, null_expr
,
3730 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
3731 gfc_add_expr_to_block (&block
, tmp
);
3734 else if (expr
->ts
.type
== BT_DERIVED
)
3736 if (expr
->expr_type
!= EXPR_STRUCTURE
)
3738 gfc_init_se (&se
, NULL
);
3739 gfc_conv_expr (&se
, expr
);
3740 gfc_add_block_to_block (&block
, &se
.pre
);
3741 gfc_add_modify (&block
, dest
,
3742 fold_convert (TREE_TYPE (dest
), se
.expr
));
3743 gfc_add_block_to_block (&block
, &se
.post
);
3747 /* Nested constructors. */
3748 tmp
= gfc_trans_structure_assign (dest
, expr
);
3749 gfc_add_expr_to_block (&block
, tmp
);
3754 /* Scalar component. */
3755 gfc_init_se (&se
, NULL
);
3756 gfc_init_se (&lse
, NULL
);
3758 gfc_conv_expr (&se
, expr
);
3759 if (cm
->ts
.type
== BT_CHARACTER
)
3760 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3762 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3763 gfc_add_expr_to_block (&block
, tmp
);
3765 return gfc_finish_block (&block
);
3768 /* Assign a derived type constructor to a variable. */
3771 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3779 gfc_start_block (&block
);
3780 cm
= expr
->ts
.derived
->components
;
3781 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3783 /* Skip absent members in default initializers. */
3787 field
= cm
->backend_decl
;
3788 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
3789 dest
, field
, NULL_TREE
);
3790 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3791 gfc_add_expr_to_block (&block
, tmp
);
3793 return gfc_finish_block (&block
);
3796 /* Build an expression for a constructor. If init is nonzero then
3797 this is part of a static variable initializer. */
3800 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3807 VEC(constructor_elt
,gc
) *v
= NULL
;
3809 gcc_assert (se
->ss
== NULL
);
3810 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3811 type
= gfc_typenode_for_spec (&expr
->ts
);
3815 /* Create a temporary variable and fill it in. */
3816 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3817 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3818 gfc_add_expr_to_block (&se
->pre
, tmp
);
3822 cm
= expr
->ts
.derived
->components
;
3824 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3826 /* Skip absent members in default initializers and allocatable
3827 components. Although the latter have a default initializer
3828 of EXPR_NULL,... by default, the static nullify is not needed
3829 since this is done every time we come into scope. */
3830 if (!c
->expr
|| cm
->attr
.allocatable
)
3833 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3834 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
,
3835 cm
->attr
.pointer
|| cm
->attr
.proc_pointer
);
3837 /* Append it to the constructor list. */
3838 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3840 se
->expr
= build_constructor (type
, v
);
3842 TREE_CONSTANT (se
->expr
) = 1;
3846 /* Translate a substring expression. */
3849 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3855 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
3857 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
3858 expr
->value
.character
.length
,
3859 expr
->value
.character
.string
);
3861 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3862 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
3865 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
3869 /* Entry point for expression translation. Evaluates a scalar quantity.
3870 EXPR is the expression to be translated, and SE is the state structure if
3871 called from within the scalarized. */
3874 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3876 if (se
->ss
&& se
->ss
->expr
== expr
3877 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3879 /* Substitute a scalar expression evaluated outside the scalarization
3881 se
->expr
= se
->ss
->data
.scalar
.expr
;
3882 se
->string_length
= se
->ss
->string_length
;
3883 gfc_advance_se_ss_chain (se
);
3887 /* We need to convert the expressions for the iso_c_binding derived types.
3888 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3889 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3890 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3891 updated to be an integer with a kind equal to the size of a (void *). */
3892 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.derived
3893 && expr
->ts
.derived
->attr
.is_iso_c
)
3895 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
3896 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
3898 /* Set expr_type to EXPR_NULL, which will result in
3899 null_pointer_node being used below. */
3900 expr
->expr_type
= EXPR_NULL
;
3904 /* Update the type/kind of the expression to be what the new
3905 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3906 expr
->ts
.type
= expr
->ts
.derived
->ts
.type
;
3907 expr
->ts
.f90_type
= expr
->ts
.derived
->ts
.f90_type
;
3908 expr
->ts
.kind
= expr
->ts
.derived
->ts
.kind
;
3912 switch (expr
->expr_type
)
3915 gfc_conv_expr_op (se
, expr
);
3919 gfc_conv_function_expr (se
, expr
);
3923 gfc_conv_constant (se
, expr
);
3927 gfc_conv_variable (se
, expr
);
3931 se
->expr
= null_pointer_node
;
3934 case EXPR_SUBSTRING
:
3935 gfc_conv_substring_expr (se
, expr
);
3938 case EXPR_STRUCTURE
:
3939 gfc_conv_structure (se
, expr
, 0);
3943 gfc_conv_array_constructor_expr (se
, expr
);
3952 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3953 of an assignment. */
3955 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3957 gfc_conv_expr (se
, expr
);
3958 /* All numeric lvalues should have empty post chains. If not we need to
3959 figure out a way of rewriting an lvalue so that it has no post chain. */
3960 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3963 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3964 numeric expressions. Used for scalar values where inserting cleanup code
3967 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3971 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3972 gfc_conv_expr (se
, expr
);
3975 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3976 gfc_add_modify (&se
->pre
, val
, se
->expr
);
3978 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3982 /* Helper to translate an expression and convert it to a particular type. */
3984 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3986 gfc_conv_expr_val (se
, expr
);
3987 se
->expr
= convert (type
, se
->expr
);
3991 /* Converts an expression so that it can be passed by reference. Scalar
3995 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3999 if (se
->ss
&& se
->ss
->expr
== expr
4000 && se
->ss
->type
== GFC_SS_REFERENCE
)
4002 se
->expr
= se
->ss
->data
.scalar
.expr
;
4003 se
->string_length
= se
->ss
->string_length
;
4004 gfc_advance_se_ss_chain (se
);
4008 if (expr
->ts
.type
== BT_CHARACTER
)
4010 gfc_conv_expr (se
, expr
);
4011 gfc_conv_string_parameter (se
);
4015 if (expr
->expr_type
== EXPR_VARIABLE
)
4017 se
->want_pointer
= 1;
4018 gfc_conv_expr (se
, expr
);
4021 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4022 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4023 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4029 if (expr
->expr_type
== EXPR_FUNCTION
4030 && expr
->symtree
->n
.sym
->attr
.pointer
4031 && !expr
->symtree
->n
.sym
->attr
.dimension
)
4033 se
->want_pointer
= 1;
4034 gfc_conv_expr (se
, expr
);
4035 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4036 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4042 gfc_conv_expr (se
, expr
);
4044 /* Create a temporary var to hold the value. */
4045 if (TREE_CONSTANT (se
->expr
))
4047 tree tmp
= se
->expr
;
4048 STRIP_TYPE_NOPS (tmp
);
4049 var
= build_decl (input_location
,
4050 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4051 DECL_INITIAL (var
) = tmp
;
4052 TREE_STATIC (var
) = 1;
4057 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4058 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4060 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4062 /* Take the address of that value. */
4063 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4068 gfc_trans_pointer_assign (gfc_code
* code
)
4070 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4074 /* Generate code for a pointer assignment. */
4077 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4088 gfc_start_block (&block
);
4090 gfc_init_se (&lse
, NULL
);
4092 lss
= gfc_walk_expr (expr1
);
4093 rss
= gfc_walk_expr (expr2
);
4094 if (lss
== gfc_ss_terminator
)
4096 /* Scalar pointers. */
4097 lse
.want_pointer
= 1;
4098 gfc_conv_expr (&lse
, expr1
);
4099 gcc_assert (rss
== gfc_ss_terminator
);
4100 gfc_init_se (&rse
, NULL
);
4101 rse
.want_pointer
= 1;
4102 gfc_conv_expr (&rse
, expr2
);
4104 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4105 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4106 lse
.expr
= build_fold_indirect_ref (lse
.expr
);
4108 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4109 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4110 rse
.expr
= build_fold_indirect_ref (rse
.expr
);
4112 gfc_add_block_to_block (&block
, &lse
.pre
);
4113 gfc_add_block_to_block (&block
, &rse
.pre
);
4115 /* Check character lengths if character expression. The test is only
4116 really added if -fbounds-check is enabled. */
4117 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4119 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4120 gcc_assert (lse
.string_length
&& rse
.string_length
);
4121 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4122 lse
.string_length
, rse
.string_length
,
4126 gfc_add_modify (&block
, lse
.expr
,
4127 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4129 gfc_add_block_to_block (&block
, &rse
.post
);
4130 gfc_add_block_to_block (&block
, &lse
.post
);
4135 tree strlen_rhs
= NULL_TREE
;
4137 /* Array pointer. */
4138 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4139 strlen_lhs
= lse
.string_length
;
4140 switch (expr2
->expr_type
)
4143 /* Just set the data pointer to null. */
4144 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4148 /* Assign directly to the pointer's descriptor. */
4149 lse
.direct_byref
= 1;
4150 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4151 strlen_rhs
= lse
.string_length
;
4153 /* If this is a subreference array pointer assignment, use the rhs
4154 descriptor element size for the lhs span. */
4155 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4157 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4158 gfc_init_se (&rse
, NULL
);
4159 rse
.descriptor_only
= 1;
4160 gfc_conv_expr (&rse
, expr2
);
4161 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4162 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4163 if (!INTEGER_CST_P (tmp
))
4164 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4165 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4171 /* Assign to a temporary descriptor and then copy that
4172 temporary to the pointer. */
4174 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4177 lse
.direct_byref
= 1;
4178 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4179 strlen_rhs
= lse
.string_length
;
4180 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4184 gfc_add_block_to_block (&block
, &lse
.pre
);
4186 /* Check string lengths if applicable. The check is only really added
4187 to the output code if -fbounds-check is enabled. */
4188 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4190 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4191 gcc_assert (strlen_lhs
&& strlen_rhs
);
4192 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4193 strlen_lhs
, strlen_rhs
, &block
);
4196 gfc_add_block_to_block (&block
, &lse
.post
);
4198 return gfc_finish_block (&block
);
4202 /* Makes sure se is suitable for passing as a function string parameter. */
4203 /* TODO: Need to check all callers of this function. It may be abused. */
4206 gfc_conv_string_parameter (gfc_se
* se
)
4210 if (TREE_CODE (se
->expr
) == STRING_CST
)
4212 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4213 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4217 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4219 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4221 type
= TREE_TYPE (se
->expr
);
4222 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4226 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4228 type
= build_pointer_type (type
);
4229 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4233 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4234 gcc_assert (se
->string_length
4235 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4239 /* Generate code for assignment of scalar variables. Includes character
4240 strings and derived types with allocatable components. */
4243 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4244 bool l_is_temp
, bool r_is_var
)
4250 gfc_init_block (&block
);
4252 if (ts
.type
== BT_CHARACTER
)
4257 if (lse
->string_length
!= NULL_TREE
)
4259 gfc_conv_string_parameter (lse
);
4260 gfc_add_block_to_block (&block
, &lse
->pre
);
4261 llen
= lse
->string_length
;
4264 if (rse
->string_length
!= NULL_TREE
)
4266 gcc_assert (rse
->string_length
!= NULL_TREE
);
4267 gfc_conv_string_parameter (rse
);
4268 gfc_add_block_to_block (&block
, &rse
->pre
);
4269 rlen
= rse
->string_length
;
4272 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4273 rse
->expr
, ts
.kind
);
4275 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
4279 /* Are the rhs and the lhs the same? */
4282 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4283 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
4284 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
4285 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4288 /* Deallocate the lhs allocated components as long as it is not
4289 the same as the rhs. This must be done following the assignment
4290 to prevent deallocating data that could be used in the rhs
4294 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4295 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, tmp
, 0);
4297 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4299 gfc_add_expr_to_block (&lse
->post
, tmp
);
4302 gfc_add_block_to_block (&block
, &rse
->pre
);
4303 gfc_add_block_to_block (&block
, &lse
->pre
);
4305 gfc_add_modify (&block
, lse
->expr
,
4306 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4308 /* Do a deep copy if the rhs is a variable, if it is not the
4312 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
4313 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4315 gfc_add_expr_to_block (&block
, tmp
);
4320 gfc_add_block_to_block (&block
, &lse
->pre
);
4321 gfc_add_block_to_block (&block
, &rse
->pre
);
4323 gfc_add_modify (&block
, lse
->expr
,
4324 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4327 gfc_add_block_to_block (&block
, &lse
->post
);
4328 gfc_add_block_to_block (&block
, &rse
->post
);
4330 return gfc_finish_block (&block
);
4334 /* Try to translate array(:) = func (...), where func is a transformational
4335 array function, without using a temporary. Returns NULL is this isn't the
4339 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4344 bool seen_array_ref
;
4346 gfc_component
*comp
= NULL
;
4348 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4349 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4352 /* Elemental functions don't need a temporary anyway. */
4353 if (expr2
->value
.function
.esym
!= NULL
4354 && expr2
->value
.function
.esym
->attr
.elemental
)
4357 /* Fail if rhs is not FULL or a contiguous section. */
4358 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
4361 /* Fail if EXPR1 can't be expressed as a descriptor. */
4362 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4365 /* Functions returning pointers need temporaries. */
4366 if (expr2
->symtree
->n
.sym
->attr
.pointer
4367 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4370 /* Character array functions need temporaries unless the
4371 character lengths are the same. */
4372 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4374 if (expr1
->ts
.cl
->length
== NULL
4375 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4378 if (expr2
->ts
.cl
->length
== NULL
4379 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4382 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
4383 expr2
->ts
.cl
->length
->value
.integer
) != 0)
4387 /* Check that no LHS component references appear during an array
4388 reference. This is needed because we do not have the means to
4389 span any arbitrary stride with an array descriptor. This check
4390 is not needed for the rhs because the function result has to be
4392 seen_array_ref
= false;
4393 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4395 if (ref
->type
== REF_ARRAY
)
4396 seen_array_ref
= true;
4397 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4401 /* Check for a dependency. */
4402 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4403 expr2
->value
.function
.esym
,
4404 expr2
->value
.function
.actual
,
4408 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4410 is_proc_ptr_comp(expr2
, &comp
);
4411 gcc_assert (expr2
->value
.function
.isym
4412 || (comp
&& comp
->attr
.dimension
)
4413 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
4414 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
4416 ss
= gfc_walk_expr (expr1
);
4417 gcc_assert (ss
!= gfc_ss_terminator
);
4418 gfc_init_se (&se
, NULL
);
4419 gfc_start_block (&se
.pre
);
4420 se
.want_pointer
= 1;
4422 gfc_conv_array_parameter (&se
, expr1
, ss
, 0, NULL
, NULL
, NULL
);
4424 se
.direct_byref
= 1;
4425 se
.ss
= gfc_walk_expr (expr2
);
4426 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4427 gfc_conv_function_expr (&se
, expr2
);
4428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4430 return gfc_finish_block (&se
.pre
);
4433 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4436 is_zero_initializer_p (gfc_expr
* expr
)
4438 if (expr
->expr_type
!= EXPR_CONSTANT
)
4441 /* We ignore constants with prescribed memory representations for now. */
4442 if (expr
->representation
.string
)
4445 switch (expr
->ts
.type
)
4448 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4451 return mpfr_zero_p (expr
->value
.real
)
4452 && MPFR_SIGN (expr
->value
.real
) >= 0;
4455 return expr
->value
.logical
== 0;
4458 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4459 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4460 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4461 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4469 /* Try to efficiently translate array(:) = 0. Return NULL if this
4473 gfc_trans_zero_assign (gfc_expr
* expr
)
4475 tree dest
, len
, type
;
4479 sym
= expr
->symtree
->n
.sym
;
4480 dest
= gfc_get_symbol_decl (sym
);
4482 type
= TREE_TYPE (dest
);
4483 if (POINTER_TYPE_P (type
))
4484 type
= TREE_TYPE (type
);
4485 if (!GFC_ARRAY_TYPE_P (type
))
4488 /* Determine the length of the array. */
4489 len
= GFC_TYPE_ARRAY_SIZE (type
);
4490 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4493 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4494 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4495 fold_convert (gfc_array_index_type
, tmp
));
4497 /* If we are zeroing a local array avoid taking its address by emitting
4499 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4500 return build2 (MODIFY_EXPR
, void_type_node
,
4501 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
4503 /* Convert arguments to the correct types. */
4504 dest
= fold_convert (pvoid_type_node
, dest
);
4505 len
= fold_convert (size_type_node
, len
);
4507 /* Construct call to __builtin_memset. */
4508 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
4509 3, dest
, integer_zero_node
, len
);
4510 return fold_convert (void_type_node
, tmp
);
4514 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4515 that constructs the call to __builtin_memcpy. */
4518 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4522 /* Convert arguments to the correct types. */
4523 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4524 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4526 dst
= fold_convert (pvoid_type_node
, dst
);
4528 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4529 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4531 src
= fold_convert (pvoid_type_node
, src
);
4533 len
= fold_convert (size_type_node
, len
);
4535 /* Construct call to __builtin_memcpy. */
4536 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4537 return fold_convert (void_type_node
, tmp
);
4541 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4542 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4543 source/rhs, both are gfc_full_array_ref_p which have been checked for
4547 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4549 tree dst
, dlen
, dtype
;
4550 tree src
, slen
, stype
;
4553 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4554 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4556 dtype
= TREE_TYPE (dst
);
4557 if (POINTER_TYPE_P (dtype
))
4558 dtype
= TREE_TYPE (dtype
);
4559 stype
= TREE_TYPE (src
);
4560 if (POINTER_TYPE_P (stype
))
4561 stype
= TREE_TYPE (stype
);
4563 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
4566 /* Determine the lengths of the arrays. */
4567 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
4568 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
4570 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4571 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
4572 fold_convert (gfc_array_index_type
, tmp
));
4574 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
4575 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
4577 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
4578 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
4579 fold_convert (gfc_array_index_type
, tmp
));
4581 /* Sanity check that they are the same. This should always be
4582 the case, as we should already have checked for conformance. */
4583 if (!tree_int_cst_equal (slen
, dlen
))
4586 return gfc_build_memcpy_call (dst
, src
, dlen
);
4590 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4591 this can't be done. EXPR1 is the destination/lhs for which
4592 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4595 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4597 unsigned HOST_WIDE_INT nelem
;
4603 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
4607 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4608 dtype
= TREE_TYPE (dst
);
4609 if (POINTER_TYPE_P (dtype
))
4610 dtype
= TREE_TYPE (dtype
);
4611 if (!GFC_ARRAY_TYPE_P (dtype
))
4614 /* Determine the lengths of the array. */
4615 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
4616 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4619 /* Confirm that the constructor is the same size. */
4620 if (compare_tree_int (len
, nelem
) != 0)
4623 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
4624 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4625 fold_convert (gfc_array_index_type
, tmp
));
4627 stype
= gfc_typenode_for_spec (&expr2
->ts
);
4628 src
= gfc_build_constant_array_constructor (expr2
, stype
);
4630 stype
= TREE_TYPE (src
);
4631 if (POINTER_TYPE_P (stype
))
4632 stype
= TREE_TYPE (stype
);
4634 return gfc_build_memcpy_call (dst
, src
, len
);
4638 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4639 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4642 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4647 gfc_ss
*lss_section
;
4654 bool scalar_to_array
;
4657 /* Assignment of the form lhs = rhs. */
4658 gfc_start_block (&block
);
4660 gfc_init_se (&lse
, NULL
);
4661 gfc_init_se (&rse
, NULL
);
4664 lss
= gfc_walk_expr (expr1
);
4666 if (lss
!= gfc_ss_terminator
)
4668 /* Allow the scalarizer to workshare array assignments. */
4669 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
4670 ompws_flags
|= OMPWS_SCALARIZER_WS
;
4672 /* The assignment needs scalarization. */
4675 /* Find a non-scalar SS from the lhs. */
4676 while (lss_section
!= gfc_ss_terminator
4677 && lss_section
->type
!= GFC_SS_SECTION
)
4678 lss_section
= lss_section
->next
;
4680 gcc_assert (lss_section
!= gfc_ss_terminator
);
4682 /* Initialize the scalarizer. */
4683 gfc_init_loopinfo (&loop
);
4686 rss
= gfc_walk_expr (expr2
);
4687 if (rss
== gfc_ss_terminator
)
4689 /* The rhs is scalar. Add a ss for the expression. */
4690 rss
= gfc_get_ss ();
4691 rss
->next
= gfc_ss_terminator
;
4692 rss
->type
= GFC_SS_SCALAR
;
4695 /* Associate the SS with the loop. */
4696 gfc_add_ss_to_loop (&loop
, lss
);
4697 gfc_add_ss_to_loop (&loop
, rss
);
4699 /* Calculate the bounds of the scalarization. */
4700 gfc_conv_ss_startstride (&loop
);
4701 /* Resolve any data dependencies in the statement. */
4702 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
4703 /* Setup the scalarizing loops. */
4704 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4706 /* Setup the gfc_se structures. */
4707 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4708 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4711 gfc_mark_ss_chain_used (rss
, 1);
4712 if (loop
.temp_ss
== NULL
)
4715 gfc_mark_ss_chain_used (lss
, 1);
4719 lse
.ss
= loop
.temp_ss
;
4720 gfc_mark_ss_chain_used (lss
, 3);
4721 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4724 /* Start the scalarized loop body. */
4725 gfc_start_scalarized_body (&loop
, &body
);
4728 gfc_init_block (&body
);
4730 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
4732 /* Translate the expression. */
4733 gfc_conv_expr (&rse
, expr2
);
4735 /* Stabilize a string length for temporaries. */
4736 if (expr2
->ts
.type
== BT_CHARACTER
)
4737 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
4739 string_length
= NULL_TREE
;
4743 gfc_conv_tmp_array_ref (&lse
);
4744 gfc_advance_se_ss_chain (&lse
);
4745 if (expr2
->ts
.type
== BT_CHARACTER
)
4746 lse
.string_length
= string_length
;
4749 gfc_conv_expr (&lse
, expr1
);
4751 /* Assignments of scalar derived types with allocatable components
4752 to arrays must be done with a deep copy and the rhs temporary
4753 must have its components deallocated afterwards. */
4754 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
4755 && expr2
->ts
.derived
->attr
.alloc_comp
4756 && expr2
->expr_type
!= EXPR_VARIABLE
4757 && !gfc_is_constant_expr (expr2
)
4758 && expr1
->rank
&& !expr2
->rank
);
4759 if (scalar_to_array
)
4761 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.derived
, rse
.expr
, 0);
4762 gfc_add_expr_to_block (&loop
.post
, tmp
);
4765 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4766 l_is_temp
|| init_flag
,
4767 (expr2
->expr_type
== EXPR_VARIABLE
)
4768 || scalar_to_array
);
4769 gfc_add_expr_to_block (&body
, tmp
);
4771 if (lss
== gfc_ss_terminator
)
4773 /* Use the scalar assignment as is. */
4774 gfc_add_block_to_block (&block
, &body
);
4778 gcc_assert (lse
.ss
== gfc_ss_terminator
4779 && rse
.ss
== gfc_ss_terminator
);
4783 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4785 /* We need to copy the temporary to the actual lhs. */
4786 gfc_init_se (&lse
, NULL
);
4787 gfc_init_se (&rse
, NULL
);
4788 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4789 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4791 rse
.ss
= loop
.temp_ss
;
4794 gfc_conv_tmp_array_ref (&rse
);
4795 gfc_advance_se_ss_chain (&rse
);
4796 gfc_conv_expr (&lse
, expr1
);
4798 gcc_assert (lse
.ss
== gfc_ss_terminator
4799 && rse
.ss
== gfc_ss_terminator
);
4801 if (expr2
->ts
.type
== BT_CHARACTER
)
4802 rse
.string_length
= string_length
;
4804 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4806 gfc_add_expr_to_block (&body
, tmp
);
4809 /* Generate the copying loops. */
4810 gfc_trans_scalarizing_loops (&loop
, &body
);
4812 /* Wrap the whole thing up. */
4813 gfc_add_block_to_block (&block
, &loop
.pre
);
4814 gfc_add_block_to_block (&block
, &loop
.post
);
4816 gfc_cleanup_loop (&loop
);
4819 return gfc_finish_block (&block
);
4823 /* Check whether EXPR is a copyable array. */
4826 copyable_array_p (gfc_expr
* expr
)
4828 if (expr
->expr_type
!= EXPR_VARIABLE
)
4831 /* First check it's an array. */
4832 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
4835 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
4838 /* Next check that it's of a simple enough type. */
4839 switch (expr
->ts
.type
)
4851 return !expr
->ts
.derived
->attr
.alloc_comp
;
4860 /* Translate an assignment. */
4863 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
4867 /* Special case a single function returning an array. */
4868 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4870 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4875 /* Special case assigning an array to zero. */
4876 if (copyable_array_p (expr1
)
4877 && is_zero_initializer_p (expr2
))
4879 tmp
= gfc_trans_zero_assign (expr1
);
4884 /* Special case copying one array to another. */
4885 if (copyable_array_p (expr1
)
4886 && copyable_array_p (expr2
)
4887 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
4888 && !gfc_check_dependency (expr1
, expr2
, 0))
4890 tmp
= gfc_trans_array_copy (expr1
, expr2
);
4895 /* Special case initializing an array from a constant array constructor. */
4896 if (copyable_array_p (expr1
)
4897 && expr2
->expr_type
== EXPR_ARRAY
4898 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
4900 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
4905 /* Fallback to the scalarizer to generate explicit loops. */
4906 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
4910 gfc_trans_init_assign (gfc_code
* code
)
4912 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true);
4916 gfc_trans_assign (gfc_code
* code
)
4918 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false);