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
.contiguous
= sym
->attr
.contiguous
;
1722 new_sym
->attr
.codimension
= sym
->attr
.codimension
;
1723 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1724 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1725 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1726 new_sym
->attr
.function
= sym
->attr
.function
;
1728 /* Ensure that the interface is available and that
1729 descriptors are passed for array actual arguments. */
1730 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1732 new_sym
->formal
= expr
->symtree
->n
.sym
->formal
;
1733 new_sym
->attr
.always_explicit
1734 = expr
->symtree
->n
.sym
->attr
.always_explicit
;
1737 /* Create a fake symtree for it. */
1739 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1740 new_symtree
->n
.sym
= new_sym
;
1741 gcc_assert (new_symtree
== root
);
1743 /* Create a dummy->actual mapping. */
1744 sm
= XCNEW (gfc_interface_sym_mapping
);
1745 sm
->next
= mapping
->syms
;
1747 sm
->new_sym
= new_symtree
;
1748 sm
->expr
= gfc_copy_expr (expr
);
1751 /* Stabilize the argument's value. */
1752 if (!sym
->attr
.function
&& se
)
1753 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1755 if (sym
->ts
.type
== BT_CHARACTER
)
1757 /* Create a copy of the dummy argument's length. */
1758 new_sym
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.u
.cl
);
1759 sm
->expr
->ts
.u
.cl
= new_sym
->ts
.u
.cl
;
1761 /* If the length is specified as "*", record the length that
1762 the caller is passing. We should use the callee's length
1763 in all other cases. */
1764 if (!new_sym
->ts
.u
.cl
->length
&& se
)
1766 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1767 new_sym
->ts
.u
.cl
->backend_decl
= se
->string_length
;
1774 /* Use the passed value as-is if the argument is a function. */
1775 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1778 /* If the argument is either a string or a pointer to a string,
1779 convert it to a boundless character type. */
1780 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1782 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1783 tmp
= build_pointer_type (tmp
);
1784 if (sym
->attr
.pointer
)
1785 value
= build_fold_indirect_ref_loc (input_location
,
1789 value
= fold_convert (tmp
, value
);
1792 /* If the argument is a scalar, a pointer to an array or an allocatable,
1794 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1795 value
= build_fold_indirect_ref_loc (input_location
,
1798 /* For character(*), use the actual argument's descriptor. */
1799 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.u
.cl
->length
)
1800 value
= build_fold_indirect_ref_loc (input_location
,
1803 /* If the argument is an array descriptor, use it to determine
1804 information about the actual argument's shape. */
1805 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1806 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1808 /* Get the actual argument's descriptor. */
1809 desc
= build_fold_indirect_ref_loc (input_location
,
1812 /* Create the replacement variable. */
1813 tmp
= gfc_conv_descriptor_data_get (desc
);
1814 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1817 /* Use DESC to work out the upper bounds, strides and offset. */
1818 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1821 /* Otherwise we have a packed array. */
1822 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1823 PACKED_FULL
, se
->expr
);
1825 new_sym
->backend_decl
= value
;
1829 /* Called once all dummy argument mappings have been added to MAPPING,
1830 but before the mapping is used to evaluate expressions. Pre-evaluate
1831 the length of each argument, adding any initialization code to PRE and
1832 any finalization code to POST. */
1835 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1836 stmtblock_t
* pre
, stmtblock_t
* post
)
1838 gfc_interface_sym_mapping
*sym
;
1842 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1843 if (sym
->new_sym
->n
.sym
->ts
.type
== BT_CHARACTER
1844 && !sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
)
1846 expr
= sym
->new_sym
->n
.sym
->ts
.u
.cl
->length
;
1847 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1848 gfc_init_se (&se
, NULL
);
1849 gfc_conv_expr (&se
, expr
);
1850 se
.expr
= fold_convert (gfc_charlen_type_node
, se
.expr
);
1851 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1852 gfc_add_block_to_block (pre
, &se
.pre
);
1853 gfc_add_block_to_block (post
, &se
.post
);
1855 sym
->new_sym
->n
.sym
->ts
.u
.cl
->backend_decl
= se
.expr
;
1860 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1864 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1865 gfc_constructor_base base
)
1868 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1870 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1873 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1874 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1875 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1881 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1885 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1890 for (; ref
; ref
= ref
->next
)
1894 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1896 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1897 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1898 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1900 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1907 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1908 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1914 /* Convert intrinsic function calls into result expressions. */
1917 gfc_map_intrinsic_function (gfc_expr
*expr
, gfc_interface_mapping
*mapping
)
1925 arg1
= expr
->value
.function
.actual
->expr
;
1926 if (expr
->value
.function
.actual
->next
)
1927 arg2
= expr
->value
.function
.actual
->next
->expr
;
1931 sym
= arg1
->symtree
->n
.sym
;
1933 if (sym
->attr
.dummy
)
1938 switch (expr
->value
.function
.isym
->id
)
1941 /* TODO figure out why this condition is necessary. */
1942 if (sym
->attr
.function
1943 && (arg1
->ts
.u
.cl
->length
== NULL
1944 || (arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
1945 && arg1
->ts
.u
.cl
->length
->expr_type
!= EXPR_VARIABLE
)))
1948 new_expr
= gfc_copy_expr (arg1
->ts
.u
.cl
->length
);
1952 if (!sym
->as
|| sym
->as
->rank
== 0)
1955 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1957 dup
= mpz_get_si (arg2
->value
.integer
);
1962 dup
= sym
->as
->rank
;
1966 for (; d
< dup
; d
++)
1970 if (!sym
->as
->upper
[d
] || !sym
->as
->lower
[d
])
1972 gfc_free_expr (new_expr
);
1976 tmp
= gfc_add (gfc_copy_expr (sym
->as
->upper
[d
]),
1977 gfc_get_int_expr (gfc_default_integer_kind
,
1979 tmp
= gfc_subtract (tmp
, gfc_copy_expr (sym
->as
->lower
[d
]));
1981 new_expr
= gfc_multiply (new_expr
, tmp
);
1987 case GFC_ISYM_LBOUND
:
1988 case GFC_ISYM_UBOUND
:
1989 /* TODO These implementations of lbound and ubound do not limit if
1990 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1992 if (!sym
->as
|| sym
->as
->rank
== 0)
1995 if (arg2
&& arg2
->expr_type
== EXPR_CONSTANT
)
1996 d
= mpz_get_si (arg2
->value
.integer
) - 1;
1998 /* TODO: If the need arises, this could produce an array of
2002 if (expr
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
)
2004 if (sym
->as
->lower
[d
])
2005 new_expr
= gfc_copy_expr (sym
->as
->lower
[d
]);
2009 if (sym
->as
->upper
[d
])
2010 new_expr
= gfc_copy_expr (sym
->as
->upper
[d
]);
2018 gfc_apply_interface_mapping_to_expr (mapping
, new_expr
);
2022 gfc_replace_expr (expr
, new_expr
);
2028 gfc_map_fcn_formal_to_actual (gfc_expr
*expr
, gfc_expr
*map_expr
,
2029 gfc_interface_mapping
* mapping
)
2031 gfc_formal_arglist
*f
;
2032 gfc_actual_arglist
*actual
;
2034 actual
= expr
->value
.function
.actual
;
2035 f
= map_expr
->symtree
->n
.sym
->formal
;
2037 for (; f
&& actual
; f
= f
->next
, actual
= actual
->next
)
2042 gfc_add_interface_mapping (mapping
, f
->sym
, NULL
, actual
->expr
);
2045 if (map_expr
->symtree
->n
.sym
->attr
.dimension
)
2050 as
= gfc_copy_array_spec (map_expr
->symtree
->n
.sym
->as
);
2052 for (d
= 0; d
< as
->rank
; d
++)
2054 gfc_apply_interface_mapping_to_expr (mapping
, as
->lower
[d
]);
2055 gfc_apply_interface_mapping_to_expr (mapping
, as
->upper
[d
]);
2058 expr
->value
.function
.esym
->as
= as
;
2061 if (map_expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2063 expr
->value
.function
.esym
->ts
.u
.cl
->length
2064 = gfc_copy_expr (map_expr
->symtree
->n
.sym
->ts
.u
.cl
->length
);
2066 gfc_apply_interface_mapping_to_expr (mapping
,
2067 expr
->value
.function
.esym
->ts
.u
.cl
->length
);
2072 /* EXPR is a copy of an expression that appeared in the interface
2073 associated with MAPPING. Walk it recursively looking for references to
2074 dummy arguments that MAPPING maps to actual arguments. Replace each such
2075 reference with a reference to the associated actual argument. */
2078 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
2081 gfc_interface_sym_mapping
*sym
;
2082 gfc_actual_arglist
*actual
;
2087 /* Copying an expression does not copy its length, so do that here. */
2088 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.u
.cl
)
2090 expr
->ts
.u
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.u
.cl
);
2091 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.u
.cl
->length
);
2094 /* Apply the mapping to any references. */
2095 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
2097 /* ...and to the expression's symbol, if it has one. */
2098 /* TODO Find out why the condition on expr->symtree had to be moved into
2099 the loop rather than being outside it, as originally. */
2100 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2101 if (expr
->symtree
&& sym
->old
== expr
->symtree
->n
.sym
)
2103 if (sym
->new_sym
->n
.sym
->backend_decl
)
2104 expr
->symtree
= sym
->new_sym
;
2106 gfc_replace_expr (expr
, gfc_copy_expr (sym
->expr
));
2109 /* ...and to subexpressions in expr->value. */
2110 switch (expr
->expr_type
)
2115 case EXPR_SUBSTRING
:
2119 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
2120 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
2124 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2125 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
2127 if (expr
->value
.function
.esym
== NULL
2128 && expr
->value
.function
.isym
!= NULL
2129 && expr
->value
.function
.actual
->expr
->symtree
2130 && gfc_map_intrinsic_function (expr
, mapping
))
2133 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
2134 if (sym
->old
== expr
->value
.function
.esym
)
2136 expr
->value
.function
.esym
= sym
->new_sym
->n
.sym
;
2137 gfc_map_fcn_formal_to_actual (expr
, sym
->expr
, mapping
);
2138 expr
->value
.function
.esym
->result
= sym
->new_sym
->n
.sym
;
2143 case EXPR_STRUCTURE
:
2144 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
2157 /* Evaluate interface expression EXPR using MAPPING. Store the result
2161 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
2162 gfc_se
* se
, gfc_expr
* expr
)
2164 expr
= gfc_copy_expr (expr
);
2165 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
2166 gfc_conv_expr (se
, expr
);
2167 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2168 gfc_free_expr (expr
);
2172 /* Returns a reference to a temporary array into which a component of
2173 an actual argument derived type array is copied and then returned
2174 after the function call. */
2176 gfc_conv_subref_array_arg (gfc_se
* parmse
, gfc_expr
* expr
, int g77
,
2177 sym_intent intent
, bool formal_ptr
)
2195 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
2197 gfc_init_se (&lse
, NULL
);
2198 gfc_init_se (&rse
, NULL
);
2200 /* Walk the argument expression. */
2201 rss
= gfc_walk_expr (expr
);
2203 gcc_assert (rss
!= gfc_ss_terminator
);
2205 /* Initialize the scalarizer. */
2206 gfc_init_loopinfo (&loop
);
2207 gfc_add_ss_to_loop (&loop
, rss
);
2209 /* Calculate the bounds of the scalarization. */
2210 gfc_conv_ss_startstride (&loop
);
2212 /* Build an ss for the temporary. */
2213 if (expr
->ts
.type
== BT_CHARACTER
&& !expr
->ts
.u
.cl
->backend_decl
)
2214 gfc_conv_string_length (expr
->ts
.u
.cl
, expr
, &parmse
->pre
);
2216 base_type
= gfc_typenode_for_spec (&expr
->ts
);
2217 if (GFC_ARRAY_TYPE_P (base_type
)
2218 || GFC_DESCRIPTOR_TYPE_P (base_type
))
2219 base_type
= gfc_get_element_type (base_type
);
2221 loop
.temp_ss
= gfc_get_ss ();;
2222 loop
.temp_ss
->type
= GFC_SS_TEMP
;
2223 loop
.temp_ss
->data
.temp
.type
= base_type
;
2225 if (expr
->ts
.type
== BT_CHARACTER
)
2226 loop
.temp_ss
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2228 loop
.temp_ss
->string_length
= NULL
;
2230 parmse
->string_length
= loop
.temp_ss
->string_length
;
2231 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
2232 loop
.temp_ss
->next
= gfc_ss_terminator
;
2234 /* Associate the SS with the loop. */
2235 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
2237 /* Setup the scalarizing loops. */
2238 gfc_conv_loop_setup (&loop
, &expr
->where
);
2240 /* Pass the temporary descriptor back to the caller. */
2241 info
= &loop
.temp_ss
->data
.info
;
2242 parmse
->expr
= info
->descriptor
;
2244 /* Setup the gfc_se structures. */
2245 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2246 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2249 lse
.ss
= loop
.temp_ss
;
2250 gfc_mark_ss_chain_used (rss
, 1);
2251 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2253 /* Start the scalarized loop body. */
2254 gfc_start_scalarized_body (&loop
, &body
);
2256 /* Translate the expression. */
2257 gfc_conv_expr (&rse
, expr
);
2259 gfc_conv_tmp_array_ref (&lse
);
2260 gfc_advance_se_ss_chain (&lse
);
2262 if (intent
!= INTENT_OUT
)
2264 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false, true);
2265 gfc_add_expr_to_block (&body
, tmp
);
2266 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2267 gfc_trans_scalarizing_loops (&loop
, &body
);
2271 /* Make sure that the temporary declaration survives by merging
2272 all the loop declarations into the current context. */
2273 for (n
= 0; n
< loop
.dimen
; n
++)
2275 gfc_merge_block_scope (&body
);
2276 body
= loop
.code
[loop
.order
[n
]];
2278 gfc_merge_block_scope (&body
);
2281 /* Add the post block after the second loop, so that any
2282 freeing of allocated memory is done at the right time. */
2283 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
2285 /**********Copy the temporary back again.*********/
2287 gfc_init_se (&lse
, NULL
);
2288 gfc_init_se (&rse
, NULL
);
2290 /* Walk the argument expression. */
2291 lss
= gfc_walk_expr (expr
);
2292 rse
.ss
= loop
.temp_ss
;
2295 /* Initialize the scalarizer. */
2296 gfc_init_loopinfo (&loop2
);
2297 gfc_add_ss_to_loop (&loop2
, lss
);
2299 /* Calculate the bounds of the scalarization. */
2300 gfc_conv_ss_startstride (&loop2
);
2302 /* Setup the scalarizing loops. */
2303 gfc_conv_loop_setup (&loop2
, &expr
->where
);
2305 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
2306 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
2308 gfc_mark_ss_chain_used (lss
, 1);
2309 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
2311 /* Declare the variable to hold the temporary offset and start the
2312 scalarized loop body. */
2313 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
2314 gfc_start_scalarized_body (&loop2
, &body
);
2316 /* Build the offsets for the temporary from the loop variables. The
2317 temporary array has lbounds of zero and strides of one in all
2318 dimensions, so this is very simple. The offset is only computed
2319 outside the innermost loop, so the overall transfer could be
2320 optimized further. */
2321 info
= &rse
.ss
->data
.info
;
2322 dimen
= info
->dimen
;
2324 tmp_index
= gfc_index_zero_node
;
2325 for (n
= dimen
- 1; n
> 0; n
--)
2328 tmp
= rse
.loop
->loopvar
[n
];
2329 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2330 tmp
, rse
.loop
->from
[n
]);
2331 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2334 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2335 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
2336 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2337 tmp_str
, gfc_index_one_node
);
2339 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2343 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2344 tmp_index
, rse
.loop
->from
[0]);
2345 gfc_add_modify (&rse
.loop
->code
[0], offset
, tmp_index
);
2347 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2348 rse
.loop
->loopvar
[0], offset
);
2350 /* Now use the offset for the reference. */
2351 tmp
= build_fold_indirect_ref_loc (input_location
,
2353 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
, NULL
);
2355 if (expr
->ts
.type
== BT_CHARACTER
)
2356 rse
.string_length
= expr
->ts
.u
.cl
->backend_decl
;
2358 gfc_conv_expr (&lse
, expr
);
2360 gcc_assert (lse
.ss
== gfc_ss_terminator
);
2362 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false, true);
2363 gfc_add_expr_to_block (&body
, tmp
);
2365 /* Generate the copying loops. */
2366 gfc_trans_scalarizing_loops (&loop2
, &body
);
2368 /* Wrap the whole thing up by adding the second loop to the post-block
2369 and following it by the post-block of the first loop. In this way,
2370 if the temporary needs freeing, it is done after use! */
2371 if (intent
!= INTENT_IN
)
2373 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
2374 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
2377 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
2379 gfc_cleanup_loop (&loop
);
2380 gfc_cleanup_loop (&loop2
);
2382 /* Pass the string length to the argument expression. */
2383 if (expr
->ts
.type
== BT_CHARACTER
)
2384 parmse
->string_length
= expr
->ts
.u
.cl
->backend_decl
;
2386 /* Determine the offset for pointer formal arguments and set the
2390 size
= gfc_index_one_node
;
2391 offset
= gfc_index_zero_node
;
2392 for (n
= 0; n
< dimen
; n
++)
2394 tmp
= gfc_conv_descriptor_ubound_get (parmse
->expr
,
2396 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2397 tmp
, gfc_index_one_node
);
2398 gfc_conv_descriptor_ubound_set (&parmse
->pre
,
2402 gfc_conv_descriptor_lbound_set (&parmse
->pre
,
2405 gfc_index_one_node
);
2406 size
= gfc_evaluate_now (size
, &parmse
->pre
);
2407 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2409 offset
= gfc_evaluate_now (offset
, &parmse
->pre
);
2410 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
2411 rse
.loop
->to
[n
], rse
.loop
->from
[n
]);
2412 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2413 tmp
, gfc_index_one_node
);
2414 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2418 gfc_conv_descriptor_offset_set (&parmse
->pre
, parmse
->expr
,
2422 /* We want either the address for the data or the address of the descriptor,
2423 depending on the mode of passing array arguments. */
2425 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
2427 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, parmse
->expr
);
2433 /* Generate the code for argument list functions. */
2436 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
2438 /* Pass by value for g77 %VAL(arg), pass the address
2439 indirectly for %LOC, else by reference. Thus %REF
2440 is a "do-nothing" and %LOC is the same as an F95
2442 if (strncmp (name
, "%VAL", 4) == 0)
2443 gfc_conv_expr (se
, expr
);
2444 else if (strncmp (name
, "%LOC", 4) == 0)
2446 gfc_conv_expr_reference (se
, expr
);
2447 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
2449 else if (strncmp (name
, "%REF", 4) == 0)
2450 gfc_conv_expr_reference (se
, expr
);
2452 gfc_error ("Unknown argument list function at %L", &expr
->where
);
2456 /* Takes a derived type expression and returns the address of a temporary
2457 class object of the 'declared' type. */
2459 gfc_conv_derived_to_class (gfc_se
*parmse
, gfc_expr
*e
,
2460 gfc_typespec class_ts
)
2464 gfc_symbol
*declared
= class_ts
.u
.derived
;
2470 /* The derived type needs to be converted to a temporary
2472 tmp
= gfc_typenode_for_spec (&class_ts
);
2473 var
= gfc_create_var (tmp
, "class");
2476 cmp
= gfc_find_component (declared
, "$vptr", true, true);
2477 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2478 var
, cmp
->backend_decl
, NULL_TREE
);
2480 /* Remember the vtab corresponds to the derived type
2481 not to the class declared type. */
2482 vtab
= gfc_find_derived_vtab (e
->ts
.u
.derived
, true);
2484 gfc_trans_assign_vtab_procs (&parmse
->pre
, e
->ts
.u
.derived
, vtab
);
2485 tmp
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtab
));
2486 gfc_add_modify (&parmse
->pre
, ctree
,
2487 fold_convert (TREE_TYPE (ctree
), tmp
));
2489 /* Now set the data field. */
2490 cmp
= gfc_find_component (declared
, "$data", true, true);
2491 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
2492 var
, cmp
->backend_decl
, NULL_TREE
);
2493 ss
= gfc_walk_expr (e
);
2494 if (ss
== gfc_ss_terminator
)
2497 gfc_conv_expr_reference (parmse
, e
);
2498 tmp
= fold_convert (TREE_TYPE (ctree
), parmse
->expr
);
2499 gfc_add_modify (&parmse
->pre
, ctree
, tmp
);
2504 gfc_conv_expr (parmse
, e
);
2505 gfc_add_modify (&parmse
->pre
, ctree
, parmse
->expr
);
2508 /* Pass the address of the class object. */
2509 parmse
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
2513 /* The following routine generates code for the intrinsic
2514 procedures from the ISO_C_BINDING module:
2516 * C_FUNLOC (function)
2517 * C_F_POINTER (subroutine)
2518 * C_F_PROCPOINTER (subroutine)
2519 * C_ASSOCIATED (function)
2520 One exception which is not handled here is C_F_POINTER with non-scalar
2521 arguments. Returns 1 if the call was replaced by inline code (else: 0). */
2524 conv_isocbinding_procedure (gfc_se
* se
, gfc_symbol
* sym
,
2525 gfc_actual_arglist
* arg
)
2530 if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2532 if (arg
->expr
->rank
== 0)
2533 gfc_conv_expr_reference (se
, arg
->expr
);
2537 /* This is really the actual arg because no formal arglist is
2538 created for C_LOC. */
2539 fsym
= arg
->expr
->symtree
->n
.sym
;
2541 /* We should want it to do g77 calling convention. */
2543 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2544 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2545 f
= f
|| !sym
->attr
.always_explicit
;
2547 argss
= gfc_walk_expr (arg
->expr
);
2548 gfc_conv_array_parameter (se
, arg
->expr
, argss
, f
,
2552 /* TODO -- the following two lines shouldn't be necessary, but if
2553 they're removed, a bug is exposed later in the code path.
2554 This workaround was thus introduced, but will have to be
2555 removed; please see PR 35150 for details about the issue. */
2556 se
->expr
= convert (pvoid_type_node
, se
->expr
);
2557 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
2561 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2563 arg
->expr
->ts
.type
= sym
->ts
.u
.derived
->ts
.type
;
2564 arg
->expr
->ts
.f90_type
= sym
->ts
.u
.derived
->ts
.f90_type
;
2565 arg
->expr
->ts
.kind
= sym
->ts
.u
.derived
->ts
.kind
;
2566 gfc_conv_expr_reference (se
, arg
->expr
);
2570 else if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2571 && arg
->next
->expr
->rank
== 0)
2572 || sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
)
2574 /* Convert c_f_pointer if fptr is a scalar
2575 and convert c_f_procpointer. */
2579 gfc_init_se (&cptrse
, NULL
);
2580 gfc_conv_expr (&cptrse
, arg
->expr
);
2581 gfc_add_block_to_block (&se
->pre
, &cptrse
.pre
);
2582 gfc_add_block_to_block (&se
->post
, &cptrse
.post
);
2584 gfc_init_se (&fptrse
, NULL
);
2585 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
2586 || gfc_is_proc_ptr_comp (arg
->next
->expr
, NULL
))
2587 fptrse
.want_pointer
= 1;
2589 gfc_conv_expr (&fptrse
, arg
->next
->expr
);
2590 gfc_add_block_to_block (&se
->pre
, &fptrse
.pre
);
2591 gfc_add_block_to_block (&se
->post
, &fptrse
.post
);
2593 if (arg
->next
->expr
->symtree
->n
.sym
->attr
.proc_pointer
2594 && arg
->next
->expr
->symtree
->n
.sym
->attr
.dummy
)
2595 fptrse
.expr
= build_fold_indirect_ref_loc (input_location
,
2598 se
->expr
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (fptrse
.expr
),
2600 fold_convert (TREE_TYPE (fptrse
.expr
),
2605 else if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2610 /* Build the addr_expr for the first argument. The argument is
2611 already an *address* so we don't need to set want_pointer in
2613 gfc_init_se (&arg1se
, NULL
);
2614 gfc_conv_expr (&arg1se
, arg
->expr
);
2615 gfc_add_block_to_block (&se
->pre
, &arg1se
.pre
);
2616 gfc_add_block_to_block (&se
->post
, &arg1se
.post
);
2618 /* See if we were given two arguments. */
2619 if (arg
->next
== NULL
)
2620 /* Only given one arg so generate a null and do a
2621 not-equal comparison against the first arg. */
2622 se
->expr
= fold_build2 (NE_EXPR
, boolean_type_node
, arg1se
.expr
,
2623 fold_convert (TREE_TYPE (arg1se
.expr
),
2624 null_pointer_node
));
2630 /* Given two arguments so build the arg2se from second arg. */
2631 gfc_init_se (&arg2se
, NULL
);
2632 gfc_conv_expr (&arg2se
, arg
->next
->expr
);
2633 gfc_add_block_to_block (&se
->pre
, &arg2se
.pre
);
2634 gfc_add_block_to_block (&se
->post
, &arg2se
.post
);
2636 /* Generate test to compare that the two args are equal. */
2637 eq_expr
= fold_build2 (EQ_EXPR
, boolean_type_node
,
2638 arg1se
.expr
, arg2se
.expr
);
2639 /* Generate test to ensure that the first arg is not null. */
2640 not_null_expr
= fold_build2 (NE_EXPR
, boolean_type_node
,
2641 arg1se
.expr
, null_pointer_node
);
2643 /* Finally, the generated test must check that both arg1 is not
2644 NULL and that it is equal to the second arg. */
2645 se
->expr
= fold_build2 (TRUTH_AND_EXPR
, boolean_type_node
,
2646 not_null_expr
, eq_expr
);
2652 /* Nothing was done. */
2657 /* Generate code for a procedure call. Note can return se->post != NULL.
2658 If se->direct_byref is set then se->expr contains the return parameter.
2659 Return nonzero, if the call has alternate specifiers.
2660 'expr' is only needed for procedure pointer components. */
2663 gfc_conv_procedure_call (gfc_se
* se
, gfc_symbol
* sym
,
2664 gfc_actual_arglist
* arg
, gfc_expr
* expr
,
2667 gfc_interface_mapping mapping
;
2682 gfc_formal_arglist
*formal
;
2683 int has_alternate_specifier
= 0;
2684 bool need_interface_mapping
;
2691 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2692 gfc_component
*comp
= NULL
;
2694 arglist
= NULL_TREE
;
2695 retargs
= NULL_TREE
;
2696 stringargs
= NULL_TREE
;
2701 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2702 && conv_isocbinding_procedure (se
, sym
, arg
))
2705 gfc_is_proc_ptr_comp (expr
, &comp
);
2709 if (!sym
->attr
.elemental
)
2711 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2712 if (se
->ss
->useflags
)
2714 gcc_assert ((!comp
&& gfc_return_by_reference (sym
)
2715 && sym
->result
->attr
.dimension
)
2716 || (comp
&& comp
->attr
.dimension
));
2717 gcc_assert (se
->loop
!= NULL
);
2719 /* Access the previously obtained result. */
2720 gfc_conv_tmp_array_ref (se
);
2721 gfc_advance_se_ss_chain (se
);
2725 info
= &se
->ss
->data
.info
;
2730 gfc_init_block (&post
);
2731 gfc_init_interface_mapping (&mapping
);
2734 formal
= sym
->formal
;
2735 need_interface_mapping
= sym
->attr
.dimension
||
2736 (sym
->ts
.type
== BT_CHARACTER
2737 && sym
->ts
.u
.cl
->length
2738 && sym
->ts
.u
.cl
->length
->expr_type
2743 formal
= comp
->formal
;
2744 need_interface_mapping
= comp
->attr
.dimension
||
2745 (comp
->ts
.type
== BT_CHARACTER
2746 && comp
->ts
.u
.cl
->length
2747 && comp
->ts
.u
.cl
->length
->expr_type
2751 /* Evaluate the arguments. */
2752 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2755 fsym
= formal
? formal
->sym
: NULL
;
2756 parm_kind
= MISSING
;
2760 if (se
->ignore_optional
)
2762 /* Some intrinsics have already been resolved to the correct
2766 else if (arg
->label
)
2768 has_alternate_specifier
= 1;
2773 /* Pass a NULL pointer for an absent arg. */
2774 gfc_init_se (&parmse
, NULL
);
2775 parmse
.expr
= null_pointer_node
;
2776 if (arg
->missing_arg_type
== BT_CHARACTER
)
2777 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2780 else if (fsym
&& fsym
->ts
.type
== BT_CLASS
2781 && e
->ts
.type
== BT_DERIVED
)
2783 /* The derived type needs to be converted to a temporary
2785 gfc_init_se (&parmse
, se
);
2786 gfc_conv_derived_to_class (&parmse
, e
, fsym
->ts
);
2788 else if (se
->ss
&& se
->ss
->useflags
)
2790 /* An elemental function inside a scalarized loop. */
2791 gfc_init_se (&parmse
, se
);
2792 gfc_conv_expr_reference (&parmse
, e
);
2793 parm_kind
= ELEMENTAL
;
2797 /* A scalar or transformational function. */
2798 gfc_init_se (&parmse
, NULL
);
2799 argss
= gfc_walk_expr (e
);
2801 if (argss
== gfc_ss_terminator
)
2803 if (e
->expr_type
== EXPR_VARIABLE
2804 && e
->symtree
->n
.sym
->attr
.cray_pointee
2805 && fsym
&& fsym
->attr
.flavor
== FL_PROCEDURE
)
2807 /* The Cray pointer needs to be converted to a pointer to
2808 a type given by the expression. */
2809 gfc_conv_expr (&parmse
, e
);
2810 type
= build_pointer_type (TREE_TYPE (parmse
.expr
));
2811 tmp
= gfc_get_symbol_decl (e
->symtree
->n
.sym
->cp_pointer
);
2812 parmse
.expr
= convert (type
, tmp
);
2814 else if (fsym
&& fsym
->attr
.value
)
2816 if (fsym
->ts
.type
== BT_CHARACTER
2817 && fsym
->ts
.is_c_interop
2818 && fsym
->ns
->proc_name
!= NULL
2819 && fsym
->ns
->proc_name
->attr
.is_bind_c
)
2822 gfc_conv_scalar_char_value (fsym
, &parmse
, &e
);
2823 if (parmse
.expr
== NULL
)
2824 gfc_conv_expr (&parmse
, e
);
2827 gfc_conv_expr (&parmse
, e
);
2829 else if (arg
->name
&& arg
->name
[0] == '%')
2830 /* Argument list functions %VAL, %LOC and %REF are signalled
2831 through arg->name. */
2832 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2833 else if ((e
->expr_type
== EXPR_FUNCTION
)
2834 && ((e
->value
.function
.esym
2835 && e
->value
.function
.esym
->result
->attr
.pointer
)
2836 || (!e
->value
.function
.esym
2837 && e
->symtree
->n
.sym
->attr
.pointer
))
2838 && fsym
&& fsym
->attr
.target
)
2840 gfc_conv_expr (&parmse
, e
);
2841 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2843 else if (e
->expr_type
== EXPR_FUNCTION
2844 && e
->symtree
->n
.sym
->result
2845 && e
->symtree
->n
.sym
->result
!= e
->symtree
->n
.sym
2846 && e
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
2848 /* Functions returning procedure pointers. */
2849 gfc_conv_expr (&parmse
, e
);
2850 if (fsym
&& fsym
->attr
.proc_pointer
)
2851 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2855 gfc_conv_expr_reference (&parmse
, e
);
2857 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2858 allocated on entry, it must be deallocated. */
2859 if (fsym
&& fsym
->attr
.allocatable
2860 && fsym
->attr
.intent
== INTENT_OUT
)
2864 gfc_init_block (&block
);
2865 tmp
= gfc_deallocate_with_status (parmse
.expr
, NULL_TREE
,
2867 gfc_add_expr_to_block (&block
, tmp
);
2868 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
,
2869 parmse
.expr
, null_pointer_node
);
2870 gfc_add_expr_to_block (&block
, tmp
);
2872 if (fsym
->attr
.optional
2873 && e
->expr_type
== EXPR_VARIABLE
2874 && e
->symtree
->n
.sym
->attr
.optional
)
2876 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2877 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2878 gfc_finish_block (&block
),
2879 build_empty_stmt (input_location
));
2882 tmp
= gfc_finish_block (&block
);
2884 gfc_add_expr_to_block (&se
->pre
, tmp
);
2887 if (fsym
&& e
->expr_type
!= EXPR_NULL
2888 && ((fsym
->attr
.pointer
2889 && fsym
->attr
.flavor
!= FL_PROCEDURE
)
2890 || (fsym
->attr
.proc_pointer
2891 && !(e
->expr_type
== EXPR_VARIABLE
2892 && e
->symtree
->n
.sym
->attr
.dummy
))
2893 || (e
->expr_type
== EXPR_VARIABLE
2894 && gfc_is_proc_ptr_comp (e
, NULL
))
2895 || fsym
->attr
.allocatable
))
2897 /* Scalar pointer dummy args require an extra level of
2898 indirection. The null pointer already contains
2899 this level of indirection. */
2900 parm_kind
= SCALAR_POINTER
;
2901 parmse
.expr
= gfc_build_addr_expr (NULL_TREE
, parmse
.expr
);
2907 /* If the procedure requires an explicit interface, the actual
2908 argument is passed according to the corresponding formal
2909 argument. If the corresponding formal argument is a POINTER,
2910 ALLOCATABLE or assumed shape, we do not use g77's calling
2911 convention, and pass the address of the array descriptor
2912 instead. Otherwise we use g77's calling convention. */
2915 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2916 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2918 f
= f
|| !comp
->attr
.always_explicit
;
2920 f
= f
|| !sym
->attr
.always_explicit
;
2922 if (e
->expr_type
== EXPR_VARIABLE
2923 && is_subref_array (e
))
2924 /* The actual argument is a component reference to an
2925 array of derived types. In this case, the argument
2926 is converted to a temporary, which is passed and then
2927 written back after the procedure call. */
2928 gfc_conv_subref_array_arg (&parmse
, e
, f
,
2929 fsym
? fsym
->attr
.intent
: INTENT_INOUT
,
2930 fsym
&& fsym
->attr
.pointer
);
2932 gfc_conv_array_parameter (&parmse
, e
, argss
, f
, fsym
,
2935 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2936 allocated on entry, it must be deallocated. */
2937 if (fsym
&& fsym
->attr
.allocatable
2938 && fsym
->attr
.intent
== INTENT_OUT
)
2940 tmp
= build_fold_indirect_ref_loc (input_location
,
2942 tmp
= gfc_trans_dealloc_allocated (tmp
);
2943 if (fsym
->attr
.optional
2944 && e
->expr_type
== EXPR_VARIABLE
2945 && e
->symtree
->n
.sym
->attr
.optional
)
2946 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
2947 gfc_conv_expr_present (e
->symtree
->n
.sym
),
2948 tmp
, build_empty_stmt (input_location
));
2949 gfc_add_expr_to_block (&se
->pre
, tmp
);
2954 /* The case with fsym->attr.optional is that of a user subroutine
2955 with an interface indicating an optional argument. When we call
2956 an intrinsic subroutine, however, fsym is NULL, but we might still
2957 have an optional argument, so we proceed to the substitution
2959 if (e
&& (fsym
== NULL
|| fsym
->attr
.optional
))
2961 /* If an optional argument is itself an optional dummy argument,
2962 check its presence and substitute a null if absent. This is
2963 only needed when passing an array to an elemental procedure
2964 as then array elements are accessed - or no NULL pointer is
2965 allowed and a "1" or "0" should be passed if not present.
2966 When passing a non-array-descriptor full array to a
2967 non-array-descriptor dummy, no check is needed. For
2968 array-descriptor actual to array-descriptor dummy, see
2969 PR 41911 for why a check has to be inserted.
2970 fsym == NULL is checked as intrinsics required the descriptor
2971 but do not always set fsym. */
2972 if (e
->expr_type
== EXPR_VARIABLE
2973 && e
->symtree
->n
.sym
->attr
.optional
2974 && ((e
->rank
> 0 && sym
->attr
.elemental
)
2975 || e
->representation
.length
|| e
->ts
.type
== BT_CHARACTER
2977 && (fsym
== NULL
|| fsym
->as
->type
== AS_ASSUMED_SHAPE
2978 || fsym
->as
->type
== AS_DEFERRED
))))
2979 gfc_conv_missing_dummy (&parmse
, e
, fsym
? fsym
->ts
: e
->ts
,
2980 e
->representation
.length
);
2985 /* Obtain the character length of an assumed character length
2986 length procedure from the typespec. */
2987 if (fsym
->ts
.type
== BT_CHARACTER
2988 && parmse
.string_length
== NULL_TREE
2989 && e
->ts
.type
== BT_PROCEDURE
2990 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2991 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
!= NULL
2992 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
2994 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.u
.cl
);
2995 parmse
.string_length
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2999 if (fsym
&& need_interface_mapping
&& e
)
3000 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
, e
);
3002 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3003 gfc_add_block_to_block (&post
, &parmse
.post
);
3005 /* Allocated allocatable components of derived types must be
3006 deallocated for non-variable scalars. Non-variable arrays are
3007 dealt with in trans-array.c(gfc_conv_array_parameter). */
3008 if (e
&& e
->ts
.type
== BT_DERIVED
3009 && e
->ts
.u
.derived
->attr
.alloc_comp
3010 && !(e
->symtree
&& e
->symtree
->n
.sym
->attr
.pointer
)
3011 && (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
))
3014 tmp
= build_fold_indirect_ref_loc (input_location
,
3016 parm_rank
= e
->rank
;
3024 case (SCALAR_POINTER
):
3025 tmp
= build_fold_indirect_ref_loc (input_location
,
3030 if (e
->expr_type
== EXPR_OP
3031 && e
->value
.op
.op
== INTRINSIC_PARENTHESES
3032 && e
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
3035 local_tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
3036 local_tmp
= gfc_copy_alloc_comp (e
->ts
.u
.derived
, local_tmp
, tmp
, parm_rank
);
3037 gfc_add_expr_to_block (&se
->post
, local_tmp
);
3040 tmp
= gfc_deallocate_alloc_comp (e
->ts
.u
.derived
, tmp
, parm_rank
);
3042 gfc_add_expr_to_block (&se
->post
, tmp
);
3045 /* Add argument checking of passing an unallocated/NULL actual to
3046 a nonallocatable/nonpointer dummy. */
3048 if (gfc_option
.rtcheck
& GFC_RTCHECK_POINTER
&& e
!= NULL
)
3050 symbol_attribute
*attr
;
3054 if (e
->expr_type
== EXPR_VARIABLE
)
3055 attr
= &e
->symtree
->n
.sym
->attr
;
3056 else if (e
->expr_type
== EXPR_FUNCTION
)
3058 /* For intrinsic functions, the gfc_attr are not available. */
3059 if (e
->symtree
->n
.sym
->attr
.generic
&& e
->value
.function
.isym
)
3060 goto end_pointer_check
;
3062 if (e
->symtree
->n
.sym
->attr
.generic
)
3063 attr
= &e
->value
.function
.esym
->attr
;
3065 attr
= &e
->symtree
->n
.sym
->result
->attr
;
3068 goto end_pointer_check
;
3072 /* If the actual argument is an optional pointer/allocatable and
3073 the formal argument takes an nonpointer optional value,
3074 it is invalid to pass a non-present argument on, even
3075 though there is no technical reason for this in gfortran.
3076 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
3077 tree present
, null_ptr
, type
;
3079 if (attr
->allocatable
3080 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3081 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3082 "allocated or not present", e
->symtree
->n
.sym
->name
);
3083 else if (attr
->pointer
3084 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3085 asprintf (&msg
, "Pointer actual argument '%s' is not "
3086 "associated or not present",
3087 e
->symtree
->n
.sym
->name
);
3088 else if (attr
->proc_pointer
3089 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3090 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3091 "associated or not present",
3092 e
->symtree
->n
.sym
->name
);
3094 goto end_pointer_check
;
3096 present
= gfc_conv_expr_present (e
->symtree
->n
.sym
);
3097 type
= TREE_TYPE (present
);
3098 present
= fold_build2 (EQ_EXPR
, boolean_type_node
, present
,
3099 fold_convert (type
, null_pointer_node
));
3100 type
= TREE_TYPE (parmse
.expr
);
3101 null_ptr
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3102 fold_convert (type
, null_pointer_node
));
3103 cond
= fold_build2 (TRUTH_ORIF_EXPR
, boolean_type_node
,
3108 if (attr
->allocatable
3109 && (fsym
== NULL
|| !fsym
->attr
.allocatable
))
3110 asprintf (&msg
, "Allocatable actual argument '%s' is not "
3111 "allocated", e
->symtree
->n
.sym
->name
);
3112 else if (attr
->pointer
3113 && (fsym
== NULL
|| !fsym
->attr
.pointer
))
3114 asprintf (&msg
, "Pointer actual argument '%s' is not "
3115 "associated", e
->symtree
->n
.sym
->name
);
3116 else if (attr
->proc_pointer
3117 && (fsym
== NULL
|| !fsym
->attr
.proc_pointer
))
3118 asprintf (&msg
, "Proc-pointer actual argument '%s' is not "
3119 "associated", e
->symtree
->n
.sym
->name
);
3121 goto end_pointer_check
;
3124 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, parmse
.expr
,
3125 fold_convert (TREE_TYPE (parmse
.expr
),
3126 null_pointer_node
));
3129 gfc_trans_runtime_check (true, false, cond
, &se
->pre
, &e
->where
,
3136 /* Character strings are passed as two parameters, a length and a
3137 pointer - except for Bind(c) which only passes the pointer. */
3138 if (parmse
.string_length
!= NULL_TREE
&& !sym
->attr
.is_bind_c
)
3139 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
3141 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
3143 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
3150 if (ts
.type
== BT_CHARACTER
&& sym
->attr
.is_bind_c
)
3151 se
->string_length
= build_int_cst (gfc_charlen_type_node
, 1);
3152 else if (ts
.type
== BT_CHARACTER
)
3154 if (ts
.u
.cl
->length
== NULL
)
3156 /* Assumed character length results are not allowed by 5.1.1.5 of the
3157 standard and are trapped in resolve.c; except in the case of SPREAD
3158 (and other intrinsics?) and dummy functions. In the case of SPREAD,
3159 we take the character length of the first argument for the result.
3160 For dummies, we have to look through the formal argument list for
3161 this function and use the character length found there.*/
3162 if (!sym
->attr
.dummy
)
3163 cl
.backend_decl
= TREE_VALUE (stringargs
);
3166 formal
= sym
->ns
->proc_name
->formal
;
3167 for (; formal
; formal
= formal
->next
)
3168 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
3169 cl
.backend_decl
= formal
->sym
->ts
.u
.cl
->backend_decl
;
3176 /* Calculate the length of the returned string. */
3177 gfc_init_se (&parmse
, NULL
);
3178 if (need_interface_mapping
)
3179 gfc_apply_interface_mapping (&mapping
, &parmse
, ts
.u
.cl
->length
);
3181 gfc_conv_expr (&parmse
, ts
.u
.cl
->length
);
3182 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
3183 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
3185 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
3186 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
3187 build_int_cst (gfc_charlen_type_node
, 0));
3188 cl
.backend_decl
= tmp
;
3191 /* Set up a charlen structure for it. */
3196 len
= cl
.backend_decl
;
3199 byref
= (comp
&& (comp
->attr
.dimension
|| comp
->ts
.type
== BT_CHARACTER
))
3200 || (!comp
&& gfc_return_by_reference (sym
));
3203 if (se
->direct_byref
)
3205 /* Sometimes, too much indirection can be applied; e.g. for
3206 function_result = array_valued_recursive_function. */
3207 if (TREE_TYPE (TREE_TYPE (se
->expr
))
3208 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))
3209 && GFC_DESCRIPTOR_TYPE_P
3210 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
)))))
3211 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3214 result
= build_fold_indirect_ref_loc (input_location
,
3216 retargs
= gfc_chainon_list (retargs
, se
->expr
);
3218 else if (comp
&& comp
->attr
.dimension
)
3220 gcc_assert (se
->loop
&& info
);
3222 /* Set the type of the array. */
3223 tmp
= gfc_typenode_for_spec (&comp
->ts
);
3224 info
->dimen
= se
->loop
->dimen
;
3226 /* Evaluate the bounds of the result, if known. */
3227 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, comp
->as
);
3229 /* Create a temporary to store the result. In case the function
3230 returns a pointer, the temporary will be a shallow copy and
3231 mustn't be deallocated. */
3232 callee_alloc
= comp
->attr
.allocatable
|| comp
->attr
.pointer
;
3233 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3234 NULL_TREE
, false, !comp
->attr
.pointer
,
3235 callee_alloc
, &se
->ss
->expr
->where
);
3237 /* Pass the temporary as the first argument. */
3238 result
= info
->descriptor
;
3239 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3240 retargs
= gfc_chainon_list (retargs
, tmp
);
3242 else if (!comp
&& sym
->result
->attr
.dimension
)
3244 gcc_assert (se
->loop
&& info
);
3246 /* Set the type of the array. */
3247 tmp
= gfc_typenode_for_spec (&ts
);
3248 info
->dimen
= se
->loop
->dimen
;
3250 /* Evaluate the bounds of the result, if known. */
3251 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
3253 /* Create a temporary to store the result. In case the function
3254 returns a pointer, the temporary will be a shallow copy and
3255 mustn't be deallocated. */
3256 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
3257 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
3258 NULL_TREE
, false, !sym
->attr
.pointer
,
3259 callee_alloc
, &se
->ss
->expr
->where
);
3261 /* Pass the temporary as the first argument. */
3262 result
= info
->descriptor
;
3263 tmp
= gfc_build_addr_expr (NULL_TREE
, result
);
3264 retargs
= gfc_chainon_list (retargs
, tmp
);
3266 else if (ts
.type
== BT_CHARACTER
)
3268 /* Pass the string length. */
3269 type
= gfc_get_character_type (ts
.kind
, ts
.u
.cl
);
3270 type
= build_pointer_type (type
);
3272 /* Return an address to a char[0:len-1]* temporary for
3273 character pointers. */
3274 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3275 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3277 var
= gfc_create_var (type
, "pstr");
3279 if ((!comp
&& sym
->attr
.allocatable
)
3280 || (comp
&& comp
->attr
.allocatable
))
3281 gfc_add_modify (&se
->pre
, var
,
3282 fold_convert (TREE_TYPE (var
),
3283 null_pointer_node
));
3285 /* Provide an address expression for the function arguments. */
3286 var
= gfc_build_addr_expr (NULL_TREE
, var
);
3289 var
= gfc_conv_string_tmp (se
, type
, len
);
3291 retargs
= gfc_chainon_list (retargs
, var
);
3295 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
3297 type
= gfc_get_complex_type (ts
.kind
);
3298 var
= gfc_build_addr_expr (NULL_TREE
, gfc_create_var (type
, "cmplx"));
3299 retargs
= gfc_chainon_list (retargs
, var
);
3302 /* Add the string length to the argument list. */
3303 if (ts
.type
== BT_CHARACTER
)
3304 retargs
= gfc_chainon_list (retargs
, len
);
3306 gfc_free_interface_mapping (&mapping
);
3308 /* Add the return arguments. */
3309 arglist
= chainon (retargs
, arglist
);
3311 /* Add the hidden string length parameters to the arguments. */
3312 arglist
= chainon (arglist
, stringargs
);
3314 /* We may want to append extra arguments here. This is used e.g. for
3315 calls to libgfortran_matmul_??, which need extra information. */
3316 if (append_args
!= NULL_TREE
)
3317 arglist
= chainon (arglist
, append_args
);
3319 /* Generate the actual call. */
3320 conv_function_val (se
, sym
, expr
);
3322 /* If there are alternate return labels, function type should be
3323 integer. Can't modify the type in place though, since it can be shared
3324 with other functions. For dummy arguments, the typing is done to
3325 to this result, even if it has to be repeated for each call. */
3326 if (has_alternate_specifier
3327 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
3329 if (!sym
->attr
.dummy
)
3331 TREE_TYPE (sym
->backend_decl
)
3332 = build_function_type (integer_type_node
,
3333 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
3334 se
->expr
= gfc_build_addr_expr (NULL_TREE
, sym
->backend_decl
);
3337 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
3340 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
3341 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
3343 /* If we have a pointer function, but we don't want a pointer, e.g.
3346 where f is pointer valued, we have to dereference the result. */
3347 if (!se
->want_pointer
&& !byref
3348 && (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
3349 && !gfc_is_proc_ptr_comp (expr
, NULL
))
3350 se
->expr
= build_fold_indirect_ref_loc (input_location
,
3353 /* f2c calling conventions require a scalar default real function to
3354 return a double precision result. Convert this back to default
3355 real. We only care about the cases that can happen in Fortran 77.
3357 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
3358 && sym
->ts
.kind
== gfc_default_real_kind
3359 && !sym
->attr
.always_explicit
)
3360 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
3362 /* A pure function may still have side-effects - it may modify its
3364 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3366 if (!sym
->attr
.pure
)
3367 TREE_SIDE_EFFECTS (se
->expr
) = 1;
3372 /* Add the function call to the pre chain. There is no expression. */
3373 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
3374 se
->expr
= NULL_TREE
;
3376 if (!se
->direct_byref
)
3378 if (sym
->attr
.dimension
|| (comp
&& comp
->attr
.dimension
))
3380 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3382 /* Check the data pointer hasn't been modified. This would
3383 happen in a function returning a pointer. */
3384 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
3385 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
3387 gfc_trans_runtime_check (true, false, tmp
, &se
->pre
, NULL
,
3390 se
->expr
= info
->descriptor
;
3391 /* Bundle in the string length. */
3392 se
->string_length
= len
;
3394 else if (ts
.type
== BT_CHARACTER
)
3396 /* Dereference for character pointer results. */
3397 if ((!comp
&& (sym
->attr
.pointer
|| sym
->attr
.allocatable
))
3398 || (comp
&& (comp
->attr
.pointer
|| comp
->attr
.allocatable
)))
3399 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3403 se
->string_length
= len
;
3407 gcc_assert (ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
3408 se
->expr
= build_fold_indirect_ref_loc (input_location
, var
);
3413 /* Follow the function call with the argument post block. */
3416 gfc_add_block_to_block (&se
->pre
, &post
);
3418 /* Transformational functions of derived types with allocatable
3419 components must have the result allocatable components copied. */
3420 arg
= expr
->value
.function
.actual
;
3421 if (result
&& arg
&& expr
->rank
3422 && expr
->value
.function
.isym
3423 && expr
->value
.function
.isym
->transformational
3424 && arg
->expr
->ts
.type
== BT_DERIVED
3425 && arg
->expr
->ts
.u
.derived
->attr
.alloc_comp
)
3428 /* Copy the allocatable components. We have to use a
3429 temporary here to prevent source allocatable components
3430 from being corrupted. */
3431 tmp2
= gfc_evaluate_now (result
, &se
->pre
);
3432 tmp
= gfc_copy_alloc_comp (arg
->expr
->ts
.u
.derived
,
3433 result
, tmp2
, expr
->rank
);
3434 gfc_add_expr_to_block (&se
->pre
, tmp
);
3435 tmp
= gfc_copy_allocatable_data (result
, tmp2
, TREE_TYPE(tmp2
),
3437 gfc_add_expr_to_block (&se
->pre
, tmp
);
3439 /* Finally free the temporary's data field. */
3440 tmp
= gfc_conv_descriptor_data_get (tmp2
);
3441 tmp
= gfc_deallocate_with_status (tmp
, NULL_TREE
, true, NULL
);
3442 gfc_add_expr_to_block (&se
->pre
, tmp
);
3446 gfc_add_block_to_block (&se
->post
, &post
);
3448 return has_alternate_specifier
;
3452 /* Fill a character string with spaces. */
3455 fill_with_spaces (tree start
, tree type
, tree size
)
3457 stmtblock_t block
, loop
;
3458 tree i
, el
, exit_label
, cond
, tmp
;
3460 /* For a simple char type, we can call memset(). */
3461 if (compare_tree_int (TYPE_SIZE_UNIT (type
), 1) == 0)
3462 return build_call_expr_loc (input_location
,
3463 built_in_decls
[BUILT_IN_MEMSET
], 3, start
,
3464 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
3465 lang_hooks
.to_target_charset (' ')),
3468 /* Otherwise, we use a loop:
3469 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3473 /* Initialize variables. */
3474 gfc_init_block (&block
);
3475 i
= gfc_create_var (sizetype
, "i");
3476 gfc_add_modify (&block
, i
, fold_convert (sizetype
, size
));
3477 el
= gfc_create_var (build_pointer_type (type
), "el");
3478 gfc_add_modify (&block
, el
, fold_convert (TREE_TYPE (el
), start
));
3479 exit_label
= gfc_build_label_decl (NULL_TREE
);
3480 TREE_USED (exit_label
) = 1;
3484 gfc_init_block (&loop
);
3486 /* Exit condition. */
3487 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, i
,
3488 fold_convert (sizetype
, integer_zero_node
));
3489 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3490 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3491 build_empty_stmt (input_location
));
3492 gfc_add_expr_to_block (&loop
, tmp
);
3495 gfc_add_modify (&loop
, fold_build1 (INDIRECT_REF
, type
, el
),
3496 build_int_cst (type
,
3497 lang_hooks
.to_target_charset (' ')));
3499 /* Increment loop variables. */
3500 gfc_add_modify (&loop
, i
, fold_build2 (MINUS_EXPR
, sizetype
, i
,
3501 TYPE_SIZE_UNIT (type
)));
3502 gfc_add_modify (&loop
, el
, fold_build2 (POINTER_PLUS_EXPR
,
3504 TYPE_SIZE_UNIT (type
)));
3506 /* Making the loop... actually loop! */
3507 tmp
= gfc_finish_block (&loop
);
3508 tmp
= build1_v (LOOP_EXPR
, tmp
);
3509 gfc_add_expr_to_block (&block
, tmp
);
3511 /* The exit label. */
3512 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3513 gfc_add_expr_to_block (&block
, tmp
);
3516 return gfc_finish_block (&block
);
3520 /* Generate code to copy a string. */
3523 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
3524 int dkind
, tree slength
, tree src
, int skind
)
3526 tree tmp
, dlen
, slen
;
3535 stmtblock_t tempblock
;
3537 gcc_assert (dkind
== skind
);
3539 if (slength
!= NULL_TREE
)
3541 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
3542 ssc
= string_to_single_character (slen
, src
, skind
);
3546 slen
= build_int_cst (size_type_node
, 1);
3550 if (dlength
!= NULL_TREE
)
3552 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
3553 dsc
= string_to_single_character (slen
, dest
, dkind
);
3557 dlen
= build_int_cst (size_type_node
, 1);
3561 if (slength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (src
)))
3562 ssc
= string_to_single_character (slen
, src
, skind
);
3563 if (dlength
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (dest
)))
3564 dsc
= string_to_single_character (dlen
, dest
, dkind
);
3567 /* Assign directly if the types are compatible. */
3568 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
3569 && TREE_TYPE (dsc
) == TREE_TYPE (ssc
))
3571 gfc_add_modify (block
, dsc
, ssc
);
3575 /* Do nothing if the destination length is zero. */
3576 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
3577 build_int_cst (size_type_node
, 0));
3579 /* The following code was previously in _gfortran_copy_string:
3581 // The two strings may overlap so we use memmove.
3583 copy_string (GFC_INTEGER_4 destlen, char * dest,
3584 GFC_INTEGER_4 srclen, const char * src)
3586 if (srclen >= destlen)
3588 // This will truncate if too long.
3589 memmove (dest, src, destlen);
3593 memmove (dest, src, srclen);
3595 memset (&dest[srclen], ' ', destlen - srclen);
3599 We're now doing it here for better optimization, but the logic
3602 /* For non-default character kinds, we have to multiply the string
3603 length by the base type size. */
3604 chartype
= gfc_get_char_type (dkind
);
3605 slen
= fold_build2 (MULT_EXPR
, size_type_node
,
3606 fold_convert (size_type_node
, slen
),
3607 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3608 dlen
= fold_build2 (MULT_EXPR
, size_type_node
,
3609 fold_convert (size_type_node
, dlen
),
3610 fold_convert (size_type_node
, TYPE_SIZE_UNIT (chartype
)));
3613 dest
= fold_convert (pvoid_type_node
, dest
);
3615 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3618 src
= fold_convert (pvoid_type_node
, src
);
3620 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3622 /* Truncate string if source is too long. */
3623 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
3624 tmp2
= build_call_expr_loc (input_location
,
3625 built_in_decls
[BUILT_IN_MEMMOVE
],
3626 3, dest
, src
, dlen
);
3628 /* Else copy and pad with spaces. */
3629 tmp3
= build_call_expr_loc (input_location
,
3630 built_in_decls
[BUILT_IN_MEMMOVE
],
3631 3, dest
, src
, slen
);
3633 tmp4
= fold_build2 (POINTER_PLUS_EXPR
, TREE_TYPE (dest
), dest
,
3634 fold_convert (sizetype
, slen
));
3635 tmp4
= fill_with_spaces (tmp4
, chartype
,
3636 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
3639 gfc_init_block (&tempblock
);
3640 gfc_add_expr_to_block (&tempblock
, tmp3
);
3641 gfc_add_expr_to_block (&tempblock
, tmp4
);
3642 tmp3
= gfc_finish_block (&tempblock
);
3644 /* The whole copy_string function is there. */
3645 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
3646 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
,
3647 build_empty_stmt (input_location
));
3648 gfc_add_expr_to_block (block
, tmp
);
3652 /* Translate a statement function.
3653 The value of a statement function reference is obtained by evaluating the
3654 expression using the values of the actual arguments for the values of the
3655 corresponding dummy arguments. */
3658 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
3662 gfc_formal_arglist
*fargs
;
3663 gfc_actual_arglist
*args
;
3666 gfc_saved_var
*saved_vars
;
3672 sym
= expr
->symtree
->n
.sym
;
3673 args
= expr
->value
.function
.actual
;
3674 gfc_init_se (&lse
, NULL
);
3675 gfc_init_se (&rse
, NULL
);
3678 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
3680 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
3681 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
3683 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3685 /* Each dummy shall be specified, explicitly or implicitly, to be
3687 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
3690 /* Create a temporary to hold the value. */
3691 type
= gfc_typenode_for_spec (&fsym
->ts
);
3692 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
3694 if (fsym
->ts
.type
== BT_CHARACTER
)
3696 /* Copy string arguments. */
3699 gcc_assert (fsym
->ts
.u
.cl
&& fsym
->ts
.u
.cl
->length
3700 && fsym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
3702 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
3703 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
3706 gfc_conv_expr (&rse
, args
->expr
);
3707 gfc_conv_string_parameter (&rse
);
3708 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3709 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
3711 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, fsym
->ts
.kind
,
3712 rse
.string_length
, rse
.expr
, fsym
->ts
.kind
);
3713 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3714 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
3718 /* For everything else, just evaluate the expression. */
3719 gfc_conv_expr (&lse
, args
->expr
);
3721 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
3722 gfc_add_modify (&se
->pre
, temp_vars
[n
], lse
.expr
);
3723 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
3729 /* Use the temporary variables in place of the real ones. */
3730 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3731 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
3733 gfc_conv_expr (se
, sym
->value
);
3735 if (sym
->ts
.type
== BT_CHARACTER
)
3737 gfc_conv_const_charlen (sym
->ts
.u
.cl
);
3739 /* Force the expression to the correct length. */
3740 if (!INTEGER_CST_P (se
->string_length
)
3741 || tree_int_cst_lt (se
->string_length
,
3742 sym
->ts
.u
.cl
->backend_decl
))
3744 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.u
.cl
);
3745 tmp
= gfc_create_var (type
, sym
->name
);
3746 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
3747 gfc_trans_string_copy (&se
->pre
, sym
->ts
.u
.cl
->backend_decl
, tmp
,
3748 sym
->ts
.kind
, se
->string_length
, se
->expr
,
3752 se
->string_length
= sym
->ts
.u
.cl
->backend_decl
;
3755 /* Restore the original variables. */
3756 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
3757 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
3758 gfc_free (saved_vars
);
3762 /* Translate a function expression. */
3765 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
3769 if (expr
->value
.function
.isym
)
3771 gfc_conv_intrinsic_function (se
, expr
);
3775 /* We distinguish statement functions from general functions to improve
3776 runtime performance. */
3777 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
3779 gfc_conv_statement_function (se
, expr
);
3783 /* expr.value.function.esym is the resolved (specific) function symbol for
3784 most functions. However this isn't set for dummy procedures. */
3785 sym
= expr
->value
.function
.esym
;
3787 sym
= expr
->symtree
->n
.sym
;
3789 gfc_conv_procedure_call (se
, sym
, expr
->value
.function
.actual
, expr
,
3794 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3797 is_zero_initializer_p (gfc_expr
* expr
)
3799 if (expr
->expr_type
!= EXPR_CONSTANT
)
3802 /* We ignore constants with prescribed memory representations for now. */
3803 if (expr
->representation
.string
)
3806 switch (expr
->ts
.type
)
3809 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3812 return mpfr_zero_p (expr
->value
.real
)
3813 && MPFR_SIGN (expr
->value
.real
) >= 0;
3816 return expr
->value
.logical
== 0;
3819 return mpfr_zero_p (mpc_realref (expr
->value
.complex))
3820 && MPFR_SIGN (mpc_realref (expr
->value
.complex)) >= 0
3821 && mpfr_zero_p (mpc_imagref (expr
->value
.complex))
3822 && MPFR_SIGN (mpc_imagref (expr
->value
.complex)) >= 0;
3832 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
3834 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
3835 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
3837 gfc_conv_tmp_array_ref (se
);
3838 gfc_advance_se_ss_chain (se
);
3842 /* Build a static initializer. EXPR is the expression for the initial value.
3843 The other parameters describe the variable of the component being
3844 initialized. EXPR may be null. */
3847 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
3848 bool array
, bool pointer
)
3852 if (!(expr
|| pointer
))
3855 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3856 (these are the only two iso_c_binding derived types that can be
3857 used as initialization expressions). If so, we need to modify
3858 the 'expr' to be that for a (void *). */
3859 if (expr
!= NULL
&& expr
->ts
.type
== BT_DERIVED
3860 && expr
->ts
.is_iso_c
&& expr
->ts
.u
.derived
)
3862 gfc_symbol
*derived
= expr
->ts
.u
.derived
;
3864 /* The derived symbol has already been converted to a (void *). Use
3866 expr
= gfc_get_int_expr (derived
->ts
.kind
, NULL
, 0);
3867 expr
->ts
.f90_type
= derived
->ts
.f90_type
;
3869 gfc_init_se (&se
, NULL
);
3870 gfc_conv_constant (&se
, expr
);
3876 /* Arrays need special handling. */
3878 return gfc_build_null_descriptor (type
);
3879 /* Special case assigning an array to zero. */
3880 else if (is_zero_initializer_p (expr
))
3881 return build_constructor (type
, NULL
);
3883 return gfc_conv_array_initializer (type
, expr
);
3886 return fold_convert (type
, null_pointer_node
);
3893 gfc_init_se (&se
, NULL
);
3894 if (ts
->type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
3895 gfc_conv_structure (&se
, gfc_class_null_initializer(ts
), 1);
3897 gfc_conv_structure (&se
, expr
, 1);
3901 return gfc_conv_string_init (ts
->u
.cl
->backend_decl
,expr
);
3904 gfc_init_se (&se
, NULL
);
3905 gfc_conv_constant (&se
, expr
);
3912 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
3924 gfc_start_block (&block
);
3926 /* Initialize the scalarizer. */
3927 gfc_init_loopinfo (&loop
);
3929 gfc_init_se (&lse
, NULL
);
3930 gfc_init_se (&rse
, NULL
);
3933 rss
= gfc_walk_expr (expr
);
3934 if (rss
== gfc_ss_terminator
)
3936 /* The rhs is scalar. Add a ss for the expression. */
3937 rss
= gfc_get_ss ();
3938 rss
->next
= gfc_ss_terminator
;
3939 rss
->type
= GFC_SS_SCALAR
;
3943 /* Create a SS for the destination. */
3944 lss
= gfc_get_ss ();
3945 lss
->type
= GFC_SS_COMPONENT
;
3947 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
3948 lss
->next
= gfc_ss_terminator
;
3949 lss
->data
.info
.dimen
= cm
->as
->rank
;
3950 lss
->data
.info
.descriptor
= dest
;
3951 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
3952 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
3953 for (n
= 0; n
< cm
->as
->rank
; n
++)
3955 lss
->data
.info
.dim
[n
] = n
;
3956 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
3957 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
3959 mpz_init (lss
->shape
[n
]);
3960 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
3961 cm
->as
->lower
[n
]->value
.integer
);
3962 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
3965 /* Associate the SS with the loop. */
3966 gfc_add_ss_to_loop (&loop
, lss
);
3967 gfc_add_ss_to_loop (&loop
, rss
);
3969 /* Calculate the bounds of the scalarization. */
3970 gfc_conv_ss_startstride (&loop
);
3972 /* Setup the scalarizing loops. */
3973 gfc_conv_loop_setup (&loop
, &expr
->where
);
3975 /* Setup the gfc_se structures. */
3976 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3977 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3980 gfc_mark_ss_chain_used (rss
, 1);
3982 gfc_mark_ss_chain_used (lss
, 1);
3984 /* Start the scalarized loop body. */
3985 gfc_start_scalarized_body (&loop
, &body
);
3987 gfc_conv_tmp_array_ref (&lse
);
3988 if (cm
->ts
.type
== BT_CHARACTER
)
3989 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
3991 gfc_conv_expr (&rse
, expr
);
3993 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false, true);
3994 gfc_add_expr_to_block (&body
, tmp
);
3996 gcc_assert (rse
.ss
== gfc_ss_terminator
);
3998 /* Generate the copying loops. */
3999 gfc_trans_scalarizing_loops (&loop
, &body
);
4001 /* Wrap the whole thing up. */
4002 gfc_add_block_to_block (&block
, &loop
.pre
);
4003 gfc_add_block_to_block (&block
, &loop
.post
);
4005 for (n
= 0; n
< cm
->as
->rank
; n
++)
4006 mpz_clear (lss
->shape
[n
]);
4007 gfc_free (lss
->shape
);
4009 gfc_cleanup_loop (&loop
);
4011 return gfc_finish_block (&block
);
4016 gfc_trans_alloc_subarray_assign (tree dest
, gfc_component
* cm
,
4027 gfc_expr
*arg
= NULL
;
4029 gfc_start_block (&block
);
4030 gfc_init_se (&se
, NULL
);
4032 /* Get the descriptor for the expressions. */
4033 rss
= gfc_walk_expr (expr
);
4034 se
.want_pointer
= 0;
4035 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4036 gfc_add_block_to_block (&block
, &se
.pre
);
4037 gfc_add_modify (&block
, dest
, se
.expr
);
4039 /* Deal with arrays of derived types with allocatable components. */
4040 if (cm
->ts
.type
== BT_DERIVED
4041 && cm
->ts
.u
.derived
->attr
.alloc_comp
)
4042 tmp
= gfc_copy_alloc_comp (cm
->ts
.u
.derived
,
4046 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
4047 TREE_TYPE(cm
->backend_decl
),
4050 gfc_add_expr_to_block (&block
, tmp
);
4051 gfc_add_block_to_block (&block
, &se
.post
);
4053 if (expr
->expr_type
!= EXPR_VARIABLE
)
4054 gfc_conv_descriptor_data_set (&block
, se
.expr
,
4057 /* We need to know if the argument of a conversion function is a
4058 variable, so that the correct lower bound can be used. */
4059 if (expr
->expr_type
== EXPR_FUNCTION
4060 && expr
->value
.function
.isym
4061 && expr
->value
.function
.isym
->conversion
4062 && expr
->value
.function
.actual
->expr
4063 && expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
)
4064 arg
= expr
->value
.function
.actual
->expr
;
4066 /* Obtain the array spec of full array references. */
4068 as
= gfc_get_full_arrayspec_from_expr (arg
);
4070 as
= gfc_get_full_arrayspec_from_expr (expr
);
4072 /* Shift the lbound and ubound of temporaries to being unity,
4073 rather than zero, based. Always calculate the offset. */
4074 offset
= gfc_conv_descriptor_offset_get (dest
);
4075 gfc_add_modify (&block
, offset
, gfc_index_zero_node
);
4076 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
4078 for (n
= 0; n
< expr
->rank
; n
++)
4083 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
4084 TODO It looks as if gfc_conv_expr_descriptor should return
4085 the correct bounds and that the following should not be
4086 necessary. This would simplify gfc_conv_intrinsic_bound
4088 if (as
&& as
->lower
[n
])
4091 gfc_init_se (&lbse
, NULL
);
4092 gfc_conv_expr (&lbse
, as
->lower
[n
]);
4093 gfc_add_block_to_block (&block
, &lbse
.pre
);
4094 lbound
= gfc_evaluate_now (lbse
.expr
, &block
);
4098 tmp
= gfc_get_symbol_decl (arg
->symtree
->n
.sym
);
4099 lbound
= gfc_conv_descriptor_lbound_get (tmp
,
4103 lbound
= gfc_conv_descriptor_lbound_get (dest
,
4106 lbound
= gfc_index_one_node
;
4108 lbound
= fold_convert (gfc_array_index_type
, lbound
);
4110 /* Shift the bounds and set the offset accordingly. */
4111 tmp
= gfc_conv_descriptor_ubound_get (dest
, gfc_rank_cst
[n
]);
4112 span
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, tmp
,
4113 gfc_conv_descriptor_lbound_get (dest
, gfc_rank_cst
[n
]));
4114 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, span
, lbound
);
4115 gfc_conv_descriptor_ubound_set (&block
, dest
,
4116 gfc_rank_cst
[n
], tmp
);
4117 gfc_conv_descriptor_lbound_set (&block
, dest
,
4118 gfc_rank_cst
[n
], lbound
);
4120 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
4121 gfc_conv_descriptor_lbound_get (dest
,
4123 gfc_conv_descriptor_stride_get (dest
,
4125 gfc_add_modify (&block
, tmp2
, tmp
);
4126 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
4127 gfc_conv_descriptor_offset_set (&block
, dest
, tmp
);
4132 /* If a conversion expression has a null data pointer
4133 argument, nullify the allocatable component. */
4137 if (arg
->symtree
->n
.sym
->attr
.allocatable
4138 || arg
->symtree
->n
.sym
->attr
.pointer
)
4140 non_null_expr
= gfc_finish_block (&block
);
4141 gfc_start_block (&block
);
4142 gfc_conv_descriptor_data_set (&block
, dest
,
4144 null_expr
= gfc_finish_block (&block
);
4145 tmp
= gfc_conv_descriptor_data_get (arg
->symtree
->n
.sym
->backend_decl
);
4146 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
,
4147 fold_convert (TREE_TYPE (tmp
),
4148 null_pointer_node
));
4149 return build3_v (COND_EXPR
, tmp
,
4150 null_expr
, non_null_expr
);
4154 return gfc_finish_block (&block
);
4158 /* Assign a single component of a derived type constructor. */
4161 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
4169 gfc_start_block (&block
);
4171 if (cm
->attr
.pointer
)
4173 gfc_init_se (&se
, NULL
);
4174 /* Pointer component. */
4175 if (cm
->attr
.dimension
)
4177 /* Array pointer. */
4178 if (expr
->expr_type
== EXPR_NULL
)
4179 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4182 rss
= gfc_walk_expr (expr
);
4183 se
.direct_byref
= 1;
4185 gfc_conv_expr_descriptor (&se
, expr
, rss
);
4186 gfc_add_block_to_block (&block
, &se
.pre
);
4187 gfc_add_block_to_block (&block
, &se
.post
);
4192 /* Scalar pointers. */
4193 se
.want_pointer
= 1;
4194 gfc_conv_expr (&se
, expr
);
4195 gfc_add_block_to_block (&block
, &se
.pre
);
4196 gfc_add_modify (&block
, dest
,
4197 fold_convert (TREE_TYPE (dest
), se
.expr
));
4198 gfc_add_block_to_block (&block
, &se
.post
);
4201 else if (cm
->ts
.type
== BT_CLASS
&& expr
->expr_type
== EXPR_NULL
)
4203 /* NULL initialization for CLASS components. */
4204 tmp
= gfc_trans_structure_assign (dest
,
4205 gfc_class_null_initializer (&cm
->ts
));
4206 gfc_add_expr_to_block (&block
, tmp
);
4208 else if (cm
->attr
.dimension
)
4210 if (cm
->attr
.allocatable
&& expr
->expr_type
== EXPR_NULL
)
4211 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
4212 else if (cm
->attr
.allocatable
)
4214 tmp
= gfc_trans_alloc_subarray_assign (dest
, cm
, expr
);
4215 gfc_add_expr_to_block (&block
, tmp
);
4219 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
4220 gfc_add_expr_to_block (&block
, tmp
);
4223 else if (expr
->ts
.type
== BT_DERIVED
)
4225 if (expr
->expr_type
!= EXPR_STRUCTURE
)
4227 gfc_init_se (&se
, NULL
);
4228 gfc_conv_expr (&se
, expr
);
4229 gfc_add_block_to_block (&block
, &se
.pre
);
4230 gfc_add_modify (&block
, dest
,
4231 fold_convert (TREE_TYPE (dest
), se
.expr
));
4232 gfc_add_block_to_block (&block
, &se
.post
);
4236 /* Nested constructors. */
4237 tmp
= gfc_trans_structure_assign (dest
, expr
);
4238 gfc_add_expr_to_block (&block
, tmp
);
4243 /* Scalar component. */
4244 gfc_init_se (&se
, NULL
);
4245 gfc_init_se (&lse
, NULL
);
4247 gfc_conv_expr (&se
, expr
);
4248 if (cm
->ts
.type
== BT_CHARACTER
)
4249 lse
.string_length
= cm
->ts
.u
.cl
->backend_decl
;
4251 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false, true);
4252 gfc_add_expr_to_block (&block
, tmp
);
4254 return gfc_finish_block (&block
);
4257 /* Assign a derived type constructor to a variable. */
4260 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
4268 gfc_start_block (&block
);
4269 cm
= expr
->ts
.u
.derived
->components
;
4270 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4271 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4273 /* Skip absent members in default initializers. */
4277 /* Handle c_null_(fun)ptr. */
4278 if (c
&& c
->expr
&& c
->expr
->ts
.is_iso_c
)
4280 field
= cm
->backend_decl
;
4281 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4282 dest
, field
, NULL_TREE
);
4283 tmp
= fold_build2 (MODIFY_EXPR
, TREE_TYPE (tmp
), tmp
,
4284 fold_convert (TREE_TYPE (tmp
),
4285 null_pointer_node
));
4286 gfc_add_expr_to_block (&block
, tmp
);
4290 field
= cm
->backend_decl
;
4291 tmp
= fold_build3 (COMPONENT_REF
, TREE_TYPE (field
),
4292 dest
, field
, NULL_TREE
);
4293 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
4294 gfc_add_expr_to_block (&block
, tmp
);
4296 return gfc_finish_block (&block
);
4299 /* Build an expression for a constructor. If init is nonzero then
4300 this is part of a static variable initializer. */
4303 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
4310 VEC(constructor_elt
,gc
) *v
= NULL
;
4312 gcc_assert (se
->ss
== NULL
);
4313 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
4314 type
= gfc_typenode_for_spec (&expr
->ts
);
4318 /* Create a temporary variable and fill it in. */
4319 se
->expr
= gfc_create_var (type
, expr
->ts
.u
.derived
->name
);
4320 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
4321 gfc_add_expr_to_block (&se
->pre
, tmp
);
4325 cm
= expr
->ts
.u
.derived
->components
;
4327 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4328 c
; c
= gfc_constructor_next (c
), cm
= cm
->next
)
4330 /* Skip absent members in default initializers and allocatable
4331 components. Although the latter have a default initializer
4332 of EXPR_NULL,... by default, the static nullify is not needed
4333 since this is done every time we come into scope. */
4334 if (!c
->expr
|| cm
->attr
.allocatable
)
4337 if (strcmp (cm
->name
, "$size") == 0)
4339 val
= TYPE_SIZE_UNIT (gfc_get_derived_type (cm
->ts
.u
.derived
));
4340 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4342 else if (cm
->initializer
&& cm
->initializer
->expr_type
!= EXPR_NULL
4343 && strcmp (cm
->name
, "$extends") == 0)
4347 vtabs
= cm
->initializer
->symtree
->n
.sym
;
4348 vtab
= gfc_build_addr_expr (NULL_TREE
, gfc_get_symbol_decl (vtabs
));
4349 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, vtab
);
4353 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
4354 TREE_TYPE (cm
->backend_decl
), cm
->attr
.dimension
,
4355 cm
->attr
.pointer
|| cm
->attr
.proc_pointer
);
4357 /* Append it to the constructor list. */
4358 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
4361 se
->expr
= build_constructor (type
, v
);
4363 TREE_CONSTANT (se
->expr
) = 1;
4367 /* Translate a substring expression. */
4370 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
4376 gcc_assert (ref
== NULL
|| ref
->type
== REF_SUBSTRING
);
4378 se
->expr
= gfc_build_wide_string_const (expr
->ts
.kind
,
4379 expr
->value
.character
.length
,
4380 expr
->value
.character
.string
);
4382 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
4383 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)) = 1;
4386 gfc_conv_substring (se
, ref
, expr
->ts
.kind
, NULL
, &expr
->where
);
4390 /* Entry point for expression translation. Evaluates a scalar quantity.
4391 EXPR is the expression to be translated, and SE is the state structure if
4392 called from within the scalarized. */
4395 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
4397 if (se
->ss
&& se
->ss
->expr
== expr
4398 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
4400 /* Substitute a scalar expression evaluated outside the scalarization
4402 se
->expr
= se
->ss
->data
.scalar
.expr
;
4403 if (se
->ss
->type
== GFC_SS_REFERENCE
)
4404 se
->expr
= gfc_build_addr_expr (NULL_TREE
, se
->expr
);
4405 se
->string_length
= se
->ss
->string_length
;
4406 gfc_advance_se_ss_chain (se
);
4410 /* We need to convert the expressions for the iso_c_binding derived types.
4411 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
4412 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
4413 typespec for the C_PTR and C_FUNPTR symbols, which has already been
4414 updated to be an integer with a kind equal to the size of a (void *). */
4415 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
4416 && expr
->ts
.u
.derived
->attr
.is_iso_c
)
4418 if (expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_PTR
4419 || expr
->symtree
->n
.sym
->intmod_sym_id
== ISOCBINDING_NULL_FUNPTR
)
4421 /* Set expr_type to EXPR_NULL, which will result in
4422 null_pointer_node being used below. */
4423 expr
->expr_type
= EXPR_NULL
;
4427 /* Update the type/kind of the expression to be what the new
4428 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
4429 expr
->ts
.type
= expr
->ts
.u
.derived
->ts
.type
;
4430 expr
->ts
.f90_type
= expr
->ts
.u
.derived
->ts
.f90_type
;
4431 expr
->ts
.kind
= expr
->ts
.u
.derived
->ts
.kind
;
4435 switch (expr
->expr_type
)
4438 gfc_conv_expr_op (se
, expr
);
4442 gfc_conv_function_expr (se
, expr
);
4446 gfc_conv_constant (se
, expr
);
4450 gfc_conv_variable (se
, expr
);
4454 se
->expr
= null_pointer_node
;
4457 case EXPR_SUBSTRING
:
4458 gfc_conv_substring_expr (se
, expr
);
4461 case EXPR_STRUCTURE
:
4462 gfc_conv_structure (se
, expr
, 0);
4466 gfc_conv_array_constructor_expr (se
, expr
);
4475 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
4476 of an assignment. */
4478 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
4480 gfc_conv_expr (se
, expr
);
4481 /* All numeric lvalues should have empty post chains. If not we need to
4482 figure out a way of rewriting an lvalue so that it has no post chain. */
4483 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
4486 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
4487 numeric expressions. Used for scalar values where inserting cleanup code
4490 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
4494 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
4495 gfc_conv_expr (se
, expr
);
4498 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4499 gfc_add_modify (&se
->pre
, val
, se
->expr
);
4501 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4505 /* Helper to translate an expression and convert it to a particular type. */
4507 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
4509 gfc_conv_expr_val (se
, expr
);
4510 se
->expr
= convert (type
, se
->expr
);
4514 /* Converts an expression so that it can be passed by reference. Scalar
4518 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
4522 if (se
->ss
&& se
->ss
->expr
== expr
4523 && se
->ss
->type
== GFC_SS_REFERENCE
)
4525 /* Returns a reference to the scalar evaluated outside the loop
4527 gfc_conv_expr (se
, expr
);
4531 if (expr
->ts
.type
== BT_CHARACTER
)
4533 gfc_conv_expr (se
, expr
);
4534 gfc_conv_string_parameter (se
);
4538 if (expr
->expr_type
== EXPR_VARIABLE
)
4540 se
->want_pointer
= 1;
4541 gfc_conv_expr (se
, expr
);
4544 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4545 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4546 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4552 if (expr
->expr_type
== EXPR_FUNCTION
4553 && ((expr
->value
.function
.esym
4554 && expr
->value
.function
.esym
->result
->attr
.pointer
4555 && !expr
->value
.function
.esym
->result
->attr
.dimension
)
4556 || (!expr
->value
.function
.esym
4557 && expr
->symtree
->n
.sym
->attr
.pointer
4558 && !expr
->symtree
->n
.sym
->attr
.dimension
)))
4560 se
->want_pointer
= 1;
4561 gfc_conv_expr (se
, expr
);
4562 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4563 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4569 gfc_conv_expr (se
, expr
);
4571 /* Create a temporary var to hold the value. */
4572 if (TREE_CONSTANT (se
->expr
))
4574 tree tmp
= se
->expr
;
4575 STRIP_TYPE_NOPS (tmp
);
4576 var
= build_decl (input_location
,
4577 CONST_DECL
, NULL
, TREE_TYPE (tmp
));
4578 DECL_INITIAL (var
) = tmp
;
4579 TREE_STATIC (var
) = 1;
4584 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
4585 gfc_add_modify (&se
->pre
, var
, se
->expr
);
4587 gfc_add_block_to_block (&se
->pre
, &se
->post
);
4589 /* Take the address of that value. */
4590 se
->expr
= gfc_build_addr_expr (NULL_TREE
, var
);
4595 gfc_trans_pointer_assign (gfc_code
* code
)
4597 return gfc_trans_pointer_assignment (code
->expr1
, code
->expr2
);
4601 /* Generate code for a pointer assignment. */
4604 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
4615 gfc_start_block (&block
);
4617 gfc_init_se (&lse
, NULL
);
4619 lss
= gfc_walk_expr (expr1
);
4620 rss
= gfc_walk_expr (expr2
);
4621 if (lss
== gfc_ss_terminator
)
4623 /* Scalar pointers. */
4624 lse
.want_pointer
= 1;
4625 gfc_conv_expr (&lse
, expr1
);
4626 gcc_assert (rss
== gfc_ss_terminator
);
4627 gfc_init_se (&rse
, NULL
);
4628 rse
.want_pointer
= 1;
4629 gfc_conv_expr (&rse
, expr2
);
4631 if (expr1
->symtree
->n
.sym
->attr
.proc_pointer
4632 && expr1
->symtree
->n
.sym
->attr
.dummy
)
4633 lse
.expr
= build_fold_indirect_ref_loc (input_location
,
4636 if (expr2
->symtree
&& expr2
->symtree
->n
.sym
->attr
.proc_pointer
4637 && expr2
->symtree
->n
.sym
->attr
.dummy
)
4638 rse
.expr
= build_fold_indirect_ref_loc (input_location
,
4641 gfc_add_block_to_block (&block
, &lse
.pre
);
4642 gfc_add_block_to_block (&block
, &rse
.pre
);
4644 /* Check character lengths if character expression. The test is only
4645 really added if -fbounds-check is enabled. */
4646 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
4647 && !expr1
->symtree
->n
.sym
->attr
.proc_pointer
4648 && !gfc_is_proc_ptr_comp (expr1
, NULL
))
4650 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4651 gcc_assert (lse
.string_length
&& rse
.string_length
);
4652 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4653 lse
.string_length
, rse
.string_length
,
4657 gfc_add_modify (&block
, lse
.expr
,
4658 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4660 gfc_add_block_to_block (&block
, &rse
.post
);
4661 gfc_add_block_to_block (&block
, &lse
.post
);
4666 tree strlen_rhs
= NULL_TREE
;
4668 /* Array pointer. */
4669 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
4670 strlen_lhs
= lse
.string_length
;
4671 switch (expr2
->expr_type
)
4674 /* Just set the data pointer to null. */
4675 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
4679 /* Assign directly to the pointer's descriptor. */
4680 lse
.direct_byref
= 1;
4681 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4682 strlen_rhs
= lse
.string_length
;
4684 /* If this is a subreference array pointer assignment, use the rhs
4685 descriptor element size for the lhs span. */
4686 if (expr1
->symtree
->n
.sym
->attr
.subref_array_pointer
)
4688 decl
= expr1
->symtree
->n
.sym
->backend_decl
;
4689 gfc_init_se (&rse
, NULL
);
4690 rse
.descriptor_only
= 1;
4691 gfc_conv_expr (&rse
, expr2
);
4692 tmp
= gfc_get_element_type (TREE_TYPE (rse
.expr
));
4693 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
4694 if (!INTEGER_CST_P (tmp
))
4695 gfc_add_block_to_block (&lse
.post
, &rse
.pre
);
4696 gfc_add_modify (&lse
.post
, GFC_DECL_SPAN(decl
), tmp
);
4702 /* Assign to a temporary descriptor and then copy that
4703 temporary to the pointer. */
4705 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
4708 lse
.direct_byref
= 1;
4709 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
4710 strlen_rhs
= lse
.string_length
;
4711 gfc_add_modify (&lse
.pre
, desc
, tmp
);
4715 gfc_add_block_to_block (&block
, &lse
.pre
);
4717 /* Check string lengths if applicable. The check is only really added
4718 to the output code if -fbounds-check is enabled. */
4719 if (expr1
->ts
.type
== BT_CHARACTER
&& expr2
->expr_type
!= EXPR_NULL
)
4721 gcc_assert (expr2
->ts
.type
== BT_CHARACTER
);
4722 gcc_assert (strlen_lhs
&& strlen_rhs
);
4723 gfc_trans_same_strlen_check ("pointer assignment", &expr1
->where
,
4724 strlen_lhs
, strlen_rhs
, &block
);
4727 gfc_add_block_to_block (&block
, &lse
.post
);
4729 return gfc_finish_block (&block
);
4733 /* Makes sure se is suitable for passing as a function string parameter. */
4734 /* TODO: Need to check all callers of this function. It may be abused. */
4737 gfc_conv_string_parameter (gfc_se
* se
)
4741 if (TREE_CODE (se
->expr
) == STRING_CST
)
4743 type
= TREE_TYPE (TREE_TYPE (se
->expr
));
4744 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4748 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
4750 if (TREE_CODE (se
->expr
) != INDIRECT_REF
)
4752 type
= TREE_TYPE (se
->expr
);
4753 se
->expr
= gfc_build_addr_expr (build_pointer_type (type
), se
->expr
);
4757 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4759 type
= build_pointer_type (type
);
4760 se
->expr
= gfc_build_addr_expr (type
, se
->expr
);
4764 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
4765 gcc_assert (se
->string_length
4766 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
4770 /* Generate code for assignment of scalar variables. Includes character
4771 strings and derived types with allocatable components.
4772 If you know that the LHS has no allocations, set dealloc to false. */
4775 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
4776 bool l_is_temp
, bool r_is_var
, bool dealloc
)
4782 gfc_init_block (&block
);
4784 if (ts
.type
== BT_CHARACTER
)
4789 if (lse
->string_length
!= NULL_TREE
)
4791 gfc_conv_string_parameter (lse
);
4792 gfc_add_block_to_block (&block
, &lse
->pre
);
4793 llen
= lse
->string_length
;
4796 if (rse
->string_length
!= NULL_TREE
)
4798 gcc_assert (rse
->string_length
!= NULL_TREE
);
4799 gfc_conv_string_parameter (rse
);
4800 gfc_add_block_to_block (&block
, &rse
->pre
);
4801 rlen
= rse
->string_length
;
4804 gfc_trans_string_copy (&block
, llen
, lse
->expr
, ts
.kind
, rlen
,
4805 rse
->expr
, ts
.kind
);
4807 else if (ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
4811 /* Are the rhs and the lhs the same? */
4814 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
4815 gfc_build_addr_expr (NULL_TREE
, lse
->expr
),
4816 gfc_build_addr_expr (NULL_TREE
, rse
->expr
));
4817 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
4820 /* Deallocate the lhs allocated components as long as it is not
4821 the same as the rhs. This must be done following the assignment
4822 to prevent deallocating data that could be used in the rhs
4824 if (!l_is_temp
&& dealloc
)
4826 tmp
= gfc_evaluate_now (lse
->expr
, &lse
->pre
);
4827 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0);
4829 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4831 gfc_add_expr_to_block (&lse
->post
, tmp
);
4834 gfc_add_block_to_block (&block
, &rse
->pre
);
4835 gfc_add_block_to_block (&block
, &lse
->pre
);
4837 gfc_add_modify (&block
, lse
->expr
,
4838 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4840 /* Do a deep copy if the rhs is a variable, if it is not the
4844 tmp
= gfc_copy_alloc_comp (ts
.u
.derived
, rse
->expr
, lse
->expr
, 0);
4845 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (input_location
),
4847 gfc_add_expr_to_block (&block
, tmp
);
4850 else if (ts
.type
== BT_DERIVED
|| ts
.type
== BT_CLASS
)
4852 gfc_add_block_to_block (&block
, &lse
->pre
);
4853 gfc_add_block_to_block (&block
, &rse
->pre
);
4854 tmp
= fold_build1 (VIEW_CONVERT_EXPR
, TREE_TYPE (lse
->expr
), rse
->expr
);
4855 gfc_add_modify (&block
, lse
->expr
, tmp
);
4859 gfc_add_block_to_block (&block
, &lse
->pre
);
4860 gfc_add_block_to_block (&block
, &rse
->pre
);
4862 gfc_add_modify (&block
, lse
->expr
,
4863 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
4866 gfc_add_block_to_block (&block
, &lse
->post
);
4867 gfc_add_block_to_block (&block
, &rse
->post
);
4869 return gfc_finish_block (&block
);
4873 /* There are quite a lot of restrictions on the optimisation in using an
4874 array function assign without a temporary. */
4877 arrayfunc_assign_needs_temporary (gfc_expr
* expr1
, gfc_expr
* expr2
)
4880 bool seen_array_ref
;
4882 gfc_symbol
*sym
= expr1
->symtree
->n
.sym
;
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 are scalarized so that they don't need a
4889 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
4890 they would need special treatment in gfc_trans_arrayfunc_assign. */
4891 if (expr2
->value
.function
.esym
!= NULL
4892 && expr2
->value
.function
.esym
->attr
.elemental
)
4895 /* Need a temporary if rhs is not FULL or a contiguous section. */
4896 if (expr1
->ref
&& !(gfc_full_array_ref_p (expr1
->ref
, &c
) || c
))
4899 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
4900 if (gfc_ref_needs_temporary_p (expr1
->ref
))
4903 /* Functions returning pointers need temporaries. */
4904 if (expr2
->symtree
->n
.sym
->attr
.pointer
4905 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
4908 /* Character array functions need temporaries unless the
4909 character lengths are the same. */
4910 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
4912 if (expr1
->ts
.u
.cl
->length
== NULL
4913 || expr1
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4916 if (expr2
->ts
.u
.cl
->length
== NULL
4917 || expr2
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4920 if (mpz_cmp (expr1
->ts
.u
.cl
->length
->value
.integer
,
4921 expr2
->ts
.u
.cl
->length
->value
.integer
) != 0)
4925 /* Check that no LHS component references appear during an array
4926 reference. This is needed because we do not have the means to
4927 span any arbitrary stride with an array descriptor. This check
4928 is not needed for the rhs because the function result has to be
4930 seen_array_ref
= false;
4931 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
4933 if (ref
->type
== REF_ARRAY
)
4934 seen_array_ref
= true;
4935 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
4939 /* Check for a dependency. */
4940 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
4941 expr2
->value
.function
.esym
,
4942 expr2
->value
.function
.actual
,
4946 /* If we have reached here with an intrinsic function, we do not
4947 need a temporary. */
4948 if (expr2
->value
.function
.isym
)
4951 /* If the LHS is a dummy, we need a temporary if it is not
4953 if (sym
->attr
.dummy
&& sym
->attr
.intent
!= INTENT_OUT
)
4956 /* A PURE function can unconditionally be called without a temporary. */
4957 if (expr2
->value
.function
.esym
!= NULL
4958 && expr2
->value
.function
.esym
->attr
.pure
)
4961 /* TODO a function that could correctly be declared PURE but is not
4962 could do with returning false as well. */
4964 if (!sym
->attr
.use_assoc
4965 && !sym
->attr
.in_common
4966 && !sym
->attr
.pointer
4967 && !sym
->attr
.target
4968 && expr2
->value
.function
.esym
)
4970 /* A temporary is not needed if the function is not contained and
4971 the variable is local or host associated and not a pointer or
4973 if (!expr2
->value
.function
.esym
->attr
.contained
)
4976 /* A temporary is not needed if the variable is local and not
4977 a pointer, a target or a result. */
4979 && expr2
->value
.function
.esym
->ns
== sym
->ns
->parent
)
4983 /* Default to temporary use. */
4988 /* Try to translate array(:) = func (...), where func is a transformational
4989 array function, without using a temporary. Returns NULL if this isn't the
4993 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
4997 gfc_component
*comp
= NULL
;
4999 if (arrayfunc_assign_needs_temporary (expr1
, expr2
))
5002 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
5004 gcc_assert (expr2
->value
.function
.isym
5005 || (gfc_is_proc_ptr_comp (expr2
, &comp
)
5006 && comp
&& comp
->attr
.dimension
)
5007 || (!comp
&& gfc_return_by_reference (expr2
->value
.function
.esym
)
5008 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
5010 ss
= gfc_walk_expr (expr1
);
5011 gcc_assert (ss
!= gfc_ss_terminator
);
5012 gfc_init_se (&se
, NULL
);
5013 gfc_start_block (&se
.pre
);
5014 se
.want_pointer
= 1;
5016 gfc_conv_array_parameter (&se
, expr1
, ss
, false, NULL
, NULL
, NULL
);
5018 if (expr1
->ts
.type
== BT_DERIVED
5019 && expr1
->ts
.u
.derived
->attr
.alloc_comp
)
5022 tmp
= gfc_deallocate_alloc_comp (expr1
->ts
.u
.derived
, se
.expr
,
5024 gfc_add_expr_to_block (&se
.pre
, tmp
);
5027 se
.direct_byref
= 1;
5028 se
.ss
= gfc_walk_expr (expr2
);
5029 gcc_assert (se
.ss
!= gfc_ss_terminator
);
5030 gfc_conv_function_expr (&se
, expr2
);
5031 gfc_add_block_to_block (&se
.pre
, &se
.post
);
5033 return gfc_finish_block (&se
.pre
);
5037 /* Try to efficiently translate array(:) = 0. Return NULL if this
5041 gfc_trans_zero_assign (gfc_expr
* expr
)
5043 tree dest
, len
, type
;
5047 sym
= expr
->symtree
->n
.sym
;
5048 dest
= gfc_get_symbol_decl (sym
);
5050 type
= TREE_TYPE (dest
);
5051 if (POINTER_TYPE_P (type
))
5052 type
= TREE_TYPE (type
);
5053 if (!GFC_ARRAY_TYPE_P (type
))
5056 /* Determine the length of the array. */
5057 len
= GFC_TYPE_ARRAY_SIZE (type
);
5058 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5061 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (type
));
5062 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5063 fold_convert (gfc_array_index_type
, tmp
));
5065 /* If we are zeroing a local array avoid taking its address by emitting
5067 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
5068 return build2 (MODIFY_EXPR
, void_type_node
,
5069 dest
, build_constructor (TREE_TYPE (dest
), NULL
));
5071 /* Convert arguments to the correct types. */
5072 dest
= fold_convert (pvoid_type_node
, dest
);
5073 len
= fold_convert (size_type_node
, len
);
5075 /* Construct call to __builtin_memset. */
5076 tmp
= build_call_expr_loc (input_location
,
5077 built_in_decls
[BUILT_IN_MEMSET
],
5078 3, dest
, integer_zero_node
, len
);
5079 return fold_convert (void_type_node
, tmp
);
5083 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
5084 that constructs the call to __builtin_memcpy. */
5087 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
5091 /* Convert arguments to the correct types. */
5092 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
5093 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
5095 dst
= fold_convert (pvoid_type_node
, dst
);
5097 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
5098 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
5100 src
= fold_convert (pvoid_type_node
, src
);
5102 len
= fold_convert (size_type_node
, len
);
5104 /* Construct call to __builtin_memcpy. */
5105 tmp
= build_call_expr_loc (input_location
,
5106 built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
5107 return fold_convert (void_type_node
, tmp
);
5111 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
5112 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
5113 source/rhs, both are gfc_full_array_ref_p which have been checked for
5117 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5119 tree dst
, dlen
, dtype
;
5120 tree src
, slen
, stype
;
5123 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5124 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
5126 dtype
= TREE_TYPE (dst
);
5127 if (POINTER_TYPE_P (dtype
))
5128 dtype
= TREE_TYPE (dtype
);
5129 stype
= TREE_TYPE (src
);
5130 if (POINTER_TYPE_P (stype
))
5131 stype
= TREE_TYPE (stype
);
5133 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
5136 /* Determine the lengths of the arrays. */
5137 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
5138 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
5140 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5141 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
5142 fold_convert (gfc_array_index_type
, tmp
));
5144 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
5145 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
5147 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (stype
));
5148 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
5149 fold_convert (gfc_array_index_type
, tmp
));
5151 /* Sanity check that they are the same. This should always be
5152 the case, as we should already have checked for conformance. */
5153 if (!tree_int_cst_equal (slen
, dlen
))
5156 return gfc_build_memcpy_call (dst
, src
, dlen
);
5160 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
5161 this can't be done. EXPR1 is the destination/lhs for which
5162 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
5165 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
5167 unsigned HOST_WIDE_INT nelem
;
5173 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
5177 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
5178 dtype
= TREE_TYPE (dst
);
5179 if (POINTER_TYPE_P (dtype
))
5180 dtype
= TREE_TYPE (dtype
);
5181 if (!GFC_ARRAY_TYPE_P (dtype
))
5184 /* Determine the lengths of the array. */
5185 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
5186 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
5189 /* Confirm that the constructor is the same size. */
5190 if (compare_tree_int (len
, nelem
) != 0)
5193 tmp
= TYPE_SIZE_UNIT (gfc_get_element_type (dtype
));
5194 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
5195 fold_convert (gfc_array_index_type
, tmp
));
5197 stype
= gfc_typenode_for_spec (&expr2
->ts
);
5198 src
= gfc_build_constant_array_constructor (expr2
, stype
);
5200 stype
= TREE_TYPE (src
);
5201 if (POINTER_TYPE_P (stype
))
5202 stype
= TREE_TYPE (stype
);
5204 return gfc_build_memcpy_call (dst
, src
, len
);
5208 /* Subroutine of gfc_trans_assignment that actually scalarizes the
5209 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
5210 init_flag indicates initialization expressions and dealloc that no
5211 deallocate prior assignment is needed (if in doubt, set true). */
5214 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5220 gfc_ss
*lss_section
;
5227 bool scalar_to_array
;
5230 /* Assignment of the form lhs = rhs. */
5231 gfc_start_block (&block
);
5233 gfc_init_se (&lse
, NULL
);
5234 gfc_init_se (&rse
, NULL
);
5237 lss
= gfc_walk_expr (expr1
);
5239 if (lss
!= gfc_ss_terminator
)
5241 /* Allow the scalarizer to workshare array assignments. */
5242 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5243 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5245 /* The assignment needs scalarization. */
5248 /* Find a non-scalar SS from the lhs. */
5249 while (lss_section
!= gfc_ss_terminator
5250 && lss_section
->type
!= GFC_SS_SECTION
)
5251 lss_section
= lss_section
->next
;
5253 gcc_assert (lss_section
!= gfc_ss_terminator
);
5255 /* Initialize the scalarizer. */
5256 gfc_init_loopinfo (&loop
);
5259 rss
= gfc_walk_expr (expr2
);
5260 if (rss
== gfc_ss_terminator
)
5262 /* The rhs is scalar. Add a ss for the expression. */
5263 rss
= gfc_get_ss ();
5264 rss
->next
= gfc_ss_terminator
;
5265 rss
->type
= GFC_SS_SCALAR
;
5268 /* Associate the SS with the loop. */
5269 gfc_add_ss_to_loop (&loop
, lss
);
5270 gfc_add_ss_to_loop (&loop
, rss
);
5272 /* Calculate the bounds of the scalarization. */
5273 gfc_conv_ss_startstride (&loop
);
5274 /* Resolve any data dependencies in the statement. */
5275 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
5276 /* Setup the scalarizing loops. */
5277 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5279 /* Setup the gfc_se structures. */
5280 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5281 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5284 gfc_mark_ss_chain_used (rss
, 1);
5285 if (loop
.temp_ss
== NULL
)
5288 gfc_mark_ss_chain_used (lss
, 1);
5292 lse
.ss
= loop
.temp_ss
;
5293 gfc_mark_ss_chain_used (lss
, 3);
5294 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5297 /* Start the scalarized loop body. */
5298 gfc_start_scalarized_body (&loop
, &body
);
5301 gfc_init_block (&body
);
5303 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
5305 /* Translate the expression. */
5306 gfc_conv_expr (&rse
, expr2
);
5308 /* Stabilize a string length for temporaries. */
5309 if (expr2
->ts
.type
== BT_CHARACTER
)
5310 string_length
= gfc_evaluate_now (rse
.string_length
, &rse
.pre
);
5312 string_length
= NULL_TREE
;
5316 gfc_conv_tmp_array_ref (&lse
);
5317 gfc_advance_se_ss_chain (&lse
);
5318 if (expr2
->ts
.type
== BT_CHARACTER
)
5319 lse
.string_length
= string_length
;
5322 gfc_conv_expr (&lse
, expr1
);
5324 /* Assignments of scalar derived types with allocatable components
5325 to arrays must be done with a deep copy and the rhs temporary
5326 must have its components deallocated afterwards. */
5327 scalar_to_array
= (expr2
->ts
.type
== BT_DERIVED
5328 && expr2
->ts
.u
.derived
->attr
.alloc_comp
5329 && expr2
->expr_type
!= EXPR_VARIABLE
5330 && !gfc_is_constant_expr (expr2
)
5331 && expr1
->rank
&& !expr2
->rank
);
5332 if (scalar_to_array
&& dealloc
)
5334 tmp
= gfc_deallocate_alloc_comp (expr2
->ts
.u
.derived
, rse
.expr
, 0);
5335 gfc_add_expr_to_block (&loop
.post
, tmp
);
5338 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5339 l_is_temp
|| init_flag
,
5340 (expr2
->expr_type
== EXPR_VARIABLE
)
5341 || scalar_to_array
, dealloc
);
5342 gfc_add_expr_to_block (&body
, tmp
);
5344 if (lss
== gfc_ss_terminator
)
5346 /* Use the scalar assignment as is. */
5347 gfc_add_block_to_block (&block
, &body
);
5351 gcc_assert (lse
.ss
== gfc_ss_terminator
5352 && rse
.ss
== gfc_ss_terminator
);
5356 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5358 /* We need to copy the temporary to the actual lhs. */
5359 gfc_init_se (&lse
, NULL
);
5360 gfc_init_se (&rse
, NULL
);
5361 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5362 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5364 rse
.ss
= loop
.temp_ss
;
5367 gfc_conv_tmp_array_ref (&rse
);
5368 gfc_advance_se_ss_chain (&rse
);
5369 gfc_conv_expr (&lse
, expr1
);
5371 gcc_assert (lse
.ss
== gfc_ss_terminator
5372 && rse
.ss
== gfc_ss_terminator
);
5374 if (expr2
->ts
.type
== BT_CHARACTER
)
5375 rse
.string_length
= string_length
;
5377 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5378 false, false, dealloc
);
5379 gfc_add_expr_to_block (&body
, tmp
);
5382 /* Generate the copying loops. */
5383 gfc_trans_scalarizing_loops (&loop
, &body
);
5385 /* Wrap the whole thing up. */
5386 gfc_add_block_to_block (&block
, &loop
.pre
);
5387 gfc_add_block_to_block (&block
, &loop
.post
);
5389 gfc_cleanup_loop (&loop
);
5392 return gfc_finish_block (&block
);
5396 /* Check whether EXPR is a copyable array. */
5399 copyable_array_p (gfc_expr
* expr
)
5401 if (expr
->expr_type
!= EXPR_VARIABLE
)
5404 /* First check it's an array. */
5405 if (expr
->rank
< 1 || !expr
->ref
|| expr
->ref
->next
)
5408 if (!gfc_full_array_ref_p (expr
->ref
, NULL
))
5411 /* Next check that it's of a simple enough type. */
5412 switch (expr
->ts
.type
)
5424 return !expr
->ts
.u
.derived
->attr
.alloc_comp
;
5433 /* Translate an assignment. */
5436 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
,
5441 /* Special case a single function returning an array. */
5442 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5444 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5449 /* Special case assigning an array to zero. */
5450 if (copyable_array_p (expr1
)
5451 && is_zero_initializer_p (expr2
))
5453 tmp
= gfc_trans_zero_assign (expr1
);
5458 /* Special case copying one array to another. */
5459 if (copyable_array_p (expr1
)
5460 && copyable_array_p (expr2
)
5461 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
5462 && !gfc_check_dependency (expr1
, expr2
, 0))
5464 tmp
= gfc_trans_array_copy (expr1
, expr2
);
5469 /* Special case initializing an array from a constant array constructor. */
5470 if (copyable_array_p (expr1
)
5471 && expr2
->expr_type
== EXPR_ARRAY
5472 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
5474 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
5479 /* Fallback to the scalarizer to generate explicit loops. */
5480 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
, dealloc
);
5484 gfc_trans_init_assign (gfc_code
* code
)
5486 return gfc_trans_assignment (code
->expr1
, code
->expr2
, true, false);
5490 gfc_trans_assign (gfc_code
* code
)
5492 return gfc_trans_assignment (code
->expr1
, code
->expr2
, false, true);
5496 /* Generate code to assign typebound procedures to a derived vtab. */
5497 void gfc_trans_assign_vtab_procs (stmtblock_t
*block
, gfc_symbol
*dt
,
5504 tree cond
= NULL_TREE
;
5508 /* Point to the first procedure pointer. */
5509 cmp
= gfc_find_component (vtab
->ts
.u
.derived
, "$extends", true, true);
5511 seen_extends
= (cmp
!= NULL
);
5513 vtb
= gfc_get_symbol_decl (vtab
);
5520 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5521 vtb
, cmp
->backend_decl
, NULL_TREE
);
5522 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, ctree
,
5523 build_int_cst (TREE_TYPE (ctree
), 0));
5527 cmp
= vtab
->ts
.u
.derived
->components
;
5530 gfc_init_block (&body
);
5531 for (; cmp
; cmp
= cmp
->next
)
5533 gfc_symbol
*target
= NULL
;
5535 /* Generic procedure - build its vtab. */
5536 if (cmp
->ts
.type
== BT_DERIVED
&& !cmp
->tb
)
5538 gfc_symbol
*vt
= cmp
->ts
.interface
;
5542 /* Use association loses the interface. Obtain the vtab
5544 char name
[2 * GFC_MAX_SYMBOL_LEN
+ 8];
5545 sprintf (name
, "vtab$%s$%s", vtab
->ts
.u
.derived
->name
,
5547 gfc_find_symbol (name
, vtab
->ns
, 0, &vt
);
5552 gfc_trans_assign_vtab_procs (&body
, dt
, vt
);
5553 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5554 vtb
, cmp
->backend_decl
, NULL_TREE
);
5555 proc
= gfc_get_symbol_decl (vt
);
5556 proc
= gfc_build_addr_expr (TREE_TYPE (ctree
), proc
);
5557 gfc_add_modify (&body
, ctree
, proc
);
5561 /* This is required when typebound generic procedures are called
5562 with derived type targets. The specific procedures do not get
5563 added to the vtype, which remains "empty". */
5564 if (cmp
->tb
&& cmp
->tb
->u
.specific
&& cmp
->tb
->u
.specific
->n
.sym
)
5565 target
= cmp
->tb
->u
.specific
->n
.sym
;
5569 st
= gfc_find_typebound_proc (dt
, NULL
, cmp
->name
, false, NULL
);
5570 if (st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5571 target
= st
->n
.tb
->u
.specific
->n
.sym
;
5577 ctree
= fold_build3 (COMPONENT_REF
, TREE_TYPE (cmp
->backend_decl
),
5578 vtb
, cmp
->backend_decl
, NULL_TREE
);
5579 proc
= gfc_get_symbol_decl (target
);
5580 proc
= gfc_build_addr_expr (TREE_TYPE (ctree
), proc
);
5581 gfc_add_modify (&body
, ctree
, proc
);
5584 proc
= gfc_finish_block (&body
);
5587 proc
= build3_v (COND_EXPR
, cond
, proc
, build_empty_stmt (input_location
));
5589 gfc_add_expr_to_block (block
, proc
);
5593 /* Translate an assignment to a CLASS object
5594 (pointer or ordinary assignment). */
5597 gfc_trans_class_assign (gfc_code
*code
)
5604 gfc_start_block (&block
);
5606 if (code
->op
== EXEC_INIT_ASSIGN
)
5608 /* Special case for initializing a CLASS variable on allocation.
5609 A MEMCPY is needed to copy the full data of the dynamic type,
5610 which may be different from the declared type. */
5613 gfc_init_se (&dst
, NULL
);
5614 gfc_init_se (&src
, NULL
);
5615 gfc_add_component_ref (code
->expr1
, "$data");
5616 gfc_conv_expr (&dst
, code
->expr1
);
5617 gfc_conv_expr (&src
, code
->expr2
);
5618 gfc_add_block_to_block (&block
, &src
.pre
);
5619 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr2
->ts
));
5620 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
);
5621 gfc_add_expr_to_block (&block
, tmp
);
5622 return gfc_finish_block (&block
);
5625 if (code
->expr2
->ts
.type
!= BT_CLASS
)
5627 /* Insert an additional assignment which sets the '$vptr' field. */
5628 lhs
= gfc_copy_expr (code
->expr1
);
5629 gfc_add_component_ref (lhs
, "$vptr");
5630 if (code
->expr2
->ts
.type
== BT_DERIVED
)
5634 vtab
= gfc_find_derived_vtab (code
->expr2
->ts
.u
.derived
, true);
5636 gfc_trans_assign_vtab_procs (&block
, code
->expr2
->ts
.u
.derived
, vtab
);
5637 rhs
= gfc_get_expr ();
5638 rhs
->expr_type
= EXPR_VARIABLE
;
5639 gfc_find_sym_tree (vtab
->name
, NULL
, 1, &st
);
5643 else if (code
->expr2
->expr_type
== EXPR_NULL
)
5644 rhs
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0);
5648 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
5649 gfc_add_expr_to_block (&block
, tmp
);
5651 gfc_free_expr (lhs
);
5652 gfc_free_expr (rhs
);
5655 /* Do the actual CLASS assignment. */
5656 if (code
->expr2
->ts
.type
== BT_CLASS
)
5657 code
->op
= EXEC_ASSIGN
;
5659 gfc_add_component_ref (code
->expr1
, "$data");
5661 if (code
->op
== EXEC_ASSIGN
)
5662 tmp
= gfc_trans_assign (code
);
5663 else if (code
->op
== EXEC_POINTER_ASSIGN
)
5664 tmp
= gfc_trans_pointer_assign (code
);
5668 gfc_add_expr_to_block (&block
, tmp
);
5670 return gfc_finish_block (&block
);