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_loc (input_location
,
164 /* Test for a NULL value. */
165 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
,
166 fold_convert (TREE_TYPE (tmp
), integer_one_node
));
167 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
168 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
172 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
173 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
174 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
178 if (ts
.type
== BT_CHARACTER
)
180 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
181 tmp
= fold_build3 (COND_EXPR
, gfc_charlen_type_node
,
182 present
, se
->string_length
, tmp
);
183 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
184 se
->string_length
= tmp
;
190 /* Get the character length of an expression, looking through gfc_refs
194 gfc_get_expr_charlen (gfc_expr
*e
)
199 gcc_assert (e
->expr_type
== EXPR_VARIABLE
200 && e
->ts
.type
== BT_CHARACTER
);
202 length
= NULL
; /* To silence compiler warning. */
204 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
207 gfc_init_se (&tmpse
, NULL
);
208 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
209 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
213 /* First candidate: if the variable is of type CHARACTER, the
214 expression's length could be the length of the character
216 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
217 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
219 /* Look through the reference chain for component references. */
220 for (r
= e
->ref
; r
; r
= r
->next
)
225 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
226 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
234 /* We should never got substring references here. These will be
235 broken down by the scalarizer. */
241 gcc_assert (length
!= NULL
);
246 /* For each character array constructor subexpression without a ts.u.cl->length,
247 replace it by its first element (if there aren't any elements, the length
248 should already be set to zero). */
251 flatten_array_ctors_without_strlen (gfc_expr
* e
)
253 gfc_actual_arglist
* arg
;
259 switch (e
->expr_type
)
263 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
264 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
268 /* TODO: Implement as with EXPR_FUNCTION when needed. */
272 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
273 flatten_array_ctors_without_strlen (arg
->expr
);
278 /* We've found what we're looking for. */
279 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
282 gcc_assert (e
->value
.constructor
);
284 new_expr
= e
->value
.constructor
->expr
;
285 e
->value
.constructor
->expr
= NULL
;
287 flatten_array_ctors_without_strlen (new_expr
);
288 gfc_replace_expr (e
, new_expr
);
292 /* Otherwise, fall through to handle constructor elements. */
294 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
295 flatten_array_ctors_without_strlen (c
->expr
);
305 /* Generate code to initialize a string length variable. Returns the
306 value. For array constructors, cl->length might be NULL and in this case,
307 the first element of the constructor is needed. expr is the original
308 expression so we can access it but can be NULL if this is not needed. */
311 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
315 gfc_init_se (&se
, NULL
);
317 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
318 "flatten" array constructors by taking their first element; all elements
319 should be the same length or a cl->length should be present. */
325 expr_flat
= gfc_copy_expr (expr
);
326 flatten_array_ctors_without_strlen (expr_flat
);
327 gfc_resolve_expr (expr_flat
);
329 gfc_conv_expr (&se
, expr_flat
);
330 gfc_add_block_to_block (pblock
, &se
.pre
);
331 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
333 gfc_free_expr (expr_flat
);
337 /* Convert cl->length. */
339 gcc_assert (cl
->length
);
341 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
342 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
343 build_int_cst (gfc_charlen_type_node
, 0));
344 gfc_add_block_to_block (pblock
, &se
.pre
);
346 if (cl
->backend_decl
)
347 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
349 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
354 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
355 const char *name
, locus
*where
)
365 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
366 type
= build_pointer_type (type
);
369 gfc_init_se (&start
, se
);
370 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
371 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
373 if (integer_onep (start
.expr
))
374 gfc_conv_string_parameter (se
);
379 /* Avoid multiple evaluation of substring start. */
380 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
381 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
383 /* Change the start of the string. */
384 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
387 tmp
= build_fold_indirect_ref_loc (input_location
,
389 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
390 se
->expr
= gfc_build_addr_expr (type
, tmp
);
393 /* Length = end + 1 - start. */
394 gfc_init_se (&end
, se
);
395 if (ref
->u
.ss
.end
== NULL
)
396 end
.expr
= se
->string_length
;
399 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
400 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
404 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
405 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
407 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
409 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
410 start
.expr
, end
.expr
);
412 /* Check lower bound. */
413 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
414 build_int_cst (gfc_charlen_type_node
, 1));
415 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
418 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
419 "is less than one", name
);
421 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
423 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
424 fold_convert (long_integer_type_node
,
428 /* Check upper bound. */
429 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
431 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
434 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
435 "exceeds string length (%%ld)", name
);
437 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
438 "exceeds string length (%%ld)");
439 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
440 fold_convert (long_integer_type_node
, end
.expr
),
441 fold_convert (long_integer_type_node
,
446 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
447 end
.expr
, start
.expr
);
448 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
449 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
450 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
451 build_int_cst (gfc_charlen_type_node
, 0));
452 se
->string_length
= tmp
;
456 /* Convert a derived type component reference. */
459 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
466 c
= ref
->u
.c
.component
;
468 gcc_assert (c
->backend_decl
);
470 field
= c
->backend_decl
;
471 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
473 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
477 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
479 tmp
= c
->ts
.u
.cl
->backend_decl
;
480 /* Components must always be constant length. */
481 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
482 se
->string_length
= tmp
;
485 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
486 && c
->ts
.type
!= BT_CHARACTER
)
487 || c
->attr
.proc_pointer
)
488 se
->expr
= build_fold_indirect_ref_loc (input_location
,
493 /* This function deals with component references to components of the
494 parent type for derived type extensons. */
496 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
504 c
= ref
->u
.c
.component
;
506 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
507 parent
.type
= REF_COMPONENT
;
510 parent
.u
.c
.component
= dt
->components
;
512 if (dt
->attr
.extension
&& dt
->components
)
514 if (dt
->attr
.is_class
)
515 cmp
= dt
->components
;
517 cmp
= dt
->components
->next
;
518 /* Return if the component is not in the parent type. */
519 for (; cmp
; cmp
= cmp
->next
)
520 if (strcmp (c
->name
, cmp
->name
) == 0)
523 /* Otherwise build the reference and call self. */
524 gfc_conv_component_ref (se
, &parent
);
525 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
526 parent
.u
.c
.component
= c
;
527 conv_parent_component_references (se
, &parent
);
531 /* Return the contents of a variable. Also handles reference/pointer
532 variables (all Fortran pointer references are implicit). */
535 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
542 bool alternate_entry
;
545 sym
= expr
->symtree
->n
.sym
;
548 /* Check that something hasn't gone horribly wrong. */
549 gcc_assert (se
->ss
!= gfc_ss_terminator
);
550 gcc_assert (se
->ss
->expr
== expr
);
552 /* A scalarized term. We already know the descriptor. */
553 se
->expr
= se
->ss
->data
.info
.descriptor
;
554 se
->string_length
= se
->ss
->string_length
;
555 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
556 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
561 tree se_expr
= NULL_TREE
;
563 se
->expr
= gfc_get_symbol_decl (sym
);
565 /* Deal with references to a parent results or entries by storing
566 the current_function_decl and moving to the parent_decl. */
567 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
568 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
569 && sym
->result
== sym
;
570 entry_master
= sym
->attr
.result
571 && sym
->ns
->proc_name
->attr
.entry_master
572 && !gfc_return_by_reference (sym
->ns
->proc_name
);
573 parent_decl
= DECL_CONTEXT (current_function_decl
);
575 if ((se
->expr
== parent_decl
&& return_value
)
576 || (sym
->ns
&& sym
->ns
->proc_name
578 && sym
->ns
->proc_name
->backend_decl
== parent_decl
579 && (alternate_entry
|| entry_master
)))
584 /* Special case for assigning the return value of a function.
585 Self recursive functions must have an explicit return value. */
586 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
587 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
589 /* Similarly for alternate entry points. */
590 else if (alternate_entry
591 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
594 gfc_entry_list
*el
= NULL
;
596 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
599 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
604 else if (entry_master
605 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
607 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
612 /* Procedure actual arguments. */
613 else if (sym
->attr
.flavor
== FL_PROCEDURE
614 && se
->expr
!= current_function_decl
)
616 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
618 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
619 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
625 /* Dereference the expression, where needed. Since characters
626 are entirely different from other types, they are treated
628 if (sym
->ts
.type
== BT_CHARACTER
)
630 /* Dereference character pointer dummy arguments
632 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
634 || sym
->attr
.function
635 || sym
->attr
.result
))
636 se
->expr
= build_fold_indirect_ref_loc (input_location
,
640 else if (!sym
->attr
.value
)
642 /* Dereference non-character scalar dummy arguments. */
643 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
644 se
->expr
= build_fold_indirect_ref_loc (input_location
,
647 /* Dereference scalar hidden result. */
648 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
649 && (sym
->attr
.function
|| sym
->attr
.result
)
650 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
651 && !sym
->attr
.always_explicit
)
652 se
->expr
= build_fold_indirect_ref_loc (input_location
,
655 /* Dereference non-character pointer variables.
656 These must be dummies, results, or scalars. */
657 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
659 || sym
->attr
.function
661 || !sym
->attr
.dimension
))
662 se
->expr
= build_fold_indirect_ref_loc (input_location
,
669 /* For character variables, also get the length. */
670 if (sym
->ts
.type
== BT_CHARACTER
)
672 /* If the character length of an entry isn't set, get the length from
673 the master function instead. */
674 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
675 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
677 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
678 gcc_assert (se
->string_length
);
686 /* Return the descriptor if that's what we want and this is an array
687 section reference. */
688 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
690 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
691 /* Return the descriptor for array pointers and allocations. */
693 && ref
->next
== NULL
&& (se
->descriptor_only
))
696 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
697 /* Return a pointer to an element. */
701 if (ref
->u
.c
.sym
->attr
.extension
)
702 conv_parent_component_references (se
, ref
);
704 gfc_conv_component_ref (se
, ref
);
708 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
709 expr
->symtree
->name
, &expr
->where
);
718 /* Pointer assignment, allocation or pass by reference. Arrays are handled
720 if (se
->want_pointer
)
722 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
723 gfc_conv_string_parameter (se
);
725 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
730 /* Unary ops are easy... Or they would be if ! was a valid op. */
733 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
738 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
739 /* Initialize the operand. */
740 gfc_init_se (&operand
, se
);
741 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
742 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
744 type
= gfc_typenode_for_spec (&expr
->ts
);
746 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
747 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
748 All other unary operators have an equivalent GIMPLE unary operator. */
749 if (code
== TRUTH_NOT_EXPR
)
750 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
751 build_int_cst (type
, 0));
753 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
757 /* Expand power operator to optimal multiplications when a value is raised
758 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
759 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
760 Programming", 3rd Edition, 1998. */
762 /* This code is mostly duplicated from expand_powi in the backend.
763 We establish the "optimal power tree" lookup table with the defined size.
764 The items in the table are the exponents used to calculate the index
765 exponents. Any integer n less than the value can get an "addition chain",
766 with the first node being one. */
767 #define POWI_TABLE_SIZE 256
769 /* The table is from builtins.c. */
770 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
772 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
773 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
774 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
775 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
776 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
777 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
778 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
779 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
780 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
781 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
782 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
783 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
784 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
785 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
786 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
787 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
788 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
789 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
790 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
791 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
792 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
793 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
794 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
795 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
796 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
797 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
798 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
799 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
800 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
801 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
802 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
803 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
806 /* If n is larger than lookup table's max index, we use the "window
808 #define POWI_WINDOW_SIZE 3
810 /* Recursive function to expand the power operator. The temporary
811 values are put in tmpvar. The function returns tmpvar[1] ** n. */
813 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
820 if (n
< POWI_TABLE_SIZE
)
825 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
826 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
830 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
831 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
832 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
836 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
840 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
841 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
843 if (n
< POWI_TABLE_SIZE
)
850 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
851 return 1. Else return 0 and a call to runtime library functions
852 will have to be built. */
854 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
859 tree vartmp
[POWI_TABLE_SIZE
];
861 unsigned HOST_WIDE_INT n
;
864 /* If exponent is too large, we won't expand it anyway, so don't bother
865 with large integer values. */
866 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
869 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
870 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
871 of the asymmetric range of the integer type. */
872 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
874 type
= TREE_TYPE (lhs
);
875 sgn
= tree_int_cst_sgn (rhs
);
877 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
878 || optimize_size
) && (m
> 2 || m
< -1))
884 se
->expr
= gfc_build_const (type
, integer_one_node
);
888 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
889 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
891 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
892 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
893 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
894 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
897 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
900 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
901 se
->expr
= fold_build3 (COND_EXPR
, type
,
902 tmp
, build_int_cst (type
, 1),
903 build_int_cst (type
, 0));
907 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
908 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
909 build_int_cst (type
, 0));
910 se
->expr
= fold_build3 (COND_EXPR
, type
,
911 cond
, build_int_cst (type
, 1), tmp
);
915 memset (vartmp
, 0, sizeof (vartmp
));
919 tmp
= gfc_build_const (type
, integer_one_node
);
920 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
923 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
929 /* Power op (**). Constant integer exponent has special handling. */
932 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
934 tree gfc_int4_type_node
;
941 gfc_init_se (&lse
, se
);
942 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
943 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
944 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
946 gfc_init_se (&rse
, se
);
947 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
948 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
950 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
951 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
952 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
955 gfc_int4_type_node
= gfc_get_int_type (4);
957 kind
= expr
->value
.op
.op1
->ts
.kind
;
958 switch (expr
->value
.op
.op2
->ts
.type
)
961 ikind
= expr
->value
.op
.op2
->ts
.kind
;
966 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
988 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
989 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1014 switch (expr
->value
.op
.op1
->ts
.type
)
1017 if (kind
== 3) /* Case 16 was not handled properly above. */
1019 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1023 /* Use builtins for real ** int4. */
1029 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1033 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1038 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1046 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1050 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1062 fndecl
= built_in_decls
[BUILT_IN_POWF
];
1065 fndecl
= built_in_decls
[BUILT_IN_POW
];
1069 fndecl
= built_in_decls
[BUILT_IN_POWL
];
1080 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
1083 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
1087 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
1099 se
->expr
= build_call_expr_loc (input_location
,
1100 fndecl
, 2, lse
.expr
, rse
.expr
);
1104 /* Generate code to allocate a string temporary. */
1107 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1112 gcc_assert (types_compatible_p (TREE_TYPE (len
), gfc_charlen_type_node
));
1114 if (gfc_can_put_var_on_stack (len
))
1116 /* Create a temporary variable to hold the result. */
1117 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1118 build_int_cst (gfc_charlen_type_node
, 1));
1119 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1121 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1122 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1124 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1126 var
= gfc_create_var (tmp
, "str");
1127 var
= gfc_build_addr_expr (type
, var
);
1131 /* Allocate a temporary to hold the result. */
1132 var
= gfc_create_var (type
, "pstr");
1133 tmp
= gfc_call_malloc (&se
->pre
, type
,
1134 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
1135 fold_convert (TREE_TYPE (len
),
1136 TYPE_SIZE (type
))));
1137 gfc_add_modify (&se
->pre
, var
, tmp
);
1139 /* Free the temporary afterwards. */
1140 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1141 gfc_add_expr_to_block (&se
->post
, tmp
);
1148 /* Handle a string concatenation operation. A temporary will be allocated to
1152 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1155 tree len
, type
, var
, tmp
, fndecl
;
1157 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1158 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1159 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1161 gfc_init_se (&lse
, se
);
1162 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1163 gfc_conv_string_parameter (&lse
);
1164 gfc_init_se (&rse
, se
);
1165 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1166 gfc_conv_string_parameter (&rse
);
1168 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1169 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1171 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1172 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1173 if (len
== NULL_TREE
)
1175 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1176 lse
.string_length
, rse
.string_length
);
1179 type
= build_pointer_type (type
);
1181 var
= gfc_conv_string_tmp (se
, type
, len
);
1183 /* Do the actual concatenation. */
1184 if (expr
->ts
.kind
== 1)
1185 fndecl
= gfor_fndecl_concat_string
;
1186 else if (expr
->ts
.kind
== 4)
1187 fndecl
= gfor_fndecl_concat_string_char4
;
1191 tmp
= build_call_expr_loc (input_location
,
1192 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1193 rse
.string_length
, rse
.expr
);
1194 gfc_add_expr_to_block (&se
->pre
, tmp
);
1196 /* Add the cleanup for the operands. */
1197 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1198 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1201 se
->string_length
= len
;
1204 /* Translates an op expression. Common (binary) cases are handled by this
1205 function, others are passed on. Recursion is used in either case.
1206 We use the fact that (op1.ts == op2.ts) (except for the power
1208 Operators need no special handling for scalarized expressions as long as
1209 they call gfc_conv_simple_val to get their operands.
1210 Character strings get special handling. */
1213 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1215 enum tree_code code
;
1224 switch (expr
->value
.op
.op
)
1226 case INTRINSIC_PARENTHESES
:
1227 if (expr
->ts
.type
== BT_REAL
1228 || expr
->ts
.type
== BT_COMPLEX
)
1230 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1231 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1236 case INTRINSIC_UPLUS
:
1237 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1240 case INTRINSIC_UMINUS
:
1241 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1245 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1248 case INTRINSIC_PLUS
:
1252 case INTRINSIC_MINUS
:
1256 case INTRINSIC_TIMES
:
1260 case INTRINSIC_DIVIDE
:
1261 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1262 an integer, we must round towards zero, so we use a
1264 if (expr
->ts
.type
== BT_INTEGER
)
1265 code
= TRUNC_DIV_EXPR
;
1270 case INTRINSIC_POWER
:
1271 gfc_conv_power_op (se
, expr
);
1274 case INTRINSIC_CONCAT
:
1275 gfc_conv_concat_op (se
, expr
);
1279 code
= TRUTH_ANDIF_EXPR
;
1284 code
= TRUTH_ORIF_EXPR
;
1288 /* EQV and NEQV only work on logicals, but since we represent them
1289 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1291 case INTRINSIC_EQ_OS
:
1299 case INTRINSIC_NE_OS
:
1300 case INTRINSIC_NEQV
:
1307 case INTRINSIC_GT_OS
:
1314 case INTRINSIC_GE_OS
:
1321 case INTRINSIC_LT_OS
:
1328 case INTRINSIC_LE_OS
:
1334 case INTRINSIC_USER
:
1335 case INTRINSIC_ASSIGN
:
1336 /* These should be converted into function calls by the frontend. */
1340 fatal_error ("Unknown intrinsic op");
1344 /* The only exception to this is **, which is handled separately anyway. */
1345 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1347 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1351 gfc_init_se (&lse
, se
);
1352 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1353 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1356 gfc_init_se (&rse
, se
);
1357 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1358 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1362 gfc_conv_string_parameter (&lse
);
1363 gfc_conv_string_parameter (&rse
);
1365 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1366 rse
.string_length
, rse
.expr
,
1367 expr
->value
.op
.op1
->ts
.kind
);
1368 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1369 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1372 type
= gfc_typenode_for_spec (&expr
->ts
);
1376 /* The result of logical ops is always boolean_type_node. */
1377 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1378 se
->expr
= convert (type
, tmp
);
1381 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1383 /* Add the post blocks. */
1384 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1385 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1388 /* If a string's length is one, we convert it to a single character. */
1391 string_to_single_character (tree len
, tree str
, int kind
)
1393 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1395 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1396 && TREE_INT_CST_HIGH (len
) == 0)
1398 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1399 return build_fold_indirect_ref_loc (input_location
,
1408 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1411 if (sym
->backend_decl
)
1413 /* This becomes the nominal_type in
1414 function.c:assign_parm_find_data_types. */
1415 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1416 /* This becomes the passed_type in
1417 function.c:assign_parm_find_data_types. C promotes char to
1418 integer for argument passing. */
1419 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1421 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1426 /* If we have a constant character expression, make it into an
1428 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1433 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1434 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1436 /* The expr needs to be compatible with a C int. If the
1437 conversion fails, then the 2 causes an ICE. */
1438 ts
.type
= BT_INTEGER
;
1439 ts
.kind
= gfc_c_int_kind
;
1440 gfc_convert_type (*expr
, &ts
, 2);
1443 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1445 if ((*expr
)->ref
== NULL
)
1447 se
->expr
= string_to_single_character
1448 (build_int_cst (integer_type_node
, 1),
1449 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1451 ((*expr
)->symtree
->n
.sym
)),
1456 gfc_conv_variable (se
, *expr
);
1457 se
->expr
= string_to_single_character
1458 (build_int_cst (integer_type_node
, 1),
1459 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1468 /* Compare two strings. If they are all single characters, the result is the
1469 subtraction of them. Otherwise, we build a library call. */
1472 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1478 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1479 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1481 sc1
= string_to_single_character (len1
, str1
, kind
);
1482 sc2
= string_to_single_character (len2
, str2
, kind
);
1484 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1486 /* Deal with single character specially. */
1487 sc1
= fold_convert (integer_type_node
, sc1
);
1488 sc2
= fold_convert (integer_type_node
, sc2
);
1489 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1493 /* Build a call for the comparison. */
1497 fndecl
= gfor_fndecl_compare_string
;
1499 fndecl
= gfor_fndecl_compare_string_char4
;
1503 tmp
= build_call_expr_loc (input_location
,
1504 fndecl
, 4, len1
, str1
, len2
, str2
);
1511 /* Return the backend_decl for a procedure pointer component. */
1514 get_proc_ptr_comp (gfc_expr
*e
)
1518 gfc_init_se (&comp_se
, NULL
);
1519 e2
= gfc_copy_expr (e
);
1520 e2
->expr_type
= EXPR_VARIABLE
;
1521 gfc_conv_expr (&comp_se
, e2
);
1523 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1527 /* Select a class typebound procedure at runtime. */
1529 select_class_proc (gfc_se
*se
, gfc_class_esym_list
*elist
,
1530 tree declared
, gfc_expr
*expr
)
1537 gfc_class_esym_list
*next_elist
, *tmp_elist
;
1540 /* Convert the vindex expression. */
1541 gfc_init_se (&tmpse
, NULL
);
1542 gfc_conv_expr (&tmpse
, elist
->vindex
);
1543 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1544 vindex
= gfc_evaluate_now (tmpse
.expr
, &se
->pre
);
1545 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1547 /* Fix the function type to be that of the declared type method. */
1548 declared
= gfc_create_var (TREE_TYPE (declared
), "method");
1550 end_label
= gfc_build_label_decl (NULL_TREE
);
1552 gfc_init_block (&body
);
1554 /* Go through the list of extensions. */
1555 for (; elist
; elist
= next_elist
)
1557 /* This case has already been added. */
1558 if (elist
->derived
== NULL
)
1561 /* Run through the chain picking up all the cases that call the
1564 for (; elist
; elist
= elist
->next
)
1568 if (elist
->esym
!= tmp_elist
->esym
)
1571 cval
= build_int_cst (TREE_TYPE (vindex
),
1572 elist
->derived
->vindex
);
1573 /* Build a label for the vindex value. */
1574 label
= gfc_build_label_decl (NULL_TREE
);
1575 tmp
= fold_build3 (CASE_LABEL_EXPR
, void_type_node
,
1576 cval
, NULL_TREE
, label
);
1577 gfc_add_expr_to_block (&body
, tmp
);
1579 /* Null the reference the derived type so that this case is
1581 elist
->derived
= NULL
;
1586 /* Get a pointer to the procedure, */
1587 tmp
= gfc_get_symbol_decl (elist
->esym
);
1588 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1590 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1591 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1594 /* Assign the pointer to the appropriate procedure. */
1595 gfc_add_modify (&body
, declared
,
1596 fold_convert (TREE_TYPE (declared
), tmp
));
1598 /* Break to the end of the construct. */
1599 tmp
= build1_v (GOTO_EXPR
, end_label
);
1600 gfc_add_expr_to_block (&body
, tmp
);
1602 /* Free the elists as we go; freeing them in gfc_free_expr causes
1603 segfaults because it occurs too early and too often. */
1605 next_elist
= elist
->next
;
1607 gfc_free_expr (elist
->vindex
);
1612 /* Default is an error. */
1613 label
= gfc_build_label_decl (NULL_TREE
);
1614 tmp
= fold_build3 (CASE_LABEL_EXPR
, void_type_node
,
1615 NULL_TREE
, NULL_TREE
, label
);
1616 gfc_add_expr_to_block (&body
, tmp
);
1617 tmp
= gfc_trans_runtime_error (true, &expr
->where
,
1618 "internal error: bad vindex in dynamic dispatch");
1619 gfc_add_expr_to_block (&body
, tmp
);
1621 /* Write the switch expression. */
1622 tmp
= gfc_finish_block (&body
);
1623 tmp
= build3_v (SWITCH_EXPR
, vindex
, tmp
, NULL_TREE
);
1624 gfc_add_expr_to_block (&se
->pre
, tmp
);
1626 tmp
= build1_v (LABEL_EXPR
, end_label
);
1627 gfc_add_expr_to_block (&se
->pre
, tmp
);
1629 se
->expr
= declared
;
1635 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1639 if (expr
&& expr
->symtree
1640 && expr
->value
.function
.class_esym
)
1642 if (!sym
->backend_decl
)
1643 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1645 tmp
= sym
->backend_decl
;
1647 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1649 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1650 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1653 select_class_proc (se
, expr
->value
.function
.class_esym
,
1658 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1659 tmp
= get_proc_ptr_comp (expr
);
1660 else if (sym
->attr
.dummy
)
1662 tmp
= gfc_get_symbol_decl (sym
);
1663 if (sym
->attr
.proc_pointer
)
1664 tmp
= build_fold_indirect_ref_loc (input_location
,
1666 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1667 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1671 if (!sym
->backend_decl
)
1672 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1674 tmp
= sym
->backend_decl
;
1676 if (sym
->attr
.cray_pointee
)
1678 /* TODO - make the cray pointee a pointer to a procedure,
1679 assign the pointer to it and use it for the call. This
1681 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1682 gfc_get_symbol_decl (sym
->cp_pointer
));
1683 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1686 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1688 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1689 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1696 /* Initialize MAPPING. */
1699 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1701 mapping
->syms
= NULL
;
1702 mapping
->charlens
= NULL
;
1706 /* Free all memory held by MAPPING (but not MAPPING itself). */
1709 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1711 gfc_interface_sym_mapping
*sym
;
1712 gfc_interface_sym_mapping
*nextsym
;
1714 gfc_charlen
*nextcl
;
1716 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1718 nextsym
= sym
->next
;
1719 sym
->new_sym
->n
.sym
->formal
= NULL
;
1720 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1721 gfc_free_expr (sym
->expr
);
1722 gfc_free (sym
->new_sym
);
1725 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1728 gfc_free_expr (cl
->length
);
1734 /* Return a copy of gfc_charlen CL. Add the returned structure to
1735 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1737 static gfc_charlen
*
1738 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1741 gfc_charlen
*new_charlen
;
1743 new_charlen
= gfc_get_charlen ();
1744 new_charlen
->next
= mapping
->charlens
;
1745 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1747 mapping
->charlens
= new_charlen
;
1752 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1753 array variable that can be used as the actual argument for dummy
1754 argument SYM. Add any initialization code to BLOCK. PACKED is as
1755 for gfc_get_nodesc_array_type and DATA points to the first element
1756 in the passed array. */
1759 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1760 gfc_packed packed
, tree data
)
1765 type
= gfc_typenode_for_spec (&sym
->ts
);
1766 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1767 !sym
->attr
.target
&& !sym
->attr
.pointer
1768 && !sym
->attr
.proc_pointer
);
1770 var
= gfc_create_var (type
, "ifm");
1771 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1777 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1778 and offset of descriptorless array type TYPE given that it has the same
1779 size as DESC. Add any set-up code to BLOCK. */
1782 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1789 offset
= gfc_index_zero_node
;
1790 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1792 dim
= gfc_rank_cst
[n
];
1793 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1794 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1796 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1797 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1798 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1799 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1801 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1803 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1804 gfc_conv_descriptor_ubound_get (desc
, dim
),
1805 gfc_conv_descriptor_lbound_get (desc
, dim
));
1806 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1807 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1809 tmp
= gfc_evaluate_now (tmp
, block
);
1810 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1812 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1813 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1814 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1815 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1817 offset
= gfc_evaluate_now (offset
, block
);
1818 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1822 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1823 in SE. The caller may still use se->expr and se->string_length after
1824 calling this function. */
1827 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1828 gfc_symbol
* sym
, gfc_se
* se
,
1831 gfc_interface_sym_mapping
*sm
;
1835 gfc_symbol
*new_sym
;
1837 gfc_symtree
*new_symtree
;
1839 /* Create a new symbol to represent the actual argument. */
1840 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1841 new_sym
->ts
= sym
->ts
;
1842 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1843 new_sym
->attr
.referenced
= 1;
1844 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1845 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1846 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1847 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1848 new_sym
->attr
.function
= sym
->attr
.function
;
1850 /* Ensure that the interface is available and that
1851 descriptors are passed for array actual arguments. */
1852 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1854 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1855 new_sym
->attr
.always_explicit
1856 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1859 /* Create a fake symtree for it. */
1861 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1862 new_symtree
->n
.sym
= new_sym
;
1863 gcc_assert (new_symtree
== root
);
1865 /* Create a dummy->actual mapping. */
1866 sm
= XCNEW (gfc_interface_sym_mapping
);
1867 sm
->next
= mapping
->syms
;
1869 sm
->new_sym
= new_symtree
;
1870 sm
->expr
= gfc_copy_expr (expr
);
1873 /* Stabilize the argument's value. */
1874 if (!sym
->attr
.function
&& se
)
1875 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1877 if (sym
->ts
.type
== BT_CHARACTER
)
1879 /* Create a copy of the dummy argument's length. */
1880 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1881 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1883 /* If the length is specified as "*", record the length that
1884 the caller is passing. We should use the callee's length
1885 in all other cases. */
1886 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1888 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1889 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1896 /* Use the passed value as-is if the argument is a function. */
1897 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1900 /* If the argument is either a string or a pointer to a string,
1901 convert it to a boundless character type. */
1902 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1904 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1905 tmp
= build_pointer_type (tmp
);
1906 if (sym
->attr
.pointer
)
1907 value
= build_fold_indirect_ref_loc (input_location
,
1911 value
= fold_convert (tmp
, value
);
1914 /* If the argument is a scalar, a pointer to an array or an allocatable,
1916 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1917 value
= build_fold_indirect_ref_loc (input_location
,
1920 /* For character(*), use the actual argument's descriptor. */
1921 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1922 value
= build_fold_indirect_ref_loc (input_location
,
1925 /* If the argument is an array descriptor, use it to determine
1926 information about the actual argument's shape. */
1927 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1928 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1930 /* Get the actual argument's descriptor. */
1931 desc
= build_fold_indirect_ref_loc (input_location
,
1934 /* Create the replacement variable. */
1935 tmp
= gfc_conv_descriptor_data_get (desc
);
1936 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1939 /* Use DESC to work out the upper bounds, strides and offset. */
1940 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1943 /* Otherwise we have a packed array. */
1944 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1945 PACKED_FULL
, se
->expr
);
1947 new_sym
->backend_decl
= value
;
1951 /* Called once all dummy argument mappings have been added to MAPPING,
1952 but before the mapping is used to evaluate expressions. Pre-evaluate
1953 the length of each argument, adding any initialization code to PRE and
1954 any finalization code to POST. */
1957 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1958 stmtblock_t
* pre
, stmtblock_t
* post
)
1960 gfc_interface_sym_mapping
*sym
;
1964 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1965 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1966 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1968 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1969 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1970 gfc_init_se (&se
, NULL
);
1971 gfc_conv_expr (&se
, expr
);
1972 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1973 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1974 gfc_add_block_to_block (pre
, &se
.pre
);
1975 gfc_add_block_to_block (post
, &se
.post
);
1977 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1982 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1986 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1987 gfc_constructor
* c
)
1989 for (; c
; c
= c
->next
)
1991 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1994 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1995 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1996 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2002 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2006 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2011 for (; ref
; ref
= ref
->next
)
2015 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2017 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2018 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2019 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2021 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2028 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2029 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2035 /* Convert intrinsic function calls into result expressions. */
2038 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2046 arg1
= expr
->value
.function
.actual
->expr
;
2047 if (expr
->value
.function
.actual
->next
)
2048 arg2
= expr
->value
.function
.actual
->next
->expr
;
2052 sym
= arg1
->symtree
->n
.sym
;
2054 if (sym
->attr
.dummy
)
2059 switch (expr
->value
.function
.isym
->id
)
2062 /* TODO figure out why this condition is necessary. */
2063 if (sym
->attr
.function
2064 && (arg1
->ts
.u
.cl
->length
== NULL
2065 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2066 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2069 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2076 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2078 dup
= mpz_get_si (arg2
->value
.integer
);
2083 dup
= sym
->as
->rank
;
2087 for (; d
< dup
; d
++)
2091 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2093 gfc_free_expr (new_expr
);
2097 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
2098 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2100 new_expr
= gfc_multiply (new_expr
, tmp
);
2106 case GFC_ISYM_LBOUND
:
2107 case GFC_ISYM_UBOUND
:
2108 /* TODO These implementations of lbound and ubound do not limit if
2109 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2114 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2115 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2117 /* TODO: If the need arises, this could produce an array of
2121 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2123 if (sym
->as
->lower
[d
])
2124 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2128 if (sym
->as
->upper
[d
])
2129 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2137 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2141 gfc_replace_expr (expr
, new_expr
);
2147 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2148 gfc_interface_mapping
* mapping
)
2150 gfc_formal_arglist
*f
;
2151 gfc_actual_arglist
*actual
;
2153 actual
= expr
->value
.function
.actual
;
2154 f
= map_expr
->symtree
->n
.sym
->formal
;
2156 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2161 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2164 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2169 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2171 for (d
= 0; d
< as
->rank
; d
++)
2173 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2174 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2177 expr
->value
.function
.esym
->as
= as
;
2180 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2182 expr
->value
.function
.esym
->ts
.u
.cl
->length
2183 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2185 gfc_apply_interface_mapping_to_expr (mapping
,
2186 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2191 /* EXPR is a copy of an expression that appeared in the interface
2192 associated with MAPPING. Walk it recursively looking for references to
2193 dummy arguments that MAPPING maps to actual arguments. Replace each such
2194 reference with a reference to the associated actual argument. */
2197 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2200 gfc_interface_sym_mapping
*sym
;
2201 gfc_actual_arglist
*actual
;
2206 /* Copying an expression does not copy its length, so do that here. */
2207 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2209 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2210 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2213 /* Apply the mapping to any references. */
2214 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2216 /* ...and to the expression's symbol, if it has one. */
2217 /* TODO Find out why the condition on expr->symtree had to be moved into
2218 the loop rather than being outside it, as originally. */
2219 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2220 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2222 if (sym
->new_sym
->n
.sym
->backend_decl
)
2223 expr
->symtree
= sym
->new_sym
;
2225 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2228 /* ...and to subexpressions in expr->value. */
2229 switch (expr
->expr_type
)
2234 case EXPR_SUBSTRING
:
2238 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2239 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2243 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2244 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2246 if (expr
->value
.function
.esym
== NULL
2247 && expr
->value
.function
.isym
!= NULL
2248 && expr
->value
.function
.actual
->expr
->symtree
2249 && gfc_map_intrinsic_function (expr
, mapping
))
2252 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2253 if (sym
->old
== expr
->value
.function
.esym
)
2255 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2256 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2257 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2262 case EXPR_STRUCTURE
:
2263 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2276 /* Evaluate interface expression EXPR using MAPPING. Store the result
2280 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2281 gfc_se
* se
, gfc_expr
* expr
)
2283 expr
= gfc_copy_expr (expr
);
2284 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2285 gfc_conv_expr (se
, expr
);
2286 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2287 gfc_free_expr (expr
);
2291 /* Returns a reference to a temporary array into which a component of
2292 an actual argument derived type array is copied and then returned
2293 after the function call. */
2295 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
,
2296 int g77
, sym_intent intent
)
2312 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2314 gfc_init_se (&lse
, NULL
);
2315 gfc_init_se (&rse
, NULL
);
2317 /* Walk the argument expression. */
2318 rss
= gfc_walk_expr (expr
);
2320 gcc_assert (rss
!= gfc_ss_terminator
);
2322 /* Initialize the scalarizer. */
2323 gfc_init_loopinfo (&loop
);
2324 gfc_add_ss_to_loop (&loop
, rss
);
2326 /* Calculate the bounds of the scalarization. */
2327 gfc_conv_ss_startstride (&loop
);
2329 /* Build an ss for the temporary. */
2330 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2331 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2333 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2334 if (GFC_ARRAY_TYPE_P (base_type
)
2335 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2336 base_type
= gfc_get_element_type (base_type
);
2338 loop
.temp_ss
= gfc_get_ss ();;
2339 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2340 loop
.temp_ss
->data
.temp
.type
= base_type
;
2342 if (expr
->ts
.type
== BT_CHARACTER
)
2343 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2345 loop
.temp_ss
->string_length
= NULL
;
2347 parmse
->string_length
= loop
.temp_ss
->string_length
;
2348 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2349 loop
.temp_ss
->next
= gfc_ss_terminator
;
2351 /* Associate the SS with the loop. */
2352 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2354 /* Setup the scalarizing loops. */
2355 gfc_conv_loop_setup (&loop
, &expr
->where
);
2357 /* Pass the temporary descriptor back to the caller. */
2358 info
= &loop
.temp_ss
->data
.info
;
2359 parmse
->expr
= info
->descriptor
;
2361 /* Setup the gfc_se structures. */
2362 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2363 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2366 lse
.ss
= loop
.temp_ss
;
2367 gfc_mark_ss_chain_used (rss
, 1);
2368 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2370 /* Start the scalarized loop body. */
2371 gfc_start_scalarized_body (&loop
, &body
);
2373 /* Translate the expression. */
2374 gfc_conv_expr (&rse
, expr
);
2376 gfc_conv_tmp_array_ref (&lse
);
2377 gfc_advance_se_ss_chain (&lse
);
2379 if (intent
!= INTENT_OUT
)
2381 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2382 gfc_add_expr_to_block (&body
, tmp
);
2383 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2384 gfc_trans_scalarizing_loops (&loop
, &body
);
2388 /* Make sure that the temporary declaration survives by merging
2389 all the loop declarations into the current context. */
2390 for (n
= 0; n
< loop
.dimen
; n
++)
2392 gfc_merge_block_scope (&body
);
2393 body
= loop
.code
[loop
.order
[n
]];
2395 gfc_merge_block_scope (&body
);
2398 /* Add the post block after the second loop, so that any
2399 freeing of allocated memory is done at the right time. */
2400 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2402 /**********Copy the temporary back again.*********/
2404 gfc_init_se (&lse
, NULL
);
2405 gfc_init_se (&rse
, NULL
);
2407 /* Walk the argument expression. */
2408 lss
= gfc_walk_expr (expr
);
2409 rse
.ss
= loop
.temp_ss
;
2412 /* Initialize the scalarizer. */
2413 gfc_init_loopinfo (&loop2
);
2414 gfc_add_ss_to_loop (&loop2
, lss
);
2416 /* Calculate the bounds of the scalarization. */
2417 gfc_conv_ss_startstride (&loop2
);
2419 /* Setup the scalarizing loops. */
2420 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2422 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2423 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2425 gfc_mark_ss_chain_used (lss
, 1);
2426 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2428 /* Declare the variable to hold the temporary offset and start the
2429 scalarized loop body. */
2430 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2431 gfc_start_scalarized_body (&loop2
, &body
);
2433 /* Build the offsets for the temporary from the loop variables. The
2434 temporary array has lbounds of zero and strides of one in all
2435 dimensions, so this is very simple. The offset is only computed
2436 outside the innermost loop, so the overall transfer could be
2437 optimized further. */
2438 info
= &rse
.ss
->data
.info
;
2440 tmp_index
= gfc_index_zero_node
;
2441 for (n
= info
->dimen
- 1; n
> 0; n
--)
2444 tmp
= rse
.loop
->loopvar
[n
];
2445 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2446 tmp
, rse
.loop
->from
[n
]);
2447 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2450 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2451 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2452 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2453 tmp_str
, gfc_index_one_node
);
2455 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2459 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2460 tmp_index
, rse
.loop
->from
[0]);
2461 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2463 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2464 rse
.loop
->loopvar
[0], offset
);
2466 /* Now use the offset for the reference. */
2467 tmp
= build_fold_indirect_ref_loc (input_location
,
2469 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2471 if (expr
->ts
.type
== BT_CHARACTER
)
2472 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2474 gfc_conv_expr (&lse
, expr
);
2476 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2478 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2479 gfc_add_expr_to_block (&body
, tmp
);
2481 /* Generate the copying loops. */
2482 gfc_trans_scalarizing_loops (&loop2
, &body
);
2484 /* Wrap the whole thing up by adding the second loop to the post-block
2485 and following it by the post-block of the first loop. In this way,
2486 if the temporary needs freeing, it is done after use! */
2487 if (intent
!= INTENT_IN
)
2489 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2490 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2493 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2495 gfc_cleanup_loop (&loop
);
2496 gfc_cleanup_loop (&loop2
);
2498 /* Pass the string length to the argument expression. */
2499 if (expr
->ts
.type
== BT_CHARACTER
)
2500 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2502 /* We want either the address for the data or the address of the descriptor,
2503 depending on the mode of passing array arguments. */
2505 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2507 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2513 /* Generate the code for argument list functions. */
2516 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2518 /* Pass by value for g77 %VAL(arg), pass the address
2519 indirectly for %LOC, else by reference. Thus %REF
2520 is a "do-nothing" and %LOC is the same as an F95
2522 if (strncmp (name
, "%VAL", 4) == 0)
2523 gfc_conv_expr (se
, expr
);
2524 else if (strncmp (name
, "%LOC", 4) == 0)
2526 gfc_conv_expr_reference (se
, expr
);
2527 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2529 else if (strncmp (name
, "%REF", 4) == 0)
2530 gfc_conv_expr_reference (se
, expr
);
2532 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2536 /* The following routine generates code for the intrinsic
2537 procedures from the ISO_C_BINDING module:
2539 * C_FUNLOC (function)
2540 * C_F_POINTER (subroutine)
2541 * C_F_PROCPOINTER (subroutine)
2542 * C_ASSOCIATED (function)
2543 One exception which is not handled here is C_F_POINTER with non-scalar
2544 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2547 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2548 gfc_actual_arglist
* arg
)
2553 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2555 if (arg
->expr
->rank
== 0)
2556 gfc_conv_expr_reference (se
, arg
->expr
);
2560 /* This is really the actual arg because no formal arglist is
2561 created for C_LOC. */
2562 fsym
= arg
->expr
->symtree
->n
.sym
;
2564 /* We should want it to do g77 calling convention. */
2566 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2567 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2568 f
= f
|| !sym
->attr
.always_explicit
;
2570 argss
= gfc_walk_expr (arg
->expr
);
2571 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2575 /* TODO -- the following two lines shouldn't be necessary, but if
2576 they're removed, a bug is exposed later in the code path.
2577 This workaround was thus introduced, but will have to be
2578 removed; please see PR 35150 for details about the issue. */
2579 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2580 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2584 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2586 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2587 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2588 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2589 gfc_conv_expr_reference (se
, arg
->expr
);
2593 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2594 && arg
->next
->expr
->rank
== 0)
2595 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2597 /* Convert c_f_pointer if fptr is a scalar
2598 and convert c_f_procpointer. */
2602 gfc_init_se (&cptrse
, NULL
);
2603 gfc_conv_expr (&cptrse
, arg
->expr
);
2604 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2605 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2607 gfc_init_se (&fptrse
, NULL
);
2608 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2609 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2610 fptrse
.want_pointer
= 1;
2612 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2613 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2614 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2616 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2617 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2618 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2621 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (fptrse
.expr
),
2623 fold_convert (TREE_TYPE (fptrse
.expr
),
2628 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2633 /* Build the addr_expr for the first argument. The argument is
2634 already an *address* so we don't need to set want_pointer in
2636 gfc_init_se (&arg1se
, NULL
);
2637 gfc_conv_expr (&arg1se
, arg
->expr
);
2638 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2639 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2641 /* See if we were given two arguments. */
2642 if (arg
->next
== NULL
)
2643 /* Only given one arg so generate a null and do a
2644 not-equal comparison against the first arg. */
2645 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2646 fold_convert (TREE_TYPE (arg1se
.expr
),
2647 null_pointer_node
));
2653 /* Given two arguments so build the arg2se from second arg. */
2654 gfc_init_se (&arg2se
, NULL
);
2655 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2656 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2657 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2659 /* Generate test to compare that the two args are equal. */
2660 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2661 arg1se
.expr
, arg2se
.expr
);
2662 /* Generate test to ensure that the first arg is not null. */
2663 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2664 arg1se
.expr
, null_pointer_node
);
2666 /* Finally, the generated test must check that both arg1 is not
2667 NULL and that it is equal to the second arg. */
2668 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2669 not_null_expr
, eq_expr
);
2675 /* Nothing was done. */
2680 /* Generate code for a procedure call. Note can return se->post != NULL.
2681 If se->direct_byref is set then se->expr contains the return parameter.
2682 Return nonzero, if the call has alternate specifiers.
2683 'expr' is only needed for procedure pointer components. */
2686 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2687 gfc_actual_arglist
* arg
, gfc_expr
* expr
,
2690 gfc_interface_mapping mapping
;
2704 gfc_formal_arglist
*formal
;
2705 int has_alternate_specifier
= 0;
2706 bool need_interface_mapping
;
2713 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2714 gfc_component
*comp
= NULL
;
2716 arglist
= NULL_TREE
;
2717 retargs
= NULL_TREE
;
2718 stringargs
= NULL_TREE
;
2723 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2724 && conv_isocbinding_procedure (se
, sym
, arg
))
2727 gfc_is_proc_ptr_comp (expr
, &comp
);
2731 if (!sym
->attr
.elemental
)
2733 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2734 if (se
->ss
->useflags
)
2736 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2737 && sym
->result
->attr
.dimension
)
2738 || (comp
&& comp
->attr
.dimension
));
2739 gcc_assert (se
->loop
!= NULL
);
2741 /* Access the previously obtained result. */
2742 gfc_conv_tmp_array_ref (se
);
2743 gfc_advance_se_ss_chain (se
);
2747 info
= &se
->ss
->data
.info
;
2752 gfc_init_block (&post
);
2753 gfc_init_interface_mapping (&mapping
);
2756 formal
= sym
->formal
;
2757 need_interface_mapping
= sym
->attr
.dimension
||
2758 (sym
->ts
.type
== BT_CHARACTER
2759 && sym
->ts
.u
.cl
->length
2760 && sym
->ts
.u
.cl
->length
->expr_type
2765 formal
= comp
->formal
;
2766 need_interface_mapping
= comp
->attr
.dimension
||
2767 (comp
->ts
.type
== BT_CHARACTER
2768 && comp
->ts
.u
.cl
->length
2769 && comp
->ts
.u
.cl
->length
->expr_type
2773 /* Evaluate the arguments. */
2774 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2777 fsym
= formal
? formal
->sym
: NULL
;
2778 parm_kind
= MISSING
;
2782 if (se
->ignore_optional
)
2784 /* Some intrinsics have already been resolved to the correct
2788 else if (arg
->label
)
2790 has_alternate_specifier
= 1;
2795 /* Pass a NULL pointer for an absent arg. */
2796 gfc_init_se (&parmse
, NULL
);
2797 parmse
.expr
= null_pointer_node
;
2798 if (arg
->missing_arg_type
== BT_CHARACTER
)
2799 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2802 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2803 && e
->ts
.type
== BT_DERIVED
)
2809 /* The derived type needs to be converted to a temporary
2811 gfc_init_se (&parmse
, se
);
2812 type
= gfc_typenode_for_spec (&fsym
->ts
);
2813 var
= gfc_create_var (type
, "class");
2815 /* Get the components. */
2816 tmp
= fsym
->ts
.u
.derived
->components
->backend_decl
;
2817 data
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
2818 var
, tmp
, NULL_TREE
);
2819 tmp
= fsym
->ts
.u
.derived
->components
->next
->backend_decl
;
2820 vindex
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
2821 var
, tmp
, NULL_TREE
);
2822 tmp
= fsym
->ts
.u
.derived
->components
->next
->next
->backend_decl
;
2823 size
= fold_build3 (COMPONENT_REF
, TREE_TYPE (tmp
),
2824 var
, tmp
, NULL_TREE
);
2826 /* Set the vindex. */
2827 tmp
= build_int_cst (TREE_TYPE (vindex
), e
->ts
.u
.derived
->vindex
);
2828 gfc_add_modify (&parmse
.pre
, vindex
, tmp
);
2831 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e
->ts
));
2832 gfc_add_modify (&parmse
.pre
, size
,
2833 fold_convert (TREE_TYPE (size
), tmp
));
2835 /* Now set the data field. */
2836 argss
= gfc_walk_expr (e
);
2837 if (argss
== gfc_ss_terminator
)
2839 gfc_conv_expr_reference (&parmse
, e
);
2840 tmp
= fold_convert (TREE_TYPE (data
),
2842 gfc_add_modify (&parmse
.pre
, data
, tmp
);
2846 gfc_conv_expr (&parmse
, e
);
2847 gfc_add_modify (&parmse
.pre
, data
, parmse
.expr
);
2850 /* Pass the address of the class object. */
2851 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2853 else if (se
->ss
&& se
->ss
->useflags
)
2855 /* An elemental function inside a scalarized loop. */
2856 gfc_init_se (&parmse
, se
);
2857 gfc_conv_expr_reference (&parmse
, e
);
2858 parm_kind
= ELEMENTAL
;
2862 /* A scalar or transformational function. */
2863 gfc_init_se (&parmse
, NULL
);
2864 argss
= gfc_walk_expr (e
);
2866 if (argss
== gfc_ss_terminator
)
2868 if (e
->expr_type
== EXPR_VARIABLE
2869 && e
->symtree
->n
.sym
->attr
.cray_pointee
2870 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2872 /* The Cray pointer needs to be converted to a pointer to
2873 a type given by the expression. */
2874 gfc_conv_expr (&parmse
, e
);
2875 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2876 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2877 parmse
.expr
= convert (type
, tmp
);
2879 else if (fsym
&& fsym
->attr
.value
)
2881 if (fsym
->ts
.type
== BT_CHARACTER
2882 && fsym
->ts
.is_c_interop
2883 && fsym
->ns
->proc_name
!= NULL
2884 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2887 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2888 if (parmse
.expr
== NULL
)
2889 gfc_conv_expr (&parmse
, e
);
2892 gfc_conv_expr (&parmse
, e
);
2894 else if (arg
->name
&& arg
->name
[0] == '%')
2895 /* Argument list functions %VAL, %LOC and %REF are signalled
2896 through arg->name. */
2897 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2898 else if ((e
->expr_type
== EXPR_FUNCTION
)
2899 && ((e
->value
.function
.esym
2900 && e
->value
.function
.esym
->result
->attr
.pointer
)
2901 || (!e
->value
.function
.esym
2902 && e
->symtree
->n
.sym
->attr
.pointer
))
2903 && fsym
&& fsym
->attr
.target
)
2905 gfc_conv_expr (&parmse
, e
);
2906 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2908 else if (e
->expr_type
== EXPR_FUNCTION
2909 && e
->symtree
->n
.sym
->result
2910 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2911 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2913 /* Functions returning procedure pointers. */
2914 gfc_conv_expr (&parmse
, e
);
2915 if (fsym
&& fsym
->attr
.proc_pointer
)
2916 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2920 gfc_conv_expr_reference (&parmse
, e
);
2922 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2923 allocated on entry, it must be deallocated. */
2924 if (fsym
&& fsym
->attr
.allocatable
2925 && fsym
->attr
.intent
== INTENT_OUT
)
2929 gfc_init_block (&block
);
2930 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
2932 gfc_add_expr_to_block (&block
, tmp
);
2933 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
2934 parmse
.expr
, null_pointer_node
);
2935 gfc_add_expr_to_block (&block
, tmp
);
2937 if (fsym
->attr
.optional
2938 && e
->expr_type
== EXPR_VARIABLE
2939 && e
->symtree
->n
.sym
->attr
.optional
)
2941 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2942 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2943 gfc_finish_block (&block
),
2944 build_empty_stmt (input_location
));
2947 tmp
= gfc_finish_block (&block
);
2949 gfc_add_expr_to_block (&se
->pre
, tmp
);
2952 if (fsym
&& e
->expr_type
!= EXPR_NULL
2953 && ((fsym
->attr
.pointer
2954 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
2955 || (fsym
->attr
.proc_pointer
2956 && !(e
->expr_type
== EXPR_VARIABLE
2957 && e
->symtree
->n
.sym
->attr
.dummy
))
2958 || (e
->expr_type
== EXPR_VARIABLE
2959 && gfc_is_proc_ptr_comp (e
, NULL
))
2960 || fsym
->attr
.allocatable
))
2962 /* Scalar pointer dummy args require an extra level of
2963 indirection. The null pointer already contains
2964 this level of indirection. */
2965 parm_kind
= SCALAR_POINTER
;
2966 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2972 /* If the procedure requires an explicit interface, the actual
2973 argument is passed according to the corresponding formal
2974 argument. If the corresponding formal argument is a POINTER,
2975 ALLOCATABLE or assumed shape, we do not use g77's calling
2976 convention, and pass the address of the array descriptor
2977 instead. Otherwise we use g77's calling convention. */
2980 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2981 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2983 f
= f
|| !comp
->attr
.always_explicit
;
2985 f
= f
|| !sym
->attr
.always_explicit
;
2987 if (e
->expr_type
== EXPR_VARIABLE
2988 && is_subref_array (e
))
2989 /* The actual argument is a component reference to an
2990 array of derived types. In this case, the argument
2991 is converted to a temporary, which is passed and then
2992 written back after the procedure call. */
2993 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2994 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2996 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
2999 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3000 allocated on entry, it must be deallocated. */
3001 if (fsym
&& fsym
->attr
.allocatable
3002 && fsym
->attr
.intent
== INTENT_OUT
)
3004 tmp
= build_fold_indirect_ref_loc (input_location
,
3006 tmp
= gfc_trans_dealloc_allocated (tmp
);
3007 if (fsym
->attr
.optional
3008 && e
->expr_type
== EXPR_VARIABLE
3009 && e
->symtree
->n
.sym
->attr
.optional
)
3010 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
3011 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3012 tmp
, build_empty_stmt (input_location
));
3013 gfc_add_expr_to_block (&se
->pre
, tmp
);
3018 /* The case with fsym->attr.optional is that of a user subroutine
3019 with an interface indicating an optional argument. When we call
3020 an intrinsic subroutine, however, fsym is NULL, but we might still
3021 have an optional argument, so we proceed to the substitution
3023 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3025 /* If an optional argument is itself an optional dummy argument,
3026 check its presence and substitute a null if absent. This is
3027 only needed when passing an array to an elemental procedure
3028 as then array elements are accessed - or no NULL pointer is
3029 allowed and a "1" or "0" should be passed if not present.
3030 When passing a non-array-descriptor full array to a
3031 non-array-descriptor dummy, no check is needed. For
3032 array-descriptor actual to array-descriptor dummy, see
3033 PR 41911 for why a check has to be inserted.
3034 fsym == NULL is checked as intrinsics required the descriptor
3035 but do not always set fsym. */
3036 if (e
->expr_type
== EXPR_VARIABLE
3037 && e
->symtree
->n
.sym
->attr
.optional
3038 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3039 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3041 && (fsym
== NULL
|| fsym
->as
->type
== AS_ASSUMED_SHAPE
3042 || fsym
->as
->type
== AS_DEFERRED
))))
3043 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3044 e
->representation
.length
);
3049 /* Obtain the character length of an assumed character length
3050 length procedure from the typespec. */
3051 if (fsym
->ts
.type
== BT_CHARACTER
3052 && parmse
.string_length
== NULL_TREE
3053 && e
->ts
.type
== BT_PROCEDURE
3054 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3055 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3056 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3058 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3059 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3063 if (fsym
&& need_interface_mapping
&& e
)
3064 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3066 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3067 gfc_add_block_to_block (&post
, &parmse
.post
);
3069 /* Allocated allocatable components of derived types must be
3070 deallocated for non-variable scalars. Non-variable arrays are
3071 dealt with in trans-array.c(gfc_conv_array_parameter). */
3072 if (e
&& e
->ts
.type
== BT_DERIVED
3073 && e
->ts
.u
.derived
->attr
.alloc_comp
3074 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3075 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3078 tmp
= build_fold_indirect_ref_loc (input_location
,
3080 parm_rank
= e
->rank
;
3088 case (SCALAR_POINTER
):
3089 tmp
= build_fold_indirect_ref_loc (input_location
,
3094 if (e
->expr_type
== EXPR_OP
3095 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3096 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3099 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3100 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3101 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3104 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3106 gfc_add_expr_to_block (&se
->post
, tmp
);
3109 /* Add argument checking of passing an unallocated/NULL actual to
3110 a nonallocatable/nonpointer dummy. */
3112 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3114 symbol_attribute
*attr
;
3118 if (e
->expr_type
== EXPR_VARIABLE
)
3119 attr
= &e
->symtree
->n
.sym
->attr
;
3120 else if (e
->expr_type
== EXPR_FUNCTION
)
3122 /* For intrinsic functions, the gfc_attr are not available. */
3123 if (e
->symtree
->n
.sym
->attr
.generic
&& e
->value
.function
.isym
)
3124 goto end_pointer_check
;
3126 if (e
->symtree
->n
.sym
->attr
.generic
)
3127 attr
= &e
->value
.function
.esym
->attr
;
3129 attr
= &e
->symtree
->n
.sym
->result
->attr
;
3132 goto end_pointer_check
;
3136 /* If the actual argument is an optional pointer/allocatable and
3137 the formal argument takes an nonpointer optional value,
3138 it is invalid to pass a non-present argument on, even
3139 though there is no technical reason for this in gfortran.
3140 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3141 tree present
, nullptr, type
;
3143 if (attr
->allocatable
3144 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3145 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3146 "allocated or not present", e
->symtree
->n
.sym
->name
);
3147 else if (attr
->pointer
3148 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3149 asprintf (&msg
, "Pointer actual argument '%s' is not "
3150 "associated or not present",
3151 e
->symtree
->n
.sym
->name
);
3152 else if (attr
->proc_pointer
3153 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3154 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3155 "associated or not present",
3156 e
->symtree
->n
.sym
->name
);
3158 goto end_pointer_check
;
3160 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3161 type
= TREE_TYPE (present
);
3162 present
= fold_build2 (EQ_EXPR
, boolean_type_node
, present
,
3163 fold_convert (type
, null_pointer_node
));
3164 type
= TREE_TYPE (parmse
.expr
);
3165 nullptr = fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3166 fold_convert (type
, null_pointer_node
));
3167 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
,
3172 if (attr
->allocatable
3173 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3174 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3175 "allocated", e
->symtree
->n
.sym
->name
);
3176 else if (attr
->pointer
3177 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3178 asprintf (&msg
, "Pointer actual argument '%s' is not "
3179 "associated", e
->symtree
->n
.sym
->name
);
3180 else if (attr
->proc_pointer
3181 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3182 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3183 "associated", e
->symtree
->n
.sym
->name
);
3185 goto end_pointer_check
;
3188 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3189 fold_convert (TREE_TYPE (parmse
.expr
),
3190 null_pointer_node
));
3193 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3200 /* Character strings are passed as two parameters, a length and a
3201 pointer - except for Bind(c) which only passes the pointer. */
3202 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3203 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
3205 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
3207 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3214 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3215 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3216 else if (ts
.type
== BT_CHARACTER
)
3218 if (ts
.u
.cl
->length
== NULL
)
3220 /* Assumed character length results are not allowed by 5.1.1.5 of the
3221 standard and are trapped in resolve.c; except in the case of SPREAD
3222 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3223 we take the character length of the first argument for the result.
3224 For dummies, we have to look through the formal argument list for
3225 this function and use the character length found there.*/
3226 if (!sym
->attr
.dummy
)
3227 cl
.backend_decl
= TREE_VALUE (stringargs
);
3230 formal
= sym
->ns
->proc_name
->formal
;
3231 for (; formal
; formal
= formal
->next
)
3232 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3233 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3240 /* Calculate the length of the returned string. */
3241 gfc_init_se (&parmse
, NULL
);
3242 if (need_interface_mapping
)
3243 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3245 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3246 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3247 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3249 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3250 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
3251 build_int_cst (gfc_charlen_type_node
, 0));
3252 cl
.backend_decl
= tmp
;
3255 /* Set up a charlen structure for it. */
3260 len
= cl
.backend_decl
;
3263 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3264 || (!comp
&& gfc_return_by_reference (sym
));
3267 if (se
->direct_byref
)
3269 /* Sometimes, too much indirection can be applied; e.g. for
3270 function_result = array_valued_recursive_function. */
3271 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3272 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3273 && GFC_DESCRIPTOR_TYPE_P
3274 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3275 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3278 retargs
= gfc_chainon_list (retargs
, se
->expr
);
3280 else if (comp
&& comp
->attr
.dimension
)
3282 gcc_assert (se
->loop
&& info
);
3284 /* Set the type of the array. */
3285 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3286 info
->dimen
= se
->loop
->dimen
;
3288 /* Evaluate the bounds of the result, if known. */
3289 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3291 /* Create a temporary to store the result. In case the function
3292 returns a pointer, the temporary will be a shallow copy and
3293 mustn't be deallocated. */
3294 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3295 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3296 NULL_TREE
, false, !comp
->attr
.pointer
,
3297 callee_alloc
, &se
->ss
->expr
->where
);
3299 /* Pass the temporary as the first argument. */
3300 tmp
= info
->descriptor
;
3301 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3302 retargs
= gfc_chainon_list (retargs
, tmp
);
3304 else if (!comp
&& sym
->result
->attr
.dimension
)
3306 gcc_assert (se
->loop
&& info
);
3308 /* Set the type of the array. */
3309 tmp
= gfc_typenode_for_spec (&ts
);
3310 info
->dimen
= se
->loop
->dimen
;
3312 /* Evaluate the bounds of the result, if known. */
3313 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3315 /* Create a temporary to store the result. In case the function
3316 returns a pointer, the temporary will be a shallow copy and
3317 mustn't be deallocated. */
3318 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3319 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3320 NULL_TREE
, false, !sym
->attr
.pointer
,
3321 callee_alloc
, &se
->ss
->expr
->where
);
3323 /* Pass the temporary as the first argument. */
3324 tmp
= info
->descriptor
;
3325 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
3326 retargs
= gfc_chainon_list (retargs
, tmp
);
3328 else if (ts
.type
== BT_CHARACTER
)
3330 /* Pass the string length. */
3331 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3332 type
= build_pointer_type (type
);
3334 /* Return an address to a char[0:len-1]* temporary for
3335 character pointers. */
3336 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3337 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3339 var
= gfc_create_var (type
, "pstr");
3341 /* Provide an address expression for the function arguments. */
3342 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3345 var
= gfc_conv_string_tmp (se
, type
, len
);
3347 retargs
= gfc_chainon_list (retargs
, var
);
3351 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3353 type
= gfc_get_complex_type (ts
.kind
);
3354 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3355 retargs
= gfc_chainon_list (retargs
, var
);
3358 /* Add the string length to the argument list. */
3359 if (ts
.type
== BT_CHARACTER
)
3360 retargs
= gfc_chainon_list (retargs
, len
);
3362 gfc_free_interface_mapping (&mapping
);
3364 /* Add the return arguments. */
3365 arglist
= chainon (retargs
, arglist
);
3367 /* Add the hidden string length parameters to the arguments. */
3368 arglist
= chainon (arglist
, stringargs
);
3370 /* We may want to append extra arguments here. This is used e.g. for
3371 calls to libgfortran_matmul_??, which need extra information. */
3372 if (append_args
!= NULL_TREE
)
3373 arglist
= chainon (arglist
, append_args
);
3375 /* Generate the actual call. */
3376 conv_function_val (se
, sym
, expr
);
3378 /* If there are alternate return labels, function type should be
3379 integer. Can't modify the type in place though, since it can be shared
3380 with other functions. For dummy arguments, the typing is done to
3381 to this result, even if it has to be repeated for each call. */
3382 if (has_alternate_specifier
3383 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3385 if (!sym
->attr
.dummy
)
3387 TREE_TYPE (sym
->backend_decl
)
3388 = build_function_type (integer_type_node
,
3389 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3390 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3393 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3396 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3397 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
3399 /* If we have a pointer function, but we don't want a pointer, e.g.
3402 where f is pointer valued, we have to dereference the result. */
3403 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
3404 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3405 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3408 /* f2c calling conventions require a scalar default real function to
3409 return a double precision result. Convert this back to default
3410 real. We only care about the cases that can happen in Fortran 77.
3412 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3413 && sym
->ts
.kind
== gfc_default_real_kind
3414 && !sym
->attr
.always_explicit
)
3415 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3417 /* A pure function may still have side-effects - it may modify its
3419 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3421 if (!sym
->attr
.pure
)
3422 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3427 /* Add the function call to the pre chain. There is no expression. */
3428 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3429 se
->expr
= NULL_TREE
;
3431 if (!se
->direct_byref
)
3433 if (sym
->attr
.dimension
|| (comp
&& comp
->attr
.dimension
))
3435 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3437 /* Check the data pointer hasn't been modified. This would
3438 happen in a function returning a pointer. */
3439 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3440 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3442 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3445 se
->expr
= info
->descriptor
;
3446 /* Bundle in the string length. */
3447 se
->string_length
= len
;
3449 else if (ts
.type
== BT_CHARACTER
)
3451 /* Dereference for character pointer results. */
3452 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3453 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3454 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3458 se
->string_length
= len
;
3462 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3463 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3468 /* Follow the function call with the argument post block. */
3470 gfc_add_block_to_block (&se
->pre
, &post
);
3472 gfc_add_block_to_block (&se
->post
, &post
);
3474 return has_alternate_specifier
;
3478 /* Fill a character string with spaces. */
3481 fill_with_spaces (tree start
, tree type
, tree size
)
3483 stmtblock_t block
, loop
;
3484 tree i
, el
, exit_label
, cond
, tmp
;
3486 /* For a simple char type, we can call memset(). */
3487 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3488 return build_call_expr_loc (input_location
,
3489 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3490 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3491 lang_hooks
.to_target_charset (' ')),
3494 /* Otherwise, we use a loop:
3495 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3499 /* Initialize variables. */
3500 gfc_init_block (&block
);
3501 i
= gfc_create_var (sizetype
, "i");
3502 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3503 el
= gfc_create_var (build_pointer_type (type
), "el");
3504 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3505 exit_label
= gfc_build_label_decl (NULL_TREE
);
3506 TREE_USED (exit_label
) = 1;
3510 gfc_init_block (&loop
);
3512 /* Exit condition. */
3513 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3514 fold_convert (sizetype
, integer_zero_node
));
3515 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3516 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3517 build_empty_stmt (input_location
));
3518 gfc_add_expr_to_block (&loop
, tmp
);
3521 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3522 build_int_cst (type
,
3523 lang_hooks
.to_target_charset (' ')));
3525 /* Increment loop variables. */
3526 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3527 TYPE_SIZE_UNIT (type
)));
3528 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3530 TYPE_SIZE_UNIT (type
)));
3532 /* Making the loop... actually loop! */
3533 tmp
= gfc_finish_block (&loop
);
3534 tmp
= build1_v (LOOP_EXPR
, tmp
);
3535 gfc_add_expr_to_block (&block
, tmp
);
3537 /* The exit label. */
3538 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3539 gfc_add_expr_to_block (&block
, tmp
);
3542 return gfc_finish_block (&block
);
3546 /* Generate code to copy a string. */
3549 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3550 int dkind
, tree slength
, tree src
, int skind
)
3552 tree tmp
, dlen
, slen
;
3561 stmtblock_t tempblock
;
3563 gcc_assert (dkind
== skind
);
3565 if (slength
!= NULL_TREE
)
3567 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3568 ssc
= string_to_single_character (slen
, src
, skind
);
3572 slen
= build_int_cst (size_type_node
, 1);
3576 if (dlength
!= NULL_TREE
)
3578 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3579 dsc
= string_to_single_character (slen
, dest
, dkind
);
3583 dlen
= build_int_cst (size_type_node
, 1);
3587 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3588 ssc
= string_to_single_character (slen
, src
, skind
);
3589 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3590 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3593 /* Assign directly if the types are compatible. */
3594 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3595 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3597 gfc_add_modify (block
, dsc
, ssc
);
3601 /* Do nothing if the destination length is zero. */
3602 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3603 build_int_cst (size_type_node
, 0));
3605 /* The following code was previously in _gfortran_copy_string:
3607 // The two strings may overlap so we use memmove.
3609 copy_string (GFC_INTEGER_4 destlen, char * dest,
3610 GFC_INTEGER_4 srclen, const char * src)
3612 if (srclen >= destlen)
3614 // This will truncate if too long.
3615 memmove (dest, src, destlen);
3619 memmove (dest, src, srclen);
3621 memset (&dest[srclen], ' ', destlen - srclen);
3625 We're now doing it here for better optimization, but the logic
3628 /* For non-default character kinds, we have to multiply the string
3629 length by the base type size. */
3630 chartype
= gfc_get_char_type (dkind
);
3631 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3632 fold_convert (size_type_node
, slen
),
3633 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3634 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3635 fold_convert (size_type_node
, dlen
),
3636 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3639 dest
= fold_convert (pvoid_type_node
, dest
);
3641 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3644 src
= fold_convert (pvoid_type_node
, src
);
3646 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3648 /* Truncate string if source is too long. */
3649 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3650 tmp2
= build_call_expr_loc (input_location
,
3651 built_in_decls
[BUILT_IN_MEMMOVE
],
3652 3, dest
, src
, dlen
);
3654 /* Else copy and pad with spaces. */
3655 tmp3
= build_call_expr_loc (input_location
,
3656 built_in_decls
[BUILT_IN_MEMMOVE
],
3657 3, dest
, src
, slen
);
3659 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3660 fold_convert (sizetype
, slen
));
3661 tmp4
= fill_with_spaces (tmp4
, chartype
,
3662 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3665 gfc_init_block (&tempblock
);
3666 gfc_add_expr_to_block (&tempblock
, tmp3
);
3667 gfc_add_expr_to_block (&tempblock
, tmp4
);
3668 tmp3
= gfc_finish_block (&tempblock
);
3670 /* The whole copy_string function is there. */
3671 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3672 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3673 build_empty_stmt (input_location
));
3674 gfc_add_expr_to_block (block
, tmp
);
3678 /* Translate a statement function.
3679 The value of a statement function reference is obtained by evaluating the
3680 expression using the values of the actual arguments for the values of the
3681 corresponding dummy arguments. */
3684 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3688 gfc_formal_arglist
*fargs
;
3689 gfc_actual_arglist
*args
;
3692 gfc_saved_var
*saved_vars
;
3698 sym
= expr
->symtree
->n
.sym
;
3699 args
= expr
->value
.function
.actual
;
3700 gfc_init_se (&lse
, NULL
);
3701 gfc_init_se (&rse
, NULL
);
3704 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3706 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3707 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3709 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3711 /* Each dummy shall be specified, explicitly or implicitly, to be
3713 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3716 /* Create a temporary to hold the value. */
3717 type
= gfc_typenode_for_spec (&fsym
->ts
);
3718 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3720 if (fsym
->ts
.type
== BT_CHARACTER
)
3722 /* Copy string arguments. */
3725 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3726 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3728 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3729 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3732 gfc_conv_expr (&rse
, args
->expr
);
3733 gfc_conv_string_parameter (&rse
);
3734 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3735 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3737 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3738 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3739 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3740 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3744 /* For everything else, just evaluate the expression. */
3745 gfc_conv_expr (&lse
, args
->expr
);
3747 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3748 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3749 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3755 /* Use the temporary variables in place of the real ones. */
3756 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3757 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3759 gfc_conv_expr (se
, sym
->value
);
3761 if (sym
->ts
.type
== BT_CHARACTER
)
3763 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3765 /* Force the expression to the correct length. */
3766 if (!INTEGER_CST_P (se
->string_length
)
3767 || tree_int_cst_lt (se
->string_length
,
3768 sym
->ts
.u
.cl
->backend_decl
))
3770 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3771 tmp
= gfc_create_var (type
, sym
->name
);
3772 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3773 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3774 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3778 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3781 /* Restore the original variables. */
3782 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3783 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3784 gfc_free (saved_vars
);
3788 /* Translate a function expression. */
3791 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3795 if (expr
->value
.function
.isym
)
3797 gfc_conv_intrinsic_function (se
, expr
);
3801 /* We distinguish statement functions from general functions to improve
3802 runtime performance. */
3803 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3805 gfc_conv_statement_function (se
, expr
);
3809 /* expr.value.function.esym is the resolved (specific) function symbol for
3810 most functions. However this isn't set for dummy procedures. */
3811 sym
= expr
->value
.function
.esym
;
3813 sym
= expr
->symtree
->n
.sym
;
3815 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3821 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3823 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3824 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3826 gfc_conv_tmp_array_ref (se
);
3827 gfc_advance_se_ss_chain (se
);
3831 /* Build a static initializer. EXPR is the expression for the initial value.
3832 The other parameters describe the variable of the component being
3833 initialized. EXPR may be null. */
3836 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3837 bool array
, bool pointer
)
3841 if (!(expr
|| pointer
))
3844 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3845 (these are the only two iso_c_binding derived types that can be
3846 used as initialization expressions). If so, we need to modify
3847 the 'expr' to be that for a (void *). */
3848 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3849 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
3851 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
3853 expr
= gfc_int_expr (0);
3855 /* The derived symbol has already been converted to a (void *). Use
3857 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3858 expr
->ts
.kind
= derived
->ts
.kind
;
3863 /* Arrays need special handling. */
3865 return gfc_build_null_descriptor (type
);
3867 return gfc_conv_array_initializer (type
, expr
);
3870 return fold_convert (type
, null_pointer_node
);
3877 gfc_init_se (&se
, NULL
);
3878 gfc_conv_structure (&se
, expr
, 1);
3882 return gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
3885 gfc_init_se (&se
, NULL
);
3886 gfc_conv_constant (&se
, expr
);
3893 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3905 gfc_start_block (&block
);
3907 /* Initialize the scalarizer. */
3908 gfc_init_loopinfo (&loop
);
3910 gfc_init_se (&lse
, NULL
);
3911 gfc_init_se (&rse
, NULL
);
3914 rss
= gfc_walk_expr (expr
);
3915 if (rss
== gfc_ss_terminator
)
3917 /* The rhs is scalar. Add a ss for the expression. */
3918 rss
= gfc_get_ss ();
3919 rss
->next
= gfc_ss_terminator
;
3920 rss
->type
= GFC_SS_SCALAR
;
3924 /* Create a SS for the destination. */
3925 lss
= gfc_get_ss ();
3926 lss
->type
= GFC_SS_COMPONENT
;
3928 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3929 lss
->next
= gfc_ss_terminator
;
3930 lss
->data
.info
.dimen
= cm
->as
->rank
;
3931 lss
->data
.info
.descriptor
= dest
;
3932 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3933 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3934 for (n
= 0; n
< cm
->as
->rank
; n
++)
3936 lss
->data
.info
.dim
[n
] = n
;
3937 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3938 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3940 mpz_init (lss
->shape
[n
]);
3941 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3942 cm
->as
->lower
[n
]->value
.integer
);
3943 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3946 /* Associate the SS with the loop. */
3947 gfc_add_ss_to_loop (&loop
, lss
);
3948 gfc_add_ss_to_loop (&loop
, rss
);
3950 /* Calculate the bounds of the scalarization. */
3951 gfc_conv_ss_startstride (&loop
);
3953 /* Setup the scalarizing loops. */
3954 gfc_conv_loop_setup (&loop
, &expr
->where
);
3956 /* Setup the gfc_se structures. */
3957 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3958 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3961 gfc_mark_ss_chain_used (rss
, 1);
3963 gfc_mark_ss_chain_used (lss
, 1);
3965 /* Start the scalarized loop body. */
3966 gfc_start_scalarized_body (&loop
, &body
);
3968 gfc_conv_tmp_array_ref (&lse
);
3969 if (cm
->ts
.type
== BT_CHARACTER
)
3970 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
3972 gfc_conv_expr (&rse
, expr
);
3974 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
3975 gfc_add_expr_to_block (&body
, tmp
);
3977 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3979 /* Generate the copying loops. */
3980 gfc_trans_scalarizing_loops (&loop
, &body
);
3982 /* Wrap the whole thing up. */
3983 gfc_add_block_to_block (&block
, &loop
.pre
);
3984 gfc_add_block_to_block (&block
, &loop
.post
);
3986 for (n
= 0; n
< cm
->as
->rank
; n
++)
3987 mpz_clear (lss
->shape
[n
]);
3988 gfc_free (lss
->shape
);
3990 gfc_cleanup_loop (&loop
);
3992 return gfc_finish_block (&block
);
3996 /* Assign a single component of a derived type constructor. */
3999 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4009 gfc_start_block (&block
);
4011 if (cm
->attr
.pointer
)
4013 gfc_init_se (&se
, NULL
);
4014 /* Pointer component. */
4015 if (cm
->attr
.dimension
)
4017 /* Array pointer. */
4018 if (expr
->expr_type
== EXPR_NULL
)
4019 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4022 rss
= gfc_walk_expr (expr
);
4023 se
.direct_byref
= 1;
4025 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4026 gfc_add_block_to_block (&block
, &se
.pre
);
4027 gfc_add_block_to_block (&block
, &se
.post
);
4032 /* Scalar pointers. */
4033 se
.want_pointer
= 1;
4034 gfc_conv_expr (&se
, expr
);
4035 gfc_add_block_to_block (&block
, &se
.pre
);
4036 gfc_add_modify (&block
, dest
,
4037 fold_convert (TREE_TYPE (dest
), se
.expr
));
4038 gfc_add_block_to_block (&block
, &se
.post
);
4041 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4043 /* NULL initialization for CLASS components. */
4044 tmp
= gfc_trans_structure_assign (dest
,
4045 gfc_default_initializer (&cm
->ts
));
4046 gfc_add_expr_to_block (&block
, tmp
);
4048 else if (cm
->attr
.dimension
)
4050 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4051 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4052 else if (cm
->attr
.allocatable
)
4056 gfc_init_se (&se
, NULL
);
4058 rss
= gfc_walk_expr (expr
);
4059 se
.want_pointer
= 0;
4060 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4061 gfc_add_block_to_block (&block
, &se
.pre
);
4062 gfc_add_modify (&block
, dest
, se
.expr
);
4064 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.u
.derived
->attr
.alloc_comp
)
4065 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
, se
.expr
, dest
,
4068 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4069 TREE_TYPE(cm
->backend_decl
),
4072 gfc_add_expr_to_block (&block
, tmp
);
4073 gfc_add_block_to_block (&block
, &se
.post
);
4075 if (expr
->expr_type
!= EXPR_VARIABLE
)
4076 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
4078 /* Shift the lbound and ubound of temporaries to being unity, rather
4079 than zero, based. Calculate the offset for all cases. */
4080 offset
= gfc_conv_descriptor_offset_get (dest
);
4081 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4082 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4083 for (n
= 0; n
< expr
->rank
; n
++)
4085 if (expr
->expr_type
!= EXPR_VARIABLE
4086 && expr
->expr_type
!= EXPR_CONSTANT
)
4089 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4090 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
4091 gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4092 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
4093 span
, gfc_index_one_node
);
4094 gfc_conv_descriptor_ubound_set (&block
, dest
, gfc_rank_cst
[n
],
4096 gfc_conv_descriptor_lbound_set (&block
, dest
, gfc_rank_cst
[n
],
4097 gfc_index_one_node
);
4099 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4100 gfc_conv_descriptor_lbound_get (dest
,
4102 gfc_conv_descriptor_stride_get (dest
,
4104 gfc_add_modify (&block
, tmp2
, tmp
);
4105 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
4106 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4109 if (expr
->expr_type
== EXPR_FUNCTION
4110 && expr
->value
.function
.isym
4111 && expr
->value
.function
.isym
->conversion
4112 && expr
->value
.function
.actual
->expr
4113 && expr
->value
.function
.actual
->expr
->expr_type
4116 /* If a conversion expression has a null data pointer
4117 argument, nullify the allocatable component. */
4121 s
= expr
->value
.function
.actual
->expr
->symtree
->n
.sym
;
4122 if (s
->attr
.allocatable
|| s
->attr
.pointer
)
4124 non_null_expr
= gfc_finish_block (&block
);
4125 gfc_start_block (&block
);
4126 gfc_conv_descriptor_data_set (&block
, dest
,
4128 null_expr
= gfc_finish_block (&block
);
4129 tmp
= gfc_conv_descriptor_data_get (s
->backend_decl
);
4130 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
4131 fold_convert (TREE_TYPE (tmp
),
4132 null_pointer_node
));
4133 return build3_v (COND_EXPR
, tmp
, null_expr
,
4140 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4141 gfc_add_expr_to_block (&block
, tmp
);
4144 else if (expr
->ts
.type
== BT_DERIVED
)
4146 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4148 gfc_init_se (&se
, NULL
);
4149 gfc_conv_expr (&se
, expr
);
4150 gfc_add_block_to_block (&block
, &se
.pre
);
4151 gfc_add_modify (&block
, dest
,
4152 fold_convert (TREE_TYPE (dest
), se
.expr
));
4153 gfc_add_block_to_block (&block
, &se
.post
);
4157 /* Nested constructors. */
4158 tmp
= gfc_trans_structure_assign (dest
, expr
);
4159 gfc_add_expr_to_block (&block
, tmp
);
4164 /* Scalar component. */
4165 gfc_init_se (&se
, NULL
);
4166 gfc_init_se (&lse
, NULL
);
4168 gfc_conv_expr (&se
, expr
);
4169 if (cm
->ts
.type
== BT_CHARACTER
)
4170 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4172 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
4173 gfc_add_expr_to_block (&block
, tmp
);
4175 return gfc_finish_block (&block
);
4178 /* Assign a derived type constructor to a variable. */
4181 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4189 gfc_start_block (&block
);
4190 cm
= expr
->ts
.u
.derived
->components
;
4191 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
4193 /* Skip absent members in default initializers. */
4197 field
= cm
->backend_decl
;
4198 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4199 dest
, field
, NULL_TREE
);
4200 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4201 gfc_add_expr_to_block (&block
, tmp
);
4203 return gfc_finish_block (&block
);
4206 /* Build an expression for a constructor. If init is nonzero then
4207 this is part of a static variable initializer. */
4210 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4217 VEC(constructor_elt
,gc
) *v
= NULL
;
4219 gcc_assert (se
->ss
== NULL
);
4220 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4221 type
= gfc_typenode_for_spec (&expr
->ts
);
4225 /* Create a temporary variable and fill it in. */
4226 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4227 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4228 gfc_add_expr_to_block (&se
->pre
, tmp
);
4232 cm
= expr
->ts
.u
.derived
->components
;
4234 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
4236 /* Skip absent members in default initializers and allocatable
4237 components. Although the latter have a default initializer
4238 of EXPR_NULL,... by default, the static nullify is not needed
4239 since this is done every time we come into scope. */
4240 if (!c
->expr
|| cm
->attr
.allocatable
)
4243 if (cm
->ts
.type
== BT_CLASS
)
4245 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4246 TREE_TYPE (cm
->ts
.u
.derived
->components
->backend_decl
),
4247 cm
->ts
.u
.derived
->components
->attr
.dimension
,
4248 cm
->ts
.u
.derived
->components
->attr
.pointer
);
4250 /* Append it to the constructor list. */
4251 CONSTRUCTOR_APPEND_ELT (v
, cm
->ts
.u
.derived
->components
->backend_decl
,
4256 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4257 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
,
4258 cm
->attr
.pointer
|| cm
->attr
.proc_pointer
);
4260 /* Append it to the constructor list. */
4261 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4264 se
->expr
= build_constructor (type
, v
);
4266 TREE_CONSTANT (se
->expr
) = 1;
4270 /* Translate a substring expression. */
4273 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4279 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4281 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4282 expr
->value
.character
.length
,
4283 expr
->value
.character
.string
);
4285 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4286 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4289 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4293 /* Entry point for expression translation. Evaluates a scalar quantity.
4294 EXPR is the expression to be translated, and SE is the state structure if
4295 called from within the scalarized. */
4298 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4300 if (se
->ss
&& se
->ss
->expr
== expr
4301 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4303 /* Substitute a scalar expression evaluated outside the scalarization
4305 se
->expr
= se
->ss
->data
.scalar
.expr
;
4306 se
->string_length
= se
->ss
->string_length
;
4307 gfc_advance_se_ss_chain (se
);
4311 /* We need to convert the expressions for the iso_c_binding derived types.
4312 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4313 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4314 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4315 updated to be an integer with a kind equal to the size of a (void *). */
4316 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4317 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4319 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4320 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4322 /* Set expr_type to EXPR_NULL, which will result in
4323 null_pointer_node being used below. */
4324 expr
->expr_type
= EXPR_NULL
;
4328 /* Update the type/kind of the expression to be what the new
4329 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4330 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4331 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4332 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4336 switch (expr
->expr_type
)
4339 gfc_conv_expr_op (se
, expr
);
4343 gfc_conv_function_expr (se
, expr
);
4347 gfc_conv_constant (se
, expr
);
4351 gfc_conv_variable (se
, expr
);
4355 se
->expr
= null_pointer_node
;
4358 case EXPR_SUBSTRING
:
4359 gfc_conv_substring_expr (se
, expr
);
4362 case EXPR_STRUCTURE
:
4363 gfc_conv_structure (se
, expr
, 0);
4367 gfc_conv_array_constructor_expr (se
, expr
);
4376 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4377 of an assignment. */
4379 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4381 gfc_conv_expr (se
, expr
);
4382 /* All numeric lvalues should have empty post chains. If not we need to
4383 figure out a way of rewriting an lvalue so that it has no post chain. */
4384 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4387 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4388 numeric expressions. Used for scalar values where inserting cleanup code
4391 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4395 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4396 gfc_conv_expr (se
, expr
);
4399 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4400 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4402 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4406 /* Helper to translate an expression and convert it to a particular type. */
4408 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4410 gfc_conv_expr_val (se
, expr
);
4411 se
->expr
= convert (type
, se
->expr
);
4415 /* Converts an expression so that it can be passed by reference. Scalar
4419 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4423 if (se
->ss
&& se
->ss
->expr
== expr
4424 && se
->ss
->type
== GFC_SS_REFERENCE
)
4426 se
->expr
= se
->ss
->data
.scalar
.expr
;
4427 se
->string_length
= se
->ss
->string_length
;
4428 gfc_advance_se_ss_chain (se
);
4432 if (expr
->ts
.type
== BT_CHARACTER
)
4434 gfc_conv_expr (se
, expr
);
4435 gfc_conv_string_parameter (se
);
4439 if (expr
->expr_type
== EXPR_VARIABLE
)
4441 se
->want_pointer
= 1;
4442 gfc_conv_expr (se
, expr
);
4445 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4446 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4447 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4453 if (expr
->expr_type
== EXPR_FUNCTION
4454 && ((expr
->value
.function
.esym
4455 && expr
->value
.function
.esym
->result
->attr
.pointer
4456 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4457 || (!expr
->value
.function
.esym
4458 && expr
->symtree
->n
.sym
->attr
.pointer
4459 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4461 se
->want_pointer
= 1;
4462 gfc_conv_expr (se
, expr
);
4463 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4464 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4470 gfc_conv_expr (se
, expr
);
4472 /* Create a temporary var to hold the value. */
4473 if (TREE_CONSTANT (se
->expr
))
4475 tree tmp
= se
->expr
;
4476 STRIP_TYPE_NOPS (tmp
);
4477 var
= build_decl (input_location
,
4478 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4479 DECL_INITIAL (var
) = tmp
;
4480 TREE_STATIC (var
) = 1;
4485 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4486 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4488 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4490 /* Take the address of that value. */
4491 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4496 gfc_trans_pointer_assign (gfc_code
* code
)
4498 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4502 /* Generate code for a pointer assignment. */
4505 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4516 gfc_start_block (&block
);
4518 gfc_init_se (&lse
, NULL
);
4520 lss
= gfc_walk_expr (expr1
);
4521 rss
= gfc_walk_expr (expr2
);
4522 if (lss
== gfc_ss_terminator
)
4524 /* Scalar pointers. */
4525 lse
.want_pointer
= 1;
4526 gfc_conv_expr (&lse
, expr1
);
4527 gcc_assert (rss
== gfc_ss_terminator
);
4528 gfc_init_se (&rse
, NULL
);
4529 rse
.want_pointer
= 1;
4530 gfc_conv_expr (&rse
, expr2
);
4532 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4533 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4534 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4537 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4538 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4539 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4542 gfc_add_block_to_block (&block
, &lse
.pre
);
4543 gfc_add_block_to_block (&block
, &rse
.pre
);
4545 /* Check character lengths if character expression. The test is only
4546 really added if -fbounds-check is enabled. */
4547 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4548 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4549 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4551 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4552 gcc_assert (lse
.string_length
&& rse
.string_length
);
4553 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4554 lse
.string_length
, rse
.string_length
,
4558 gfc_add_modify (&block
, lse
.expr
,
4559 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4561 gfc_add_block_to_block (&block
, &rse
.post
);
4562 gfc_add_block_to_block (&block
, &lse
.post
);
4567 tree strlen_rhs
= NULL_TREE
;
4569 /* Array pointer. */
4570 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4571 strlen_lhs
= lse
.string_length
;
4572 switch (expr2
->expr_type
)
4575 /* Just set the data pointer to null. */
4576 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4580 /* Assign directly to the pointer's descriptor. */
4581 lse
.direct_byref
= 1;
4582 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4583 strlen_rhs
= lse
.string_length
;
4585 /* If this is a subreference array pointer assignment, use the rhs
4586 descriptor element size for the lhs span. */
4587 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4589 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4590 gfc_init_se (&rse
, NULL
);
4591 rse
.descriptor_only
= 1;
4592 gfc_conv_expr (&rse
, expr2
);
4593 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4594 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4595 if (!INTEGER_CST_P (tmp
))
4596 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4597 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4603 /* Assign to a temporary descriptor and then copy that
4604 temporary to the pointer. */
4606 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4609 lse
.direct_byref
= 1;
4610 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4611 strlen_rhs
= lse
.string_length
;
4612 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4616 gfc_add_block_to_block (&block
, &lse
.pre
);
4618 /* Check string lengths if applicable. The check is only really added
4619 to the output code if -fbounds-check is enabled. */
4620 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4622 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4623 gcc_assert (strlen_lhs
&& strlen_rhs
);
4624 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4625 strlen_lhs
, strlen_rhs
, &block
);
4628 gfc_add_block_to_block (&block
, &lse
.post
);
4630 return gfc_finish_block (&block
);
4634 /* Makes sure se is suitable for passing as a function string parameter. */
4635 /* TODO: Need to check all callers of this function. It may be abused. */
4638 gfc_conv_string_parameter (gfc_se
* se
)
4642 if (TREE_CODE (se
->expr
) == STRING_CST
)
4644 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4645 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4649 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4651 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4653 type
= TREE_TYPE (se
->expr
);
4654 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4658 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4660 type
= build_pointer_type (type
);
4661 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4665 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4666 gcc_assert (se
->string_length
4667 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4671 /* Generate code for assignment of scalar variables. Includes character
4672 strings and derived types with allocatable components. */
4675 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4676 bool l_is_temp
, bool r_is_var
)
4682 gfc_init_block (&block
);
4684 if (ts
.type
== BT_CHARACTER
)
4689 if (lse
->string_length
!= NULL_TREE
)
4691 gfc_conv_string_parameter (lse
);
4692 gfc_add_block_to_block (&block
, &lse
->pre
);
4693 llen
= lse
->string_length
;
4696 if (rse
->string_length
!= NULL_TREE
)
4698 gcc_assert (rse
->string_length
!= NULL_TREE
);
4699 gfc_conv_string_parameter (rse
);
4700 gfc_add_block_to_block (&block
, &rse
->pre
);
4701 rlen
= rse
->string_length
;
4704 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4705 rse
->expr
, ts
.kind
);
4707 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
4711 /* Are the rhs and the lhs the same? */
4714 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4715 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
4716 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
4717 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4720 /* Deallocate the lhs allocated components as long as it is not
4721 the same as the rhs. This must be done following the assignment
4722 to prevent deallocating data that could be used in the rhs
4726 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4727 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
4729 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4731 gfc_add_expr_to_block (&lse
->post
, tmp
);
4734 gfc_add_block_to_block (&block
, &rse
->pre
);
4735 gfc_add_block_to_block (&block
, &lse
->pre
);
4737 gfc_add_modify (&block
, lse
->expr
,
4738 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4740 /* Do a deep copy if the rhs is a variable, if it is not the
4744 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
4745 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4747 gfc_add_expr_to_block (&block
, tmp
);
4750 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
4752 gfc_add_block_to_block (&block
, &lse
->pre
);
4753 gfc_add_block_to_block (&block
, &rse
->pre
);
4754 tmp
= fold_build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (lse
->expr
), rse
->expr
);
4755 gfc_add_modify (&block
, lse
->expr
, tmp
);
4759 gfc_add_block_to_block (&block
, &lse
->pre
);
4760 gfc_add_block_to_block (&block
, &rse
->pre
);
4762 gfc_add_modify (&block
, lse
->expr
,
4763 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4766 gfc_add_block_to_block (&block
, &lse
->post
);
4767 gfc_add_block_to_block (&block
, &rse
->post
);
4769 return gfc_finish_block (&block
);
4773 /* Try to translate array(:) = func (...), where func is a transformational
4774 array function, without using a temporary. Returns NULL is this isn't the
4778 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4783 bool seen_array_ref
;
4785 gfc_component
*comp
= NULL
;
4787 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4788 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4791 /* Elemental functions don't need a temporary anyway. */
4792 if (expr2
->value
.function
.esym
!= NULL
4793 && expr2
->value
.function
.esym
->attr
.elemental
)
4796 /* Fail if rhs is not FULL or a contiguous section. */
4797 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
4800 /* Fail if EXPR1 can't be expressed as a descriptor. */
4801 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4804 /* Functions returning pointers need temporaries. */
4805 if (expr2
->symtree
->n
.sym
->attr
.pointer
4806 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4809 /* Character array functions need temporaries unless the
4810 character lengths are the same. */
4811 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4813 if (expr1
->ts
.u
.cl
->length
== NULL
4814 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4817 if (expr2
->ts
.u
.cl
->length
== NULL
4818 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4821 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
4822 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
4826 /* Check that no LHS component references appear during an array
4827 reference. This is needed because we do not have the means to
4828 span any arbitrary stride with an array descriptor. This check
4829 is not needed for the rhs because the function result has to be
4831 seen_array_ref
= false;
4832 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4834 if (ref
->type
== REF_ARRAY
)
4835 seen_array_ref
= true;
4836 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4840 /* Check for a dependency. */
4841 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4842 expr2
->value
.function
.esym
,
4843 expr2
->value
.function
.actual
,
4847 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4849 gcc_assert (expr2
->value
.function
.isym
4850 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
4851 && comp
&& comp
->attr
.dimension
)
4852 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
4853 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
4855 ss
= gfc_walk_expr (expr1
);
4856 gcc_assert (ss
!= gfc_ss_terminator
);
4857 gfc_init_se (&se
, NULL
);
4858 gfc_start_block (&se
.pre
);
4859 se
.want_pointer
= 1;
4861 gfc_conv_array_parameter (&se
, expr1
, ss
, 0, NULL
, NULL
, NULL
);
4863 se
.direct_byref
= 1;
4864 se
.ss
= gfc_walk_expr (expr2
);
4865 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4866 gfc_conv_function_expr (&se
, expr2
);
4867 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4869 return gfc_finish_block (&se
.pre
);
4872 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4875 is_zero_initializer_p (gfc_expr
* expr
)
4877 if (expr
->expr_type
!= EXPR_CONSTANT
)
4880 /* We ignore constants with prescribed memory representations for now. */
4881 if (expr
->representation
.string
)
4884 switch (expr
->ts
.type
)
4887 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
4890 return mpfr_zero_p (expr
->value
.real
)
4891 && MPFR_SIGN (expr
->value
.real
) >= 0;
4894 return expr
->value
.logical
== 0;
4897 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
4898 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
4899 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
4900 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
4908 /* Try to efficiently translate array(:) = 0. Return NULL if this
4912 gfc_trans_zero_assign (gfc_expr
* expr
)
4914 tree dest
, len
, type
;
4918 sym
= expr
->symtree
->n
.sym
;
4919 dest
= gfc_get_symbol_decl (sym
);
4921 type
= TREE_TYPE (dest
);
4922 if (POINTER_TYPE_P (type
))
4923 type
= TREE_TYPE (type
);
4924 if (!GFC_ARRAY_TYPE_P (type
))
4927 /* Determine the length of the array. */
4928 len
= GFC_TYPE_ARRAY_SIZE (type
);
4929 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
4932 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
4933 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
4934 fold_convert (gfc_array_index_type
, tmp
));
4936 /* If we are zeroing a local array avoid taking its address by emitting
4938 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
4939 return build2 (MODIFY_EXPR
, void_type_node
,
4940 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
4942 /* Convert arguments to the correct types. */
4943 dest
= fold_convert (pvoid_type_node
, dest
);
4944 len
= fold_convert (size_type_node
, len
);
4946 /* Construct call to __builtin_memset. */
4947 tmp
= build_call_expr_loc (input_location
,
4948 built_in_decls
[BUILT_IN_MEMSET
],
4949 3, dest
, integer_zero_node
, len
);
4950 return fold_convert (void_type_node
, tmp
);
4954 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4955 that constructs the call to __builtin_memcpy. */
4958 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
4962 /* Convert arguments to the correct types. */
4963 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
4964 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
4966 dst
= fold_convert (pvoid_type_node
, dst
);
4968 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
4969 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
4971 src
= fold_convert (pvoid_type_node
, src
);
4973 len
= fold_convert (size_type_node
, len
);
4975 /* Construct call to __builtin_memcpy. */
4976 tmp
= build_call_expr_loc (input_location
,
4977 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
4978 return fold_convert (void_type_node
, tmp
);
4982 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4983 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4984 source/rhs, both are gfc_full_array_ref_p which have been checked for
4988 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
4990 tree dst
, dlen
, dtype
;
4991 tree src
, slen
, stype
;
4994 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
4995 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
4997 dtype
= TREE_TYPE (dst
);
4998 if (POINTER_TYPE_P (dtype
))
4999 dtype
= TREE_TYPE (dtype
);
5000 stype
= TREE_TYPE (src
);
5001 if (POINTER_TYPE_P (stype
))
5002 stype
= TREE_TYPE (stype
);
5004 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5007 /* Determine the lengths of the arrays. */
5008 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5009 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5011 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5012 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
5013 fold_convert (gfc_array_index_type
, tmp
));
5015 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5016 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5018 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5019 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
5020 fold_convert (gfc_array_index_type
, tmp
));
5022 /* Sanity check that they are the same. This should always be
5023 the case, as we should already have checked for conformance. */
5024 if (!tree_int_cst_equal (slen
, dlen
))
5027 return gfc_build_memcpy_call (dst
, src
, dlen
);
5031 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5032 this can't be done. EXPR1 is the destination/lhs for which
5033 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5036 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5038 unsigned HOST_WIDE_INT nelem
;
5044 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5048 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5049 dtype
= TREE_TYPE (dst
);
5050 if (POINTER_TYPE_P (dtype
))
5051 dtype
= TREE_TYPE (dtype
);
5052 if (!GFC_ARRAY_TYPE_P (dtype
))
5055 /* Determine the lengths of the array. */
5056 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5057 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5060 /* Confirm that the constructor is the same size. */
5061 if (compare_tree_int (len
, nelem
) != 0)
5064 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5065 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5066 fold_convert (gfc_array_index_type
, tmp
));
5068 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5069 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5071 stype
= TREE_TYPE (src
);
5072 if (POINTER_TYPE_P (stype
))
5073 stype
= TREE_TYPE (stype
);
5075 return gfc_build_memcpy_call (dst
, src
, len
);
5079 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5080 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
5083 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
5088 gfc_ss
*lss_section
;
5095 bool scalar_to_array
;
5098 /* Assignment of the form lhs = rhs. */
5099 gfc_start_block (&block
);
5101 gfc_init_se (&lse
, NULL
);
5102 gfc_init_se (&rse
, NULL
);
5105 lss
= gfc_walk_expr (expr1
);
5107 if (lss
!= gfc_ss_terminator
)
5109 /* Allow the scalarizer to workshare array assignments. */
5110 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5111 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5113 /* The assignment needs scalarization. */
5116 /* Find a non-scalar SS from the lhs. */
5117 while (lss_section
!= gfc_ss_terminator
5118 && lss_section
->type
!= GFC_SS_SECTION
)
5119 lss_section
= lss_section
->next
;
5121 gcc_assert (lss_section
!= gfc_ss_terminator
);
5123 /* Initialize the scalarizer. */
5124 gfc_init_loopinfo (&loop
);
5127 rss
= gfc_walk_expr (expr2
);
5128 if (rss
== gfc_ss_terminator
)
5130 /* The rhs is scalar. Add a ss for the expression. */
5131 rss
= gfc_get_ss ();
5132 rss
->next
= gfc_ss_terminator
;
5133 rss
->type
= GFC_SS_SCALAR
;
5136 /* Associate the SS with the loop. */
5137 gfc_add_ss_to_loop (&loop
, lss
);
5138 gfc_add_ss_to_loop (&loop
, rss
);
5140 /* Calculate the bounds of the scalarization. */
5141 gfc_conv_ss_startstride (&loop
);
5142 /* Resolve any data dependencies in the statement. */
5143 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5144 /* Setup the scalarizing loops. */
5145 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5147 /* Setup the gfc_se structures. */
5148 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5149 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5152 gfc_mark_ss_chain_used (rss
, 1);
5153 if (loop
.temp_ss
== NULL
)
5156 gfc_mark_ss_chain_used (lss
, 1);
5160 lse
.ss
= loop
.temp_ss
;
5161 gfc_mark_ss_chain_used (lss
, 3);
5162 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5165 /* Start the scalarized loop body. */
5166 gfc_start_scalarized_body (&loop
, &body
);
5169 gfc_init_block (&body
);
5171 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5173 /* Translate the expression. */
5174 gfc_conv_expr (&rse
, expr2
);
5176 /* Stabilize a string length for temporaries. */
5177 if (expr2
->ts
.type
== BT_CHARACTER
)
5178 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5180 string_length
= NULL_TREE
;
5184 gfc_conv_tmp_array_ref (&lse
);
5185 gfc_advance_se_ss_chain (&lse
);
5186 if (expr2
->ts
.type
== BT_CHARACTER
)
5187 lse
.string_length
= string_length
;
5190 gfc_conv_expr (&lse
, expr1
);
5192 /* Assignments of scalar derived types with allocatable components
5193 to arrays must be done with a deep copy and the rhs temporary
5194 must have its components deallocated afterwards. */
5195 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5196 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5197 && expr2
->expr_type
!= EXPR_VARIABLE
5198 && !gfc_is_constant_expr (expr2
)
5199 && expr1
->rank
&& !expr2
->rank
);
5200 if (scalar_to_array
)
5202 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5203 gfc_add_expr_to_block (&loop
.post
, tmp
);
5206 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5207 l_is_temp
|| init_flag
,
5208 (expr2
->expr_type
== EXPR_VARIABLE
)
5209 || scalar_to_array
);
5210 gfc_add_expr_to_block (&body
, tmp
);
5212 if (lss
== gfc_ss_terminator
)
5214 /* Use the scalar assignment as is. */
5215 gfc_add_block_to_block (&block
, &body
);
5219 gcc_assert (lse
.ss
== gfc_ss_terminator
5220 && rse
.ss
== gfc_ss_terminator
);
5224 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5226 /* We need to copy the temporary to the actual lhs. */
5227 gfc_init_se (&lse
, NULL
);
5228 gfc_init_se (&rse
, NULL
);
5229 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5230 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5232 rse
.ss
= loop
.temp_ss
;
5235 gfc_conv_tmp_array_ref (&rse
);
5236 gfc_advance_se_ss_chain (&rse
);
5237 gfc_conv_expr (&lse
, expr1
);
5239 gcc_assert (lse
.ss
== gfc_ss_terminator
5240 && rse
.ss
== gfc_ss_terminator
);
5242 if (expr2
->ts
.type
== BT_CHARACTER
)
5243 rse
.string_length
= string_length
;
5245 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5247 gfc_add_expr_to_block (&body
, tmp
);
5250 /* Generate the copying loops. */
5251 gfc_trans_scalarizing_loops (&loop
, &body
);
5253 /* Wrap the whole thing up. */
5254 gfc_add_block_to_block (&block
, &loop
.pre
);
5255 gfc_add_block_to_block (&block
, &loop
.post
);
5257 gfc_cleanup_loop (&loop
);
5260 return gfc_finish_block (&block
);
5264 /* Check whether EXPR is a copyable array. */
5267 copyable_array_p (gfc_expr
* expr
)
5269 if (expr
->expr_type
!= EXPR_VARIABLE
)
5272 /* First check it's an array. */
5273 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5276 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5279 /* Next check that it's of a simple enough type. */
5280 switch (expr
->ts
.type
)
5292 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5301 /* Translate an assignment. */
5304 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
5308 /* Special case a single function returning an array. */
5309 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5311 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5316 /* Special case assigning an array to zero. */
5317 if (copyable_array_p (expr1
)
5318 && is_zero_initializer_p (expr2
))
5320 tmp
= gfc_trans_zero_assign (expr1
);
5325 /* Special case copying one array to another. */
5326 if (copyable_array_p (expr1
)
5327 && copyable_array_p (expr2
)
5328 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
5329 && !gfc_check_dependency (expr1
, expr2
, 0))
5331 tmp
= gfc_trans_array_copy (expr1
, expr2
);
5336 /* Special case initializing an array from a constant array constructor. */
5337 if (copyable_array_p (expr1
)
5338 && expr2
->expr_type
== EXPR_ARRAY
5339 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
5341 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
5346 /* Fallback to the scalarizer to generate explicit loops. */
5347 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
5351 gfc_trans_init_assign (gfc_code
* code
)
5353 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true);
5357 gfc_trans_assign (gfc_code
* code
)
5359 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false);
5363 /* Translate an assignment to a CLASS object
5364 (pointer or ordinary assignment). */
5367 gfc_trans_class_assign (gfc_code
*code
)
5372 gfc_start_block (&block
);
5374 if (code
->expr2
->ts
.type
!= BT_CLASS
)
5376 /* Insert an additional assignment which sets the '$vindex' field. */
5378 lhs
= gfc_copy_expr (code
->expr1
);
5379 gfc_add_component_ref (lhs
, "$vindex");
5380 if (code
->expr2
->ts
.type
== BT_DERIVED
)
5381 /* vindex is constant, determined at compile time. */
5382 rhs
= gfc_int_expr (code
->expr2
->ts
.u
.derived
->vindex
);
5383 else if (code
->expr2
->expr_type
== EXPR_NULL
)
5384 rhs
= gfc_int_expr (0);
5387 tmp
= gfc_trans_assignment (lhs
, rhs
, false);
5388 gfc_add_expr_to_block (&block
, tmp
);
5390 /* Insert another assignment which sets the '$size' field. */
5391 lhs
= gfc_copy_expr (code
->expr1
);
5392 gfc_add_component_ref (lhs
, "$size");
5393 if (code
->expr2
->ts
.type
== BT_DERIVED
)
5395 /* Size is fixed at compile time. */
5397 gfc_init_se (&lse
, NULL
);
5398 gfc_conv_expr (&lse
, lhs
);
5399 tmp
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr2
->ts
));
5400 gfc_add_modify (&block
, lse
.expr
,
5401 fold_convert (TREE_TYPE (lse
.expr
), tmp
));
5403 else if (code
->expr2
->expr_type
== EXPR_NULL
)
5405 rhs
= gfc_int_expr (0);
5406 tmp
= gfc_trans_assignment (lhs
, rhs
, false);
5407 gfc_add_expr_to_block (&block
, tmp
);
5412 gfc_free_expr (lhs
);
5413 gfc_free_expr (rhs
);
5416 /* Do the actual CLASS assignment. */
5417 if (code
->expr2
->ts
.type
== BT_CLASS
)
5418 code
->op
= EXEC_ASSIGN
;
5420 gfc_add_component_ref (code
->expr1
, "$data");
5422 if (code
->op
== EXEC_ASSIGN
)
5423 tmp
= gfc_trans_assign (code
);
5424 else if (code
->op
== EXEC_POINTER_ASSIGN
)
5425 tmp
= gfc_trans_pointer_assign (code
);
5429 gfc_add_expr_to_block (&block
, tmp
);
5431 return gfc_finish_block (&block
);