1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
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
)
364 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
365 type
= build_pointer_type (type
);
367 gfc_init_se (&start
, se
);
368 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
369 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
371 if (integer_onep (start
.expr
))
372 gfc_conv_string_parameter (se
);
377 /* Avoid multiple evaluation of substring start. */
378 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
379 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
381 /* Change the start of the string. */
382 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
385 tmp
= build_fold_indirect_ref_loc (input_location
,
387 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
388 se
->expr
= gfc_build_addr_expr (type
, tmp
);
391 /* Length = end + 1 - start. */
392 gfc_init_se (&end
, se
);
393 if (ref
->u
.ss
.end
== NULL
)
394 end
.expr
= se
->string_length
;
397 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
398 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
402 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
403 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
405 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
407 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
408 start
.expr
, end
.expr
);
410 /* Check lower bound. */
411 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
412 build_int_cst (gfc_charlen_type_node
, 1));
413 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
416 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
417 "is less than one", name
);
419 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
421 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
422 fold_convert (long_integer_type_node
,
426 /* Check upper bound. */
427 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
429 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
432 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
433 "exceeds string length (%%ld)", name
);
435 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
436 "exceeds string length (%%ld)");
437 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
438 fold_convert (long_integer_type_node
, end
.expr
),
439 fold_convert (long_integer_type_node
,
444 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
445 end
.expr
, start
.expr
);
446 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
447 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
448 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
449 build_int_cst (gfc_charlen_type_node
, 0));
450 se
->string_length
= tmp
;
454 /* Convert a derived type component reference. */
457 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
464 c
= ref
->u
.c
.component
;
466 gcc_assert (c
->backend_decl
);
468 field
= c
->backend_decl
;
469 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
471 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
475 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
477 tmp
= c
->ts
.u
.cl
->backend_decl
;
478 /* Components must always be constant length. */
479 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
480 se
->string_length
= tmp
;
483 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
484 && c
->ts
.type
!= BT_CHARACTER
)
485 || c
->attr
.proc_pointer
)
486 se
->expr
= build_fold_indirect_ref_loc (input_location
,
491 /* This function deals with component references to components of the
492 parent type for derived type extensons. */
494 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
502 c
= ref
->u
.c
.component
;
504 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
505 parent
.type
= REF_COMPONENT
;
508 parent
.u
.c
.component
= dt
->components
;
510 if (dt
->attr
.extension
&& dt
->components
)
512 if (dt
->attr
.is_class
)
513 cmp
= dt
->components
;
515 cmp
= dt
->components
->next
;
516 /* Return if the component is not in the parent type. */
517 for (; cmp
; cmp
= cmp
->next
)
518 if (strcmp (c
->name
, cmp
->name
) == 0)
521 /* Otherwise build the reference and call self. */
522 gfc_conv_component_ref (se
, &parent
);
523 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
524 parent
.u
.c
.component
= c
;
525 conv_parent_component_references (se
, &parent
);
529 /* Return the contents of a variable. Also handles reference/pointer
530 variables (all Fortran pointer references are implicit). */
533 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
540 bool alternate_entry
;
543 sym
= expr
->symtree
->n
.sym
;
546 /* Check that something hasn't gone horribly wrong. */
547 gcc_assert (se
->ss
!= gfc_ss_terminator
);
548 gcc_assert (se
->ss
->expr
== expr
);
550 /* A scalarized term. We already know the descriptor. */
551 se
->expr
= se
->ss
->data
.info
.descriptor
;
552 se
->string_length
= se
->ss
->string_length
;
553 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
554 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
559 tree se_expr
= NULL_TREE
;
561 se
->expr
= gfc_get_symbol_decl (sym
);
563 /* Deal with references to a parent results or entries by storing
564 the current_function_decl and moving to the parent_decl. */
565 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
566 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
567 && sym
->result
== sym
;
568 entry_master
= sym
->attr
.result
569 && sym
->ns
->proc_name
->attr
.entry_master
570 && !gfc_return_by_reference (sym
->ns
->proc_name
);
571 parent_decl
= DECL_CONTEXT (current_function_decl
);
573 if ((se
->expr
== parent_decl
&& return_value
)
574 || (sym
->ns
&& sym
->ns
->proc_name
576 && sym
->ns
->proc_name
->backend_decl
== parent_decl
577 && (alternate_entry
|| entry_master
)))
582 /* Special case for assigning the return value of a function.
583 Self recursive functions must have an explicit return value. */
584 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
585 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
587 /* Similarly for alternate entry points. */
588 else if (alternate_entry
589 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
592 gfc_entry_list
*el
= NULL
;
594 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
597 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
602 else if (entry_master
603 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
605 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
610 /* Procedure actual arguments. */
611 else if (sym
->attr
.flavor
== FL_PROCEDURE
612 && se
->expr
!= current_function_decl
)
614 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
616 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
617 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
623 /* Dereference the expression, where needed. Since characters
624 are entirely different from other types, they are treated
626 if (sym
->ts
.type
== BT_CHARACTER
)
628 /* Dereference character pointer dummy arguments
630 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
632 || sym
->attr
.function
633 || sym
->attr
.result
))
634 se
->expr
= build_fold_indirect_ref_loc (input_location
,
638 else if (!sym
->attr
.value
)
640 /* Dereference non-character scalar dummy arguments. */
641 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
642 se
->expr
= build_fold_indirect_ref_loc (input_location
,
645 /* Dereference scalar hidden result. */
646 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
647 && (sym
->attr
.function
|| sym
->attr
.result
)
648 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
649 && !sym
->attr
.always_explicit
)
650 se
->expr
= build_fold_indirect_ref_loc (input_location
,
653 /* Dereference non-character pointer variables.
654 These must be dummies, results, or scalars. */
655 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
657 || sym
->attr
.function
659 || !sym
->attr
.dimension
))
660 se
->expr
= build_fold_indirect_ref_loc (input_location
,
667 /* For character variables, also get the length. */
668 if (sym
->ts
.type
== BT_CHARACTER
)
670 /* If the character length of an entry isn't set, get the length from
671 the master function instead. */
672 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
673 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
675 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
676 gcc_assert (se
->string_length
);
684 /* Return the descriptor if that's what we want and this is an array
685 section reference. */
686 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
688 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
689 /* Return the descriptor for array pointers and allocations. */
691 && ref
->next
== NULL
&& (se
->descriptor_only
))
694 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
695 /* Return a pointer to an element. */
699 if (ref
->u
.c
.sym
->attr
.extension
)
700 conv_parent_component_references (se
, ref
);
702 gfc_conv_component_ref (se
, ref
);
706 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
707 expr
->symtree
->name
, &expr
->where
);
716 /* Pointer assignment, allocation or pass by reference. Arrays are handled
718 if (se
->want_pointer
)
720 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
721 gfc_conv_string_parameter (se
);
723 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
728 /* Unary ops are easy... Or they would be if ! was a valid op. */
731 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
736 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
737 /* Initialize the operand. */
738 gfc_init_se (&operand
, se
);
739 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
740 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
742 type
= gfc_typenode_for_spec (&expr
->ts
);
744 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
745 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
746 All other unary operators have an equivalent GIMPLE unary operator. */
747 if (code
== TRUTH_NOT_EXPR
)
748 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
749 build_int_cst (type
, 0));
751 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
755 /* Expand power operator to optimal multiplications when a value is raised
756 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
757 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
758 Programming", 3rd Edition, 1998. */
760 /* This code is mostly duplicated from expand_powi in the backend.
761 We establish the "optimal power tree" lookup table with the defined size.
762 The items in the table are the exponents used to calculate the index
763 exponents. Any integer n less than the value can get an "addition chain",
764 with the first node being one. */
765 #define POWI_TABLE_SIZE 256
767 /* The table is from builtins.c. */
768 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
770 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
771 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
772 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
773 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
774 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
775 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
776 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
777 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
778 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
779 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
780 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
781 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
782 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
783 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
784 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
785 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
786 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
787 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
788 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
789 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
790 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
791 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
792 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
793 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
794 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
795 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
796 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
797 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
798 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
799 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
800 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
801 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
804 /* If n is larger than lookup table's max index, we use the "window
806 #define POWI_WINDOW_SIZE 3
808 /* Recursive function to expand the power operator. The temporary
809 values are put in tmpvar. The function returns tmpvar[1] ** n. */
811 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
818 if (n
< POWI_TABLE_SIZE
)
823 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
824 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
828 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
829 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
830 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
834 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
838 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
839 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
841 if (n
< POWI_TABLE_SIZE
)
848 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
849 return 1. Else return 0 and a call to runtime library functions
850 will have to be built. */
852 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
857 tree vartmp
[POWI_TABLE_SIZE
];
859 unsigned HOST_WIDE_INT n
;
862 /* If exponent is too large, we won't expand it anyway, so don't bother
863 with large integer values. */
864 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
867 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
868 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
869 of the asymmetric range of the integer type. */
870 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
872 type
= TREE_TYPE (lhs
);
873 sgn
= tree_int_cst_sgn (rhs
);
875 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
876 || optimize_size
) && (m
> 2 || m
< -1))
882 se
->expr
= gfc_build_const (type
, integer_one_node
);
886 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
887 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
889 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
890 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
891 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
892 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
895 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
898 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
899 se
->expr
= fold_build3 (COND_EXPR
, type
,
900 tmp
, build_int_cst (type
, 1),
901 build_int_cst (type
, 0));
905 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
906 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
907 build_int_cst (type
, 0));
908 se
->expr
= fold_build3 (COND_EXPR
, type
,
909 cond
, build_int_cst (type
, 1), tmp
);
913 memset (vartmp
, 0, sizeof (vartmp
));
917 tmp
= gfc_build_const (type
, integer_one_node
);
918 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
921 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
927 /* Power op (**). Constant integer exponent has special handling. */
930 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
932 tree gfc_int4_type_node
;
939 gfc_init_se (&lse
, se
);
940 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
941 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
942 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
944 gfc_init_se (&rse
, se
);
945 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
946 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
948 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
949 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
950 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
953 gfc_int4_type_node
= gfc_get_int_type (4);
955 kind
= expr
->value
.op
.op1
->ts
.kind
;
956 switch (expr
->value
.op
.op2
->ts
.type
)
959 ikind
= expr
->value
.op
.op2
->ts
.kind
;
964 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
986 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
987 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1012 switch (expr
->value
.op
.op1
->ts
.type
)
1015 if (kind
== 3) /* Case 16 was not handled properly above. */
1017 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1021 /* Use builtins for real ** int4. */
1027 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1031 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1036 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1044 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1048 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1060 fndecl
= built_in_decls
[BUILT_IN_POWF
];
1063 fndecl
= built_in_decls
[BUILT_IN_POW
];
1067 fndecl
= built_in_decls
[BUILT_IN_POWL
];
1078 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
1081 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
1085 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
1097 se
->expr
= build_call_expr_loc (input_location
,
1098 fndecl
, 2, lse
.expr
, rse
.expr
);
1102 /* Generate code to allocate a string temporary. */
1105 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1110 gcc_assert (types_compatible_p (TREE_TYPE (len
), gfc_charlen_type_node
));
1112 if (gfc_can_put_var_on_stack (len
))
1114 /* Create a temporary variable to hold the result. */
1115 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1116 build_int_cst (gfc_charlen_type_node
, 1));
1117 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1119 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1120 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1122 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1124 var
= gfc_create_var (tmp
, "str");
1125 var
= gfc_build_addr_expr (type
, var
);
1129 /* Allocate a temporary to hold the result. */
1130 var
= gfc_create_var (type
, "pstr");
1131 tmp
= gfc_call_malloc (&se
->pre
, type
,
1132 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
1133 fold_convert (TREE_TYPE (len
),
1134 TYPE_SIZE (type
))));
1135 gfc_add_modify (&se
->pre
, var
, tmp
);
1137 /* Free the temporary afterwards. */
1138 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1139 gfc_add_expr_to_block (&se
->post
, tmp
);
1146 /* Handle a string concatenation operation. A temporary will be allocated to
1150 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1153 tree len
, type
, var
, tmp
, fndecl
;
1155 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1156 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1157 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1159 gfc_init_se (&lse
, se
);
1160 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1161 gfc_conv_string_parameter (&lse
);
1162 gfc_init_se (&rse
, se
);
1163 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1164 gfc_conv_string_parameter (&rse
);
1166 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1167 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1169 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1170 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1171 if (len
== NULL_TREE
)
1173 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1174 lse
.string_length
, rse
.string_length
);
1177 type
= build_pointer_type (type
);
1179 var
= gfc_conv_string_tmp (se
, type
, len
);
1181 /* Do the actual concatenation. */
1182 if (expr
->ts
.kind
== 1)
1183 fndecl
= gfor_fndecl_concat_string
;
1184 else if (expr
->ts
.kind
== 4)
1185 fndecl
= gfor_fndecl_concat_string_char4
;
1189 tmp
= build_call_expr_loc (input_location
,
1190 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1191 rse
.string_length
, rse
.expr
);
1192 gfc_add_expr_to_block (&se
->pre
, tmp
);
1194 /* Add the cleanup for the operands. */
1195 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1196 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1199 se
->string_length
= len
;
1202 /* Translates an op expression. Common (binary) cases are handled by this
1203 function, others are passed on. Recursion is used in either case.
1204 We use the fact that (op1.ts == op2.ts) (except for the power
1206 Operators need no special handling for scalarized expressions as long as
1207 they call gfc_conv_simple_val to get their operands.
1208 Character strings get special handling. */
1211 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1213 enum tree_code code
;
1222 switch (expr
->value
.op
.op
)
1224 case INTRINSIC_PARENTHESES
:
1225 if ((expr
->ts
.type
== BT_REAL
1226 || expr
->ts
.type
== BT_COMPLEX
)
1227 && gfc_option
.flag_protect_parens
)
1229 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1230 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1235 case INTRINSIC_UPLUS
:
1236 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1239 case INTRINSIC_UMINUS
:
1240 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1244 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1247 case INTRINSIC_PLUS
:
1251 case INTRINSIC_MINUS
:
1255 case INTRINSIC_TIMES
:
1259 case INTRINSIC_DIVIDE
:
1260 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1261 an integer, we must round towards zero, so we use a
1263 if (expr
->ts
.type
== BT_INTEGER
)
1264 code
= TRUNC_DIV_EXPR
;
1269 case INTRINSIC_POWER
:
1270 gfc_conv_power_op (se
, expr
);
1273 case INTRINSIC_CONCAT
:
1274 gfc_conv_concat_op (se
, expr
);
1278 code
= TRUTH_ANDIF_EXPR
;
1283 code
= TRUTH_ORIF_EXPR
;
1287 /* EQV and NEQV only work on logicals, but since we represent them
1288 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1290 case INTRINSIC_EQ_OS
:
1298 case INTRINSIC_NE_OS
:
1299 case INTRINSIC_NEQV
:
1306 case INTRINSIC_GT_OS
:
1313 case INTRINSIC_GE_OS
:
1320 case INTRINSIC_LT_OS
:
1327 case INTRINSIC_LE_OS
:
1333 case INTRINSIC_USER
:
1334 case INTRINSIC_ASSIGN
:
1335 /* These should be converted into function calls by the frontend. */
1339 fatal_error ("Unknown intrinsic op");
1343 /* The only exception to this is **, which is handled separately anyway. */
1344 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1346 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1350 gfc_init_se (&lse
, se
);
1351 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1352 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1355 gfc_init_se (&rse
, se
);
1356 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1357 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1361 gfc_conv_string_parameter (&lse
);
1362 gfc_conv_string_parameter (&rse
);
1364 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1365 rse
.string_length
, rse
.expr
,
1366 expr
->value
.op
.op1
->ts
.kind
);
1367 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1368 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1371 type
= gfc_typenode_for_spec (&expr
->ts
);
1375 /* The result of logical ops is always boolean_type_node. */
1376 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1377 se
->expr
= convert (type
, tmp
);
1380 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1382 /* Add the post blocks. */
1383 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1384 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1387 /* If a string's length is one, we convert it to a single character. */
1390 string_to_single_character (tree len
, tree str
, int kind
)
1392 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1394 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1395 && TREE_INT_CST_HIGH (len
) == 0)
1397 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1398 return build_fold_indirect_ref_loc (input_location
,
1407 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1410 if (sym
->backend_decl
)
1412 /* This becomes the nominal_type in
1413 function.c:assign_parm_find_data_types. */
1414 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1415 /* This becomes the passed_type in
1416 function.c:assign_parm_find_data_types. C promotes char to
1417 integer for argument passing. */
1418 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1420 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1425 /* If we have a constant character expression, make it into an
1427 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1432 *expr
= gfc_int_expr ((int)(*expr
)->value
.character
.string
[0]);
1433 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1435 /* The expr needs to be compatible with a C int. If the
1436 conversion fails, then the 2 causes an ICE. */
1437 ts
.type
= BT_INTEGER
;
1438 ts
.kind
= gfc_c_int_kind
;
1439 gfc_convert_type (*expr
, &ts
, 2);
1442 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1444 if ((*expr
)->ref
== NULL
)
1446 se
->expr
= string_to_single_character
1447 (build_int_cst (integer_type_node
, 1),
1448 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1450 ((*expr
)->symtree
->n
.sym
)),
1455 gfc_conv_variable (se
, *expr
);
1456 se
->expr
= string_to_single_character
1457 (build_int_cst (integer_type_node
, 1),
1458 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1467 /* Compare two strings. If they are all single characters, the result is the
1468 subtraction of them. Otherwise, we build a library call. */
1471 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1477 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1478 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1480 sc1
= string_to_single_character (len1
, str1
, kind
);
1481 sc2
= string_to_single_character (len2
, str2
, kind
);
1483 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1485 /* Deal with single character specially. */
1486 sc1
= fold_convert (integer_type_node
, sc1
);
1487 sc2
= fold_convert (integer_type_node
, sc2
);
1488 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1492 /* Build a call for the comparison. */
1496 fndecl
= gfor_fndecl_compare_string
;
1498 fndecl
= gfor_fndecl_compare_string_char4
;
1502 tmp
= build_call_expr_loc (input_location
,
1503 fndecl
, 4, len1
, str1
, len2
, str2
);
1510 /* Return the backend_decl for a procedure pointer component. */
1513 get_proc_ptr_comp (gfc_expr
*e
)
1517 gfc_init_se (&comp_se
, NULL
);
1518 e2
= gfc_copy_expr (e
);
1519 e2
->expr_type
= EXPR_VARIABLE
;
1520 gfc_conv_expr (&comp_se
, e2
);
1522 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1526 /* Select a class typebound procedure at runtime. */
1528 select_class_proc (gfc_se
*se
, gfc_class_esym_list
*elist
,
1529 tree declared
, gfc_expr
*expr
)
1536 gfc_class_esym_list
*next_elist
, *tmp_elist
;
1539 /* Convert the hash expression. */
1540 gfc_init_se (&tmpse
, NULL
);
1541 gfc_conv_expr (&tmpse
, elist
->hash_value
);
1542 gfc_add_block_to_block (&se
->pre
, &tmpse
.pre
);
1543 hash
= gfc_evaluate_now (tmpse
.expr
, &se
->pre
);
1544 gfc_add_block_to_block (&se
->post
, &tmpse
.post
);
1546 /* Fix the function type to be that of the declared type method. */
1547 declared
= gfc_create_var (TREE_TYPE (declared
), "method");
1549 end_label
= gfc_build_label_decl (NULL_TREE
);
1551 gfc_init_block (&body
);
1553 /* Go through the list of extensions. */
1554 for (; elist
; elist
= next_elist
)
1556 /* This case has already been added. */
1557 if (elist
->derived
== NULL
)
1560 /* Skip abstract base types. */
1561 if (elist
->derived
->attr
.abstract
)
1564 /* Run through the chain picking up all the cases that call the
1567 for (; elist
; elist
= elist
->next
)
1571 if (elist
->esym
!= tmp_elist
->esym
)
1574 cval
= build_int_cst (TREE_TYPE (hash
),
1575 elist
->derived
->hash_value
);
1576 /* Build a label for the hash value. */
1577 label
= gfc_build_label_decl (NULL_TREE
);
1578 tmp
= fold_build3 (CASE_LABEL_EXPR
, void_type_node
,
1579 cval
, NULL_TREE
, label
);
1580 gfc_add_expr_to_block (&body
, tmp
);
1582 /* Null the reference the derived type so that this case is
1584 elist
->derived
= NULL
;
1589 /* Get a pointer to the procedure, */
1590 tmp
= gfc_get_symbol_decl (elist
->esym
);
1591 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1593 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1594 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1597 /* Assign the pointer to the appropriate procedure. */
1598 gfc_add_modify (&body
, declared
,
1599 fold_convert (TREE_TYPE (declared
), tmp
));
1601 /* Break to the end of the construct. */
1602 tmp
= build1_v (GOTO_EXPR
, end_label
);
1603 gfc_add_expr_to_block (&body
, tmp
);
1605 /* Free the elists as we go; freeing them in gfc_free_expr causes
1606 segfaults because it occurs too early and too often. */
1608 next_elist
= elist
->next
;
1609 if (elist
->hash_value
)
1610 gfc_free_expr (elist
->hash_value
);
1615 /* Default is an error. */
1616 label
= gfc_build_label_decl (NULL_TREE
);
1617 tmp
= fold_build3 (CASE_LABEL_EXPR
, void_type_node
,
1618 NULL_TREE
, NULL_TREE
, label
);
1619 gfc_add_expr_to_block (&body
, tmp
);
1620 tmp
= gfc_trans_runtime_error (true, &expr
->where
,
1621 "internal error: bad hash value in dynamic dispatch");
1622 gfc_add_expr_to_block (&body
, tmp
);
1624 /* Write the switch expression. */
1625 tmp
= gfc_finish_block (&body
);
1626 tmp
= build3_v (SWITCH_EXPR
, hash
, tmp
, NULL_TREE
);
1627 gfc_add_expr_to_block (&se
->pre
, tmp
);
1629 tmp
= build1_v (LABEL_EXPR
, end_label
);
1630 gfc_add_expr_to_block (&se
->pre
, tmp
);
1632 se
->expr
= declared
;
1638 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1642 if (expr
&& expr
->symtree
1643 && expr
->value
.function
.class_esym
)
1645 if (!sym
->backend_decl
)
1646 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1648 tmp
= sym
->backend_decl
;
1650 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1652 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1653 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1656 select_class_proc (se
, expr
->value
.function
.class_esym
,
1661 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1662 tmp
= get_proc_ptr_comp (expr
);
1663 else if (sym
->attr
.dummy
)
1665 tmp
= gfc_get_symbol_decl (sym
);
1666 if (sym
->attr
.proc_pointer
)
1667 tmp
= build_fold_indirect_ref_loc (input_location
,
1669 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1670 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1674 if (!sym
->backend_decl
)
1675 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1677 tmp
= sym
->backend_decl
;
1679 if (sym
->attr
.cray_pointee
)
1681 /* TODO - make the cray pointee a pointer to a procedure,
1682 assign the pointer to it and use it for the call. This
1684 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1685 gfc_get_symbol_decl (sym
->cp_pointer
));
1686 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1689 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1691 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1692 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1699 /* Initialize MAPPING. */
1702 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1704 mapping
->syms
= NULL
;
1705 mapping
->charlens
= NULL
;
1709 /* Free all memory held by MAPPING (but not MAPPING itself). */
1712 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1714 gfc_interface_sym_mapping
*sym
;
1715 gfc_interface_sym_mapping
*nextsym
;
1717 gfc_charlen
*nextcl
;
1719 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1721 nextsym
= sym
->next
;
1722 sym
->new_sym
->n
.sym
->formal
= NULL
;
1723 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1724 gfc_free_expr (sym
->expr
);
1725 gfc_free (sym
->new_sym
);
1728 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1731 gfc_free_expr (cl
->length
);
1737 /* Return a copy of gfc_charlen CL. Add the returned structure to
1738 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1740 static gfc_charlen
*
1741 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1744 gfc_charlen
*new_charlen
;
1746 new_charlen
= gfc_get_charlen ();
1747 new_charlen
->next
= mapping
->charlens
;
1748 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1750 mapping
->charlens
= new_charlen
;
1755 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1756 array variable that can be used as the actual argument for dummy
1757 argument SYM. Add any initialization code to BLOCK. PACKED is as
1758 for gfc_get_nodesc_array_type and DATA points to the first element
1759 in the passed array. */
1762 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1763 gfc_packed packed
, tree data
)
1768 type
= gfc_typenode_for_spec (&sym
->ts
);
1769 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1770 !sym
->attr
.target
&& !sym
->attr
.pointer
1771 && !sym
->attr
.proc_pointer
);
1773 var
= gfc_create_var (type
, "ifm");
1774 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1780 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1781 and offset of descriptorless array type TYPE given that it has the same
1782 size as DESC. Add any set-up code to BLOCK. */
1785 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1792 offset
= gfc_index_zero_node
;
1793 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1795 dim
= gfc_rank_cst
[n
];
1796 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1797 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1799 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1800 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1801 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1802 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1804 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1806 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1807 gfc_conv_descriptor_ubound_get (desc
, dim
),
1808 gfc_conv_descriptor_lbound_get (desc
, dim
));
1809 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1810 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1812 tmp
= gfc_evaluate_now (tmp
, block
);
1813 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1815 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1816 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1817 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1818 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1820 offset
= gfc_evaluate_now (offset
, block
);
1821 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1825 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1826 in SE. The caller may still use se->expr and se->string_length after
1827 calling this function. */
1830 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1831 gfc_symbol
* sym
, gfc_se
* se
,
1834 gfc_interface_sym_mapping
*sm
;
1838 gfc_symbol
*new_sym
;
1840 gfc_symtree
*new_symtree
;
1842 /* Create a new symbol to represent the actual argument. */
1843 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1844 new_sym
->ts
= sym
->ts
;
1845 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1846 new_sym
->attr
.referenced
= 1;
1847 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1848 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1849 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1850 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1851 new_sym
->attr
.function
= sym
->attr
.function
;
1853 /* Ensure that the interface is available and that
1854 descriptors are passed for array actual arguments. */
1855 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1857 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1858 new_sym
->attr
.always_explicit
1859 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1862 /* Create a fake symtree for it. */
1864 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1865 new_symtree
->n
.sym
= new_sym
;
1866 gcc_assert (new_symtree
== root
);
1868 /* Create a dummy->actual mapping. */
1869 sm
= XCNEW (gfc_interface_sym_mapping
);
1870 sm
->next
= mapping
->syms
;
1872 sm
->new_sym
= new_symtree
;
1873 sm
->expr
= gfc_copy_expr (expr
);
1876 /* Stabilize the argument's value. */
1877 if (!sym
->attr
.function
&& se
)
1878 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1880 if (sym
->ts
.type
== BT_CHARACTER
)
1882 /* Create a copy of the dummy argument's length. */
1883 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1884 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1886 /* If the length is specified as "*", record the length that
1887 the caller is passing. We should use the callee's length
1888 in all other cases. */
1889 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1891 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1892 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1899 /* Use the passed value as-is if the argument is a function. */
1900 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1903 /* If the argument is either a string or a pointer to a string,
1904 convert it to a boundless character type. */
1905 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1907 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1908 tmp
= build_pointer_type (tmp
);
1909 if (sym
->attr
.pointer
)
1910 value
= build_fold_indirect_ref_loc (input_location
,
1914 value
= fold_convert (tmp
, value
);
1917 /* If the argument is a scalar, a pointer to an array or an allocatable,
1919 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1920 value
= build_fold_indirect_ref_loc (input_location
,
1923 /* For character(*), use the actual argument's descriptor. */
1924 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1925 value
= build_fold_indirect_ref_loc (input_location
,
1928 /* If the argument is an array descriptor, use it to determine
1929 information about the actual argument's shape. */
1930 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1931 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1933 /* Get the actual argument's descriptor. */
1934 desc
= build_fold_indirect_ref_loc (input_location
,
1937 /* Create the replacement variable. */
1938 tmp
= gfc_conv_descriptor_data_get (desc
);
1939 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1942 /* Use DESC to work out the upper bounds, strides and offset. */
1943 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1946 /* Otherwise we have a packed array. */
1947 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1948 PACKED_FULL
, se
->expr
);
1950 new_sym
->backend_decl
= value
;
1954 /* Called once all dummy argument mappings have been added to MAPPING,
1955 but before the mapping is used to evaluate expressions. Pre-evaluate
1956 the length of each argument, adding any initialization code to PRE and
1957 any finalization code to POST. */
1960 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1961 stmtblock_t
* pre
, stmtblock_t
* post
)
1963 gfc_interface_sym_mapping
*sym
;
1967 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1968 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1969 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1971 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1972 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1973 gfc_init_se (&se
, NULL
);
1974 gfc_conv_expr (&se
, expr
);
1975 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1976 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1977 gfc_add_block_to_block (pre
, &se
.pre
);
1978 gfc_add_block_to_block (post
, &se
.post
);
1980 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1985 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1989 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1990 gfc_constructor
* c
)
1992 for (; c
; c
= c
->next
)
1994 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1997 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1998 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1999 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
2005 /* Like gfc_apply_interface_mapping_to_expr, but applied to
2009 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
2014 for (; ref
; ref
= ref
->next
)
2018 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2020 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
2021 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
2022 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
2024 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
2031 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
2032 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
2038 /* Convert intrinsic function calls into result expressions. */
2041 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
2049 arg1
= expr
->value
.function
.actual
->expr
;
2050 if (expr
->value
.function
.actual
->next
)
2051 arg2
= expr
->value
.function
.actual
->next
->expr
;
2055 sym
= arg1
->symtree
->n
.sym
;
2057 if (sym
->attr
.dummy
)
2062 switch (expr
->value
.function
.isym
->id
)
2065 /* TODO figure out why this condition is necessary. */
2066 if (sym
->attr
.function
2067 && (arg1
->ts
.u
.cl
->length
== NULL
2068 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
2069 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
2072 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
2079 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2081 dup
= mpz_get_si (arg2
->value
.integer
);
2086 dup
= sym
->as
->rank
;
2090 for (; d
< dup
; d
++)
2094 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
2096 gfc_free_expr (new_expr
);
2100 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]), gfc_int_expr (1));
2101 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
2103 new_expr
= gfc_multiply (new_expr
, tmp
);
2109 case GFC_ISYM_LBOUND
:
2110 case GFC_ISYM_UBOUND
:
2111 /* TODO These implementations of lbound and ubound do not limit if
2112 the size < 0, according to F95's 13.14.53 and 13.14.113. */
2117 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
2118 d
= mpz_get_si (arg2
->value
.integer
) - 1;
2120 /* TODO: If the need arises, this could produce an array of
2124 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2126 if (sym
->as
->lower
[d
])
2127 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2131 if (sym
->as
->upper
[d
])
2132 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2140 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2144 gfc_replace_expr (expr
, new_expr
);
2150 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2151 gfc_interface_mapping
* mapping
)
2153 gfc_formal_arglist
*f
;
2154 gfc_actual_arglist
*actual
;
2156 actual
= expr
->value
.function
.actual
;
2157 f
= map_expr
->symtree
->n
.sym
->formal
;
2159 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2164 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2167 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2172 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2174 for (d
= 0; d
< as
->rank
; d
++)
2176 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2177 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2180 expr
->value
.function
.esym
->as
= as
;
2183 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2185 expr
->value
.function
.esym
->ts
.u
.cl
->length
2186 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2188 gfc_apply_interface_mapping_to_expr (mapping
,
2189 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2194 /* EXPR is a copy of an expression that appeared in the interface
2195 associated with MAPPING. Walk it recursively looking for references to
2196 dummy arguments that MAPPING maps to actual arguments. Replace each such
2197 reference with a reference to the associated actual argument. */
2200 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2203 gfc_interface_sym_mapping
*sym
;
2204 gfc_actual_arglist
*actual
;
2209 /* Copying an expression does not copy its length, so do that here. */
2210 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2212 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2213 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2216 /* Apply the mapping to any references. */
2217 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2219 /* ...and to the expression's symbol, if it has one. */
2220 /* TODO Find out why the condition on expr->symtree had to be moved into
2221 the loop rather than being outside it, as originally. */
2222 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2223 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2225 if (sym
->new_sym
->n
.sym
->backend_decl
)
2226 expr
->symtree
= sym
->new_sym
;
2228 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2231 /* ...and to subexpressions in expr->value. */
2232 switch (expr
->expr_type
)
2237 case EXPR_SUBSTRING
:
2241 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2242 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2246 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2247 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2249 if (expr
->value
.function
.esym
== NULL
2250 && expr
->value
.function
.isym
!= NULL
2251 && expr
->value
.function
.actual
->expr
->symtree
2252 && gfc_map_intrinsic_function (expr
, mapping
))
2255 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2256 if (sym
->old
== expr
->value
.function
.esym
)
2258 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2259 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2260 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2265 case EXPR_STRUCTURE
:
2266 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2279 /* Evaluate interface expression EXPR using MAPPING. Store the result
2283 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2284 gfc_se
* se
, gfc_expr
* expr
)
2286 expr
= gfc_copy_expr (expr
);
2287 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2288 gfc_conv_expr (se
, expr
);
2289 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2290 gfc_free_expr (expr
);
2294 /* Returns a reference to a temporary array into which a component of
2295 an actual argument derived type array is copied and then returned
2296 after the function call. */
2298 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2299 sym_intent intent
, bool formal_ptr
)
2317 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2319 gfc_init_se (&lse
, NULL
);
2320 gfc_init_se (&rse
, NULL
);
2322 /* Walk the argument expression. */
2323 rss
= gfc_walk_expr (expr
);
2325 gcc_assert (rss
!= gfc_ss_terminator
);
2327 /* Initialize the scalarizer. */
2328 gfc_init_loopinfo (&loop
);
2329 gfc_add_ss_to_loop (&loop
, rss
);
2331 /* Calculate the bounds of the scalarization. */
2332 gfc_conv_ss_startstride (&loop
);
2334 /* Build an ss for the temporary. */
2335 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2336 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2338 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2339 if (GFC_ARRAY_TYPE_P (base_type
)
2340 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2341 base_type
= gfc_get_element_type (base_type
);
2343 loop
.temp_ss
= gfc_get_ss ();;
2344 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2345 loop
.temp_ss
->data
.temp
.type
= base_type
;
2347 if (expr
->ts
.type
== BT_CHARACTER
)
2348 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2350 loop
.temp_ss
->string_length
= NULL
;
2352 parmse
->string_length
= loop
.temp_ss
->string_length
;
2353 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2354 loop
.temp_ss
->next
= gfc_ss_terminator
;
2356 /* Associate the SS with the loop. */
2357 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2359 /* Setup the scalarizing loops. */
2360 gfc_conv_loop_setup (&loop
, &expr
->where
);
2362 /* Pass the temporary descriptor back to the caller. */
2363 info
= &loop
.temp_ss
->data
.info
;
2364 parmse
->expr
= info
->descriptor
;
2366 /* Setup the gfc_se structures. */
2367 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2368 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2371 lse
.ss
= loop
.temp_ss
;
2372 gfc_mark_ss_chain_used (rss
, 1);
2373 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2375 /* Start the scalarized loop body. */
2376 gfc_start_scalarized_body (&loop
, &body
);
2378 /* Translate the expression. */
2379 gfc_conv_expr (&rse
, expr
);
2381 gfc_conv_tmp_array_ref (&lse
);
2382 gfc_advance_se_ss_chain (&lse
);
2384 if (intent
!= INTENT_OUT
)
2386 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
2387 gfc_add_expr_to_block (&body
, tmp
);
2388 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2389 gfc_trans_scalarizing_loops (&loop
, &body
);
2393 /* Make sure that the temporary declaration survives by merging
2394 all the loop declarations into the current context. */
2395 for (n
= 0; n
< loop
.dimen
; n
++)
2397 gfc_merge_block_scope (&body
);
2398 body
= loop
.code
[loop
.order
[n
]];
2400 gfc_merge_block_scope (&body
);
2403 /* Add the post block after the second loop, so that any
2404 freeing of allocated memory is done at the right time. */
2405 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2407 /**********Copy the temporary back again.*********/
2409 gfc_init_se (&lse
, NULL
);
2410 gfc_init_se (&rse
, NULL
);
2412 /* Walk the argument expression. */
2413 lss
= gfc_walk_expr (expr
);
2414 rse
.ss
= loop
.temp_ss
;
2417 /* Initialize the scalarizer. */
2418 gfc_init_loopinfo (&loop2
);
2419 gfc_add_ss_to_loop (&loop2
, lss
);
2421 /* Calculate the bounds of the scalarization. */
2422 gfc_conv_ss_startstride (&loop2
);
2424 /* Setup the scalarizing loops. */
2425 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2427 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2428 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2430 gfc_mark_ss_chain_used (lss
, 1);
2431 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2433 /* Declare the variable to hold the temporary offset and start the
2434 scalarized loop body. */
2435 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2436 gfc_start_scalarized_body (&loop2
, &body
);
2438 /* Build the offsets for the temporary from the loop variables. The
2439 temporary array has lbounds of zero and strides of one in all
2440 dimensions, so this is very simple. The offset is only computed
2441 outside the innermost loop, so the overall transfer could be
2442 optimized further. */
2443 info
= &rse
.ss
->data
.info
;
2444 dimen
= info
->dimen
;
2446 tmp_index
= gfc_index_zero_node
;
2447 for (n
= dimen
- 1; n
> 0; n
--)
2450 tmp
= rse
.loop
->loopvar
[n
];
2451 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2452 tmp
, rse
.loop
->from
[n
]);
2453 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2456 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2457 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2458 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2459 tmp_str
, gfc_index_one_node
);
2461 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2465 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2466 tmp_index
, rse
.loop
->from
[0]);
2467 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2469 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2470 rse
.loop
->loopvar
[0], offset
);
2472 /* Now use the offset for the reference. */
2473 tmp
= build_fold_indirect_ref_loc (input_location
,
2475 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2477 if (expr
->ts
.type
== BT_CHARACTER
)
2478 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2480 gfc_conv_expr (&lse
, expr
);
2482 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2484 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
2485 gfc_add_expr_to_block (&body
, tmp
);
2487 /* Generate the copying loops. */
2488 gfc_trans_scalarizing_loops (&loop2
, &body
);
2490 /* Wrap the whole thing up by adding the second loop to the post-block
2491 and following it by the post-block of the first loop. In this way,
2492 if the temporary needs freeing, it is done after use! */
2493 if (intent
!= INTENT_IN
)
2495 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2496 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2499 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2501 gfc_cleanup_loop (&loop
);
2502 gfc_cleanup_loop (&loop2
);
2504 /* Pass the string length to the argument expression. */
2505 if (expr
->ts
.type
== BT_CHARACTER
)
2506 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2508 /* Determine the offset for pointer formal arguments and set the
2512 size
= gfc_index_one_node
;
2513 offset
= gfc_index_zero_node
;
2514 for (n
= 0; n
< dimen
; n
++)
2516 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2518 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2519 tmp
, gfc_index_one_node
);
2520 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2524 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2527 gfc_index_one_node
);
2528 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2529 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2531 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2532 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2533 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2534 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2535 tmp
, gfc_index_one_node
);
2536 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2540 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2544 /* We want either the address for the data or the address of the descriptor,
2545 depending on the mode of passing array arguments. */
2547 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2549 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2555 /* Generate the code for argument list functions. */
2558 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2560 /* Pass by value for g77 %VAL(arg), pass the address
2561 indirectly for %LOC, else by reference. Thus %REF
2562 is a "do-nothing" and %LOC is the same as an F95
2564 if (strncmp (name
, "%VAL", 4) == 0)
2565 gfc_conv_expr (se
, expr
);
2566 else if (strncmp (name
, "%LOC", 4) == 0)
2568 gfc_conv_expr_reference (se
, expr
);
2569 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2571 else if (strncmp (name
, "%REF", 4) == 0)
2572 gfc_conv_expr_reference (se
, expr
);
2574 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2578 /* Takes a derived type expression and returns the address of a temporary
2579 class object of the 'declared' type. */
2581 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2582 gfc_typespec class_ts
)
2586 gfc_symbol
*declared
= class_ts
.u
.derived
;
2592 /* The derived type needs to be converted to a temporary
2594 tmp
= gfc_typenode_for_spec (&class_ts
);
2595 var
= gfc_create_var (tmp
, "class");
2598 cmp
= gfc_find_component (declared
, "$vptr", true, true);
2599 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2600 var
, cmp
->backend_decl
, NULL_TREE
);
2602 /* Remember the vtab corresponds to the derived type
2603 not to the class declared type. */
2604 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
);
2606 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2607 gfc_add_modify (&parmse
->pre
, ctree
,
2608 fold_convert (TREE_TYPE (ctree
), tmp
));
2610 /* Now set the data field. */
2611 cmp
= gfc_find_component (declared
, "$data", true, true);
2612 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2613 var
, cmp
->backend_decl
, NULL_TREE
);
2614 ss
= gfc_walk_expr (e
);
2615 if (ss
== gfc_ss_terminator
)
2617 gfc_conv_expr_reference (parmse
, e
);
2618 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2619 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2623 gfc_conv_expr (parmse
, e
);
2624 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2627 /* Pass the address of the class object. */
2628 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2632 /* The following routine generates code for the intrinsic
2633 procedures from the ISO_C_BINDING module:
2635 * C_FUNLOC (function)
2636 * C_F_POINTER (subroutine)
2637 * C_F_PROCPOINTER (subroutine)
2638 * C_ASSOCIATED (function)
2639 One exception which is not handled here is C_F_POINTER with non-scalar
2640 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2643 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2644 gfc_actual_arglist
* arg
)
2649 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2651 if (arg
->expr
->rank
== 0)
2652 gfc_conv_expr_reference (se
, arg
->expr
);
2656 /* This is really the actual arg because no formal arglist is
2657 created for C_LOC. */
2658 fsym
= arg
->expr
->symtree
->n
.sym
;
2660 /* We should want it to do g77 calling convention. */
2662 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2663 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2664 f
= f
|| !sym
->attr
.always_explicit
;
2666 argss
= gfc_walk_expr (arg
->expr
);
2667 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2671 /* TODO -- the following two lines shouldn't be necessary, but if
2672 they're removed, a bug is exposed later in the code path.
2673 This workaround was thus introduced, but will have to be
2674 removed; please see PR 35150 for details about the issue. */
2675 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2676 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2680 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2682 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2683 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2684 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2685 gfc_conv_expr_reference (se
, arg
->expr
);
2689 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2690 && arg
->next
->expr
->rank
== 0)
2691 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2693 /* Convert c_f_pointer if fptr is a scalar
2694 and convert c_f_procpointer. */
2698 gfc_init_se (&cptrse
, NULL
);
2699 gfc_conv_expr (&cptrse
, arg
->expr
);
2700 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2701 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2703 gfc_init_se (&fptrse
, NULL
);
2704 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2705 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2706 fptrse
.want_pointer
= 1;
2708 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2709 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2710 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2712 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2713 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2714 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2717 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (fptrse
.expr
),
2719 fold_convert (TREE_TYPE (fptrse
.expr
),
2724 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2729 /* Build the addr_expr for the first argument. The argument is
2730 already an *address* so we don't need to set want_pointer in
2732 gfc_init_se (&arg1se
, NULL
);
2733 gfc_conv_expr (&arg1se
, arg
->expr
);
2734 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2735 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2737 /* See if we were given two arguments. */
2738 if (arg
->next
== NULL
)
2739 /* Only given one arg so generate a null and do a
2740 not-equal comparison against the first arg. */
2741 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2742 fold_convert (TREE_TYPE (arg1se
.expr
),
2743 null_pointer_node
));
2749 /* Given two arguments so build the arg2se from second arg. */
2750 gfc_init_se (&arg2se
, NULL
);
2751 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2752 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2753 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2755 /* Generate test to compare that the two args are equal. */
2756 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2757 arg1se
.expr
, arg2se
.expr
);
2758 /* Generate test to ensure that the first arg is not null. */
2759 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2760 arg1se
.expr
, null_pointer_node
);
2762 /* Finally, the generated test must check that both arg1 is not
2763 NULL and that it is equal to the second arg. */
2764 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2765 not_null_expr
, eq_expr
);
2771 /* Nothing was done. */
2776 /* Generate code for a procedure call. Note can return se->post != NULL.
2777 If se->direct_byref is set then se->expr contains the return parameter.
2778 Return nonzero, if the call has alternate specifiers.
2779 'expr' is only needed for procedure pointer components. */
2782 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2783 gfc_actual_arglist
* arg
, gfc_expr
* expr
,
2786 gfc_interface_mapping mapping
;
2801 gfc_formal_arglist
*formal
;
2802 int has_alternate_specifier
= 0;
2803 bool need_interface_mapping
;
2810 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2811 gfc_component
*comp
= NULL
;
2813 arglist
= NULL_TREE
;
2814 retargs
= NULL_TREE
;
2815 stringargs
= NULL_TREE
;
2820 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2821 && conv_isocbinding_procedure (se
, sym
, arg
))
2824 gfc_is_proc_ptr_comp (expr
, &comp
);
2828 if (!sym
->attr
.elemental
)
2830 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2831 if (se
->ss
->useflags
)
2833 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2834 && sym
->result
->attr
.dimension
)
2835 || (comp
&& comp
->attr
.dimension
));
2836 gcc_assert (se
->loop
!= NULL
);
2838 /* Access the previously obtained result. */
2839 gfc_conv_tmp_array_ref (se
);
2840 gfc_advance_se_ss_chain (se
);
2844 info
= &se
->ss
->data
.info
;
2849 gfc_init_block (&post
);
2850 gfc_init_interface_mapping (&mapping
);
2853 formal
= sym
->formal
;
2854 need_interface_mapping
= sym
->attr
.dimension
||
2855 (sym
->ts
.type
== BT_CHARACTER
2856 && sym
->ts
.u
.cl
->length
2857 && sym
->ts
.u
.cl
->length
->expr_type
2862 formal
= comp
->formal
;
2863 need_interface_mapping
= comp
->attr
.dimension
||
2864 (comp
->ts
.type
== BT_CHARACTER
2865 && comp
->ts
.u
.cl
->length
2866 && comp
->ts
.u
.cl
->length
->expr_type
2870 /* Evaluate the arguments. */
2871 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2874 fsym
= formal
? formal
->sym
: NULL
;
2875 parm_kind
= MISSING
;
2879 if (se
->ignore_optional
)
2881 /* Some intrinsics have already been resolved to the correct
2885 else if (arg
->label
)
2887 has_alternate_specifier
= 1;
2892 /* Pass a NULL pointer for an absent arg. */
2893 gfc_init_se (&parmse
, NULL
);
2894 parmse
.expr
= null_pointer_node
;
2895 if (arg
->missing_arg_type
== BT_CHARACTER
)
2896 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2899 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2900 && e
->ts
.type
== BT_DERIVED
)
2902 /* The derived type needs to be converted to a temporary
2904 gfc_init_se (&parmse
, se
);
2905 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2907 else if (se
->ss
&& se
->ss
->useflags
)
2909 /* An elemental function inside a scalarized loop. */
2910 gfc_init_se (&parmse
, se
);
2911 gfc_conv_expr_reference (&parmse
, e
);
2912 parm_kind
= ELEMENTAL
;
2916 /* A scalar or transformational function. */
2917 gfc_init_se (&parmse
, NULL
);
2918 argss
= gfc_walk_expr (e
);
2920 if (argss
== gfc_ss_terminator
)
2922 if (e
->expr_type
== EXPR_VARIABLE
2923 && e
->symtree
->n
.sym
->attr
.cray_pointee
2924 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2926 /* The Cray pointer needs to be converted to a pointer to
2927 a type given by the expression. */
2928 gfc_conv_expr (&parmse
, e
);
2929 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2930 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2931 parmse
.expr
= convert (type
, tmp
);
2933 else if (fsym
&& fsym
->attr
.value
)
2935 if (fsym
->ts
.type
== BT_CHARACTER
2936 && fsym
->ts
.is_c_interop
2937 && fsym
->ns
->proc_name
!= NULL
2938 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2941 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2942 if (parmse
.expr
== NULL
)
2943 gfc_conv_expr (&parmse
, e
);
2946 gfc_conv_expr (&parmse
, e
);
2948 else if (arg
->name
&& arg
->name
[0] == '%')
2949 /* Argument list functions %VAL, %LOC and %REF are signalled
2950 through arg->name. */
2951 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2952 else if ((e
->expr_type
== EXPR_FUNCTION
)
2953 && ((e
->value
.function
.esym
2954 && e
->value
.function
.esym
->result
->attr
.pointer
)
2955 || (!e
->value
.function
.esym
2956 && e
->symtree
->n
.sym
->attr
.pointer
))
2957 && fsym
&& fsym
->attr
.target
)
2959 gfc_conv_expr (&parmse
, e
);
2960 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2962 else if (e
->expr_type
== EXPR_FUNCTION
2963 && e
->symtree
->n
.sym
->result
2964 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2965 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2967 /* Functions returning procedure pointers. */
2968 gfc_conv_expr (&parmse
, e
);
2969 if (fsym
&& fsym
->attr
.proc_pointer
)
2970 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2974 gfc_conv_expr_reference (&parmse
, e
);
2976 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2977 allocated on entry, it must be deallocated. */
2978 if (fsym
&& fsym
->attr
.allocatable
2979 && fsym
->attr
.intent
== INTENT_OUT
)
2983 gfc_init_block (&block
);
2984 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
2986 gfc_add_expr_to_block (&block
, tmp
);
2987 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
2988 parmse
.expr
, null_pointer_node
);
2989 gfc_add_expr_to_block (&block
, tmp
);
2991 if (fsym
->attr
.optional
2992 && e
->expr_type
== EXPR_VARIABLE
2993 && e
->symtree
->n
.sym
->attr
.optional
)
2995 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2996 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2997 gfc_finish_block (&block
),
2998 build_empty_stmt (input_location
));
3001 tmp
= gfc_finish_block (&block
);
3003 gfc_add_expr_to_block (&se
->pre
, tmp
);
3006 if (fsym
&& e
->expr_type
!= EXPR_NULL
3007 && ((fsym
->attr
.pointer
3008 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
3009 || (fsym
->attr
.proc_pointer
3010 && !(e
->expr_type
== EXPR_VARIABLE
3011 && e
->symtree
->n
.sym
->attr
.dummy
))
3012 || (e
->expr_type
== EXPR_VARIABLE
3013 && gfc_is_proc_ptr_comp (e
, NULL
))
3014 || fsym
->attr
.allocatable
))
3016 /* Scalar pointer dummy args require an extra level of
3017 indirection. The null pointer already contains
3018 this level of indirection. */
3019 parm_kind
= SCALAR_POINTER
;
3020 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
3026 /* If the procedure requires an explicit interface, the actual
3027 argument is passed according to the corresponding formal
3028 argument. If the corresponding formal argument is a POINTER,
3029 ALLOCATABLE or assumed shape, we do not use g77's calling
3030 convention, and pass the address of the array descriptor
3031 instead. Otherwise we use g77's calling convention. */
3034 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
3035 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
3037 f
= f
|| !comp
->attr
.always_explicit
;
3039 f
= f
|| !sym
->attr
.always_explicit
;
3041 if (e
->expr_type
== EXPR_VARIABLE
3042 && is_subref_array (e
))
3043 /* The actual argument is a component reference to an
3044 array of derived types. In this case, the argument
3045 is converted to a temporary, which is passed and then
3046 written back after the procedure call. */
3047 gfc_conv_subref_array_arg (&parmse
, e
, f
,
3048 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
3049 fsym
&& fsym
->attr
.pointer
);
3051 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
3054 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
3055 allocated on entry, it must be deallocated. */
3056 if (fsym
&& fsym
->attr
.allocatable
3057 && fsym
->attr
.intent
== INTENT_OUT
)
3059 tmp
= build_fold_indirect_ref_loc (input_location
,
3061 tmp
= gfc_trans_dealloc_allocated (tmp
);
3062 if (fsym
->attr
.optional
3063 && e
->expr_type
== EXPR_VARIABLE
3064 && e
->symtree
->n
.sym
->attr
.optional
)
3065 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
3066 gfc_conv_expr_present (e
->symtree
->n
.sym
),
3067 tmp
, build_empty_stmt (input_location
));
3068 gfc_add_expr_to_block (&se
->pre
, tmp
);
3073 /* The case with fsym->attr.optional is that of a user subroutine
3074 with an interface indicating an optional argument. When we call
3075 an intrinsic subroutine, however, fsym is NULL, but we might still
3076 have an optional argument, so we proceed to the substitution
3078 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
3080 /* If an optional argument is itself an optional dummy argument,
3081 check its presence and substitute a null if absent. This is
3082 only needed when passing an array to an elemental procedure
3083 as then array elements are accessed - or no NULL pointer is
3084 allowed and a "1" or "0" should be passed if not present.
3085 When passing a non-array-descriptor full array to a
3086 non-array-descriptor dummy, no check is needed. For
3087 array-descriptor actual to array-descriptor dummy, see
3088 PR 41911 for why a check has to be inserted.
3089 fsym == NULL is checked as intrinsics required the descriptor
3090 but do not always set fsym. */
3091 if (e
->expr_type
== EXPR_VARIABLE
3092 && e
->symtree
->n
.sym
->attr
.optional
3093 && ((e
->rank
> 0 && sym
->attr
.elemental
)
3094 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
3096 && (fsym
== NULL
|| fsym
->as
->type
== AS_ASSUMED_SHAPE
3097 || fsym
->as
->type
== AS_DEFERRED
))))
3098 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
3099 e
->representation
.length
);
3104 /* Obtain the character length of an assumed character length
3105 length procedure from the typespec. */
3106 if (fsym
->ts
.type
== BT_CHARACTER
3107 && parmse
.string_length
== NULL_TREE
3108 && e
->ts
.type
== BT_PROCEDURE
3109 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
3110 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
3111 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
3113 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
3114 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
3118 if (fsym
&& need_interface_mapping
&& e
)
3119 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3121 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3122 gfc_add_block_to_block (&post
, &parmse
.post
);
3124 /* Allocated allocatable components of derived types must be
3125 deallocated for non-variable scalars. Non-variable arrays are
3126 dealt with in trans-array.c(gfc_conv_array_parameter). */
3127 if (e
&& e
->ts
.type
== BT_DERIVED
3128 && e
->ts
.u
.derived
->attr
.alloc_comp
3129 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3130 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3133 tmp
= build_fold_indirect_ref_loc (input_location
,
3135 parm_rank
= e
->rank
;
3143 case (SCALAR_POINTER
):
3144 tmp
= build_fold_indirect_ref_loc (input_location
,
3149 if (e
->expr_type
== EXPR_OP
3150 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3151 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3154 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3155 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3156 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3159 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3161 gfc_add_expr_to_block (&se
->post
, tmp
);
3164 /* Add argument checking of passing an unallocated/NULL actual to
3165 a nonallocatable/nonpointer dummy. */
3167 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3169 symbol_attribute
*attr
;
3173 if (e
->expr_type
== EXPR_VARIABLE
)
3174 attr
= &e
->symtree
->n
.sym
->attr
;
3175 else if (e
->expr_type
== EXPR_FUNCTION
)
3177 /* For intrinsic functions, the gfc_attr are not available. */
3178 if (e
->symtree
->n
.sym
->attr
.generic
&& e
->value
.function
.isym
)
3179 goto end_pointer_check
;
3181 if (e
->symtree
->n
.sym
->attr
.generic
)
3182 attr
= &e
->value
.function
.esym
->attr
;
3184 attr
= &e
->symtree
->n
.sym
->result
->attr
;
3187 goto end_pointer_check
;
3191 /* If the actual argument is an optional pointer/allocatable and
3192 the formal argument takes an nonpointer optional value,
3193 it is invalid to pass a non-present argument on, even
3194 though there is no technical reason for this in gfortran.
3195 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3196 tree present
, nullptr, type
;
3198 if (attr
->allocatable
3199 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3200 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3201 "allocated or not present", e
->symtree
->n
.sym
->name
);
3202 else if (attr
->pointer
3203 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3204 asprintf (&msg
, "Pointer actual argument '%s' is not "
3205 "associated or not present",
3206 e
->symtree
->n
.sym
->name
);
3207 else if (attr
->proc_pointer
3208 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3209 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3210 "associated or not present",
3211 e
->symtree
->n
.sym
->name
);
3213 goto end_pointer_check
;
3215 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3216 type
= TREE_TYPE (present
);
3217 present
= fold_build2 (EQ_EXPR
, boolean_type_node
, present
,
3218 fold_convert (type
, null_pointer_node
));
3219 type
= TREE_TYPE (parmse
.expr
);
3220 nullptr = fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3221 fold_convert (type
, null_pointer_node
));
3222 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
,
3227 if (attr
->allocatable
3228 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3229 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3230 "allocated", e
->symtree
->n
.sym
->name
);
3231 else if (attr
->pointer
3232 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3233 asprintf (&msg
, "Pointer actual argument '%s' is not "
3234 "associated", e
->symtree
->n
.sym
->name
);
3235 else if (attr
->proc_pointer
3236 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3237 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3238 "associated", e
->symtree
->n
.sym
->name
);
3240 goto end_pointer_check
;
3243 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3244 fold_convert (TREE_TYPE (parmse
.expr
),
3245 null_pointer_node
));
3248 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3255 /* Character strings are passed as two parameters, a length and a
3256 pointer - except for Bind(c) which only passes the pointer. */
3257 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3258 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
3260 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
3262 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3269 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3270 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3271 else if (ts
.type
== BT_CHARACTER
)
3273 if (ts
.u
.cl
->length
== NULL
)
3275 /* Assumed character length results are not allowed by 5.1.1.5 of the
3276 standard and are trapped in resolve.c; except in the case of SPREAD
3277 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3278 we take the character length of the first argument for the result.
3279 For dummies, we have to look through the formal argument list for
3280 this function and use the character length found there.*/
3281 if (!sym
->attr
.dummy
)
3282 cl
.backend_decl
= TREE_VALUE (stringargs
);
3285 formal
= sym
->ns
->proc_name
->formal
;
3286 for (; formal
; formal
= formal
->next
)
3287 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3288 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3295 /* Calculate the length of the returned string. */
3296 gfc_init_se (&parmse
, NULL
);
3297 if (need_interface_mapping
)
3298 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3300 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3301 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3302 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3304 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3305 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
3306 build_int_cst (gfc_charlen_type_node
, 0));
3307 cl
.backend_decl
= tmp
;
3310 /* Set up a charlen structure for it. */
3315 len
= cl
.backend_decl
;
3318 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3319 || (!comp
&& gfc_return_by_reference (sym
));
3322 if (se
->direct_byref
)
3324 /* Sometimes, too much indirection can be applied; e.g. for
3325 function_result = array_valued_recursive_function. */
3326 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3327 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3328 && GFC_DESCRIPTOR_TYPE_P
3329 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3330 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3333 result
= build_fold_indirect_ref_loc (input_location
,
3335 retargs
= gfc_chainon_list (retargs
, se
->expr
);
3337 else if (comp
&& comp
->attr
.dimension
)
3339 gcc_assert (se
->loop
&& info
);
3341 /* Set the type of the array. */
3342 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3343 info
->dimen
= se
->loop
->dimen
;
3345 /* Evaluate the bounds of the result, if known. */
3346 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3348 /* Create a temporary to store the result. In case the function
3349 returns a pointer, the temporary will be a shallow copy and
3350 mustn't be deallocated. */
3351 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3352 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3353 NULL_TREE
, false, !comp
->attr
.pointer
,
3354 callee_alloc
, &se
->ss
->expr
->where
);
3356 /* Pass the temporary as the first argument. */
3357 result
= info
->descriptor
;
3358 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3359 retargs
= gfc_chainon_list (retargs
, tmp
);
3361 else if (!comp
&& sym
->result
->attr
.dimension
)
3363 gcc_assert (se
->loop
&& info
);
3365 /* Set the type of the array. */
3366 tmp
= gfc_typenode_for_spec (&ts
);
3367 info
->dimen
= se
->loop
->dimen
;
3369 /* Evaluate the bounds of the result, if known. */
3370 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3372 /* Create a temporary to store the result. In case the function
3373 returns a pointer, the temporary will be a shallow copy and
3374 mustn't be deallocated. */
3375 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3376 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3377 NULL_TREE
, false, !sym
->attr
.pointer
,
3378 callee_alloc
, &se
->ss
->expr
->where
);
3380 /* Pass the temporary as the first argument. */
3381 result
= info
->descriptor
;
3382 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3383 retargs
= gfc_chainon_list (retargs
, tmp
);
3385 else if (ts
.type
== BT_CHARACTER
)
3387 /* Pass the string length. */
3388 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3389 type
= build_pointer_type (type
);
3391 /* Return an address to a char[0:len-1]* temporary for
3392 character pointers. */
3393 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3394 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3396 var
= gfc_create_var (type
, "pstr");
3398 if ((!comp
&& sym
->attr
.allocatable
)
3399 || (comp
&& comp
->attr
.allocatable
))
3400 gfc_add_modify (&se
->pre
, var
,
3401 fold_convert (TREE_TYPE (var
),
3402 null_pointer_node
));
3404 /* Provide an address expression for the function arguments. */
3405 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3408 var
= gfc_conv_string_tmp (se
, type
, len
);
3410 retargs
= gfc_chainon_list (retargs
, var
);
3414 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3416 type
= gfc_get_complex_type (ts
.kind
);
3417 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3418 retargs
= gfc_chainon_list (retargs
, var
);
3421 /* Add the string length to the argument list. */
3422 if (ts
.type
== BT_CHARACTER
)
3423 retargs
= gfc_chainon_list (retargs
, len
);
3425 gfc_free_interface_mapping (&mapping
);
3427 /* Add the return arguments. */
3428 arglist
= chainon (retargs
, arglist
);
3430 /* Add the hidden string length parameters to the arguments. */
3431 arglist
= chainon (arglist
, stringargs
);
3433 /* We may want to append extra arguments here. This is used e.g. for
3434 calls to libgfortran_matmul_??, which need extra information. */
3435 if (append_args
!= NULL_TREE
)
3436 arglist
= chainon (arglist
, append_args
);
3438 /* Generate the actual call. */
3439 conv_function_val (se
, sym
, expr
);
3441 /* If there are alternate return labels, function type should be
3442 integer. Can't modify the type in place though, since it can be shared
3443 with other functions. For dummy arguments, the typing is done to
3444 to this result, even if it has to be repeated for each call. */
3445 if (has_alternate_specifier
3446 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3448 if (!sym
->attr
.dummy
)
3450 TREE_TYPE (sym
->backend_decl
)
3451 = build_function_type (integer_type_node
,
3452 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3453 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3456 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3459 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3460 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
3462 /* If we have a pointer function, but we don't want a pointer, e.g.
3465 where f is pointer valued, we have to dereference the result. */
3466 if (!se
->want_pointer
&& !byref
3467 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3468 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3469 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3472 /* f2c calling conventions require a scalar default real function to
3473 return a double precision result. Convert this back to default
3474 real. We only care about the cases that can happen in Fortran 77.
3476 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3477 && sym
->ts
.kind
== gfc_default_real_kind
3478 && !sym
->attr
.always_explicit
)
3479 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3481 /* A pure function may still have side-effects - it may modify its
3483 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3485 if (!sym
->attr
.pure
)
3486 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3491 /* Add the function call to the pre chain. There is no expression. */
3492 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3493 se
->expr
= NULL_TREE
;
3495 if (!se
->direct_byref
)
3497 if (sym
->attr
.dimension
|| (comp
&& comp
->attr
.dimension
))
3499 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3501 /* Check the data pointer hasn't been modified. This would
3502 happen in a function returning a pointer. */
3503 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3504 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3506 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3509 se
->expr
= info
->descriptor
;
3510 /* Bundle in the string length. */
3511 se
->string_length
= len
;
3513 else if (ts
.type
== BT_CHARACTER
)
3515 /* Dereference for character pointer results. */
3516 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3517 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3518 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3522 se
->string_length
= len
;
3526 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3527 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3532 /* Follow the function call with the argument post block. */
3535 gfc_add_block_to_block (&se
->pre
, &post
);
3537 /* Transformational functions of derived types with allocatable
3538 components must have the result allocatable components copied. */
3539 arg
= expr
->value
.function
.actual
;
3540 if (result
&& arg
&& expr
->rank
3541 && expr
->value
.function
.isym
3542 && expr
->value
.function
.isym
->transformational
3543 && arg
->expr
->ts
.type
== BT_DERIVED
3544 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3547 /* Copy the allocatable components. We have to use a
3548 temporary here to prevent source allocatable components
3549 from being corrupted. */
3550 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3551 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3552 result
, tmp2
, expr
->rank
);
3553 gfc_add_expr_to_block (&se
->pre
, tmp
);
3554 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3556 gfc_add_expr_to_block (&se
->pre
, tmp
);
3558 /* Finally free the temporary's data field. */
3559 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3560 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3561 gfc_add_expr_to_block (&se
->pre
, tmp
);
3565 gfc_add_block_to_block (&se
->post
, &post
);
3567 return has_alternate_specifier
;
3571 /* Fill a character string with spaces. */
3574 fill_with_spaces (tree start
, tree type
, tree size
)
3576 stmtblock_t block
, loop
;
3577 tree i
, el
, exit_label
, cond
, tmp
;
3579 /* For a simple char type, we can call memset(). */
3580 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3581 return build_call_expr_loc (input_location
,
3582 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3583 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3584 lang_hooks
.to_target_charset (' ')),
3587 /* Otherwise, we use a loop:
3588 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3592 /* Initialize variables. */
3593 gfc_init_block (&block
);
3594 i
= gfc_create_var (sizetype
, "i");
3595 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3596 el
= gfc_create_var (build_pointer_type (type
), "el");
3597 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3598 exit_label
= gfc_build_label_decl (NULL_TREE
);
3599 TREE_USED (exit_label
) = 1;
3603 gfc_init_block (&loop
);
3605 /* Exit condition. */
3606 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3607 fold_convert (sizetype
, integer_zero_node
));
3608 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3609 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3610 build_empty_stmt (input_location
));
3611 gfc_add_expr_to_block (&loop
, tmp
);
3614 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3615 build_int_cst (type
,
3616 lang_hooks
.to_target_charset (' ')));
3618 /* Increment loop variables. */
3619 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3620 TYPE_SIZE_UNIT (type
)));
3621 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3623 TYPE_SIZE_UNIT (type
)));
3625 /* Making the loop... actually loop! */
3626 tmp
= gfc_finish_block (&loop
);
3627 tmp
= build1_v (LOOP_EXPR
, tmp
);
3628 gfc_add_expr_to_block (&block
, tmp
);
3630 /* The exit label. */
3631 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3632 gfc_add_expr_to_block (&block
, tmp
);
3635 return gfc_finish_block (&block
);
3639 /* Generate code to copy a string. */
3642 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3643 int dkind
, tree slength
, tree src
, int skind
)
3645 tree tmp
, dlen
, slen
;
3654 stmtblock_t tempblock
;
3656 gcc_assert (dkind
== skind
);
3658 if (slength
!= NULL_TREE
)
3660 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3661 ssc
= string_to_single_character (slen
, src
, skind
);
3665 slen
= build_int_cst (size_type_node
, 1);
3669 if (dlength
!= NULL_TREE
)
3671 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3672 dsc
= string_to_single_character (slen
, dest
, dkind
);
3676 dlen
= build_int_cst (size_type_node
, 1);
3680 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3681 ssc
= string_to_single_character (slen
, src
, skind
);
3682 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3683 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3686 /* Assign directly if the types are compatible. */
3687 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3688 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3690 gfc_add_modify (block
, dsc
, ssc
);
3694 /* Do nothing if the destination length is zero. */
3695 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3696 build_int_cst (size_type_node
, 0));
3698 /* The following code was previously in _gfortran_copy_string:
3700 // The two strings may overlap so we use memmove.
3702 copy_string (GFC_INTEGER_4 destlen, char * dest,
3703 GFC_INTEGER_4 srclen, const char * src)
3705 if (srclen >= destlen)
3707 // This will truncate if too long.
3708 memmove (dest, src, destlen);
3712 memmove (dest, src, srclen);
3714 memset (&dest[srclen], ' ', destlen - srclen);
3718 We're now doing it here for better optimization, but the logic
3721 /* For non-default character kinds, we have to multiply the string
3722 length by the base type size. */
3723 chartype
= gfc_get_char_type (dkind
);
3724 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3725 fold_convert (size_type_node
, slen
),
3726 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3727 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3728 fold_convert (size_type_node
, dlen
),
3729 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3732 dest
= fold_convert (pvoid_type_node
, dest
);
3734 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3737 src
= fold_convert (pvoid_type_node
, src
);
3739 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3741 /* Truncate string if source is too long. */
3742 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3743 tmp2
= build_call_expr_loc (input_location
,
3744 built_in_decls
[BUILT_IN_MEMMOVE
],
3745 3, dest
, src
, dlen
);
3747 /* Else copy and pad with spaces. */
3748 tmp3
= build_call_expr_loc (input_location
,
3749 built_in_decls
[BUILT_IN_MEMMOVE
],
3750 3, dest
, src
, slen
);
3752 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3753 fold_convert (sizetype
, slen
));
3754 tmp4
= fill_with_spaces (tmp4
, chartype
,
3755 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3758 gfc_init_block (&tempblock
);
3759 gfc_add_expr_to_block (&tempblock
, tmp3
);
3760 gfc_add_expr_to_block (&tempblock
, tmp4
);
3761 tmp3
= gfc_finish_block (&tempblock
);
3763 /* The whole copy_string function is there. */
3764 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3765 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3766 build_empty_stmt (input_location
));
3767 gfc_add_expr_to_block (block
, tmp
);
3771 /* Translate a statement function.
3772 The value of a statement function reference is obtained by evaluating the
3773 expression using the values of the actual arguments for the values of the
3774 corresponding dummy arguments. */
3777 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3781 gfc_formal_arglist
*fargs
;
3782 gfc_actual_arglist
*args
;
3785 gfc_saved_var
*saved_vars
;
3791 sym
= expr
->symtree
->n
.sym
;
3792 args
= expr
->value
.function
.actual
;
3793 gfc_init_se (&lse
, NULL
);
3794 gfc_init_se (&rse
, NULL
);
3797 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3799 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3800 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3802 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3804 /* Each dummy shall be specified, explicitly or implicitly, to be
3806 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3809 /* Create a temporary to hold the value. */
3810 type
= gfc_typenode_for_spec (&fsym
->ts
);
3811 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3813 if (fsym
->ts
.type
== BT_CHARACTER
)
3815 /* Copy string arguments. */
3818 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3819 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3821 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3822 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3825 gfc_conv_expr (&rse
, args
->expr
);
3826 gfc_conv_string_parameter (&rse
);
3827 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3828 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3830 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3831 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3832 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3833 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3837 /* For everything else, just evaluate the expression. */
3838 gfc_conv_expr (&lse
, args
->expr
);
3840 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3841 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3842 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3848 /* Use the temporary variables in place of the real ones. */
3849 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3850 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3852 gfc_conv_expr (se
, sym
->value
);
3854 if (sym
->ts
.type
== BT_CHARACTER
)
3856 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3858 /* Force the expression to the correct length. */
3859 if (!INTEGER_CST_P (se
->string_length
)
3860 || tree_int_cst_lt (se
->string_length
,
3861 sym
->ts
.u
.cl
->backend_decl
))
3863 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3864 tmp
= gfc_create_var (type
, sym
->name
);
3865 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3866 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3867 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3871 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3874 /* Restore the original variables. */
3875 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3876 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3877 gfc_free (saved_vars
);
3881 /* Translate a function expression. */
3884 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3888 if (expr
->value
.function
.isym
)
3890 gfc_conv_intrinsic_function (se
, expr
);
3894 /* We distinguish statement functions from general functions to improve
3895 runtime performance. */
3896 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3898 gfc_conv_statement_function (se
, expr
);
3902 /* expr.value.function.esym is the resolved (specific) function symbol for
3903 most functions. However this isn't set for dummy procedures. */
3904 sym
= expr
->value
.function
.esym
;
3906 sym
= expr
->symtree
->n
.sym
;
3908 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3914 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3916 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3917 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3919 gfc_conv_tmp_array_ref (se
);
3920 gfc_advance_se_ss_chain (se
);
3924 /* Build a static initializer. EXPR is the expression for the initial value.
3925 The other parameters describe the variable of the component being
3926 initialized. EXPR may be null. */
3929 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3930 bool array
, bool pointer
)
3934 if (!(expr
|| pointer
))
3937 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3938 (these are the only two iso_c_binding derived types that can be
3939 used as initialization expressions). If so, we need to modify
3940 the 'expr' to be that for a (void *). */
3941 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3942 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
3944 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
3946 expr
= gfc_int_expr (0);
3948 /* The derived symbol has already been converted to a (void *). Use
3950 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3951 expr
->ts
.kind
= derived
->ts
.kind
;
3956 /* Arrays need special handling. */
3958 return gfc_build_null_descriptor (type
);
3960 return gfc_conv_array_initializer (type
, expr
);
3963 return fold_convert (type
, null_pointer_node
);
3970 gfc_init_se (&se
, NULL
);
3971 gfc_conv_structure (&se
, expr
, 1);
3975 return gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
3978 gfc_init_se (&se
, NULL
);
3979 gfc_conv_constant (&se
, expr
);
3986 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3998 gfc_start_block (&block
);
4000 /* Initialize the scalarizer. */
4001 gfc_init_loopinfo (&loop
);
4003 gfc_init_se (&lse
, NULL
);
4004 gfc_init_se (&rse
, NULL
);
4007 rss
= gfc_walk_expr (expr
);
4008 if (rss
== gfc_ss_terminator
)
4010 /* The rhs is scalar. Add a ss for the expression. */
4011 rss
= gfc_get_ss ();
4012 rss
->next
= gfc_ss_terminator
;
4013 rss
->type
= GFC_SS_SCALAR
;
4017 /* Create a SS for the destination. */
4018 lss
= gfc_get_ss ();
4019 lss
->type
= GFC_SS_COMPONENT
;
4021 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
4022 lss
->next
= gfc_ss_terminator
;
4023 lss
->data
.info
.dimen
= cm
->as
->rank
;
4024 lss
->data
.info
.descriptor
= dest
;
4025 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
4026 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
4027 for (n
= 0; n
< cm
->as
->rank
; n
++)
4029 lss
->data
.info
.dim
[n
] = n
;
4030 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
4031 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
4033 mpz_init (lss
->shape
[n
]);
4034 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
4035 cm
->as
->lower
[n
]->value
.integer
);
4036 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
4039 /* Associate the SS with the loop. */
4040 gfc_add_ss_to_loop (&loop
, lss
);
4041 gfc_add_ss_to_loop (&loop
, rss
);
4043 /* Calculate the bounds of the scalarization. */
4044 gfc_conv_ss_startstride (&loop
);
4046 /* Setup the scalarizing loops. */
4047 gfc_conv_loop_setup (&loop
, &expr
->where
);
4049 /* Setup the gfc_se structures. */
4050 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4051 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4054 gfc_mark_ss_chain_used (rss
, 1);
4056 gfc_mark_ss_chain_used (lss
, 1);
4058 /* Start the scalarized loop body. */
4059 gfc_start_scalarized_body (&loop
, &body
);
4061 gfc_conv_tmp_array_ref (&lse
);
4062 if (cm
->ts
.type
== BT_CHARACTER
)
4063 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4065 gfc_conv_expr (&rse
, expr
);
4067 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
4068 gfc_add_expr_to_block (&body
, tmp
);
4070 gcc_assert (rse
.ss
== gfc_ss_terminator
);
4072 /* Generate the copying loops. */
4073 gfc_trans_scalarizing_loops (&loop
, &body
);
4075 /* Wrap the whole thing up. */
4076 gfc_add_block_to_block (&block
, &loop
.pre
);
4077 gfc_add_block_to_block (&block
, &loop
.post
);
4079 for (n
= 0; n
< cm
->as
->rank
; n
++)
4080 mpz_clear (lss
->shape
[n
]);
4081 gfc_free (lss
->shape
);
4083 gfc_cleanup_loop (&loop
);
4085 return gfc_finish_block (&block
);
4090 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4101 gfc_expr
*arg
= NULL
;
4103 gfc_start_block (&block
);
4104 gfc_init_se (&se
, NULL
);
4106 /* Get the descriptor for the expressions. */
4107 rss
= gfc_walk_expr (expr
);
4108 se
.want_pointer
= 0;
4109 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4110 gfc_add_block_to_block (&block
, &se
.pre
);
4111 gfc_add_modify (&block
, dest
, se
.expr
);
4113 /* Deal with arrays of derived types with allocatable components. */
4114 if (cm
->ts
.type
== BT_DERIVED
4115 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4116 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4120 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4121 TREE_TYPE(cm
->backend_decl
),
4124 gfc_add_expr_to_block (&block
, tmp
);
4125 gfc_add_block_to_block (&block
, &se
.post
);
4127 if (expr
->expr_type
!= EXPR_VARIABLE
)
4128 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4131 /* We need to know if the argument of a conversion function is a
4132 variable, so that the correct lower bound can be used. */
4133 if (expr
->expr_type
== EXPR_FUNCTION
4134 && expr
->value
.function
.isym
4135 && expr
->value
.function
.isym
->conversion
4136 && expr
->value
.function
.actual
->expr
4137 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4138 arg
= expr
->value
.function
.actual
->expr
;
4140 /* Obtain the array spec of full array references. */
4142 as
= gfc_get_full_arrayspec_from_expr (arg
);
4144 as
= gfc_get_full_arrayspec_from_expr (expr
);
4146 /* Shift the lbound and ubound of temporaries to being unity,
4147 rather than zero, based. Always calculate the offset. */
4148 offset
= gfc_conv_descriptor_offset_get (dest
);
4149 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4150 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4152 for (n
= 0; n
< expr
->rank
; n
++)
4157 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4158 TODO It looks as if gfc_conv_expr_descriptor should return
4159 the correct bounds and that the following should not be
4160 necessary. This would simplify gfc_conv_intrinsic_bound
4162 if (as
&& as
->lower
[n
])
4165 gfc_init_se (&lbse
, NULL
);
4166 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4167 gfc_add_block_to_block (&block
, &lbse
.pre
);
4168 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4172 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4173 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4177 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4180 lbound
= gfc_index_one_node
;
4182 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4184 /* Shift the bounds and set the offset accordingly. */
4185 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4186 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
4187 gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4188 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, span
, lbound
);
4189 gfc_conv_descriptor_ubound_set (&block
, dest
,
4190 gfc_rank_cst
[n
], tmp
);
4191 gfc_conv_descriptor_lbound_set (&block
, dest
,
4192 gfc_rank_cst
[n
], lbound
);
4194 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4195 gfc_conv_descriptor_lbound_get (dest
,
4197 gfc_conv_descriptor_stride_get (dest
,
4199 gfc_add_modify (&block
, tmp2
, tmp
);
4200 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
4201 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4206 /* If a conversion expression has a null data pointer
4207 argument, nullify the allocatable component. */
4211 if (arg
->symtree
->n
.sym
->attr
.allocatable
4212 || arg
->symtree
->n
.sym
->attr
.pointer
)
4214 non_null_expr
= gfc_finish_block (&block
);
4215 gfc_start_block (&block
);
4216 gfc_conv_descriptor_data_set (&block
, dest
,
4218 null_expr
= gfc_finish_block (&block
);
4219 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4220 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
4221 fold_convert (TREE_TYPE (tmp
),
4222 null_pointer_node
));
4223 return build3_v (COND_EXPR
, tmp
,
4224 null_expr
, non_null_expr
);
4228 return gfc_finish_block (&block
);
4232 /* Assign a single component of a derived type constructor. */
4235 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4243 gfc_start_block (&block
);
4245 if (cm
->attr
.pointer
)
4247 gfc_init_se (&se
, NULL
);
4248 /* Pointer component. */
4249 if (cm
->attr
.dimension
)
4251 /* Array pointer. */
4252 if (expr
->expr_type
== EXPR_NULL
)
4253 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4256 rss
= gfc_walk_expr (expr
);
4257 se
.direct_byref
= 1;
4259 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4260 gfc_add_block_to_block (&block
, &se
.pre
);
4261 gfc_add_block_to_block (&block
, &se
.post
);
4266 /* Scalar pointers. */
4267 se
.want_pointer
= 1;
4268 gfc_conv_expr (&se
, expr
);
4269 gfc_add_block_to_block (&block
, &se
.pre
);
4270 gfc_add_modify (&block
, dest
,
4271 fold_convert (TREE_TYPE (dest
), se
.expr
));
4272 gfc_add_block_to_block (&block
, &se
.post
);
4275 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4277 /* NULL initialization for CLASS components. */
4278 tmp
= gfc_trans_structure_assign (dest
,
4279 gfc_default_initializer (&cm
->ts
));
4280 gfc_add_expr_to_block (&block
, tmp
);
4282 else if (cm
->attr
.dimension
)
4284 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4285 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4286 else if (cm
->attr
.allocatable
)
4288 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4289 gfc_add_expr_to_block (&block
, tmp
);
4293 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4294 gfc_add_expr_to_block (&block
, tmp
);
4297 else if (expr
->ts
.type
== BT_DERIVED
)
4299 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4301 gfc_init_se (&se
, NULL
);
4302 gfc_conv_expr (&se
, expr
);
4303 gfc_add_block_to_block (&block
, &se
.pre
);
4304 gfc_add_modify (&block
, dest
,
4305 fold_convert (TREE_TYPE (dest
), se
.expr
));
4306 gfc_add_block_to_block (&block
, &se
.post
);
4310 /* Nested constructors. */
4311 tmp
= gfc_trans_structure_assign (dest
, expr
);
4312 gfc_add_expr_to_block (&block
, tmp
);
4317 /* Scalar component. */
4318 gfc_init_se (&se
, NULL
);
4319 gfc_init_se (&lse
, NULL
);
4321 gfc_conv_expr (&se
, expr
);
4322 if (cm
->ts
.type
== BT_CHARACTER
)
4323 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4325 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
4326 gfc_add_expr_to_block (&block
, tmp
);
4328 return gfc_finish_block (&block
);
4331 /* Assign a derived type constructor to a variable. */
4334 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4342 gfc_start_block (&block
);
4343 cm
= expr
->ts
.u
.derived
->components
;
4344 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
4346 /* Skip absent members in default initializers. */
4350 /* Handle c_null_(fun)ptr. */
4351 if (c
&& c
->expr
&& c
->expr
->ts
.is_iso_c
)
4353 field
= cm
->backend_decl
;
4354 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4355 dest
, field
, NULL_TREE
);
4356 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
), tmp
,
4357 fold_convert (TREE_TYPE (tmp
),
4358 null_pointer_node
));
4359 gfc_add_expr_to_block (&block
, tmp
);
4363 field
= cm
->backend_decl
;
4364 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4365 dest
, field
, NULL_TREE
);
4366 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4367 gfc_add_expr_to_block (&block
, tmp
);
4369 return gfc_finish_block (&block
);
4372 /* Build an expression for a constructor. If init is nonzero then
4373 this is part of a static variable initializer. */
4376 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4383 VEC(constructor_elt
,gc
) *v
= NULL
;
4385 gcc_assert (se
->ss
== NULL
);
4386 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4387 type
= gfc_typenode_for_spec (&expr
->ts
);
4391 /* Create a temporary variable and fill it in. */
4392 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4393 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4394 gfc_add_expr_to_block (&se
->pre
, tmp
);
4398 cm
= expr
->ts
.u
.derived
->components
;
4400 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
4402 /* Skip absent members in default initializers and allocatable
4403 components. Although the latter have a default initializer
4404 of EXPR_NULL,... by default, the static nullify is not needed
4405 since this is done every time we come into scope. */
4406 if (!c
->expr
|| cm
->attr
.allocatable
)
4409 if (cm
->ts
.type
== BT_CLASS
)
4411 gfc_component
*data
;
4412 data
= gfc_find_component (cm
->ts
.u
.derived
, "$data", true, true);
4413 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4414 TREE_TYPE (data
->backend_decl
),
4415 data
->attr
.dimension
,
4416 data
->attr
.pointer
);
4418 CONSTRUCTOR_APPEND_ELT (v
, data
->backend_decl
, val
);
4420 else if (strcmp (cm
->name
, "$size") == 0)
4422 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4423 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4425 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4426 && strcmp (cm
->name
, "$extends") == 0)
4429 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4430 val
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4431 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4435 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4436 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
,
4437 cm
->attr
.pointer
|| cm
->attr
.proc_pointer
);
4439 /* Append it to the constructor list. */
4440 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4443 se
->expr
= build_constructor (type
, v
);
4445 TREE_CONSTANT (se
->expr
) = 1;
4449 /* Translate a substring expression. */
4452 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4458 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4460 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4461 expr
->value
.character
.length
,
4462 expr
->value
.character
.string
);
4464 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4465 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4468 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4472 /* Entry point for expression translation. Evaluates a scalar quantity.
4473 EXPR is the expression to be translated, and SE is the state structure if
4474 called from within the scalarized. */
4477 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4479 if (se
->ss
&& se
->ss
->expr
== expr
4480 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4482 /* Substitute a scalar expression evaluated outside the scalarization
4484 se
->expr
= se
->ss
->data
.scalar
.expr
;
4485 se
->string_length
= se
->ss
->string_length
;
4486 gfc_advance_se_ss_chain (se
);
4490 /* We need to convert the expressions for the iso_c_binding derived types.
4491 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4492 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4493 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4494 updated to be an integer with a kind equal to the size of a (void *). */
4495 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4496 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4498 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4499 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4501 /* Set expr_type to EXPR_NULL, which will result in
4502 null_pointer_node being used below. */
4503 expr
->expr_type
= EXPR_NULL
;
4507 /* Update the type/kind of the expression to be what the new
4508 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4509 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4510 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4511 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4515 switch (expr
->expr_type
)
4518 gfc_conv_expr_op (se
, expr
);
4522 gfc_conv_function_expr (se
, expr
);
4526 gfc_conv_constant (se
, expr
);
4530 gfc_conv_variable (se
, expr
);
4534 se
->expr
= null_pointer_node
;
4537 case EXPR_SUBSTRING
:
4538 gfc_conv_substring_expr (se
, expr
);
4541 case EXPR_STRUCTURE
:
4542 gfc_conv_structure (se
, expr
, 0);
4546 gfc_conv_array_constructor_expr (se
, expr
);
4555 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4556 of an assignment. */
4558 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4560 gfc_conv_expr (se
, expr
);
4561 /* All numeric lvalues should have empty post chains. If not we need to
4562 figure out a way of rewriting an lvalue so that it has no post chain. */
4563 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4566 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4567 numeric expressions. Used for scalar values where inserting cleanup code
4570 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4574 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4575 gfc_conv_expr (se
, expr
);
4578 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4579 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4581 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4585 /* Helper to translate an expression and convert it to a particular type. */
4587 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4589 gfc_conv_expr_val (se
, expr
);
4590 se
->expr
= convert (type
, se
->expr
);
4594 /* Converts an expression so that it can be passed by reference. Scalar
4598 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4602 if (se
->ss
&& se
->ss
->expr
== expr
4603 && se
->ss
->type
== GFC_SS_REFERENCE
)
4605 se
->expr
= se
->ss
->data
.scalar
.expr
;
4606 se
->string_length
= se
->ss
->string_length
;
4607 gfc_advance_se_ss_chain (se
);
4611 if (expr
->ts
.type
== BT_CHARACTER
)
4613 gfc_conv_expr (se
, expr
);
4614 gfc_conv_string_parameter (se
);
4618 if (expr
->expr_type
== EXPR_VARIABLE
)
4620 se
->want_pointer
= 1;
4621 gfc_conv_expr (se
, expr
);
4624 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4625 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4626 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4632 if (expr
->expr_type
== EXPR_FUNCTION
4633 && ((expr
->value
.function
.esym
4634 && expr
->value
.function
.esym
->result
->attr
.pointer
4635 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4636 || (!expr
->value
.function
.esym
4637 && expr
->symtree
->n
.sym
->attr
.pointer
4638 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4640 se
->want_pointer
= 1;
4641 gfc_conv_expr (se
, expr
);
4642 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4643 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4649 gfc_conv_expr (se
, expr
);
4651 /* Create a temporary var to hold the value. */
4652 if (TREE_CONSTANT (se
->expr
))
4654 tree tmp
= se
->expr
;
4655 STRIP_TYPE_NOPS (tmp
);
4656 var
= build_decl (input_location
,
4657 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4658 DECL_INITIAL (var
) = tmp
;
4659 TREE_STATIC (var
) = 1;
4664 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4665 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4667 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4669 /* Take the address of that value. */
4670 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4675 gfc_trans_pointer_assign (gfc_code
* code
)
4677 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4681 /* Generate code for a pointer assignment. */
4684 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4695 gfc_start_block (&block
);
4697 gfc_init_se (&lse
, NULL
);
4699 lss
= gfc_walk_expr (expr1
);
4700 rss
= gfc_walk_expr (expr2
);
4701 if (lss
== gfc_ss_terminator
)
4703 /* Scalar pointers. */
4704 lse
.want_pointer
= 1;
4705 gfc_conv_expr (&lse
, expr1
);
4706 gcc_assert (rss
== gfc_ss_terminator
);
4707 gfc_init_se (&rse
, NULL
);
4708 rse
.want_pointer
= 1;
4709 gfc_conv_expr (&rse
, expr2
);
4711 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4712 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4713 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4716 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4717 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4718 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4721 gfc_add_block_to_block (&block
, &lse
.pre
);
4722 gfc_add_block_to_block (&block
, &rse
.pre
);
4724 /* Check character lengths if character expression. The test is only
4725 really added if -fbounds-check is enabled. */
4726 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4727 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4728 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4730 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4731 gcc_assert (lse
.string_length
&& rse
.string_length
);
4732 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4733 lse
.string_length
, rse
.string_length
,
4737 gfc_add_modify (&block
, lse
.expr
,
4738 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4740 gfc_add_block_to_block (&block
, &rse
.post
);
4741 gfc_add_block_to_block (&block
, &lse
.post
);
4746 tree strlen_rhs
= NULL_TREE
;
4748 /* Array pointer. */
4749 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4750 strlen_lhs
= lse
.string_length
;
4751 switch (expr2
->expr_type
)
4754 /* Just set the data pointer to null. */
4755 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4759 /* Assign directly to the pointer's descriptor. */
4760 lse
.direct_byref
= 1;
4761 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4762 strlen_rhs
= lse
.string_length
;
4764 /* If this is a subreference array pointer assignment, use the rhs
4765 descriptor element size for the lhs span. */
4766 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4768 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4769 gfc_init_se (&rse
, NULL
);
4770 rse
.descriptor_only
= 1;
4771 gfc_conv_expr (&rse
, expr2
);
4772 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4773 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4774 if (!INTEGER_CST_P (tmp
))
4775 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4776 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4782 /* Assign to a temporary descriptor and then copy that
4783 temporary to the pointer. */
4785 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4788 lse
.direct_byref
= 1;
4789 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4790 strlen_rhs
= lse
.string_length
;
4791 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4795 gfc_add_block_to_block (&block
, &lse
.pre
);
4797 /* Check string lengths if applicable. The check is only really added
4798 to the output code if -fbounds-check is enabled. */
4799 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4801 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4802 gcc_assert (strlen_lhs
&& strlen_rhs
);
4803 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4804 strlen_lhs
, strlen_rhs
, &block
);
4807 gfc_add_block_to_block (&block
, &lse
.post
);
4809 return gfc_finish_block (&block
);
4813 /* Makes sure se is suitable for passing as a function string parameter. */
4814 /* TODO: Need to check all callers of this function. It may be abused. */
4817 gfc_conv_string_parameter (gfc_se
* se
)
4821 if (TREE_CODE (se
->expr
) == STRING_CST
)
4823 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4824 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4828 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4830 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4832 type
= TREE_TYPE (se
->expr
);
4833 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4837 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4839 type
= build_pointer_type (type
);
4840 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4844 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4845 gcc_assert (se
->string_length
4846 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4850 /* Generate code for assignment of scalar variables. Includes character
4851 strings and derived types with allocatable components. */
4854 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4855 bool l_is_temp
, bool r_is_var
)
4861 gfc_init_block (&block
);
4863 if (ts
.type
== BT_CHARACTER
)
4868 if (lse
->string_length
!= NULL_TREE
)
4870 gfc_conv_string_parameter (lse
);
4871 gfc_add_block_to_block (&block
, &lse
->pre
);
4872 llen
= lse
->string_length
;
4875 if (rse
->string_length
!= NULL_TREE
)
4877 gcc_assert (rse
->string_length
!= NULL_TREE
);
4878 gfc_conv_string_parameter (rse
);
4879 gfc_add_block_to_block (&block
, &rse
->pre
);
4880 rlen
= rse
->string_length
;
4883 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4884 rse
->expr
, ts
.kind
);
4886 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
4890 /* Are the rhs and the lhs the same? */
4893 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4894 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
4895 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
4896 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4899 /* Deallocate the lhs allocated components as long as it is not
4900 the same as the rhs. This must be done following the assignment
4901 to prevent deallocating data that could be used in the rhs
4905 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4906 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
4908 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4910 gfc_add_expr_to_block (&lse
->post
, tmp
);
4913 gfc_add_block_to_block (&block
, &rse
->pre
);
4914 gfc_add_block_to_block (&block
, &lse
->pre
);
4916 gfc_add_modify (&block
, lse
->expr
,
4917 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4919 /* Do a deep copy if the rhs is a variable, if it is not the
4923 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
4924 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4926 gfc_add_expr_to_block (&block
, tmp
);
4929 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
4931 gfc_add_block_to_block (&block
, &lse
->pre
);
4932 gfc_add_block_to_block (&block
, &rse
->pre
);
4933 tmp
= fold_build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (lse
->expr
), rse
->expr
);
4934 gfc_add_modify (&block
, lse
->expr
, tmp
);
4938 gfc_add_block_to_block (&block
, &lse
->pre
);
4939 gfc_add_block_to_block (&block
, &rse
->pre
);
4941 gfc_add_modify (&block
, lse
->expr
,
4942 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4945 gfc_add_block_to_block (&block
, &lse
->post
);
4946 gfc_add_block_to_block (&block
, &rse
->post
);
4948 return gfc_finish_block (&block
);
4952 /* Try to translate array(:) = func (...), where func is a transformational
4953 array function, without using a temporary. Returns NULL is this isn't the
4957 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4962 bool seen_array_ref
;
4964 gfc_component
*comp
= NULL
;
4966 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4967 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4970 /* Elemental functions don't need a temporary anyway. */
4971 if (expr2
->value
.function
.esym
!= NULL
4972 && expr2
->value
.function
.esym
->attr
.elemental
)
4975 /* Fail if rhs is not FULL or a contiguous section. */
4976 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
4979 /* Fail if EXPR1 can't be expressed as a descriptor. */
4980 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4983 /* Functions returning pointers need temporaries. */
4984 if (expr2
->symtree
->n
.sym
->attr
.pointer
4985 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4988 /* Character array functions need temporaries unless the
4989 character lengths are the same. */
4990 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4992 if (expr1
->ts
.u
.cl
->length
== NULL
4993 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4996 if (expr2
->ts
.u
.cl
->length
== NULL
4997 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5000 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
5001 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
5005 /* Check that no LHS component references appear during an array
5006 reference. This is needed because we do not have the means to
5007 span any arbitrary stride with an array descriptor. This check
5008 is not needed for the rhs because the function result has to be
5010 seen_array_ref
= false;
5011 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
5013 if (ref
->type
== REF_ARRAY
)
5014 seen_array_ref
= true;
5015 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
5019 /* Check for a dependency. */
5020 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
5021 expr2
->value
.function
.esym
,
5022 expr2
->value
.function
.actual
,
5026 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5028 gcc_assert (expr2
->value
.function
.isym
5029 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5030 && comp
&& comp
->attr
.dimension
)
5031 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5032 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5034 ss
= gfc_walk_expr (expr1
);
5035 gcc_assert (ss
!= gfc_ss_terminator
);
5036 gfc_init_se (&se
, NULL
);
5037 gfc_start_block (&se
.pre
);
5038 se
.want_pointer
= 1;
5040 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5042 if (expr1
->ts
.type
== BT_DERIVED
5043 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5046 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5048 gfc_add_expr_to_block (&se
.pre
, tmp
);
5051 se
.direct_byref
= 1;
5052 se
.ss
= gfc_walk_expr (expr2
);
5053 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5054 gfc_conv_function_expr (&se
, expr2
);
5055 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5057 return gfc_finish_block (&se
.pre
);
5060 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
5063 is_zero_initializer_p (gfc_expr
* expr
)
5065 if (expr
->expr_type
!= EXPR_CONSTANT
)
5068 /* We ignore constants with prescribed memory representations for now. */
5069 if (expr
->representation
.string
)
5072 switch (expr
->ts
.type
)
5075 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
5078 return mpfr_zero_p (expr
->value
.real
)
5079 && MPFR_SIGN (expr
->value
.real
) >= 0;
5082 return expr
->value
.logical
== 0;
5085 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
5086 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
5087 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
5088 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
5096 /* Try to efficiently translate array(:) = 0. Return NULL if this
5100 gfc_trans_zero_assign (gfc_expr
* expr
)
5102 tree dest
, len
, type
;
5106 sym
= expr
->symtree
->n
.sym
;
5107 dest
= gfc_get_symbol_decl (sym
);
5109 type
= TREE_TYPE (dest
);
5110 if (POINTER_TYPE_P (type
))
5111 type
= TREE_TYPE (type
);
5112 if (!GFC_ARRAY_TYPE_P (type
))
5115 /* Determine the length of the array. */
5116 len
= GFC_TYPE_ARRAY_SIZE (type
);
5117 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5120 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5121 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5122 fold_convert (gfc_array_index_type
, tmp
));
5124 /* If we are zeroing a local array avoid taking its address by emitting
5126 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5127 return build2 (MODIFY_EXPR
, void_type_node
,
5128 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5130 /* Convert arguments to the correct types. */
5131 dest
= fold_convert (pvoid_type_node
, dest
);
5132 len
= fold_convert (size_type_node
, len
);
5134 /* Construct call to __builtin_memset. */
5135 tmp
= build_call_expr_loc (input_location
,
5136 built_in_decls
[BUILT_IN_MEMSET
],
5137 3, dest
, integer_zero_node
, len
);
5138 return fold_convert (void_type_node
, tmp
);
5142 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5143 that constructs the call to __builtin_memcpy. */
5146 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5150 /* Convert arguments to the correct types. */
5151 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5152 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5154 dst
= fold_convert (pvoid_type_node
, dst
);
5156 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5157 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5159 src
= fold_convert (pvoid_type_node
, src
);
5161 len
= fold_convert (size_type_node
, len
);
5163 /* Construct call to __builtin_memcpy. */
5164 tmp
= build_call_expr_loc (input_location
,
5165 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5166 return fold_convert (void_type_node
, tmp
);
5170 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5171 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5172 source/rhs, both are gfc_full_array_ref_p which have been checked for
5176 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5178 tree dst
, dlen
, dtype
;
5179 tree src
, slen
, stype
;
5182 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5183 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5185 dtype
= TREE_TYPE (dst
);
5186 if (POINTER_TYPE_P (dtype
))
5187 dtype
= TREE_TYPE (dtype
);
5188 stype
= TREE_TYPE (src
);
5189 if (POINTER_TYPE_P (stype
))
5190 stype
= TREE_TYPE (stype
);
5192 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5195 /* Determine the lengths of the arrays. */
5196 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5197 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5199 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5200 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
5201 fold_convert (gfc_array_index_type
, tmp
));
5203 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5204 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5206 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5207 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
5208 fold_convert (gfc_array_index_type
, tmp
));
5210 /* Sanity check that they are the same. This should always be
5211 the case, as we should already have checked for conformance. */
5212 if (!tree_int_cst_equal (slen
, dlen
))
5215 return gfc_build_memcpy_call (dst
, src
, dlen
);
5219 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5220 this can't be done. EXPR1 is the destination/lhs for which
5221 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5224 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5226 unsigned HOST_WIDE_INT nelem
;
5232 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5236 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5237 dtype
= TREE_TYPE (dst
);
5238 if (POINTER_TYPE_P (dtype
))
5239 dtype
= TREE_TYPE (dtype
);
5240 if (!GFC_ARRAY_TYPE_P (dtype
))
5243 /* Determine the lengths of the array. */
5244 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5245 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5248 /* Confirm that the constructor is the same size. */
5249 if (compare_tree_int (len
, nelem
) != 0)
5252 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5253 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5254 fold_convert (gfc_array_index_type
, tmp
));
5256 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5257 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5259 stype
= TREE_TYPE (src
);
5260 if (POINTER_TYPE_P (stype
))
5261 stype
= TREE_TYPE (stype
);
5263 return gfc_build_memcpy_call (dst
, src
, len
);
5267 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5268 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
5271 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
5276 gfc_ss
*lss_section
;
5283 bool scalar_to_array
;
5286 /* Assignment of the form lhs = rhs. */
5287 gfc_start_block (&block
);
5289 gfc_init_se (&lse
, NULL
);
5290 gfc_init_se (&rse
, NULL
);
5293 lss
= gfc_walk_expr (expr1
);
5295 if (lss
!= gfc_ss_terminator
)
5297 /* Allow the scalarizer to workshare array assignments. */
5298 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5299 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5301 /* The assignment needs scalarization. */
5304 /* Find a non-scalar SS from the lhs. */
5305 while (lss_section
!= gfc_ss_terminator
5306 && lss_section
->type
!= GFC_SS_SECTION
)
5307 lss_section
= lss_section
->next
;
5309 gcc_assert (lss_section
!= gfc_ss_terminator
);
5311 /* Initialize the scalarizer. */
5312 gfc_init_loopinfo (&loop
);
5315 rss
= gfc_walk_expr (expr2
);
5316 if (rss
== gfc_ss_terminator
)
5318 /* The rhs is scalar. Add a ss for the expression. */
5319 rss
= gfc_get_ss ();
5320 rss
->next
= gfc_ss_terminator
;
5321 rss
->type
= GFC_SS_SCALAR
;
5324 /* Associate the SS with the loop. */
5325 gfc_add_ss_to_loop (&loop
, lss
);
5326 gfc_add_ss_to_loop (&loop
, rss
);
5328 /* Calculate the bounds of the scalarization. */
5329 gfc_conv_ss_startstride (&loop
);
5330 /* Resolve any data dependencies in the statement. */
5331 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5332 /* Setup the scalarizing loops. */
5333 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5335 /* Setup the gfc_se structures. */
5336 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5337 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5340 gfc_mark_ss_chain_used (rss
, 1);
5341 if (loop
.temp_ss
== NULL
)
5344 gfc_mark_ss_chain_used (lss
, 1);
5348 lse
.ss
= loop
.temp_ss
;
5349 gfc_mark_ss_chain_used (lss
, 3);
5350 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5353 /* Start the scalarized loop body. */
5354 gfc_start_scalarized_body (&loop
, &body
);
5357 gfc_init_block (&body
);
5359 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5361 /* Translate the expression. */
5362 gfc_conv_expr (&rse
, expr2
);
5364 /* Stabilize a string length for temporaries. */
5365 if (expr2
->ts
.type
== BT_CHARACTER
)
5366 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5368 string_length
= NULL_TREE
;
5372 gfc_conv_tmp_array_ref (&lse
);
5373 gfc_advance_se_ss_chain (&lse
);
5374 if (expr2
->ts
.type
== BT_CHARACTER
)
5375 lse
.string_length
= string_length
;
5378 gfc_conv_expr (&lse
, expr1
);
5380 /* Assignments of scalar derived types with allocatable components
5381 to arrays must be done with a deep copy and the rhs temporary
5382 must have its components deallocated afterwards. */
5383 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5384 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5385 && expr2
->expr_type
!= EXPR_VARIABLE
5386 && !gfc_is_constant_expr (expr2
)
5387 && expr1
->rank
&& !expr2
->rank
);
5388 if (scalar_to_array
)
5390 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5391 gfc_add_expr_to_block (&loop
.post
, tmp
);
5394 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5395 l_is_temp
|| init_flag
,
5396 (expr2
->expr_type
== EXPR_VARIABLE
)
5397 || scalar_to_array
);
5398 gfc_add_expr_to_block (&body
, tmp
);
5400 if (lss
== gfc_ss_terminator
)
5402 /* Use the scalar assignment as is. */
5403 gfc_add_block_to_block (&block
, &body
);
5407 gcc_assert (lse
.ss
== gfc_ss_terminator
5408 && rse
.ss
== gfc_ss_terminator
);
5412 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5414 /* We need to copy the temporary to the actual lhs. */
5415 gfc_init_se (&lse
, NULL
);
5416 gfc_init_se (&rse
, NULL
);
5417 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5418 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5420 rse
.ss
= loop
.temp_ss
;
5423 gfc_conv_tmp_array_ref (&rse
);
5424 gfc_advance_se_ss_chain (&rse
);
5425 gfc_conv_expr (&lse
, expr1
);
5427 gcc_assert (lse
.ss
== gfc_ss_terminator
5428 && rse
.ss
== gfc_ss_terminator
);
5430 if (expr2
->ts
.type
== BT_CHARACTER
)
5431 rse
.string_length
= string_length
;
5433 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5435 gfc_add_expr_to_block (&body
, tmp
);
5438 /* Generate the copying loops. */
5439 gfc_trans_scalarizing_loops (&loop
, &body
);
5441 /* Wrap the whole thing up. */
5442 gfc_add_block_to_block (&block
, &loop
.pre
);
5443 gfc_add_block_to_block (&block
, &loop
.post
);
5445 gfc_cleanup_loop (&loop
);
5448 return gfc_finish_block (&block
);
5452 /* Check whether EXPR is a copyable array. */
5455 copyable_array_p (gfc_expr
* expr
)
5457 if (expr
->expr_type
!= EXPR_VARIABLE
)
5460 /* First check it's an array. */
5461 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5464 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5467 /* Next check that it's of a simple enough type. */
5468 switch (expr
->ts
.type
)
5480 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5489 /* Translate an assignment. */
5492 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
5496 /* Special case a single function returning an array. */
5497 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5499 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5504 /* Special case assigning an array to zero. */
5505 if (copyable_array_p (expr1
)
5506 && is_zero_initializer_p (expr2
))
5508 tmp
= gfc_trans_zero_assign (expr1
);
5513 /* Special case copying one array to another. */
5514 if (copyable_array_p (expr1
)
5515 && copyable_array_p (expr2
)
5516 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
5517 && !gfc_check_dependency (expr1
, expr2
, 0))
5519 tmp
= gfc_trans_array_copy (expr1
, expr2
);
5524 /* Special case initializing an array from a constant array constructor. */
5525 if (copyable_array_p (expr1
)
5526 && expr2
->expr_type
== EXPR_ARRAY
5527 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
5529 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
5534 /* Fallback to the scalarizer to generate explicit loops. */
5535 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
5539 gfc_trans_init_assign (gfc_code
* code
)
5541 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true);
5545 gfc_trans_assign (gfc_code
* code
)
5547 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false);
5551 /* Translate an assignment to a CLASS object
5552 (pointer or ordinary assignment). */
5555 gfc_trans_class_assign (gfc_code
*code
)
5562 gfc_start_block (&block
);
5564 if (code
->op
== EXEC_INIT_ASSIGN
)
5566 /* Special case for initializing a CLASS variable on allocation.
5567 A MEMCPY is needed to copy the full data of the dynamic type,
5568 which may be different from the declared type. */
5571 gfc_init_se (&dst
, NULL
);
5572 gfc_init_se (&src
, NULL
);
5573 gfc_add_component_ref (code
->expr1
, "$data");
5574 gfc_conv_expr (&dst
, code
->expr1
);
5575 gfc_conv_expr (&src
, code
->expr2
);
5576 gfc_add_block_to_block (&block
, &src
.pre
);
5577 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr2
->ts
));
5578 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
);
5579 gfc_add_expr_to_block (&block
, tmp
);
5580 return gfc_finish_block (&block
);
5583 if (code
->expr2
->ts
.type
!= BT_CLASS
)
5585 /* Insert an additional assignment which sets the '$vptr' field. */
5586 lhs
= gfc_copy_expr (code
->expr1
);
5587 gfc_add_component_ref (lhs
, "$vptr");
5588 if (code
->expr2
->ts
.type
== BT_DERIVED
)
5592 vtab
= gfc_find_derived_vtab (code
->expr2
->ts
.u
.derived
);
5595 rhs
= gfc_get_expr ();
5596 rhs
->expr_type
= EXPR_VARIABLE
;
5597 gfc_find_sym_tree (vtab
->name
, NULL
, 1, &st
);
5601 else if (code
->expr2
->expr_type
== EXPR_NULL
)
5602 rhs
= gfc_int_expr (0);
5606 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
5607 gfc_add_expr_to_block (&block
, tmp
);
5609 gfc_free_expr (lhs
);
5610 gfc_free_expr (rhs
);
5613 /* Do the actual CLASS assignment. */
5614 if (code
->expr2
->ts
.type
== BT_CLASS
)
5615 code
->op
= EXEC_ASSIGN
;
5617 gfc_add_component_ref (code
->expr1
, "$data");
5619 if (code
->op
== EXEC_ASSIGN
)
5620 tmp
= gfc_trans_assign (code
);
5621 else if (code
->op
== EXEC_POINTER_ASSIGN
)
5622 tmp
= gfc_trans_pointer_assign (code
);
5626 gfc_add_expr_to_block (&block
, tmp
);
5628 return gfc_finish_block (&block
);