1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
29 #include "toplev.h" /* For fatal_error. */
30 #include "langhooks.h"
34 #include "constructor.h"
36 #include "trans-const.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
40 #include "trans-stmt.h"
41 #include "dependency.h"
43 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
44 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
47 /* Copy the scalarization loop variables. */
50 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
53 dest
->loop
= src
->loop
;
57 /* Initialize a simple expression holder.
59 Care must be taken when multiple se are created with the same parent.
60 The child se must be kept in sync. The easiest way is to delay creation
61 of a child se until after after the previous se has been translated. */
64 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
66 memset (se
, 0, sizeof (gfc_se
));
67 gfc_init_block (&se
->pre
);
68 gfc_init_block (&se
->post
);
73 gfc_copy_se_loopvars (se
, parent
);
77 /* Advances to the next SS in the chain. Use this rather than setting
78 se->ss = se->ss->next because all the parents needs to be kept in sync.
82 gfc_advance_se_ss_chain (gfc_se
* se
)
86 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
89 /* Walk down the parent chain. */
92 /* Simple consistency check. */
93 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
102 /* Ensures the result of the expression as either a temporary variable
103 or a constant so that it can be used repeatedly. */
106 gfc_make_safe_expr (gfc_se
* se
)
110 if (CONSTANT_CLASS_P (se
->expr
))
113 /* We need a temporary for this result. */
114 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
115 gfc_add_modify (&se
->pre
, var
, se
->expr
);
120 /* Return an expression which determines if a dummy parameter is present.
121 Also used for arguments to procedures with multiple entry points. */
124 gfc_conv_expr_present (gfc_symbol
* sym
)
128 gcc_assert (sym
->attr
.dummy
);
130 decl
= gfc_get_symbol_decl (sym
);
131 if (TREE_CODE (decl
) != PARM_DECL
)
133 /* Array parameters use a temporary descriptor, we want the real
135 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
136 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
137 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
139 return fold_build2 (NE_EXPR
, boolean_type_node
, decl
,
140 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
144 /* Converts a missing, dummy argument into a null or zero. */
147 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
, int kind
)
152 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
156 /* Create a temporary and convert it to the correct type. */
157 tmp
= gfc_get_int_type (kind
);
158 tmp
= fold_convert (tmp
, build_fold_indirect_ref_loc (input_location
,
161 /* Test for a NULL value. */
162 tmp
= build3 (COND_EXPR
, TREE_TYPE (tmp
), present
, tmp
,
163 fold_convert (TREE_TYPE (tmp
), integer_one_node
));
164 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
165 se
->expr
= gfc_build_addr_expr (NULL_TREE
, tmp
);
169 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
170 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
171 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
175 if (ts
.type
== BT_CHARACTER
)
177 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
178 tmp
= fold_build3 (COND_EXPR
, gfc_charlen_type_node
,
179 present
, se
->string_length
, tmp
);
180 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
181 se
->string_length
= tmp
;
187 /* Get the character length of an expression, looking through gfc_refs
191 gfc_get_expr_charlen (gfc_expr
*e
)
196 gcc_assert (e
->expr_type
== EXPR_VARIABLE
197 && e
->ts
.type
== BT_CHARACTER
);
199 length
= NULL
; /* To silence compiler warning. */
201 if (is_subref_array (e
) && e
->ts
.u
.cl
->length
)
204 gfc_init_se (&tmpse
, NULL
);
205 gfc_conv_expr_type (&tmpse
, e
->ts
.u
.cl
->length
, gfc_charlen_type_node
);
206 e
->ts
.u
.cl
->backend_decl
= tmpse
.expr
;
210 /* First candidate: if the variable is of type CHARACTER, the
211 expression's length could be the length of the character
213 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
214 length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
216 /* Look through the reference chain for component references. */
217 for (r
= e
->ref
; r
; r
= r
->next
)
222 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
223 length
= r
->u
.c
.component
->ts
.u
.cl
->backend_decl
;
231 /* We should never got substring references here. These will be
232 broken down by the scalarizer. */
238 gcc_assert (length
!= NULL
);
243 /* For each character array constructor subexpression without a ts.u.cl->length,
244 replace it by its first element (if there aren't any elements, the length
245 should already be set to zero). */
248 flatten_array_ctors_without_strlen (gfc_expr
* e
)
250 gfc_actual_arglist
* arg
;
256 switch (e
->expr_type
)
260 flatten_array_ctors_without_strlen (e
->value
.op
.op1
);
261 flatten_array_ctors_without_strlen (e
->value
.op
.op2
);
265 /* TODO: Implement as with EXPR_FUNCTION when needed. */
269 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
270 flatten_array_ctors_without_strlen (arg
->expr
);
275 /* We've found what we're looking for. */
276 if (e
->ts
.type
== BT_CHARACTER
&& !e
->ts
.u
.cl
->length
)
281 gcc_assert (e
->value
.constructor
);
283 c
= gfc_constructor_first (e
->value
.constructor
);
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
= gfc_constructor_first (e
->value
.constructor
);
295 c
; c
= gfc_constructor_next (c
))
296 flatten_array_ctors_without_strlen (c
->expr
);
306 /* Generate code to initialize a string length variable. Returns the
307 value. For array constructors, cl->length might be NULL and in this case,
308 the first element of the constructor is needed. expr is the original
309 expression so we can access it but can be NULL if this is not needed. */
312 gfc_conv_string_length (gfc_charlen
* cl
, gfc_expr
* expr
, stmtblock_t
* pblock
)
316 gfc_init_se (&se
, NULL
);
318 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
319 "flatten" array constructors by taking their first element; all elements
320 should be the same length or a cl->length should be present. */
326 expr_flat
= gfc_copy_expr (expr
);
327 flatten_array_ctors_without_strlen (expr_flat
);
328 gfc_resolve_expr (expr_flat
);
330 gfc_conv_expr (&se
, expr_flat
);
331 gfc_add_block_to_block (pblock
, &se
.pre
);
332 cl
->backend_decl
= convert (gfc_charlen_type_node
, se
.string_length
);
334 gfc_free_expr (expr_flat
);
338 /* Convert cl->length. */
340 gcc_assert (cl
->length
);
342 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
343 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
344 build_int_cst (gfc_charlen_type_node
, 0));
345 gfc_add_block_to_block (pblock
, &se
.pre
);
347 if (cl
->backend_decl
)
348 gfc_add_modify (pblock
, cl
->backend_decl
, se
.expr
);
350 cl
->backend_decl
= gfc_evaluate_now (se
.expr
, pblock
);
355 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
356 const char *name
, locus
*where
)
365 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
366 type
= build_pointer_type (type
);
368 gfc_init_se (&start
, se
);
369 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
370 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
372 if (integer_onep (start
.expr
))
373 gfc_conv_string_parameter (se
);
378 /* Avoid multiple evaluation of substring start. */
379 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
380 start
.expr
= gfc_evaluate_now (start
.expr
, &se
->pre
);
382 /* Change the start of the string. */
383 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
386 tmp
= build_fold_indirect_ref_loc (input_location
,
388 tmp
= gfc_build_array_ref (tmp
, start
.expr
, NULL
);
389 se
->expr
= gfc_build_addr_expr (type
, tmp
);
392 /* Length = end + 1 - start. */
393 gfc_init_se (&end
, se
);
394 if (ref
->u
.ss
.end
== NULL
)
395 end
.expr
= se
->string_length
;
398 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
399 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
403 if (!CONSTANT_CLASS_P (tmp
) && !DECL_P (tmp
))
404 end
.expr
= gfc_evaluate_now (end
.expr
, &se
->pre
);
406 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
408 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
409 start
.expr
, end
.expr
);
411 /* Check lower bound. */
412 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
413 build_int_cst (gfc_charlen_type_node
, 1));
414 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
417 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld) of '%s' "
418 "is less than one", name
);
420 asprintf (&msg
, "Substring out of bounds: lower bound (%%ld)"
422 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
423 fold_convert (long_integer_type_node
,
427 /* Check upper bound. */
428 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
430 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
433 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) of '%s' "
434 "exceeds string length (%%ld)", name
);
436 asprintf (&msg
, "Substring out of bounds: upper bound (%%ld) "
437 "exceeds string length (%%ld)");
438 gfc_trans_runtime_check (true, false, fault
, &se
->pre
, where
, msg
,
439 fold_convert (long_integer_type_node
, end
.expr
),
440 fold_convert (long_integer_type_node
,
445 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
446 end
.expr
, start
.expr
);
447 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
,
448 build_int_cst (gfc_charlen_type_node
, 1), tmp
);
449 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
450 build_int_cst (gfc_charlen_type_node
, 0));
451 se
->string_length
= tmp
;
455 /* Convert a derived type component reference. */
458 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
465 c
= ref
->u
.c
.component
;
467 gcc_assert (c
->backend_decl
);
469 field
= c
->backend_decl
;
470 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
472 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
476 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
)
478 tmp
= c
->ts
.u
.cl
->backend_decl
;
479 /* Components must always be constant length. */
480 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
481 se
->string_length
= tmp
;
484 if (((c
->attr
.pointer
|| c
->attr
.allocatable
) && c
->attr
.dimension
== 0
485 && c
->ts
.type
!= BT_CHARACTER
)
486 || c
->attr
.proc_pointer
)
487 se
->expr
= build_fold_indirect_ref_loc (input_location
,
492 /* This function deals with component references to components of the
493 parent type for derived type extensons. */
495 conv_parent_component_references (gfc_se
* se
, gfc_ref
* ref
)
503 c
= ref
->u
.c
.component
;
505 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
506 parent
.type
= REF_COMPONENT
;
509 parent
.u
.c
.component
= dt
->components
;
511 if (dt
->backend_decl
== NULL
)
512 gfc_get_derived_type (dt
);
514 if (dt
->attr
.extension
&& dt
->components
)
516 if (dt
->attr
.is_class
)
517 cmp
= dt
->components
;
519 cmp
= dt
->components
->next
;
520 /* Return if the component is not in the parent type. */
521 for (; cmp
; cmp
= cmp
->next
)
522 if (strcmp (c
->name
, cmp
->name
) == 0)
525 /* Otherwise build the reference and call self. */
526 gfc_conv_component_ref (se
, &parent
);
527 parent
.u
.c
.sym
= dt
->components
->ts
.u
.derived
;
528 parent
.u
.c
.component
= c
;
529 conv_parent_component_references (se
, &parent
);
533 /* Return the contents of a variable. Also handles reference/pointer
534 variables (all Fortran pointer references are implicit). */
537 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
544 bool alternate_entry
;
547 sym
= expr
->symtree
->n
.sym
;
550 /* Check that something hasn't gone horribly wrong. */
551 gcc_assert (se
->ss
!= gfc_ss_terminator
);
552 gcc_assert (se
->ss
->expr
== expr
);
554 /* A scalarized term. We already know the descriptor. */
555 se
->expr
= se
->ss
->data
.info
.descriptor
;
556 se
->string_length
= se
->ss
->string_length
;
557 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
558 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
563 tree se_expr
= NULL_TREE
;
565 se
->expr
= gfc_get_symbol_decl (sym
);
567 /* Deal with references to a parent results or entries by storing
568 the current_function_decl and moving to the parent_decl. */
569 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
570 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
571 && sym
->result
== sym
;
572 entry_master
= sym
->attr
.result
573 && sym
->ns
->proc_name
->attr
.entry_master
574 && !gfc_return_by_reference (sym
->ns
->proc_name
);
575 parent_decl
= DECL_CONTEXT (current_function_decl
);
577 if ((se
->expr
== parent_decl
&& return_value
)
578 || (sym
->ns
&& sym
->ns
->proc_name
580 && sym
->ns
->proc_name
->backend_decl
== parent_decl
581 && (alternate_entry
|| entry_master
)))
586 /* Special case for assigning the return value of a function.
587 Self recursive functions must have an explicit return value. */
588 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
589 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
591 /* Similarly for alternate entry points. */
592 else if (alternate_entry
593 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
596 gfc_entry_list
*el
= NULL
;
598 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
601 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
606 else if (entry_master
607 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
609 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
614 /* Procedure actual arguments. */
615 else if (sym
->attr
.flavor
== FL_PROCEDURE
616 && se
->expr
!= current_function_decl
)
618 if (!sym
->attr
.dummy
&& !sym
->attr
.proc_pointer
)
620 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
621 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
627 /* Dereference the expression, where needed. Since characters
628 are entirely different from other types, they are treated
630 if (sym
->ts
.type
== BT_CHARACTER
)
632 /* Dereference character pointer dummy arguments
634 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
636 || sym
->attr
.function
637 || sym
->attr
.result
))
638 se
->expr
= build_fold_indirect_ref_loc (input_location
,
642 else if (!sym
->attr
.value
)
644 /* Dereference non-character scalar dummy arguments. */
645 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
646 se
->expr
= build_fold_indirect_ref_loc (input_location
,
649 /* Dereference scalar hidden result. */
650 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
651 && (sym
->attr
.function
|| sym
->attr
.result
)
652 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
653 && !sym
->attr
.always_explicit
)
654 se
->expr
= build_fold_indirect_ref_loc (input_location
,
657 /* Dereference non-character pointer variables.
658 These must be dummies, results, or scalars. */
659 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
661 || sym
->attr
.function
663 || !sym
->attr
.dimension
))
664 se
->expr
= build_fold_indirect_ref_loc (input_location
,
671 /* For character variables, also get the length. */
672 if (sym
->ts
.type
== BT_CHARACTER
)
674 /* If the character length of an entry isn't set, get the length from
675 the master function instead. */
676 if (sym
->attr
.entry
&& !sym
->ts
.u
.cl
->backend_decl
)
677 se
->string_length
= sym
->ns
->proc_name
->ts
.u
.cl
->backend_decl
;
679 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
680 gcc_assert (se
->string_length
);
688 /* Return the descriptor if that's what we want and this is an array
689 section reference. */
690 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
692 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
693 /* Return the descriptor for array pointers and allocations. */
695 && ref
->next
== NULL
&& (se
->descriptor_only
))
698 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
699 /* Return a pointer to an element. */
703 if (ref
->u
.c
.sym
->attr
.extension
)
704 conv_parent_component_references (se
, ref
);
706 gfc_conv_component_ref (se
, ref
);
710 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
711 expr
->symtree
->name
, &expr
->where
);
720 /* Pointer assignment, allocation or pass by reference. Arrays are handled
722 if (se
->want_pointer
)
724 if (expr
->ts
.type
== BT_CHARACTER
&& !gfc_is_proc_ptr_comp (expr
, NULL
))
725 gfc_conv_string_parameter (se
);
727 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
732 /* Unary ops are easy... Or they would be if ! was a valid op. */
735 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
740 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
741 /* Initialize the operand. */
742 gfc_init_se (&operand
, se
);
743 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
744 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
746 type
= gfc_typenode_for_spec (&expr
->ts
);
748 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
749 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
750 All other unary operators have an equivalent GIMPLE unary operator. */
751 if (code
== TRUTH_NOT_EXPR
)
752 se
->expr
= fold_build2 (EQ_EXPR
, type
, operand
.expr
,
753 build_int_cst (type
, 0));
755 se
->expr
= fold_build1 (code
, type
, operand
.expr
);
759 /* Expand power operator to optimal multiplications when a value is raised
760 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
761 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
762 Programming", 3rd Edition, 1998. */
764 /* This code is mostly duplicated from expand_powi in the backend.
765 We establish the "optimal power tree" lookup table with the defined size.
766 The items in the table are the exponents used to calculate the index
767 exponents. Any integer n less than the value can get an "addition chain",
768 with the first node being one. */
769 #define POWI_TABLE_SIZE 256
771 /* The table is from builtins.c. */
772 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
774 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
775 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
776 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
777 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
778 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
779 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
780 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
781 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
782 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
783 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
784 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
785 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
786 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
787 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
788 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
789 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
790 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
791 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
792 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
793 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
794 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
795 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
796 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
797 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
798 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
799 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
800 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
801 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
802 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
803 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
804 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
805 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
808 /* If n is larger than lookup table's max index, we use the "window
810 #define POWI_WINDOW_SIZE 3
812 /* Recursive function to expand the power operator. The temporary
813 values are put in tmpvar. The function returns tmpvar[1] ** n. */
815 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
822 if (n
< POWI_TABLE_SIZE
)
827 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
828 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
832 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
833 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
834 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
838 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
842 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
843 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
845 if (n
< POWI_TABLE_SIZE
)
852 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
853 return 1. Else return 0 and a call to runtime library functions
854 will have to be built. */
856 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
861 tree vartmp
[POWI_TABLE_SIZE
];
863 unsigned HOST_WIDE_INT n
;
866 /* If exponent is too large, we won't expand it anyway, so don't bother
867 with large integer values. */
868 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
871 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
872 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
873 of the asymmetric range of the integer type. */
874 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
876 type
= TREE_TYPE (lhs
);
877 sgn
= tree_int_cst_sgn (rhs
);
879 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
880 || optimize_size
) && (m
> 2 || m
< -1))
886 se
->expr
= gfc_build_const (type
, integer_one_node
);
890 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
891 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
893 tmp
= fold_build2 (EQ_EXPR
, boolean_type_node
,
894 lhs
, build_int_cst (TREE_TYPE (lhs
), -1));
895 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
896 lhs
, build_int_cst (TREE_TYPE (lhs
), 1));
899 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
902 tmp
= fold_build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
903 se
->expr
= fold_build3 (COND_EXPR
, type
,
904 tmp
, build_int_cst (type
, 1),
905 build_int_cst (type
, 0));
909 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
910 tmp
= fold_build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
911 build_int_cst (type
, 0));
912 se
->expr
= fold_build3 (COND_EXPR
, type
,
913 cond
, build_int_cst (type
, 1), tmp
);
917 memset (vartmp
, 0, sizeof (vartmp
));
921 tmp
= gfc_build_const (type
, integer_one_node
);
922 vartmp
[1] = fold_build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
925 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
931 /* Power op (**). Constant integer exponent has special handling. */
934 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
936 tree gfc_int4_type_node
;
943 gfc_init_se (&lse
, se
);
944 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
945 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
946 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
948 gfc_init_se (&rse
, se
);
949 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
950 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
952 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
953 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
954 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
957 gfc_int4_type_node
= gfc_get_int_type (4);
959 kind
= expr
->value
.op
.op1
->ts
.kind
;
960 switch (expr
->value
.op
.op2
->ts
.type
)
963 ikind
= expr
->value
.op
.op2
->ts
.kind
;
968 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
990 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
991 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
1016 switch (expr
->value
.op
.op1
->ts
.type
)
1019 if (kind
== 3) /* Case 16 was not handled properly above. */
1021 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
1025 /* Use builtins for real ** int4. */
1031 fndecl
= built_in_decls
[BUILT_IN_POWIF
];
1035 fndecl
= built_in_decls
[BUILT_IN_POWI
];
1040 fndecl
= built_in_decls
[BUILT_IN_POWIL
];
1048 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
1052 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
1064 fndecl
= built_in_decls
[BUILT_IN_POWF
];
1067 fndecl
= built_in_decls
[BUILT_IN_POW
];
1071 fndecl
= built_in_decls
[BUILT_IN_POWL
];
1082 fndecl
= built_in_decls
[BUILT_IN_CPOWF
];
1085 fndecl
= built_in_decls
[BUILT_IN_CPOW
];
1089 fndecl
= built_in_decls
[BUILT_IN_CPOWL
];
1101 se
->expr
= build_call_expr_loc (input_location
,
1102 fndecl
, 2, lse
.expr
, rse
.expr
);
1106 /* Generate code to allocate a string temporary. */
1109 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
1114 if (gfc_can_put_var_on_stack (len
))
1116 /* Create a temporary variable to hold the result. */
1117 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1118 build_int_cst (gfc_charlen_type_node
, 1));
1119 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1121 if (TREE_CODE (TREE_TYPE (type
)) == ARRAY_TYPE
)
1122 tmp
= build_array_type (TREE_TYPE (TREE_TYPE (type
)), tmp
);
1124 tmp
= build_array_type (TREE_TYPE (type
), tmp
);
1126 var
= gfc_create_var (tmp
, "str");
1127 var
= gfc_build_addr_expr (type
, var
);
1131 /* Allocate a temporary to hold the result. */
1132 var
= gfc_create_var (type
, "pstr");
1133 tmp
= gfc_call_malloc (&se
->pre
, type
,
1134 fold_build2 (MULT_EXPR
, TREE_TYPE (len
), len
,
1135 fold_convert (TREE_TYPE (len
),
1136 TYPE_SIZE (type
))));
1137 gfc_add_modify (&se
->pre
, var
, tmp
);
1139 /* Free the temporary afterwards. */
1140 tmp
= gfc_call_free (convert (pvoid_type_node
, var
));
1141 gfc_add_expr_to_block (&se
->post
, tmp
);
1148 /* Handle a string concatenation operation. A temporary will be allocated to
1152 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
1155 tree len
, type
, var
, tmp
, fndecl
;
1157 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
1158 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
1159 gcc_assert (expr
->value
.op
.op1
->ts
.kind
== expr
->value
.op
.op2
->ts
.kind
);
1161 gfc_init_se (&lse
, se
);
1162 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1163 gfc_conv_string_parameter (&lse
);
1164 gfc_init_se (&rse
, se
);
1165 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1166 gfc_conv_string_parameter (&rse
);
1168 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1169 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1171 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.u
.cl
);
1172 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1173 if (len
== NULL_TREE
)
1175 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
1176 lse
.string_length
, rse
.string_length
);
1179 type
= build_pointer_type (type
);
1181 var
= gfc_conv_string_tmp (se
, type
, len
);
1183 /* Do the actual concatenation. */
1184 if (expr
->ts
.kind
== 1)
1185 fndecl
= gfor_fndecl_concat_string
;
1186 else if (expr
->ts
.kind
== 4)
1187 fndecl
= gfor_fndecl_concat_string_char4
;
1191 tmp
= build_call_expr_loc (input_location
,
1192 fndecl
, 6, len
, var
, lse
.string_length
, lse
.expr
,
1193 rse
.string_length
, rse
.expr
);
1194 gfc_add_expr_to_block (&se
->pre
, tmp
);
1196 /* Add the cleanup for the operands. */
1197 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1198 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1201 se
->string_length
= len
;
1204 /* Translates an op expression. Common (binary) cases are handled by this
1205 function, others are passed on. Recursion is used in either case.
1206 We use the fact that (op1.ts == op2.ts) (except for the power
1208 Operators need no special handling for scalarized expressions as long as
1209 they call gfc_conv_simple_val to get their operands.
1210 Character strings get special handling. */
1213 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1215 enum tree_code code
;
1224 switch (expr
->value
.op
.op
)
1226 case INTRINSIC_PARENTHESES
:
1227 if ((expr
->ts
.type
== BT_REAL
1228 || expr
->ts
.type
== BT_COMPLEX
)
1229 && gfc_option
.flag_protect_parens
)
1231 gfc_conv_unary_op (PAREN_EXPR
, se
, expr
);
1232 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se
->expr
)));
1237 case INTRINSIC_UPLUS
:
1238 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1241 case INTRINSIC_UMINUS
:
1242 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1246 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1249 case INTRINSIC_PLUS
:
1253 case INTRINSIC_MINUS
:
1257 case INTRINSIC_TIMES
:
1261 case INTRINSIC_DIVIDE
:
1262 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1263 an integer, we must round towards zero, so we use a
1265 if (expr
->ts
.type
== BT_INTEGER
)
1266 code
= TRUNC_DIV_EXPR
;
1271 case INTRINSIC_POWER
:
1272 gfc_conv_power_op (se
, expr
);
1275 case INTRINSIC_CONCAT
:
1276 gfc_conv_concat_op (se
, expr
);
1280 code
= TRUTH_ANDIF_EXPR
;
1285 code
= TRUTH_ORIF_EXPR
;
1289 /* EQV and NEQV only work on logicals, but since we represent them
1290 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1292 case INTRINSIC_EQ_OS
:
1300 case INTRINSIC_NE_OS
:
1301 case INTRINSIC_NEQV
:
1308 case INTRINSIC_GT_OS
:
1315 case INTRINSIC_GE_OS
:
1322 case INTRINSIC_LT_OS
:
1329 case INTRINSIC_LE_OS
:
1335 case INTRINSIC_USER
:
1336 case INTRINSIC_ASSIGN
:
1337 /* These should be converted into function calls by the frontend. */
1341 fatal_error ("Unknown intrinsic op");
1345 /* The only exception to this is **, which is handled separately anyway. */
1346 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1348 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1352 gfc_init_se (&lse
, se
);
1353 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1354 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1357 gfc_init_se (&rse
, se
);
1358 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1359 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1363 gfc_conv_string_parameter (&lse
);
1364 gfc_conv_string_parameter (&rse
);
1366 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1367 rse
.string_length
, rse
.expr
,
1368 expr
->value
.op
.op1
->ts
.kind
);
1369 rse
.expr
= build_int_cst (TREE_TYPE (lse
.expr
), 0);
1370 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1373 type
= gfc_typenode_for_spec (&expr
->ts
);
1377 /* The result of logical ops is always boolean_type_node. */
1378 tmp
= fold_build2 (code
, boolean_type_node
, lse
.expr
, rse
.expr
);
1379 se
->expr
= convert (type
, tmp
);
1382 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1384 /* Add the post blocks. */
1385 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1386 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1389 /* If a string's length is one, we convert it to a single character. */
1392 string_to_single_character (tree len
, tree str
, int kind
)
1394 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1396 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1397 && TREE_INT_CST_HIGH (len
) == 0)
1399 str
= fold_convert (gfc_get_pchar_type (kind
), str
);
1400 return build_fold_indirect_ref_loc (input_location
,
1409 gfc_conv_scalar_char_value (gfc_symbol
*sym
, gfc_se
*se
, gfc_expr
**expr
)
1412 if (sym
->backend_decl
)
1414 /* This becomes the nominal_type in
1415 function.c:assign_parm_find_data_types. */
1416 TREE_TYPE (sym
->backend_decl
) = unsigned_char_type_node
;
1417 /* This becomes the passed_type in
1418 function.c:assign_parm_find_data_types. C promotes char to
1419 integer for argument passing. */
1420 DECL_ARG_TYPE (sym
->backend_decl
) = unsigned_type_node
;
1422 DECL_BY_REFERENCE (sym
->backend_decl
) = 0;
1427 /* If we have a constant character expression, make it into an
1429 if ((*expr
)->expr_type
== EXPR_CONSTANT
)
1434 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
1435 (int)(*expr
)->value
.character
.string
[0]);
1436 if ((*expr
)->ts
.kind
!= gfc_c_int_kind
)
1438 /* The expr needs to be compatible with a C int. If the
1439 conversion fails, then the 2 causes an ICE. */
1440 ts
.type
= BT_INTEGER
;
1441 ts
.kind
= gfc_c_int_kind
;
1442 gfc_convert_type (*expr
, &ts
, 2);
1445 else if (se
!= NULL
&& (*expr
)->expr_type
== EXPR_VARIABLE
)
1447 if ((*expr
)->ref
== NULL
)
1449 se
->expr
= string_to_single_character
1450 (build_int_cst (integer_type_node
, 1),
1451 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1453 ((*expr
)->symtree
->n
.sym
)),
1458 gfc_conv_variable (se
, *expr
);
1459 se
->expr
= string_to_single_character
1460 (build_int_cst (integer_type_node
, 1),
1461 gfc_build_addr_expr (gfc_get_pchar_type ((*expr
)->ts
.kind
),
1470 /* Compare two strings. If they are all single characters, the result is the
1471 subtraction of them. Otherwise, we build a library call. */
1474 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
, int kind
)
1480 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1481 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1483 sc1
= string_to_single_character (len1
, str1
, kind
);
1484 sc2
= string_to_single_character (len2
, str2
, kind
);
1486 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1488 /* Deal with single character specially. */
1489 sc1
= fold_convert (integer_type_node
, sc1
);
1490 sc2
= fold_convert (integer_type_node
, sc2
);
1491 tmp
= fold_build2 (MINUS_EXPR
, integer_type_node
, sc1
, sc2
);
1495 /* Build a call for the comparison. */
1499 fndecl
= gfor_fndecl_compare_string
;
1501 fndecl
= gfor_fndecl_compare_string_char4
;
1505 tmp
= build_call_expr_loc (input_location
,
1506 fndecl
, 4, len1
, str1
, len2
, str2
);
1513 /* Return the backend_decl for a procedure pointer component. */
1516 get_proc_ptr_comp (gfc_expr
*e
)
1520 gfc_init_se (&comp_se
, NULL
);
1521 e2
= gfc_copy_expr (e
);
1522 e2
->expr_type
= EXPR_VARIABLE
;
1523 gfc_conv_expr (&comp_se
, e2
);
1525 return build_fold_addr_expr_loc (input_location
, comp_se
.expr
);
1530 conv_function_val (gfc_se
* se
, gfc_symbol
* sym
, gfc_expr
* expr
)
1534 if (gfc_is_proc_ptr_comp (expr
, NULL
))
1535 tmp
= get_proc_ptr_comp (expr
);
1536 else if (sym
->attr
.dummy
)
1538 tmp
= gfc_get_symbol_decl (sym
);
1539 if (sym
->attr
.proc_pointer
)
1540 tmp
= build_fold_indirect_ref_loc (input_location
,
1542 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1543 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1547 if (!sym
->backend_decl
)
1548 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1550 tmp
= sym
->backend_decl
;
1552 if (sym
->attr
.cray_pointee
)
1554 /* TODO - make the cray pointee a pointer to a procedure,
1555 assign the pointer to it and use it for the call. This
1557 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1558 gfc_get_symbol_decl (sym
->cp_pointer
));
1559 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
1562 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1564 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1565 tmp
= gfc_build_addr_expr (NULL_TREE
, tmp
);
1572 /* Initialize MAPPING. */
1575 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1577 mapping
->syms
= NULL
;
1578 mapping
->charlens
= NULL
;
1582 /* Free all memory held by MAPPING (but not MAPPING itself). */
1585 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1587 gfc_interface_sym_mapping
*sym
;
1588 gfc_interface_sym_mapping
*nextsym
;
1590 gfc_charlen
*nextcl
;
1592 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1594 nextsym
= sym
->next
;
1595 sym
->new_sym
->n
.sym
->formal
= NULL
;
1596 gfc_free_symbol (sym
->new_sym
->n
.sym
);
1597 gfc_free_expr (sym
->expr
);
1598 gfc_free (sym
->new_sym
);
1601 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1604 gfc_free_expr (cl
->length
);
1610 /* Return a copy of gfc_charlen CL. Add the returned structure to
1611 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1613 static gfc_charlen
*
1614 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1617 gfc_charlen
*new_charlen
;
1619 new_charlen
= gfc_get_charlen ();
1620 new_charlen
->next
= mapping
->charlens
;
1621 new_charlen
->length
= gfc_copy_expr (cl
->length
);
1623 mapping
->charlens
= new_charlen
;
1628 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1629 array variable that can be used as the actual argument for dummy
1630 argument SYM. Add any initialization code to BLOCK. PACKED is as
1631 for gfc_get_nodesc_array_type and DATA points to the first element
1632 in the passed array. */
1635 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1636 gfc_packed packed
, tree data
)
1641 type
= gfc_typenode_for_spec (&sym
->ts
);
1642 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
,
1643 !sym
->attr
.target
&& !sym
->attr
.pointer
1644 && !sym
->attr
.proc_pointer
);
1646 var
= gfc_create_var (type
, "ifm");
1647 gfc_add_modify (block
, var
, fold_convert (type
, data
));
1653 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1654 and offset of descriptorless array type TYPE given that it has the same
1655 size as DESC. Add any set-up code to BLOCK. */
1658 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1665 offset
= gfc_index_zero_node
;
1666 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1668 dim
= gfc_rank_cst
[n
];
1669 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1670 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1672 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1673 = gfc_conv_descriptor_lbound_get (desc
, dim
);
1674 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1675 = gfc_conv_descriptor_ubound_get (desc
, dim
);
1677 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1679 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1680 gfc_conv_descriptor_ubound_get (desc
, dim
),
1681 gfc_conv_descriptor_lbound_get (desc
, dim
));
1682 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1683 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1685 tmp
= gfc_evaluate_now (tmp
, block
);
1686 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1688 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1689 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1690 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1691 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1693 offset
= gfc_evaluate_now (offset
, block
);
1694 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1698 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1699 in SE. The caller may still use se->expr and se->string_length after
1700 calling this function. */
1703 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1704 gfc_symbol
* sym
, gfc_se
* se
,
1707 gfc_interface_sym_mapping
*sm
;
1711 gfc_symbol
*new_sym
;
1713 gfc_symtree
*new_symtree
;
1715 /* Create a new symbol to represent the actual argument. */
1716 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1717 new_sym
->ts
= sym
->ts
;
1718 new_sym
->as
= gfc_copy_array_spec (sym
->as
);
1719 new_sym
->attr
.referenced
= 1;
1720 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1721 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
1722 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1723 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1724 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1725 new_sym
->attr
.function
= sym
->attr
.function
;
1727 /* Ensure that the interface is available and that
1728 descriptors are passed for array actual arguments. */
1729 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1731 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1732 new_sym
->attr
.always_explicit
1733 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1736 /* Create a fake symtree for it. */
1738 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1739 new_symtree
->n
.sym
= new_sym
;
1740 gcc_assert (new_symtree
== root
);
1742 /* Create a dummy->actual mapping. */
1743 sm
= XCNEW (gfc_interface_sym_mapping
);
1744 sm
->next
= mapping
->syms
;
1746 sm
->new_sym
= new_symtree
;
1747 sm
->expr
= gfc_copy_expr (expr
);
1750 /* Stabilize the argument's value. */
1751 if (!sym
->attr
.function
&& se
)
1752 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1754 if (sym
->ts
.type
== BT_CHARACTER
)
1756 /* Create a copy of the dummy argument's length. */
1757 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1758 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1760 /* If the length is specified as "*", record the length that
1761 the caller is passing. We should use the callee's length
1762 in all other cases. */
1763 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1765 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1766 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1773 /* Use the passed value as-is if the argument is a function. */
1774 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1777 /* If the argument is either a string or a pointer to a string,
1778 convert it to a boundless character type. */
1779 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1781 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1782 tmp
= build_pointer_type (tmp
);
1783 if (sym
->attr
.pointer
)
1784 value
= build_fold_indirect_ref_loc (input_location
,
1788 value
= fold_convert (tmp
, value
);
1791 /* If the argument is a scalar, a pointer to an array or an allocatable,
1793 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1794 value
= build_fold_indirect_ref_loc (input_location
,
1797 /* For character(*), use the actual argument's descriptor. */
1798 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1799 value
= build_fold_indirect_ref_loc (input_location
,
1802 /* If the argument is an array descriptor, use it to determine
1803 information about the actual argument's shape. */
1804 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1805 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1807 /* Get the actual argument's descriptor. */
1808 desc
= build_fold_indirect_ref_loc (input_location
,
1811 /* Create the replacement variable. */
1812 tmp
= gfc_conv_descriptor_data_get (desc
);
1813 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1816 /* Use DESC to work out the upper bounds, strides and offset. */
1817 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1820 /* Otherwise we have a packed array. */
1821 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1822 PACKED_FULL
, se
->expr
);
1824 new_sym
->backend_decl
= value
;
1828 /* Called once all dummy argument mappings have been added to MAPPING,
1829 but before the mapping is used to evaluate expressions. Pre-evaluate
1830 the length of each argument, adding any initialization code to PRE and
1831 any finalization code to POST. */
1834 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1835 stmtblock_t
* pre
, stmtblock_t
* post
)
1837 gfc_interface_sym_mapping
*sym
;
1841 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1842 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1843 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1845 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1846 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1847 gfc_init_se (&se
, NULL
);
1848 gfc_conv_expr (&se
, expr
);
1849 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1850 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1851 gfc_add_block_to_block (pre
, &se
.pre
);
1852 gfc_add_block_to_block (post
, &se
.post
);
1854 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1859 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1863 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1864 gfc_constructor_base base
)
1867 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1869 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1872 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1873 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1874 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1880 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1884 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1889 for (; ref
; ref
= ref
->next
)
1893 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1895 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1896 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1897 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1899 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1906 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1907 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1913 /* Convert intrinsic function calls into result expressions. */
1916 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
1924 arg1
= expr
->value
.function
.actual
->expr
;
1925 if (expr
->value
.function
.actual
->next
)
1926 arg2
= expr
->value
.function
.actual
->next
->expr
;
1930 sym
= arg1
->symtree
->n
.sym
;
1932 if (sym
->attr
.dummy
)
1937 switch (expr
->value
.function
.isym
->id
)
1940 /* TODO figure out why this condition is necessary. */
1941 if (sym
->attr
.function
1942 && (arg1
->ts
.u
.cl
->length
== NULL
1943 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
1944 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
1947 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
1951 if (!sym
->as
|| sym
->as
->rank
== 0)
1954 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1956 dup
= mpz_get_si (arg2
->value
.integer
);
1961 dup
= sym
->as
->rank
;
1965 for (; d
< dup
; d
++)
1969 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
1971 gfc_free_expr (new_expr
);
1975 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
1976 gfc_get_int_expr (gfc_default_integer_kind
,
1978 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1980 new_expr
= gfc_multiply (new_expr
, tmp
);
1986 case GFC_ISYM_LBOUND
:
1987 case GFC_ISYM_UBOUND
:
1988 /* TODO These implementations of lbound and ubound do not limit if
1989 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1991 if (!sym
->as
|| sym
->as
->rank
== 0)
1994 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1995 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1997 /* TODO: If the need arises, this could produce an array of
2001 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2003 if (sym
->as
->lower
[d
])
2004 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2008 if (sym
->as
->upper
[d
])
2009 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2017 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2021 gfc_replace_expr (expr
, new_expr
);
2027 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2028 gfc_interface_mapping
* mapping
)
2030 gfc_formal_arglist
*f
;
2031 gfc_actual_arglist
*actual
;
2033 actual
= expr
->value
.function
.actual
;
2034 f
= map_expr
->symtree
->n
.sym
->formal
;
2036 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2041 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2044 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2049 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2051 for (d
= 0; d
< as
->rank
; d
++)
2053 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2054 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2057 expr
->value
.function
.esym
->as
= as
;
2060 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2062 expr
->value
.function
.esym
->ts
.u
.cl
->length
2063 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2065 gfc_apply_interface_mapping_to_expr (mapping
,
2066 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2071 /* EXPR is a copy of an expression that appeared in the interface
2072 associated with MAPPING. Walk it recursively looking for references to
2073 dummy arguments that MAPPING maps to actual arguments. Replace each such
2074 reference with a reference to the associated actual argument. */
2077 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2080 gfc_interface_sym_mapping
*sym
;
2081 gfc_actual_arglist
*actual
;
2086 /* Copying an expression does not copy its length, so do that here. */
2087 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2089 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2090 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2093 /* Apply the mapping to any references. */
2094 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2096 /* ...and to the expression's symbol, if it has one. */
2097 /* TODO Find out why the condition on expr->symtree had to be moved into
2098 the loop rather than being outside it, as originally. */
2099 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2100 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2102 if (sym
->new_sym
->n
.sym
->backend_decl
)
2103 expr
->symtree
= sym
->new_sym
;
2105 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2108 /* ...and to subexpressions in expr->value. */
2109 switch (expr
->expr_type
)
2114 case EXPR_SUBSTRING
:
2118 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2119 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2123 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2124 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2126 if (expr
->value
.function
.esym
== NULL
2127 && expr
->value
.function
.isym
!= NULL
2128 && expr
->value
.function
.actual
->expr
->symtree
2129 && gfc_map_intrinsic_function (expr
, mapping
))
2132 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2133 if (sym
->old
== expr
->value
.function
.esym
)
2135 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2136 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2137 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2142 case EXPR_STRUCTURE
:
2143 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2156 /* Evaluate interface expression EXPR using MAPPING. Store the result
2160 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2161 gfc_se
* se
, gfc_expr
* expr
)
2163 expr
= gfc_copy_expr (expr
);
2164 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2165 gfc_conv_expr (se
, expr
);
2166 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2167 gfc_free_expr (expr
);
2171 /* Returns a reference to a temporary array into which a component of
2172 an actual argument derived type array is copied and then returned
2173 after the function call. */
2175 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2176 sym_intent intent
, bool formal_ptr
)
2194 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2196 gfc_init_se (&lse
, NULL
);
2197 gfc_init_se (&rse
, NULL
);
2199 /* Walk the argument expression. */
2200 rss
= gfc_walk_expr (expr
);
2202 gcc_assert (rss
!= gfc_ss_terminator
);
2204 /* Initialize the scalarizer. */
2205 gfc_init_loopinfo (&loop
);
2206 gfc_add_ss_to_loop (&loop
, rss
);
2208 /* Calculate the bounds of the scalarization. */
2209 gfc_conv_ss_startstride (&loop
);
2211 /* Build an ss for the temporary. */
2212 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2213 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2215 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2216 if (GFC_ARRAY_TYPE_P (base_type
)
2217 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2218 base_type
= gfc_get_element_type (base_type
);
2220 loop
.temp_ss
= gfc_get_ss ();;
2221 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2222 loop
.temp_ss
->data
.temp
.type
= base_type
;
2224 if (expr
->ts
.type
== BT_CHARACTER
)
2225 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2227 loop
.temp_ss
->string_length
= NULL
;
2229 parmse
->string_length
= loop
.temp_ss
->string_length
;
2230 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2231 loop
.temp_ss
->next
= gfc_ss_terminator
;
2233 /* Associate the SS with the loop. */
2234 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2236 /* Setup the scalarizing loops. */
2237 gfc_conv_loop_setup (&loop
, &expr
->where
);
2239 /* Pass the temporary descriptor back to the caller. */
2240 info
= &loop
.temp_ss
->data
.info
;
2241 parmse
->expr
= info
->descriptor
;
2243 /* Setup the gfc_se structures. */
2244 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2245 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2248 lse
.ss
= loop
.temp_ss
;
2249 gfc_mark_ss_chain_used (rss
, 1);
2250 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2252 /* Start the scalarized loop body. */
2253 gfc_start_scalarized_body (&loop
, &body
);
2255 /* Translate the expression. */
2256 gfc_conv_expr (&rse
, expr
);
2258 gfc_conv_tmp_array_ref (&lse
);
2259 gfc_advance_se_ss_chain (&lse
);
2261 if (intent
!= INTENT_OUT
)
2263 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2264 gfc_add_expr_to_block (&body
, tmp
);
2265 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2266 gfc_trans_scalarizing_loops (&loop
, &body
);
2270 /* Make sure that the temporary declaration survives by merging
2271 all the loop declarations into the current context. */
2272 for (n
= 0; n
< loop
.dimen
; n
++)
2274 gfc_merge_block_scope (&body
);
2275 body
= loop
.code
[loop
.order
[n
]];
2277 gfc_merge_block_scope (&body
);
2280 /* Add the post block after the second loop, so that any
2281 freeing of allocated memory is done at the right time. */
2282 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2284 /**********Copy the temporary back again.*********/
2286 gfc_init_se (&lse
, NULL
);
2287 gfc_init_se (&rse
, NULL
);
2289 /* Walk the argument expression. */
2290 lss
= gfc_walk_expr (expr
);
2291 rse
.ss
= loop
.temp_ss
;
2294 /* Initialize the scalarizer. */
2295 gfc_init_loopinfo (&loop2
);
2296 gfc_add_ss_to_loop (&loop2
, lss
);
2298 /* Calculate the bounds of the scalarization. */
2299 gfc_conv_ss_startstride (&loop2
);
2301 /* Setup the scalarizing loops. */
2302 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2304 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2305 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2307 gfc_mark_ss_chain_used (lss
, 1);
2308 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2310 /* Declare the variable to hold the temporary offset and start the
2311 scalarized loop body. */
2312 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2313 gfc_start_scalarized_body (&loop2
, &body
);
2315 /* Build the offsets for the temporary from the loop variables. The
2316 temporary array has lbounds of zero and strides of one in all
2317 dimensions, so this is very simple. The offset is only computed
2318 outside the innermost loop, so the overall transfer could be
2319 optimized further. */
2320 info
= &rse
.ss
->data
.info
;
2321 dimen
= info
->dimen
;
2323 tmp_index
= gfc_index_zero_node
;
2324 for (n
= dimen
- 1; n
> 0; n
--)
2327 tmp
= rse
.loop
->loopvar
[n
];
2328 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2329 tmp
, rse
.loop
->from
[n
]);
2330 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2333 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2334 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2335 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2336 tmp_str
, gfc_index_one_node
);
2338 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2342 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2343 tmp_index
, rse
.loop
->from
[0]);
2344 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2346 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2347 rse
.loop
->loopvar
[0], offset
);
2349 /* Now use the offset for the reference. */
2350 tmp
= build_fold_indirect_ref_loc (input_location
,
2352 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2354 if (expr
->ts
.type
== BT_CHARACTER
)
2355 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2357 gfc_conv_expr (&lse
, expr
);
2359 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2361 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2362 gfc_add_expr_to_block (&body
, tmp
);
2364 /* Generate the copying loops. */
2365 gfc_trans_scalarizing_loops (&loop2
, &body
);
2367 /* Wrap the whole thing up by adding the second loop to the post-block
2368 and following it by the post-block of the first loop. In this way,
2369 if the temporary needs freeing, it is done after use! */
2370 if (intent
!= INTENT_IN
)
2372 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2373 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2376 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2378 gfc_cleanup_loop (&loop
);
2379 gfc_cleanup_loop (&loop2
);
2381 /* Pass the string length to the argument expression. */
2382 if (expr
->ts
.type
== BT_CHARACTER
)
2383 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2385 /* Determine the offset for pointer formal arguments and set the
2389 size
= gfc_index_one_node
;
2390 offset
= gfc_index_zero_node
;
2391 for (n
= 0; n
< dimen
; n
++)
2393 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2395 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2396 tmp
, gfc_index_one_node
);
2397 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2401 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2404 gfc_index_one_node
);
2405 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2406 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2408 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2409 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2410 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2411 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2412 tmp
, gfc_index_one_node
);
2413 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2417 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2421 /* We want either the address for the data or the address of the descriptor,
2422 depending on the mode of passing array arguments. */
2424 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2426 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2432 /* Generate the code for argument list functions. */
2435 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2437 /* Pass by value for g77 %VAL(arg), pass the address
2438 indirectly for %LOC, else by reference. Thus %REF
2439 is a "do-nothing" and %LOC is the same as an F95
2441 if (strncmp (name
, "%VAL", 4) == 0)
2442 gfc_conv_expr (se
, expr
);
2443 else if (strncmp (name
, "%LOC", 4) == 0)
2445 gfc_conv_expr_reference (se
, expr
);
2446 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2448 else if (strncmp (name
, "%REF", 4) == 0)
2449 gfc_conv_expr_reference (se
, expr
);
2451 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2455 /* Takes a derived type expression and returns the address of a temporary
2456 class object of the 'declared' type. */
2458 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2459 gfc_typespec class_ts
)
2463 gfc_symbol
*declared
= class_ts
.u
.derived
;
2469 /* The derived type needs to be converted to a temporary
2471 tmp
= gfc_typenode_for_spec (&class_ts
);
2472 var
= gfc_create_var (tmp
, "class");
2475 cmp
= gfc_find_component (declared
, "$vptr", true, true);
2476 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2477 var
, cmp
->backend_decl
, NULL_TREE
);
2479 /* Remember the vtab corresponds to the derived type
2480 not to the class declared type. */
2481 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
, true);
2483 gfc_trans_assign_vtab_procs (&parmse
->pre
, e
->ts
.u
.derived
, vtab
);
2484 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2485 gfc_add_modify (&parmse
->pre
, ctree
,
2486 fold_convert (TREE_TYPE (ctree
), tmp
));
2488 /* Now set the data field. */
2489 cmp
= gfc_find_component (declared
, "$data", true, true);
2490 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2491 var
, cmp
->backend_decl
, NULL_TREE
);
2492 ss
= gfc_walk_expr (e
);
2493 if (ss
== gfc_ss_terminator
)
2495 gfc_conv_expr_reference (parmse
, e
);
2496 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2497 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2501 gfc_conv_expr (parmse
, e
);
2502 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2505 /* Pass the address of the class object. */
2506 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2510 /* The following routine generates code for the intrinsic
2511 procedures from the ISO_C_BINDING module:
2513 * C_FUNLOC (function)
2514 * C_F_POINTER (subroutine)
2515 * C_F_PROCPOINTER (subroutine)
2516 * C_ASSOCIATED (function)
2517 One exception which is not handled here is C_F_POINTER with non-scalar
2518 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2521 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2522 gfc_actual_arglist
* arg
)
2527 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2529 if (arg
->expr
->rank
== 0)
2530 gfc_conv_expr_reference (se
, arg
->expr
);
2534 /* This is really the actual arg because no formal arglist is
2535 created for C_LOC. */
2536 fsym
= arg
->expr
->symtree
->n
.sym
;
2538 /* We should want it to do g77 calling convention. */
2540 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2541 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2542 f
= f
|| !sym
->attr
.always_explicit
;
2544 argss
= gfc_walk_expr (arg
->expr
);
2545 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2549 /* TODO -- the following two lines shouldn't be necessary, but if
2550 they're removed, a bug is exposed later in the code path.
2551 This workaround was thus introduced, but will have to be
2552 removed; please see PR 35150 for details about the issue. */
2553 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2554 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2558 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2560 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2561 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2562 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2563 gfc_conv_expr_reference (se
, arg
->expr
);
2567 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2568 && arg
->next
->expr
->rank
== 0)
2569 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2571 /* Convert c_f_pointer if fptr is a scalar
2572 and convert c_f_procpointer. */
2576 gfc_init_se (&cptrse
, NULL
);
2577 gfc_conv_expr (&cptrse
, arg
->expr
);
2578 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2579 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2581 gfc_init_se (&fptrse
, NULL
);
2582 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2583 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2584 fptrse
.want_pointer
= 1;
2586 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2587 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2588 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2590 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2591 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2592 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2595 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (fptrse
.expr
),
2597 fold_convert (TREE_TYPE (fptrse
.expr
),
2602 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2607 /* Build the addr_expr for the first argument. The argument is
2608 already an *address* so we don't need to set want_pointer in
2610 gfc_init_se (&arg1se
, NULL
);
2611 gfc_conv_expr (&arg1se
, arg
->expr
);
2612 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2613 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2615 /* See if we were given two arguments. */
2616 if (arg
->next
== NULL
)
2617 /* Only given one arg so generate a null and do a
2618 not-equal comparison against the first arg. */
2619 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2620 fold_convert (TREE_TYPE (arg1se
.expr
),
2621 null_pointer_node
));
2627 /* Given two arguments so build the arg2se from second arg. */
2628 gfc_init_se (&arg2se
, NULL
);
2629 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2630 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2631 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2633 /* Generate test to compare that the two args are equal. */
2634 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2635 arg1se
.expr
, arg2se
.expr
);
2636 /* Generate test to ensure that the first arg is not null. */
2637 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2638 arg1se
.expr
, null_pointer_node
);
2640 /* Finally, the generated test must check that both arg1 is not
2641 NULL and that it is equal to the second arg. */
2642 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2643 not_null_expr
, eq_expr
);
2649 /* Nothing was done. */
2654 /* Generate code for a procedure call. Note can return se->post != NULL.
2655 If se->direct_byref is set then se->expr contains the return parameter.
2656 Return nonzero, if the call has alternate specifiers.
2657 'expr' is only needed for procedure pointer components. */
2660 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2661 gfc_actual_arglist
* arg
, gfc_expr
* expr
,
2664 gfc_interface_mapping mapping
;
2679 gfc_formal_arglist
*formal
;
2680 int has_alternate_specifier
= 0;
2681 bool need_interface_mapping
;
2688 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2689 gfc_component
*comp
= NULL
;
2691 arglist
= NULL_TREE
;
2692 retargs
= NULL_TREE
;
2693 stringargs
= NULL_TREE
;
2698 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2699 && conv_isocbinding_procedure (se
, sym
, arg
))
2702 gfc_is_proc_ptr_comp (expr
, &comp
);
2706 if (!sym
->attr
.elemental
)
2708 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2709 if (se
->ss
->useflags
)
2711 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2712 && sym
->result
->attr
.dimension
)
2713 || (comp
&& comp
->attr
.dimension
));
2714 gcc_assert (se
->loop
!= NULL
);
2716 /* Access the previously obtained result. */
2717 gfc_conv_tmp_array_ref (se
);
2718 gfc_advance_se_ss_chain (se
);
2722 info
= &se
->ss
->data
.info
;
2727 gfc_init_block (&post
);
2728 gfc_init_interface_mapping (&mapping
);
2731 formal
= sym
->formal
;
2732 need_interface_mapping
= sym
->attr
.dimension
||
2733 (sym
->ts
.type
== BT_CHARACTER
2734 && sym
->ts
.u
.cl
->length
2735 && sym
->ts
.u
.cl
->length
->expr_type
2740 formal
= comp
->formal
;
2741 need_interface_mapping
= comp
->attr
.dimension
||
2742 (comp
->ts
.type
== BT_CHARACTER
2743 && comp
->ts
.u
.cl
->length
2744 && comp
->ts
.u
.cl
->length
->expr_type
2748 /* Evaluate the arguments. */
2749 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2752 fsym
= formal
? formal
->sym
: NULL
;
2753 parm_kind
= MISSING
;
2757 if (se
->ignore_optional
)
2759 /* Some intrinsics have already been resolved to the correct
2763 else if (arg
->label
)
2765 has_alternate_specifier
= 1;
2770 /* Pass a NULL pointer for an absent arg. */
2771 gfc_init_se (&parmse
, NULL
);
2772 parmse
.expr
= null_pointer_node
;
2773 if (arg
->missing_arg_type
== BT_CHARACTER
)
2774 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2777 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2778 && e
->ts
.type
== BT_DERIVED
)
2780 /* The derived type needs to be converted to a temporary
2782 gfc_init_se (&parmse
, se
);
2783 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2785 else if (se
->ss
&& se
->ss
->useflags
)
2787 /* An elemental function inside a scalarized loop. */
2788 gfc_init_se (&parmse
, se
);
2789 gfc_conv_expr_reference (&parmse
, e
);
2790 parm_kind
= ELEMENTAL
;
2794 /* A scalar or transformational function. */
2795 gfc_init_se (&parmse
, NULL
);
2796 argss
= gfc_walk_expr (e
);
2798 if (argss
== gfc_ss_terminator
)
2800 if (e
->expr_type
== EXPR_VARIABLE
2801 && e
->symtree
->n
.sym
->attr
.cray_pointee
2802 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2804 /* The Cray pointer needs to be converted to a pointer to
2805 a type given by the expression. */
2806 gfc_conv_expr (&parmse
, e
);
2807 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2808 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2809 parmse
.expr
= convert (type
, tmp
);
2811 else if (fsym
&& fsym
->attr
.value
)
2813 if (fsym
->ts
.type
== BT_CHARACTER
2814 && fsym
->ts
.is_c_interop
2815 && fsym
->ns
->proc_name
!= NULL
2816 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2819 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2820 if (parmse
.expr
== NULL
)
2821 gfc_conv_expr (&parmse
, e
);
2824 gfc_conv_expr (&parmse
, e
);
2826 else if (arg
->name
&& arg
->name
[0] == '%')
2827 /* Argument list functions %VAL, %LOC and %REF are signalled
2828 through arg->name. */
2829 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2830 else if ((e
->expr_type
== EXPR_FUNCTION
)
2831 && ((e
->value
.function
.esym
2832 && e
->value
.function
.esym
->result
->attr
.pointer
)
2833 || (!e
->value
.function
.esym
2834 && e
->symtree
->n
.sym
->attr
.pointer
))
2835 && fsym
&& fsym
->attr
.target
)
2837 gfc_conv_expr (&parmse
, e
);
2838 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2840 else if (e
->expr_type
== EXPR_FUNCTION
2841 && e
->symtree
->n
.sym
->result
2842 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2843 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2845 /* Functions returning procedure pointers. */
2846 gfc_conv_expr (&parmse
, e
);
2847 if (fsym
&& fsym
->attr
.proc_pointer
)
2848 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2852 gfc_conv_expr_reference (&parmse
, e
);
2854 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2855 allocated on entry, it must be deallocated. */
2856 if (fsym
&& fsym
->attr
.allocatable
2857 && fsym
->attr
.intent
== INTENT_OUT
)
2861 gfc_init_block (&block
);
2862 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
2864 gfc_add_expr_to_block (&block
, tmp
);
2865 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
2866 parmse
.expr
, null_pointer_node
);
2867 gfc_add_expr_to_block (&block
, tmp
);
2869 if (fsym
->attr
.optional
2870 && e
->expr_type
== EXPR_VARIABLE
2871 && e
->symtree
->n
.sym
->attr
.optional
)
2873 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2874 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2875 gfc_finish_block (&block
),
2876 build_empty_stmt (input_location
));
2879 tmp
= gfc_finish_block (&block
);
2881 gfc_add_expr_to_block (&se
->pre
, tmp
);
2884 if (fsym
&& e
->expr_type
!= EXPR_NULL
2885 && ((fsym
->attr
.pointer
2886 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
2887 || (fsym
->attr
.proc_pointer
2888 && !(e
->expr_type
== EXPR_VARIABLE
2889 && e
->symtree
->n
.sym
->attr
.dummy
))
2890 || (e
->expr_type
== EXPR_VARIABLE
2891 && gfc_is_proc_ptr_comp (e
, NULL
))
2892 || fsym
->attr
.allocatable
))
2894 /* Scalar pointer dummy args require an extra level of
2895 indirection. The null pointer already contains
2896 this level of indirection. */
2897 parm_kind
= SCALAR_POINTER
;
2898 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2904 /* If the procedure requires an explicit interface, the actual
2905 argument is passed according to the corresponding formal
2906 argument. If the corresponding formal argument is a POINTER,
2907 ALLOCATABLE or assumed shape, we do not use g77's calling
2908 convention, and pass the address of the array descriptor
2909 instead. Otherwise we use g77's calling convention. */
2912 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2913 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2915 f
= f
|| !comp
->attr
.always_explicit
;
2917 f
= f
|| !sym
->attr
.always_explicit
;
2919 if (e
->expr_type
== EXPR_VARIABLE
2920 && is_subref_array (e
))
2921 /* The actual argument is a component reference to an
2922 array of derived types. In this case, the argument
2923 is converted to a temporary, which is passed and then
2924 written back after the procedure call. */
2925 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2926 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
2927 fsym
&& fsym
->attr
.pointer
);
2929 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
2932 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2933 allocated on entry, it must be deallocated. */
2934 if (fsym
&& fsym
->attr
.allocatable
2935 && fsym
->attr
.intent
== INTENT_OUT
)
2937 tmp
= build_fold_indirect_ref_loc (input_location
,
2939 tmp
= gfc_trans_dealloc_allocated (tmp
);
2940 if (fsym
->attr
.optional
2941 && e
->expr_type
== EXPR_VARIABLE
2942 && e
->symtree
->n
.sym
->attr
.optional
)
2943 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2944 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2945 tmp
, build_empty_stmt (input_location
));
2946 gfc_add_expr_to_block (&se
->pre
, tmp
);
2951 /* The case with fsym->attr.optional is that of a user subroutine
2952 with an interface indicating an optional argument. When we call
2953 an intrinsic subroutine, however, fsym is NULL, but we might still
2954 have an optional argument, so we proceed to the substitution
2956 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2958 /* If an optional argument is itself an optional dummy argument,
2959 check its presence and substitute a null if absent. This is
2960 only needed when passing an array to an elemental procedure
2961 as then array elements are accessed - or no NULL pointer is
2962 allowed and a "1" or "0" should be passed if not present.
2963 When passing a non-array-descriptor full array to a
2964 non-array-descriptor dummy, no check is needed. For
2965 array-descriptor actual to array-descriptor dummy, see
2966 PR 41911 for why a check has to be inserted.
2967 fsym == NULL is checked as intrinsics required the descriptor
2968 but do not always set fsym. */
2969 if (e
->expr_type
== EXPR_VARIABLE
2970 && e
->symtree
->n
.sym
->attr
.optional
2971 && ((e
->rank
> 0 && sym
->attr
.elemental
)
2972 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
2974 && (fsym
== NULL
|| fsym
->as
->type
== AS_ASSUMED_SHAPE
2975 || fsym
->as
->type
== AS_DEFERRED
))))
2976 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2977 e
->representation
.length
);
2982 /* Obtain the character length of an assumed character length
2983 length procedure from the typespec. */
2984 if (fsym
->ts
.type
== BT_CHARACTER
2985 && parmse
.string_length
== NULL_TREE
2986 && e
->ts
.type
== BT_PROCEDURE
2987 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2988 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
2989 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2991 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
2992 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2996 if (fsym
&& need_interface_mapping
&& e
)
2997 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
2999 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3000 gfc_add_block_to_block (&post
, &parmse
.post
);
3002 /* Allocated allocatable components of derived types must be
3003 deallocated for non-variable scalars. Non-variable arrays are
3004 dealt with in trans-array.c(gfc_conv_array_parameter). */
3005 if (e
&& e
->ts
.type
== BT_DERIVED
3006 && e
->ts
.u
.derived
->attr
.alloc_comp
3007 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3008 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3011 tmp
= build_fold_indirect_ref_loc (input_location
,
3013 parm_rank
= e
->rank
;
3021 case (SCALAR_POINTER
):
3022 tmp
= build_fold_indirect_ref_loc (input_location
,
3027 if (e
->expr_type
== EXPR_OP
3028 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3029 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3032 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3033 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3034 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3037 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3039 gfc_add_expr_to_block (&se
->post
, tmp
);
3042 /* Add argument checking of passing an unallocated/NULL actual to
3043 a nonallocatable/nonpointer dummy. */
3045 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3047 symbol_attribute
*attr
;
3051 if (e
->expr_type
== EXPR_VARIABLE
)
3052 attr
= &e
->symtree
->n
.sym
->attr
;
3053 else if (e
->expr_type
== EXPR_FUNCTION
)
3055 /* For intrinsic functions, the gfc_attr are not available. */
3056 if (e
->symtree
->n
.sym
->attr
.generic
&& e
->value
.function
.isym
)
3057 goto end_pointer_check
;
3059 if (e
->symtree
->n
.sym
->attr
.generic
)
3060 attr
= &e
->value
.function
.esym
->attr
;
3062 attr
= &e
->symtree
->n
.sym
->result
->attr
;
3065 goto end_pointer_check
;
3069 /* If the actual argument is an optional pointer/allocatable and
3070 the formal argument takes an nonpointer optional value,
3071 it is invalid to pass a non-present argument on, even
3072 though there is no technical reason for this in gfortran.
3073 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3074 tree present
, null_ptr
, type
;
3076 if (attr
->allocatable
3077 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3078 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3079 "allocated or not present", e
->symtree
->n
.sym
->name
);
3080 else if (attr
->pointer
3081 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3082 asprintf (&msg
, "Pointer actual argument '%s' is not "
3083 "associated or not present",
3084 e
->symtree
->n
.sym
->name
);
3085 else if (attr
->proc_pointer
3086 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3087 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3088 "associated or not present",
3089 e
->symtree
->n
.sym
->name
);
3091 goto end_pointer_check
;
3093 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3094 type
= TREE_TYPE (present
);
3095 present
= fold_build2 (EQ_EXPR
, boolean_type_node
, present
,
3096 fold_convert (type
, null_pointer_node
));
3097 type
= TREE_TYPE (parmse
.expr
);
3098 null_ptr
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3099 fold_convert (type
, null_pointer_node
));
3100 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
,
3105 if (attr
->allocatable
3106 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3107 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3108 "allocated", e
->symtree
->n
.sym
->name
);
3109 else if (attr
->pointer
3110 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3111 asprintf (&msg
, "Pointer actual argument '%s' is not "
3112 "associated", e
->symtree
->n
.sym
->name
);
3113 else if (attr
->proc_pointer
3114 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3115 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3116 "associated", e
->symtree
->n
.sym
->name
);
3118 goto end_pointer_check
;
3121 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3122 fold_convert (TREE_TYPE (parmse
.expr
),
3123 null_pointer_node
));
3126 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3133 /* Character strings are passed as two parameters, a length and a
3134 pointer - except for Bind(c) which only passes the pointer. */
3135 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3136 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
3138 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
3140 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3147 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3148 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3149 else if (ts
.type
== BT_CHARACTER
)
3151 if (ts
.u
.cl
->length
== NULL
)
3153 /* Assumed character length results are not allowed by 5.1.1.5 of the
3154 standard and are trapped in resolve.c; except in the case of SPREAD
3155 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3156 we take the character length of the first argument for the result.
3157 For dummies, we have to look through the formal argument list for
3158 this function and use the character length found there.*/
3159 if (!sym
->attr
.dummy
)
3160 cl
.backend_decl
= TREE_VALUE (stringargs
);
3163 formal
= sym
->ns
->proc_name
->formal
;
3164 for (; formal
; formal
= formal
->next
)
3165 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3166 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3173 /* Calculate the length of the returned string. */
3174 gfc_init_se (&parmse
, NULL
);
3175 if (need_interface_mapping
)
3176 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3178 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3179 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3180 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3182 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3183 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
3184 build_int_cst (gfc_charlen_type_node
, 0));
3185 cl
.backend_decl
= tmp
;
3188 /* Set up a charlen structure for it. */
3193 len
= cl
.backend_decl
;
3196 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3197 || (!comp
&& gfc_return_by_reference (sym
));
3200 if (se
->direct_byref
)
3202 /* Sometimes, too much indirection can be applied; e.g. for
3203 function_result = array_valued_recursive_function. */
3204 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3205 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3206 && GFC_DESCRIPTOR_TYPE_P
3207 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3208 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3211 result
= build_fold_indirect_ref_loc (input_location
,
3213 retargs
= gfc_chainon_list (retargs
, se
->expr
);
3215 else if (comp
&& comp
->attr
.dimension
)
3217 gcc_assert (se
->loop
&& info
);
3219 /* Set the type of the array. */
3220 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3221 info
->dimen
= se
->loop
->dimen
;
3223 /* Evaluate the bounds of the result, if known. */
3224 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3226 /* Create a temporary to store the result. In case the function
3227 returns a pointer, the temporary will be a shallow copy and
3228 mustn't be deallocated. */
3229 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3230 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3231 NULL_TREE
, false, !comp
->attr
.pointer
,
3232 callee_alloc
, &se
->ss
->expr
->where
);
3234 /* Pass the temporary as the first argument. */
3235 result
= info
->descriptor
;
3236 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3237 retargs
= gfc_chainon_list (retargs
, tmp
);
3239 else if (!comp
&& sym
->result
->attr
.dimension
)
3241 gcc_assert (se
->loop
&& info
);
3243 /* Set the type of the array. */
3244 tmp
= gfc_typenode_for_spec (&ts
);
3245 info
->dimen
= se
->loop
->dimen
;
3247 /* Evaluate the bounds of the result, if known. */
3248 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3250 /* Create a temporary to store the result. In case the function
3251 returns a pointer, the temporary will be a shallow copy and
3252 mustn't be deallocated. */
3253 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3254 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3255 NULL_TREE
, false, !sym
->attr
.pointer
,
3256 callee_alloc
, &se
->ss
->expr
->where
);
3258 /* Pass the temporary as the first argument. */
3259 result
= info
->descriptor
;
3260 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3261 retargs
= gfc_chainon_list (retargs
, tmp
);
3263 else if (ts
.type
== BT_CHARACTER
)
3265 /* Pass the string length. */
3266 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3267 type
= build_pointer_type (type
);
3269 /* Return an address to a char[0:len-1]* temporary for
3270 character pointers. */
3271 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3272 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3274 var
= gfc_create_var (type
, "pstr");
3276 if ((!comp
&& sym
->attr
.allocatable
)
3277 || (comp
&& comp
->attr
.allocatable
))
3278 gfc_add_modify (&se
->pre
, var
,
3279 fold_convert (TREE_TYPE (var
),
3280 null_pointer_node
));
3282 /* Provide an address expression for the function arguments. */
3283 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3286 var
= gfc_conv_string_tmp (se
, type
, len
);
3288 retargs
= gfc_chainon_list (retargs
, var
);
3292 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3294 type
= gfc_get_complex_type (ts
.kind
);
3295 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3296 retargs
= gfc_chainon_list (retargs
, var
);
3299 /* Add the string length to the argument list. */
3300 if (ts
.type
== BT_CHARACTER
)
3301 retargs
= gfc_chainon_list (retargs
, len
);
3303 gfc_free_interface_mapping (&mapping
);
3305 /* Add the return arguments. */
3306 arglist
= chainon (retargs
, arglist
);
3308 /* Add the hidden string length parameters to the arguments. */
3309 arglist
= chainon (arglist
, stringargs
);
3311 /* We may want to append extra arguments here. This is used e.g. for
3312 calls to libgfortran_matmul_??, which need extra information. */
3313 if (append_args
!= NULL_TREE
)
3314 arglist
= chainon (arglist
, append_args
);
3316 /* Generate the actual call. */
3317 conv_function_val (se
, sym
, expr
);
3319 /* If there are alternate return labels, function type should be
3320 integer. Can't modify the type in place though, since it can be shared
3321 with other functions. For dummy arguments, the typing is done to
3322 to this result, even if it has to be repeated for each call. */
3323 if (has_alternate_specifier
3324 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3326 if (!sym
->attr
.dummy
)
3328 TREE_TYPE (sym
->backend_decl
)
3329 = build_function_type (integer_type_node
,
3330 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3331 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3334 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3337 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3338 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
3340 /* If we have a pointer function, but we don't want a pointer, e.g.
3343 where f is pointer valued, we have to dereference the result. */
3344 if (!se
->want_pointer
&& !byref
3345 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3346 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3347 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3350 /* f2c calling conventions require a scalar default real function to
3351 return a double precision result. Convert this back to default
3352 real. We only care about the cases that can happen in Fortran 77.
3354 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3355 && sym
->ts
.kind
== gfc_default_real_kind
3356 && !sym
->attr
.always_explicit
)
3357 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3359 /* A pure function may still have side-effects - it may modify its
3361 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3363 if (!sym
->attr
.pure
)
3364 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3369 /* Add the function call to the pre chain. There is no expression. */
3370 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3371 se
->expr
= NULL_TREE
;
3373 if (!se
->direct_byref
)
3375 if (sym
->attr
.dimension
|| (comp
&& comp
->attr
.dimension
))
3377 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3379 /* Check the data pointer hasn't been modified. This would
3380 happen in a function returning a pointer. */
3381 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3382 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3384 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3387 se
->expr
= info
->descriptor
;
3388 /* Bundle in the string length. */
3389 se
->string_length
= len
;
3391 else if (ts
.type
== BT_CHARACTER
)
3393 /* Dereference for character pointer results. */
3394 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3395 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3396 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3400 se
->string_length
= len
;
3404 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3405 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3410 /* Follow the function call with the argument post block. */
3413 gfc_add_block_to_block (&se
->pre
, &post
);
3415 /* Transformational functions of derived types with allocatable
3416 components must have the result allocatable components copied. */
3417 arg
= expr
->value
.function
.actual
;
3418 if (result
&& arg
&& expr
->rank
3419 && expr
->value
.function
.isym
3420 && expr
->value
.function
.isym
->transformational
3421 && arg
->expr
->ts
.type
== BT_DERIVED
3422 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3425 /* Copy the allocatable components. We have to use a
3426 temporary here to prevent source allocatable components
3427 from being corrupted. */
3428 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3429 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3430 result
, tmp2
, expr
->rank
);
3431 gfc_add_expr_to_block (&se
->pre
, tmp
);
3432 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3434 gfc_add_expr_to_block (&se
->pre
, tmp
);
3436 /* Finally free the temporary's data field. */
3437 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3438 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3439 gfc_add_expr_to_block (&se
->pre
, tmp
);
3443 gfc_add_block_to_block (&se
->post
, &post
);
3445 return has_alternate_specifier
;
3449 /* Fill a character string with spaces. */
3452 fill_with_spaces (tree start
, tree type
, tree size
)
3454 stmtblock_t block
, loop
;
3455 tree i
, el
, exit_label
, cond
, tmp
;
3457 /* For a simple char type, we can call memset(). */
3458 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3459 return build_call_expr_loc (input_location
,
3460 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3461 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3462 lang_hooks
.to_target_charset (' ')),
3465 /* Otherwise, we use a loop:
3466 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3470 /* Initialize variables. */
3471 gfc_init_block (&block
);
3472 i
= gfc_create_var (sizetype
, "i");
3473 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3474 el
= gfc_create_var (build_pointer_type (type
), "el");
3475 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3476 exit_label
= gfc_build_label_decl (NULL_TREE
);
3477 TREE_USED (exit_label
) = 1;
3481 gfc_init_block (&loop
);
3483 /* Exit condition. */
3484 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3485 fold_convert (sizetype
, integer_zero_node
));
3486 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3487 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3488 build_empty_stmt (input_location
));
3489 gfc_add_expr_to_block (&loop
, tmp
);
3492 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3493 build_int_cst (type
,
3494 lang_hooks
.to_target_charset (' ')));
3496 /* Increment loop variables. */
3497 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3498 TYPE_SIZE_UNIT (type
)));
3499 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3501 TYPE_SIZE_UNIT (type
)));
3503 /* Making the loop... actually loop! */
3504 tmp
= gfc_finish_block (&loop
);
3505 tmp
= build1_v (LOOP_EXPR
, tmp
);
3506 gfc_add_expr_to_block (&block
, tmp
);
3508 /* The exit label. */
3509 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3510 gfc_add_expr_to_block (&block
, tmp
);
3513 return gfc_finish_block (&block
);
3517 /* Generate code to copy a string. */
3520 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3521 int dkind
, tree slength
, tree src
, int skind
)
3523 tree tmp
, dlen
, slen
;
3532 stmtblock_t tempblock
;
3534 gcc_assert (dkind
== skind
);
3536 if (slength
!= NULL_TREE
)
3538 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3539 ssc
= string_to_single_character (slen
, src
, skind
);
3543 slen
= build_int_cst (size_type_node
, 1);
3547 if (dlength
!= NULL_TREE
)
3549 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3550 dsc
= string_to_single_character (slen
, dest
, dkind
);
3554 dlen
= build_int_cst (size_type_node
, 1);
3558 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3559 ssc
= string_to_single_character (slen
, src
, skind
);
3560 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3561 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3564 /* Assign directly if the types are compatible. */
3565 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3566 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3568 gfc_add_modify (block
, dsc
, ssc
);
3572 /* Do nothing if the destination length is zero. */
3573 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3574 build_int_cst (size_type_node
, 0));
3576 /* The following code was previously in _gfortran_copy_string:
3578 // The two strings may overlap so we use memmove.
3580 copy_string (GFC_INTEGER_4 destlen, char * dest,
3581 GFC_INTEGER_4 srclen, const char * src)
3583 if (srclen >= destlen)
3585 // This will truncate if too long.
3586 memmove (dest, src, destlen);
3590 memmove (dest, src, srclen);
3592 memset (&dest[srclen], ' ', destlen - srclen);
3596 We're now doing it here for better optimization, but the logic
3599 /* For non-default character kinds, we have to multiply the string
3600 length by the base type size. */
3601 chartype
= gfc_get_char_type (dkind
);
3602 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3603 fold_convert (size_type_node
, slen
),
3604 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3605 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3606 fold_convert (size_type_node
, dlen
),
3607 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3610 dest
= fold_convert (pvoid_type_node
, dest
);
3612 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3615 src
= fold_convert (pvoid_type_node
, src
);
3617 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3619 /* Truncate string if source is too long. */
3620 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3621 tmp2
= build_call_expr_loc (input_location
,
3622 built_in_decls
[BUILT_IN_MEMMOVE
],
3623 3, dest
, src
, dlen
);
3625 /* Else copy and pad with spaces. */
3626 tmp3
= build_call_expr_loc (input_location
,
3627 built_in_decls
[BUILT_IN_MEMMOVE
],
3628 3, dest
, src
, slen
);
3630 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3631 fold_convert (sizetype
, slen
));
3632 tmp4
= fill_with_spaces (tmp4
, chartype
,
3633 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3636 gfc_init_block (&tempblock
);
3637 gfc_add_expr_to_block (&tempblock
, tmp3
);
3638 gfc_add_expr_to_block (&tempblock
, tmp4
);
3639 tmp3
= gfc_finish_block (&tempblock
);
3641 /* The whole copy_string function is there. */
3642 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3643 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3644 build_empty_stmt (input_location
));
3645 gfc_add_expr_to_block (block
, tmp
);
3649 /* Translate a statement function.
3650 The value of a statement function reference is obtained by evaluating the
3651 expression using the values of the actual arguments for the values of the
3652 corresponding dummy arguments. */
3655 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3659 gfc_formal_arglist
*fargs
;
3660 gfc_actual_arglist
*args
;
3663 gfc_saved_var
*saved_vars
;
3669 sym
= expr
->symtree
->n
.sym
;
3670 args
= expr
->value
.function
.actual
;
3671 gfc_init_se (&lse
, NULL
);
3672 gfc_init_se (&rse
, NULL
);
3675 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3677 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3678 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3680 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3682 /* Each dummy shall be specified, explicitly or implicitly, to be
3684 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3687 /* Create a temporary to hold the value. */
3688 type
= gfc_typenode_for_spec (&fsym
->ts
);
3689 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3691 if (fsym
->ts
.type
== BT_CHARACTER
)
3693 /* Copy string arguments. */
3696 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3697 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3699 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3700 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3703 gfc_conv_expr (&rse
, args
->expr
);
3704 gfc_conv_string_parameter (&rse
);
3705 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3706 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3708 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3709 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3710 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3711 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3715 /* For everything else, just evaluate the expression. */
3716 gfc_conv_expr (&lse
, args
->expr
);
3718 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3719 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3720 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3726 /* Use the temporary variables in place of the real ones. */
3727 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3728 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3730 gfc_conv_expr (se
, sym
->value
);
3732 if (sym
->ts
.type
== BT_CHARACTER
)
3734 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3736 /* Force the expression to the correct length. */
3737 if (!INTEGER_CST_P (se
->string_length
)
3738 || tree_int_cst_lt (se
->string_length
,
3739 sym
->ts
.u
.cl
->backend_decl
))
3741 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3742 tmp
= gfc_create_var (type
, sym
->name
);
3743 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3744 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3745 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3749 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3752 /* Restore the original variables. */
3753 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3754 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3755 gfc_free (saved_vars
);
3759 /* Translate a function expression. */
3762 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3766 if (expr
->value
.function
.isym
)
3768 gfc_conv_intrinsic_function (se
, expr
);
3772 /* We distinguish statement functions from general functions to improve
3773 runtime performance. */
3774 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3776 gfc_conv_statement_function (se
, expr
);
3780 /* expr.value.function.esym is the resolved (specific) function symbol for
3781 most functions. However this isn't set for dummy procedures. */
3782 sym
= expr
->value
.function
.esym
;
3784 sym
= expr
->symtree
->n
.sym
;
3786 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3791 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3794 is_zero_initializer_p (gfc_expr
* expr
)
3796 if (expr
->expr_type
!= EXPR_CONSTANT
)
3799 /* We ignore constants with prescribed memory representations for now. */
3800 if (expr
->representation
.string
)
3803 switch (expr
->ts
.type
)
3806 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3809 return mpfr_zero_p (expr
->value
.real
)
3810 && MPFR_SIGN (expr
->value
.real
) >= 0;
3813 return expr
->value
.logical
== 0;
3816 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
3817 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
3818 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
3819 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
3829 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3831 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3832 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3834 gfc_conv_tmp_array_ref (se
);
3835 gfc_advance_se_ss_chain (se
);
3839 /* Build a static initializer. EXPR is the expression for the initial value.
3840 The other parameters describe the variable of the component being
3841 initialized. EXPR may be null. */
3844 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3845 bool array
, bool pointer
)
3849 if (!(expr
|| pointer
))
3852 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3853 (these are the only two iso_c_binding derived types that can be
3854 used as initialization expressions). If so, we need to modify
3855 the 'expr' to be that for a (void *). */
3856 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3857 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
3859 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
3861 /* The derived symbol has already been converted to a (void *). Use
3863 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
3864 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3866 gfc_init_se (&se
, NULL
);
3867 gfc_conv_constant (&se
, expr
);
3873 /* Arrays need special handling. */
3875 return gfc_build_null_descriptor (type
);
3876 /* Special case assigning an array to zero. */
3877 else if (is_zero_initializer_p (expr
))
3878 return build_constructor (type
, NULL
);
3880 return gfc_conv_array_initializer (type
, expr
);
3883 return fold_convert (type
, null_pointer_node
);
3890 gfc_init_se (&se
, NULL
);
3891 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
3892 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
3894 gfc_conv_structure (&se
, expr
, 1);
3898 return gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
3901 gfc_init_se (&se
, NULL
);
3902 gfc_conv_constant (&se
, expr
);
3909 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3921 gfc_start_block (&block
);
3923 /* Initialize the scalarizer. */
3924 gfc_init_loopinfo (&loop
);
3926 gfc_init_se (&lse
, NULL
);
3927 gfc_init_se (&rse
, NULL
);
3930 rss
= gfc_walk_expr (expr
);
3931 if (rss
== gfc_ss_terminator
)
3933 /* The rhs is scalar. Add a ss for the expression. */
3934 rss
= gfc_get_ss ();
3935 rss
->next
= gfc_ss_terminator
;
3936 rss
->type
= GFC_SS_SCALAR
;
3940 /* Create a SS for the destination. */
3941 lss
= gfc_get_ss ();
3942 lss
->type
= GFC_SS_COMPONENT
;
3944 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3945 lss
->next
= gfc_ss_terminator
;
3946 lss
->data
.info
.dimen
= cm
->as
->rank
;
3947 lss
->data
.info
.descriptor
= dest
;
3948 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3949 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3950 for (n
= 0; n
< cm
->as
->rank
; n
++)
3952 lss
->data
.info
.dim
[n
] = n
;
3953 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3954 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3956 mpz_init (lss
->shape
[n
]);
3957 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3958 cm
->as
->lower
[n
]->value
.integer
);
3959 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3962 /* Associate the SS with the loop. */
3963 gfc_add_ss_to_loop (&loop
, lss
);
3964 gfc_add_ss_to_loop (&loop
, rss
);
3966 /* Calculate the bounds of the scalarization. */
3967 gfc_conv_ss_startstride (&loop
);
3969 /* Setup the scalarizing loops. */
3970 gfc_conv_loop_setup (&loop
, &expr
->where
);
3972 /* Setup the gfc_se structures. */
3973 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3974 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3977 gfc_mark_ss_chain_used (rss
, 1);
3979 gfc_mark_ss_chain_used (lss
, 1);
3981 /* Start the scalarized loop body. */
3982 gfc_start_scalarized_body (&loop
, &body
);
3984 gfc_conv_tmp_array_ref (&lse
);
3985 if (cm
->ts
.type
== BT_CHARACTER
)
3986 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
3988 gfc_conv_expr (&rse
, expr
);
3990 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
3991 gfc_add_expr_to_block (&body
, tmp
);
3993 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3995 /* Generate the copying loops. */
3996 gfc_trans_scalarizing_loops (&loop
, &body
);
3998 /* Wrap the whole thing up. */
3999 gfc_add_block_to_block (&block
, &loop
.pre
);
4000 gfc_add_block_to_block (&block
, &loop
.post
);
4002 for (n
= 0; n
< cm
->as
->rank
; n
++)
4003 mpz_clear (lss
->shape
[n
]);
4004 gfc_free (lss
->shape
);
4006 gfc_cleanup_loop (&loop
);
4008 return gfc_finish_block (&block
);
4013 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4024 gfc_expr
*arg
= NULL
;
4026 gfc_start_block (&block
);
4027 gfc_init_se (&se
, NULL
);
4029 /* Get the descriptor for the expressions. */
4030 rss
= gfc_walk_expr (expr
);
4031 se
.want_pointer
= 0;
4032 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4033 gfc_add_block_to_block (&block
, &se
.pre
);
4034 gfc_add_modify (&block
, dest
, se
.expr
);
4036 /* Deal with arrays of derived types with allocatable components. */
4037 if (cm
->ts
.type
== BT_DERIVED
4038 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4039 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4043 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4044 TREE_TYPE(cm
->backend_decl
),
4047 gfc_add_expr_to_block (&block
, tmp
);
4048 gfc_add_block_to_block (&block
, &se
.post
);
4050 if (expr
->expr_type
!= EXPR_VARIABLE
)
4051 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4054 /* We need to know if the argument of a conversion function is a
4055 variable, so that the correct lower bound can be used. */
4056 if (expr
->expr_type
== EXPR_FUNCTION
4057 && expr
->value
.function
.isym
4058 && expr
->value
.function
.isym
->conversion
4059 && expr
->value
.function
.actual
->expr
4060 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4061 arg
= expr
->value
.function
.actual
->expr
;
4063 /* Obtain the array spec of full array references. */
4065 as
= gfc_get_full_arrayspec_from_expr (arg
);
4067 as
= gfc_get_full_arrayspec_from_expr (expr
);
4069 /* Shift the lbound and ubound of temporaries to being unity,
4070 rather than zero, based. Always calculate the offset. */
4071 offset
= gfc_conv_descriptor_offset_get (dest
);
4072 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4073 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4075 for (n
= 0; n
< expr
->rank
; n
++)
4080 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4081 TODO It looks as if gfc_conv_expr_descriptor should return
4082 the correct bounds and that the following should not be
4083 necessary. This would simplify gfc_conv_intrinsic_bound
4085 if (as
&& as
->lower
[n
])
4088 gfc_init_se (&lbse
, NULL
);
4089 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4090 gfc_add_block_to_block (&block
, &lbse
.pre
);
4091 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4095 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4096 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4100 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4103 lbound
= gfc_index_one_node
;
4105 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4107 /* Shift the bounds and set the offset accordingly. */
4108 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4109 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
4110 gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4111 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, span
, lbound
);
4112 gfc_conv_descriptor_ubound_set (&block
, dest
,
4113 gfc_rank_cst
[n
], tmp
);
4114 gfc_conv_descriptor_lbound_set (&block
, dest
,
4115 gfc_rank_cst
[n
], lbound
);
4117 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4118 gfc_conv_descriptor_lbound_get (dest
,
4120 gfc_conv_descriptor_stride_get (dest
,
4122 gfc_add_modify (&block
, tmp2
, tmp
);
4123 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
4124 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4129 /* If a conversion expression has a null data pointer
4130 argument, nullify the allocatable component. */
4134 if (arg
->symtree
->n
.sym
->attr
.allocatable
4135 || arg
->symtree
->n
.sym
->attr
.pointer
)
4137 non_null_expr
= gfc_finish_block (&block
);
4138 gfc_start_block (&block
);
4139 gfc_conv_descriptor_data_set (&block
, dest
,
4141 null_expr
= gfc_finish_block (&block
);
4142 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4143 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
4144 fold_convert (TREE_TYPE (tmp
),
4145 null_pointer_node
));
4146 return build3_v (COND_EXPR
, tmp
,
4147 null_expr
, non_null_expr
);
4151 return gfc_finish_block (&block
);
4155 /* Assign a single component of a derived type constructor. */
4158 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4166 gfc_start_block (&block
);
4168 if (cm
->attr
.pointer
)
4170 gfc_init_se (&se
, NULL
);
4171 /* Pointer component. */
4172 if (cm
->attr
.dimension
)
4174 /* Array pointer. */
4175 if (expr
->expr_type
== EXPR_NULL
)
4176 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4179 rss
= gfc_walk_expr (expr
);
4180 se
.direct_byref
= 1;
4182 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4183 gfc_add_block_to_block (&block
, &se
.pre
);
4184 gfc_add_block_to_block (&block
, &se
.post
);
4189 /* Scalar pointers. */
4190 se
.want_pointer
= 1;
4191 gfc_conv_expr (&se
, expr
);
4192 gfc_add_block_to_block (&block
, &se
.pre
);
4193 gfc_add_modify (&block
, dest
,
4194 fold_convert (TREE_TYPE (dest
), se
.expr
));
4195 gfc_add_block_to_block (&block
, &se
.post
);
4198 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4200 /* NULL initialization for CLASS components. */
4201 tmp
= gfc_trans_structure_assign (dest
,
4202 gfc_class_null_initializer (&cm
->ts
));
4203 gfc_add_expr_to_block (&block
, tmp
);
4205 else if (cm
->attr
.dimension
)
4207 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4208 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4209 else if (cm
->attr
.allocatable
)
4211 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4212 gfc_add_expr_to_block (&block
, tmp
);
4216 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4217 gfc_add_expr_to_block (&block
, tmp
);
4220 else if (expr
->ts
.type
== BT_DERIVED
)
4222 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4224 gfc_init_se (&se
, NULL
);
4225 gfc_conv_expr (&se
, expr
);
4226 gfc_add_block_to_block (&block
, &se
.pre
);
4227 gfc_add_modify (&block
, dest
,
4228 fold_convert (TREE_TYPE (dest
), se
.expr
));
4229 gfc_add_block_to_block (&block
, &se
.post
);
4233 /* Nested constructors. */
4234 tmp
= gfc_trans_structure_assign (dest
, expr
);
4235 gfc_add_expr_to_block (&block
, tmp
);
4240 /* Scalar component. */
4241 gfc_init_se (&se
, NULL
);
4242 gfc_init_se (&lse
, NULL
);
4244 gfc_conv_expr (&se
, expr
);
4245 if (cm
->ts
.type
== BT_CHARACTER
)
4246 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4248 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4249 gfc_add_expr_to_block (&block
, tmp
);
4251 return gfc_finish_block (&block
);
4254 /* Assign a derived type constructor to a variable. */
4257 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4265 gfc_start_block (&block
);
4266 cm
= expr
->ts
.u
.derived
->components
;
4267 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4268 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4270 /* Skip absent members in default initializers. */
4274 /* Handle c_null_(fun)ptr. */
4275 if (c
&& c
->expr
&& c
->expr
->ts
.is_iso_c
)
4277 field
= cm
->backend_decl
;
4278 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4279 dest
, field
, NULL_TREE
);
4280 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
), tmp
,
4281 fold_convert (TREE_TYPE (tmp
),
4282 null_pointer_node
));
4283 gfc_add_expr_to_block (&block
, tmp
);
4287 field
= cm
->backend_decl
;
4288 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4289 dest
, field
, NULL_TREE
);
4290 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4291 gfc_add_expr_to_block (&block
, tmp
);
4293 return gfc_finish_block (&block
);
4296 /* Build an expression for a constructor. If init is nonzero then
4297 this is part of a static variable initializer. */
4300 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4307 VEC(constructor_elt
,gc
) *v
= NULL
;
4309 gcc_assert (se
->ss
== NULL
);
4310 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4311 type
= gfc_typenode_for_spec (&expr
->ts
);
4315 /* Create a temporary variable and fill it in. */
4316 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4317 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4318 gfc_add_expr_to_block (&se
->pre
, tmp
);
4322 cm
= expr
->ts
.u
.derived
->components
;
4324 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4325 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4327 /* Skip absent members in default initializers and allocatable
4328 components. Although the latter have a default initializer
4329 of EXPR_NULL,... by default, the static nullify is not needed
4330 since this is done every time we come into scope. */
4331 if (!c
->expr
|| cm
->attr
.allocatable
)
4334 if (strcmp (cm
->name
, "$size") == 0)
4336 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4337 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4339 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4340 && strcmp (cm
->name
, "$extends") == 0)
4344 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4345 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4346 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4350 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4351 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
,
4352 cm
->attr
.pointer
|| cm
->attr
.proc_pointer
);
4354 /* Append it to the constructor list. */
4355 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4358 se
->expr
= build_constructor (type
, v
);
4360 TREE_CONSTANT (se
->expr
) = 1;
4364 /* Translate a substring expression. */
4367 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4373 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4375 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4376 expr
->value
.character
.length
,
4377 expr
->value
.character
.string
);
4379 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4380 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4383 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4387 /* Entry point for expression translation. Evaluates a scalar quantity.
4388 EXPR is the expression to be translated, and SE is the state structure if
4389 called from within the scalarized. */
4392 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4394 if (se
->ss
&& se
->ss
->expr
== expr
4395 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4397 /* Substitute a scalar expression evaluated outside the scalarization
4399 se
->expr
= se
->ss
->data
.scalar
.expr
;
4400 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4401 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4402 se
->string_length
= se
->ss
->string_length
;
4403 gfc_advance_se_ss_chain (se
);
4407 /* We need to convert the expressions for the iso_c_binding derived types.
4408 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4409 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4410 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4411 updated to be an integer with a kind equal to the size of a (void *). */
4412 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4413 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4415 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4416 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4418 /* Set expr_type to EXPR_NULL, which will result in
4419 null_pointer_node being used below. */
4420 expr
->expr_type
= EXPR_NULL
;
4424 /* Update the type/kind of the expression to be what the new
4425 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4426 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4427 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4428 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4432 switch (expr
->expr_type
)
4435 gfc_conv_expr_op (se
, expr
);
4439 gfc_conv_function_expr (se
, expr
);
4443 gfc_conv_constant (se
, expr
);
4447 gfc_conv_variable (se
, expr
);
4451 se
->expr
= null_pointer_node
;
4454 case EXPR_SUBSTRING
:
4455 gfc_conv_substring_expr (se
, expr
);
4458 case EXPR_STRUCTURE
:
4459 gfc_conv_structure (se
, expr
, 0);
4463 gfc_conv_array_constructor_expr (se
, expr
);
4472 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4473 of an assignment. */
4475 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4477 gfc_conv_expr (se
, expr
);
4478 /* All numeric lvalues should have empty post chains. If not we need to
4479 figure out a way of rewriting an lvalue so that it has no post chain. */
4480 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4483 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4484 numeric expressions. Used for scalar values where inserting cleanup code
4487 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4491 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4492 gfc_conv_expr (se
, expr
);
4495 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4496 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4498 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4502 /* Helper to translate an expression and convert it to a particular type. */
4504 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4506 gfc_conv_expr_val (se
, expr
);
4507 se
->expr
= convert (type
, se
->expr
);
4511 /* Converts an expression so that it can be passed by reference. Scalar
4515 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4519 if (se
->ss
&& se
->ss
->expr
== expr
4520 && se
->ss
->type
== GFC_SS_REFERENCE
)
4522 /* Returns a reference to the scalar evaluated outside the loop
4524 gfc_conv_expr (se
, expr
);
4528 if (expr
->ts
.type
== BT_CHARACTER
)
4530 gfc_conv_expr (se
, expr
);
4531 gfc_conv_string_parameter (se
);
4535 if (expr
->expr_type
== EXPR_VARIABLE
)
4537 se
->want_pointer
= 1;
4538 gfc_conv_expr (se
, expr
);
4541 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4542 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4543 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4549 if (expr
->expr_type
== EXPR_FUNCTION
4550 && ((expr
->value
.function
.esym
4551 && expr
->value
.function
.esym
->result
->attr
.pointer
4552 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4553 || (!expr
->value
.function
.esym
4554 && expr
->symtree
->n
.sym
->attr
.pointer
4555 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4557 se
->want_pointer
= 1;
4558 gfc_conv_expr (se
, expr
);
4559 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4560 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4566 gfc_conv_expr (se
, expr
);
4568 /* Create a temporary var to hold the value. */
4569 if (TREE_CONSTANT (se
->expr
))
4571 tree tmp
= se
->expr
;
4572 STRIP_TYPE_NOPS (tmp
);
4573 var
= build_decl (input_location
,
4574 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4575 DECL_INITIAL (var
) = tmp
;
4576 TREE_STATIC (var
) = 1;
4581 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4582 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4584 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4586 /* Take the address of that value. */
4587 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4592 gfc_trans_pointer_assign (gfc_code
* code
)
4594 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4598 /* Generate code for a pointer assignment. */
4601 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4612 gfc_start_block (&block
);
4614 gfc_init_se (&lse
, NULL
);
4616 lss
= gfc_walk_expr (expr1
);
4617 rss
= gfc_walk_expr (expr2
);
4618 if (lss
== gfc_ss_terminator
)
4620 /* Scalar pointers. */
4621 lse
.want_pointer
= 1;
4622 gfc_conv_expr (&lse
, expr1
);
4623 gcc_assert (rss
== gfc_ss_terminator
);
4624 gfc_init_se (&rse
, NULL
);
4625 rse
.want_pointer
= 1;
4626 gfc_conv_expr (&rse
, expr2
);
4628 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4629 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4630 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4633 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4634 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4635 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4638 gfc_add_block_to_block (&block
, &lse
.pre
);
4639 gfc_add_block_to_block (&block
, &rse
.pre
);
4641 /* Check character lengths if character expression. The test is only
4642 really added if -fbounds-check is enabled. */
4643 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4644 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4645 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4647 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4648 gcc_assert (lse
.string_length
&& rse
.string_length
);
4649 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4650 lse
.string_length
, rse
.string_length
,
4654 gfc_add_modify (&block
, lse
.expr
,
4655 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4657 gfc_add_block_to_block (&block
, &rse
.post
);
4658 gfc_add_block_to_block (&block
, &lse
.post
);
4663 tree strlen_rhs
= NULL_TREE
;
4665 /* Array pointer. */
4666 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4667 strlen_lhs
= lse
.string_length
;
4668 switch (expr2
->expr_type
)
4671 /* Just set the data pointer to null. */
4672 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4676 /* Assign directly to the pointer's descriptor. */
4677 lse
.direct_byref
= 1;
4678 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4679 strlen_rhs
= lse
.string_length
;
4681 /* If this is a subreference array pointer assignment, use the rhs
4682 descriptor element size for the lhs span. */
4683 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4685 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4686 gfc_init_se (&rse
, NULL
);
4687 rse
.descriptor_only
= 1;
4688 gfc_conv_expr (&rse
, expr2
);
4689 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4690 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4691 if (!INTEGER_CST_P (tmp
))
4692 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4693 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4699 /* Assign to a temporary descriptor and then copy that
4700 temporary to the pointer. */
4702 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4705 lse
.direct_byref
= 1;
4706 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4707 strlen_rhs
= lse
.string_length
;
4708 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4712 gfc_add_block_to_block (&block
, &lse
.pre
);
4714 /* Check string lengths if applicable. The check is only really added
4715 to the output code if -fbounds-check is enabled. */
4716 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4718 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4719 gcc_assert (strlen_lhs
&& strlen_rhs
);
4720 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4721 strlen_lhs
, strlen_rhs
, &block
);
4724 gfc_add_block_to_block (&block
, &lse
.post
);
4726 return gfc_finish_block (&block
);
4730 /* Makes sure se is suitable for passing as a function string parameter. */
4731 /* TODO: Need to check all callers of this function. It may be abused. */
4734 gfc_conv_string_parameter (gfc_se
* se
)
4738 if (TREE_CODE (se
->expr
) == STRING_CST
)
4740 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4741 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4745 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4747 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4749 type
= TREE_TYPE (se
->expr
);
4750 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4754 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4756 type
= build_pointer_type (type
);
4757 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4761 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4762 gcc_assert (se
->string_length
4763 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4767 /* Generate code for assignment of scalar variables. Includes character
4768 strings and derived types with allocatable components.
4769 If you know that the LHS has no allocations, set dealloc to false. */
4772 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4773 bool l_is_temp
, bool r_is_var
, bool dealloc
)
4779 gfc_init_block (&block
);
4781 if (ts
.type
== BT_CHARACTER
)
4786 if (lse
->string_length
!= NULL_TREE
)
4788 gfc_conv_string_parameter (lse
);
4789 gfc_add_block_to_block (&block
, &lse
->pre
);
4790 llen
= lse
->string_length
;
4793 if (rse
->string_length
!= NULL_TREE
)
4795 gcc_assert (rse
->string_length
!= NULL_TREE
);
4796 gfc_conv_string_parameter (rse
);
4797 gfc_add_block_to_block (&block
, &rse
->pre
);
4798 rlen
= rse
->string_length
;
4801 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4802 rse
->expr
, ts
.kind
);
4804 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
4808 /* Are the rhs and the lhs the same? */
4811 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4812 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
4813 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
4814 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4817 /* Deallocate the lhs allocated components as long as it is not
4818 the same as the rhs. This must be done following the assignment
4819 to prevent deallocating data that could be used in the rhs
4821 if (!l_is_temp
&& dealloc
)
4823 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4824 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
4826 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4828 gfc_add_expr_to_block (&lse
->post
, tmp
);
4831 gfc_add_block_to_block (&block
, &rse
->pre
);
4832 gfc_add_block_to_block (&block
, &lse
->pre
);
4834 gfc_add_modify (&block
, lse
->expr
,
4835 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4837 /* Do a deep copy if the rhs is a variable, if it is not the
4841 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
4842 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4844 gfc_add_expr_to_block (&block
, tmp
);
4847 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
4849 gfc_add_block_to_block (&block
, &lse
->pre
);
4850 gfc_add_block_to_block (&block
, &rse
->pre
);
4851 tmp
= fold_build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (lse
->expr
), rse
->expr
);
4852 gfc_add_modify (&block
, lse
->expr
, tmp
);
4856 gfc_add_block_to_block (&block
, &lse
->pre
);
4857 gfc_add_block_to_block (&block
, &rse
->pre
);
4859 gfc_add_modify (&block
, lse
->expr
,
4860 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4863 gfc_add_block_to_block (&block
, &lse
->post
);
4864 gfc_add_block_to_block (&block
, &rse
->post
);
4866 return gfc_finish_block (&block
);
4870 /* Try to translate array(:) = func (...), where func is a transformational
4871 array function, without using a temporary. Returns NULL is this isn't the
4875 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4880 bool seen_array_ref
;
4882 gfc_component
*comp
= NULL
;
4884 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4885 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
4888 /* Elemental functions don't need a temporary anyway. */
4889 if (expr2
->value
.function
.esym
!= NULL
4890 && expr2
->value
.function
.esym
->attr
.elemental
)
4893 /* Fail if rhs is not FULL or a contiguous section. */
4894 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
4897 /* Fail if EXPR1 can't be expressed as a descriptor. */
4898 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4901 /* Functions returning pointers need temporaries. */
4902 if (expr2
->symtree
->n
.sym
->attr
.pointer
4903 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4906 /* Character array functions need temporaries unless the
4907 character lengths are the same. */
4908 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4910 if (expr1
->ts
.u
.cl
->length
== NULL
4911 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4914 if (expr2
->ts
.u
.cl
->length
== NULL
4915 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4918 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
4919 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
4923 /* Check that no LHS component references appear during an array
4924 reference. This is needed because we do not have the means to
4925 span any arbitrary stride with an array descriptor. This check
4926 is not needed for the rhs because the function result has to be
4928 seen_array_ref
= false;
4929 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4931 if (ref
->type
== REF_ARRAY
)
4932 seen_array_ref
= true;
4933 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4937 /* Check for a dependency. */
4938 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4939 expr2
->value
.function
.esym
,
4940 expr2
->value
.function
.actual
,
4944 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4946 gcc_assert (expr2
->value
.function
.isym
4947 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
4948 && comp
&& comp
->attr
.dimension
)
4949 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
4950 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
4952 ss
= gfc_walk_expr (expr1
);
4953 gcc_assert (ss
!= gfc_ss_terminator
);
4954 gfc_init_se (&se
, NULL
);
4955 gfc_start_block (&se
.pre
);
4956 se
.want_pointer
= 1;
4958 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
4960 if (expr1
->ts
.type
== BT_DERIVED
4961 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
4964 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
4966 gfc_add_expr_to_block (&se
.pre
, tmp
);
4969 se
.direct_byref
= 1;
4970 se
.ss
= gfc_walk_expr (expr2
);
4971 gcc_assert (se
.ss
!= gfc_ss_terminator
);
4972 gfc_conv_function_expr (&se
, expr2
);
4973 gfc_add_block_to_block (&se
.pre
, &se
.post
);
4975 return gfc_finish_block (&se
.pre
);
4979 /* Try to efficiently translate array(:) = 0. Return NULL if this
4983 gfc_trans_zero_assign (gfc_expr
* expr
)
4985 tree dest
, len
, type
;
4989 sym
= expr
->symtree
->n
.sym
;
4990 dest
= gfc_get_symbol_decl (sym
);
4992 type
= TREE_TYPE (dest
);
4993 if (POINTER_TYPE_P (type
))
4994 type
= TREE_TYPE (type
);
4995 if (!GFC_ARRAY_TYPE_P (type
))
4998 /* Determine the length of the array. */
4999 len
= GFC_TYPE_ARRAY_SIZE (type
);
5000 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5003 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5004 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5005 fold_convert (gfc_array_index_type
, tmp
));
5007 /* If we are zeroing a local array avoid taking its address by emitting
5009 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5010 return build2 (MODIFY_EXPR
, void_type_node
,
5011 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5013 /* Convert arguments to the correct types. */
5014 dest
= fold_convert (pvoid_type_node
, dest
);
5015 len
= fold_convert (size_type_node
, len
);
5017 /* Construct call to __builtin_memset. */
5018 tmp
= build_call_expr_loc (input_location
,
5019 built_in_decls
[BUILT_IN_MEMSET
],
5020 3, dest
, integer_zero_node
, len
);
5021 return fold_convert (void_type_node
, tmp
);
5025 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5026 that constructs the call to __builtin_memcpy. */
5029 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5033 /* Convert arguments to the correct types. */
5034 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5035 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5037 dst
= fold_convert (pvoid_type_node
, dst
);
5039 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5040 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5042 src
= fold_convert (pvoid_type_node
, src
);
5044 len
= fold_convert (size_type_node
, len
);
5046 /* Construct call to __builtin_memcpy. */
5047 tmp
= build_call_expr_loc (input_location
,
5048 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5049 return fold_convert (void_type_node
, tmp
);
5053 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5054 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5055 source/rhs, both are gfc_full_array_ref_p which have been checked for
5059 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5061 tree dst
, dlen
, dtype
;
5062 tree src
, slen
, stype
;
5065 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5066 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5068 dtype
= TREE_TYPE (dst
);
5069 if (POINTER_TYPE_P (dtype
))
5070 dtype
= TREE_TYPE (dtype
);
5071 stype
= TREE_TYPE (src
);
5072 if (POINTER_TYPE_P (stype
))
5073 stype
= TREE_TYPE (stype
);
5075 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5078 /* Determine the lengths of the arrays. */
5079 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5080 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5082 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5083 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
5084 fold_convert (gfc_array_index_type
, tmp
));
5086 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5087 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5089 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5090 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
5091 fold_convert (gfc_array_index_type
, tmp
));
5093 /* Sanity check that they are the same. This should always be
5094 the case, as we should already have checked for conformance. */
5095 if (!tree_int_cst_equal (slen
, dlen
))
5098 return gfc_build_memcpy_call (dst
, src
, dlen
);
5102 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5103 this can't be done. EXPR1 is the destination/lhs for which
5104 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5107 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5109 unsigned HOST_WIDE_INT nelem
;
5115 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5119 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5120 dtype
= TREE_TYPE (dst
);
5121 if (POINTER_TYPE_P (dtype
))
5122 dtype
= TREE_TYPE (dtype
);
5123 if (!GFC_ARRAY_TYPE_P (dtype
))
5126 /* Determine the lengths of the array. */
5127 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5128 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5131 /* Confirm that the constructor is the same size. */
5132 if (compare_tree_int (len
, nelem
) != 0)
5135 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5136 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5137 fold_convert (gfc_array_index_type
, tmp
));
5139 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5140 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5142 stype
= TREE_TYPE (src
);
5143 if (POINTER_TYPE_P (stype
))
5144 stype
= TREE_TYPE (stype
);
5146 return gfc_build_memcpy_call (dst
, src
, len
);
5150 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5151 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5152 init_flag indicates initialization expressions and dealloc that no
5153 deallocate prior assignment is needed (if in doubt, set true). */
5156 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5162 gfc_ss
*lss_section
;
5169 bool scalar_to_array
;
5172 /* Assignment of the form lhs = rhs. */
5173 gfc_start_block (&block
);
5175 gfc_init_se (&lse
, NULL
);
5176 gfc_init_se (&rse
, NULL
);
5179 lss
= gfc_walk_expr (expr1
);
5181 if (lss
!= gfc_ss_terminator
)
5183 /* Allow the scalarizer to workshare array assignments. */
5184 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5185 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5187 /* The assignment needs scalarization. */
5190 /* Find a non-scalar SS from the lhs. */
5191 while (lss_section
!= gfc_ss_terminator
5192 && lss_section
->type
!= GFC_SS_SECTION
)
5193 lss_section
= lss_section
->next
;
5195 gcc_assert (lss_section
!= gfc_ss_terminator
);
5197 /* Initialize the scalarizer. */
5198 gfc_init_loopinfo (&loop
);
5201 rss
= gfc_walk_expr (expr2
);
5202 if (rss
== gfc_ss_terminator
)
5204 /* The rhs is scalar. Add a ss for the expression. */
5205 rss
= gfc_get_ss ();
5206 rss
->next
= gfc_ss_terminator
;
5207 rss
->type
= GFC_SS_SCALAR
;
5210 /* Associate the SS with the loop. */
5211 gfc_add_ss_to_loop (&loop
, lss
);
5212 gfc_add_ss_to_loop (&loop
, rss
);
5214 /* Calculate the bounds of the scalarization. */
5215 gfc_conv_ss_startstride (&loop
);
5216 /* Resolve any data dependencies in the statement. */
5217 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5218 /* Setup the scalarizing loops. */
5219 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5221 /* Setup the gfc_se structures. */
5222 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5223 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5226 gfc_mark_ss_chain_used (rss
, 1);
5227 if (loop
.temp_ss
== NULL
)
5230 gfc_mark_ss_chain_used (lss
, 1);
5234 lse
.ss
= loop
.temp_ss
;
5235 gfc_mark_ss_chain_used (lss
, 3);
5236 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5239 /* Start the scalarized loop body. */
5240 gfc_start_scalarized_body (&loop
, &body
);
5243 gfc_init_block (&body
);
5245 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5247 /* Translate the expression. */
5248 gfc_conv_expr (&rse
, expr2
);
5250 /* Stabilize a string length for temporaries. */
5251 if (expr2
->ts
.type
== BT_CHARACTER
)
5252 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5254 string_length
= NULL_TREE
;
5258 gfc_conv_tmp_array_ref (&lse
);
5259 gfc_advance_se_ss_chain (&lse
);
5260 if (expr2
->ts
.type
== BT_CHARACTER
)
5261 lse
.string_length
= string_length
;
5264 gfc_conv_expr (&lse
, expr1
);
5266 /* Assignments of scalar derived types with allocatable components
5267 to arrays must be done with a deep copy and the rhs temporary
5268 must have its components deallocated afterwards. */
5269 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5270 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5271 && expr2
->expr_type
!= EXPR_VARIABLE
5272 && !gfc_is_constant_expr (expr2
)
5273 && expr1
->rank
&& !expr2
->rank
);
5274 if (scalar_to_array
&& dealloc
)
5276 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5277 gfc_add_expr_to_block (&loop
.post
, tmp
);
5280 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5281 l_is_temp
|| init_flag
,
5282 (expr2
->expr_type
== EXPR_VARIABLE
)
5283 || scalar_to_array
, dealloc
);
5284 gfc_add_expr_to_block (&body
, tmp
);
5286 if (lss
== gfc_ss_terminator
)
5288 /* Use the scalar assignment as is. */
5289 gfc_add_block_to_block (&block
, &body
);
5293 gcc_assert (lse
.ss
== gfc_ss_terminator
5294 && rse
.ss
== gfc_ss_terminator
);
5298 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5300 /* We need to copy the temporary to the actual lhs. */
5301 gfc_init_se (&lse
, NULL
);
5302 gfc_init_se (&rse
, NULL
);
5303 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5304 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5306 rse
.ss
= loop
.temp_ss
;
5309 gfc_conv_tmp_array_ref (&rse
);
5310 gfc_advance_se_ss_chain (&rse
);
5311 gfc_conv_expr (&lse
, expr1
);
5313 gcc_assert (lse
.ss
== gfc_ss_terminator
5314 && rse
.ss
== gfc_ss_terminator
);
5316 if (expr2
->ts
.type
== BT_CHARACTER
)
5317 rse
.string_length
= string_length
;
5319 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5320 false, false, dealloc
);
5321 gfc_add_expr_to_block (&body
, tmp
);
5324 /* Generate the copying loops. */
5325 gfc_trans_scalarizing_loops (&loop
, &body
);
5327 /* Wrap the whole thing up. */
5328 gfc_add_block_to_block (&block
, &loop
.pre
);
5329 gfc_add_block_to_block (&block
, &loop
.post
);
5331 gfc_cleanup_loop (&loop
);
5334 return gfc_finish_block (&block
);
5338 /* Check whether EXPR is a copyable array. */
5341 copyable_array_p (gfc_expr
* expr
)
5343 if (expr
->expr_type
!= EXPR_VARIABLE
)
5346 /* First check it's an array. */
5347 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5350 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5353 /* Next check that it's of a simple enough type. */
5354 switch (expr
->ts
.type
)
5366 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5375 /* Translate an assignment. */
5378 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5383 /* Special case a single function returning an array. */
5384 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5386 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5391 /* Special case assigning an array to zero. */
5392 if (copyable_array_p (expr1
)
5393 && is_zero_initializer_p (expr2
))
5395 tmp
= gfc_trans_zero_assign (expr1
);
5400 /* Special case copying one array to another. */
5401 if (copyable_array_p (expr1
)
5402 && copyable_array_p (expr2
)
5403 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
5404 && !gfc_check_dependency (expr1
, expr2
, 0))
5406 tmp
= gfc_trans_array_copy (expr1
, expr2
);
5411 /* Special case initializing an array from a constant array constructor. */
5412 if (copyable_array_p (expr1
)
5413 && expr2
->expr_type
== EXPR_ARRAY
5414 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
5416 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
5421 /* Fallback to the scalarizer to generate explicit loops. */
5422 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
5426 gfc_trans_init_assign (gfc_code
* code
)
5428 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
5432 gfc_trans_assign (gfc_code
* code
)
5434 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
5438 /* Generate code to assign typebound procedures to a derived vtab. */
5439 void gfc_trans_assign_vtab_procs (stmtblock_t
*block
, gfc_symbol
*dt
,
5446 tree cond
= NULL_TREE
;
5450 /* Point to the first procedure pointer. */
5451 cmp
= gfc_find_component (vtab
->ts
.u
.derived
, "$extends", true, true);
5453 seen_extends
= (cmp
!= NULL
);
5455 vtb
= gfc_get_symbol_decl (vtab
);
5462 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5463 vtb
, cmp
->backend_decl
, NULL_TREE
);
5464 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, ctree
,
5465 build_int_cst (TREE_TYPE (ctree
), 0));
5469 cmp
= vtab
->ts
.u
.derived
->components
;
5472 gfc_init_block (&body
);
5473 for (; cmp
; cmp
= cmp
->next
)
5475 gfc_symbol
*target
= NULL
;
5477 /* Generic procedure - build its vtab. */
5478 if (cmp
->ts
.type
== BT_DERIVED
&& !cmp
->tb
)
5480 gfc_symbol
*vt
= cmp
->ts
.interface
;
5484 /* Use association loses the interface. Obtain the vtab
5486 char name
[2 * GFC_MAX_SYMBOL_LEN
+ 8];
5487 sprintf (name
, "vtab$%s$%s", vtab
->ts
.u
.derived
->name
,
5489 gfc_find_symbol (name
, vtab
->ns
, 0, &vt
);
5494 gfc_trans_assign_vtab_procs (&body
, dt
, vt
);
5495 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5496 vtb
, cmp
->backend_decl
, NULL_TREE
);
5497 proc
= gfc_get_symbol_decl (vt
);
5498 proc
= gfc_build_addr_expr (TREE_TYPE (ctree
), proc
);
5499 gfc_add_modify (&body
, ctree
, proc
);
5503 /* This is required when typebound generic procedures are called
5504 with derived type targets. The specific procedures do not get
5505 added to the vtype, which remains "empty". */
5506 if (cmp
->tb
&& cmp
->tb
->u
.specific
&& cmp
->tb
->u
.specific
->n
.sym
)
5507 target
= cmp
->tb
->u
.specific
->n
.sym
;
5511 st
= gfc_find_typebound_proc (dt
, NULL
, cmp
->name
, false, NULL
);
5512 if (st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5513 target
= st
->n
.tb
->u
.specific
->n
.sym
;
5519 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5520 vtb
, cmp
->backend_decl
, NULL_TREE
);
5521 proc
= gfc_get_symbol_decl (target
);
5522 proc
= gfc_build_addr_expr (TREE_TYPE (ctree
), proc
);
5523 gfc_add_modify (&body
, ctree
, proc
);
5526 proc
= gfc_finish_block (&body
);
5529 proc
= build3_v (COND_EXPR
, cond
, proc
, build_empty_stmt (input_location
));
5531 gfc_add_expr_to_block (block
, proc
);
5535 /* Translate an assignment to a CLASS object
5536 (pointer or ordinary assignment). */
5539 gfc_trans_class_assign (gfc_code
*code
)
5546 gfc_start_block (&block
);
5548 if (code
->op
== EXEC_INIT_ASSIGN
)
5550 /* Special case for initializing a CLASS variable on allocation.
5551 A MEMCPY is needed to copy the full data of the dynamic type,
5552 which may be different from the declared type. */
5555 gfc_init_se (&dst
, NULL
);
5556 gfc_init_se (&src
, NULL
);
5557 gfc_add_component_ref (code
->expr1
, "$data");
5558 gfc_conv_expr (&dst
, code
->expr1
);
5559 gfc_conv_expr (&src
, code
->expr2
);
5560 gfc_add_block_to_block (&block
, &src
.pre
);
5561 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr2
->ts
));
5562 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
);
5563 gfc_add_expr_to_block (&block
, tmp
);
5564 return gfc_finish_block (&block
);
5567 if (code
->expr2
->ts
.type
!= BT_CLASS
)
5569 /* Insert an additional assignment which sets the '$vptr' field. */
5570 lhs
= gfc_copy_expr (code
->expr1
);
5571 gfc_add_component_ref (lhs
, "$vptr");
5572 if (code
->expr2
->ts
.type
== BT_DERIVED
)
5576 vtab
= gfc_find_derived_vtab (code
->expr2
->ts
.u
.derived
, true);
5578 gfc_trans_assign_vtab_procs (&block
, code
->expr2
->ts
.u
.derived
, vtab
);
5579 rhs
= gfc_get_expr ();
5580 rhs
->expr_type
= EXPR_VARIABLE
;
5581 gfc_find_sym_tree (vtab
->name
, NULL
, 1, &st
);
5585 else if (code
->expr2
->expr_type
== EXPR_NULL
)
5586 rhs
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
5590 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
5591 gfc_add_expr_to_block (&block
, tmp
);
5593 gfc_free_expr (lhs
);
5594 gfc_free_expr (rhs
);
5597 /* Do the actual CLASS assignment. */
5598 if (code
->expr2
->ts
.type
== BT_CLASS
)
5599 code
->op
= EXEC_ASSIGN
;
5601 gfc_add_component_ref (code
->expr1
, "$data");
5603 if (code
->op
== EXEC_ASSIGN
)
5604 tmp
= gfc_trans_assign (code
);
5605 else if (code
->op
== EXEC_POINTER_ASSIGN
)
5606 tmp
= gfc_trans_pointer_assign (code
);
5610 gfc_add_expr_to_block (&block
, tmp
);
5612 return gfc_finish_block (&block
);