1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
28 #include "coretypes.h"
34 #include "tree-gimple.h"
35 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
47 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
56 dest
->loop
= src
->loop
;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
69 memset (se
, 0, sizeof (gfc_se
));
70 gfc_init_block (&se
->pre
);
71 gfc_init_block (&se
->post
);
76 gfc_copy_se_loopvars (se
, parent
);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se
* se
)
89 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se
* se
)
113 if (CONSTANT_CLASS_P (se
->expr
))
116 /* We need a temporary for this result. */
117 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
118 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol
* sym
)
131 gcc_assert (sym
->attr
.dummy
);
133 decl
= gfc_get_symbol_decl (sym
);
134 if (TREE_CODE (decl
) != PARM_DECL
)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
140 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
142 return build2 (NE_EXPR
, boolean_type_node
, decl
,
143 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
155 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
156 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
157 fold_convert (TREE_TYPE (se
->expr
), integer_zero_node
));
159 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
161 if (ts
.type
== BT_CHARACTER
)
163 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
164 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
165 se
->string_length
, tmp
);
166 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
167 se
->string_length
= tmp
;
173 /* Get the character length of an expression, looking through gfc_refs
177 gfc_get_expr_charlen (gfc_expr
*e
)
182 gcc_assert (e
->expr_type
== EXPR_VARIABLE
183 && e
->ts
.type
== BT_CHARACTER
);
185 length
= NULL
; /* To silence compiler warning. */
187 /* First candidate: if the variable is of type CHARACTER, the
188 expression's length could be the length of the character
190 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
191 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
193 /* Look through the reference chain for component references. */
194 for (r
= e
->ref
; r
; r
= r
->next
)
199 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
200 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
208 /* We should never got substring references here. These will be
209 broken down by the scalarizer. */
214 gcc_assert (length
!= NULL
);
220 /* Generate code to initialize a string length variable. Returns the
224 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
229 gfc_init_se (&se
, NULL
);
230 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
231 se
.expr
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, se
.expr
,
232 build_int_cst (gfc_charlen_type_node
, 0));
233 gfc_add_block_to_block (pblock
, &se
.pre
);
235 tmp
= cl
->backend_decl
;
236 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
241 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
,
242 const char *name
, locus
*where
)
252 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
253 type
= build_pointer_type (type
);
256 gfc_init_se (&start
, se
);
257 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
258 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
260 if (integer_onep (start
.expr
))
261 gfc_conv_string_parameter (se
);
264 /* Change the start of the string. */
265 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
268 tmp
= build_fold_indirect_ref (se
->expr
);
269 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
270 se
->expr
= gfc_build_addr_expr (type
, tmp
);
273 /* Length = end + 1 - start. */
274 gfc_init_se (&end
, se
);
275 if (ref
->u
.ss
.end
== NULL
)
276 end
.expr
= se
->string_length
;
279 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
280 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
282 if (flag_bounds_check
)
284 tree nonempty
= fold_build2 (LE_EXPR
, boolean_type_node
,
285 start
.expr
, end
.expr
);
287 /* Check lower bound. */
288 fault
= fold_build2 (LT_EXPR
, boolean_type_node
, start
.expr
,
289 build_int_cst (gfc_charlen_type_node
, 1));
290 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
293 asprintf (&msg
, "Substring out of bounds: lower bound of '%s' "
294 "is less than one", name
);
296 asprintf (&msg
, "Substring out of bounds: lower bound "
298 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
301 /* Check upper bound. */
302 fault
= fold_build2 (GT_EXPR
, boolean_type_node
, end
.expr
,
304 fault
= fold_build2 (TRUTH_ANDIF_EXPR
, boolean_type_node
,
307 asprintf (&msg
, "Substring out of bounds: upper bound of '%s' "
308 "exceeds string length", name
);
310 asprintf (&msg
, "Substring out of bounds: upper bound "
311 "exceeds string length");
312 gfc_trans_runtime_check (fault
, msg
, &se
->pre
, where
);
316 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
317 build_int_cst (gfc_charlen_type_node
, 1),
319 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
320 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
321 build_int_cst (gfc_charlen_type_node
, 0));
322 se
->string_length
= tmp
;
326 /* Convert a derived type component reference. */
329 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
336 c
= ref
->u
.c
.component
;
338 gcc_assert (c
->backend_decl
);
340 field
= c
->backend_decl
;
341 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
343 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
347 if (c
->ts
.type
== BT_CHARACTER
)
349 tmp
= c
->ts
.cl
->backend_decl
;
350 /* Components must always be constant length. */
351 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
352 se
->string_length
= tmp
;
355 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
356 se
->expr
= build_fold_indirect_ref (se
->expr
);
360 /* Return the contents of a variable. Also handles reference/pointer
361 variables (all Fortran pointer references are implicit). */
364 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
371 bool alternate_entry
;
374 sym
= expr
->symtree
->n
.sym
;
377 /* Check that something hasn't gone horribly wrong. */
378 gcc_assert (se
->ss
!= gfc_ss_terminator
);
379 gcc_assert (se
->ss
->expr
== expr
);
381 /* A scalarized term. We already know the descriptor. */
382 se
->expr
= se
->ss
->data
.info
.descriptor
;
383 se
->string_length
= se
->ss
->string_length
;
384 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
385 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
390 tree se_expr
= NULL_TREE
;
392 se
->expr
= gfc_get_symbol_decl (sym
);
394 /* Deal with references to a parent results or entries by storing
395 the current_function_decl and moving to the parent_decl. */
396 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
397 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
398 && sym
->result
== sym
;
399 entry_master
= sym
->attr
.result
400 && sym
->ns
->proc_name
->attr
.entry_master
401 && !gfc_return_by_reference (sym
->ns
->proc_name
);
402 parent_decl
= DECL_CONTEXT (current_function_decl
);
404 if ((se
->expr
== parent_decl
&& return_value
)
405 || (sym
->ns
&& sym
->ns
->proc_name
407 && sym
->ns
->proc_name
->backend_decl
== parent_decl
408 && (alternate_entry
|| entry_master
)))
413 /* Special case for assigning the return value of a function.
414 Self recursive functions must have an explicit return value. */
415 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
416 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
418 /* Similarly for alternate entry points. */
419 else if (alternate_entry
420 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
423 gfc_entry_list
*el
= NULL
;
425 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
428 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
433 else if (entry_master
434 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
436 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
441 /* Procedure actual arguments. */
442 else if (sym
->attr
.flavor
== FL_PROCEDURE
443 && se
->expr
!= current_function_decl
)
445 gcc_assert (se
->want_pointer
);
446 if (!sym
->attr
.dummy
)
448 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
449 se
->expr
= build_fold_addr_expr (se
->expr
);
455 /* Dereference the expression, where needed. Since characters
456 are entirely different from other types, they are treated
458 if (sym
->ts
.type
== BT_CHARACTER
)
460 /* Dereference character pointer dummy arguments
462 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
464 || sym
->attr
.function
465 || sym
->attr
.result
))
466 se
->expr
= build_fold_indirect_ref (se
->expr
);
468 /* A character with VALUE attribute needs an address
471 se
->expr
= build_fold_addr_expr (se
->expr
);
474 else if (!sym
->attr
.value
)
476 /* Dereference non-character scalar dummy arguments. */
477 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
478 se
->expr
= build_fold_indirect_ref (se
->expr
);
480 /* Dereference scalar hidden result. */
481 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
482 && (sym
->attr
.function
|| sym
->attr
.result
)
483 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
484 se
->expr
= build_fold_indirect_ref (se
->expr
);
486 /* Dereference non-character pointer variables.
487 These must be dummies, results, or scalars. */
488 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
490 || sym
->attr
.function
492 || !sym
->attr
.dimension
))
493 se
->expr
= build_fold_indirect_ref (se
->expr
);
499 /* For character variables, also get the length. */
500 if (sym
->ts
.type
== BT_CHARACTER
)
502 /* If the character length of an entry isn't set, get the length from
503 the master function instead. */
504 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
505 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
507 se
->string_length
= sym
->ts
.cl
->backend_decl
;
508 gcc_assert (se
->string_length
);
516 /* Return the descriptor if that's what we want and this is an array
517 section reference. */
518 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
520 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
521 /* Return the descriptor for array pointers and allocations. */
523 && ref
->next
== NULL
&& (se
->descriptor_only
))
526 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
527 /* Return a pointer to an element. */
531 gfc_conv_component_ref (se
, ref
);
535 gfc_conv_substring (se
, ref
, expr
->ts
.kind
,
536 expr
->symtree
->name
, &expr
->where
);
545 /* Pointer assignment, allocation or pass by reference. Arrays are handled
547 if (se
->want_pointer
)
549 if (expr
->ts
.type
== BT_CHARACTER
)
550 gfc_conv_string_parameter (se
);
552 se
->expr
= build_fold_addr_expr (se
->expr
);
557 /* Unary ops are easy... Or they would be if ! was a valid op. */
560 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
565 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
566 /* Initialize the operand. */
567 gfc_init_se (&operand
, se
);
568 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
569 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
571 type
= gfc_typenode_for_spec (&expr
->ts
);
573 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
574 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
575 All other unary operators have an equivalent GIMPLE unary operator. */
576 if (code
== TRUTH_NOT_EXPR
)
577 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
578 build_int_cst (type
, 0));
580 se
->expr
= build1 (code
, type
, operand
.expr
);
584 /* Expand power operator to optimal multiplications when a value is raised
585 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
586 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
587 Programming", 3rd Edition, 1998. */
589 /* This code is mostly duplicated from expand_powi in the backend.
590 We establish the "optimal power tree" lookup table with the defined size.
591 The items in the table are the exponents used to calculate the index
592 exponents. Any integer n less than the value can get an "addition chain",
593 with the first node being one. */
594 #define POWI_TABLE_SIZE 256
596 /* The table is from builtins.c. */
597 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
599 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
600 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
601 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
602 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
603 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
604 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
605 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
606 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
607 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
608 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
609 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
610 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
611 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
612 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
613 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
614 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
615 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
616 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
617 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
618 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
619 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
620 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
621 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
622 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
623 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
624 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
625 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
626 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
627 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
628 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
629 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
630 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
633 /* If n is larger than lookup table's max index, we use the "window
635 #define POWI_WINDOW_SIZE 3
637 /* Recursive function to expand the power operator. The temporary
638 values are put in tmpvar. The function returns tmpvar[1] ** n. */
640 gfc_conv_powi (gfc_se
* se
, unsigned HOST_WIDE_INT n
, tree
* tmpvar
)
647 if (n
< POWI_TABLE_SIZE
)
652 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
653 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
657 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
658 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
659 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
663 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
667 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
668 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
670 if (n
< POWI_TABLE_SIZE
)
677 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
678 return 1. Else return 0 and a call to runtime library functions
679 will have to be built. */
681 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
686 tree vartmp
[POWI_TABLE_SIZE
];
688 unsigned HOST_WIDE_INT n
;
691 /* If exponent is too large, we won't expand it anyway, so don't bother
692 with large integer values. */
693 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs
)))
696 m
= double_int_to_shwi (TREE_INT_CST (rhs
));
697 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
698 of the asymmetric range of the integer type. */
699 n
= (unsigned HOST_WIDE_INT
) (m
< 0 ? -m
: m
);
701 type
= TREE_TYPE (lhs
);
702 sgn
= tree_int_cst_sgn (rhs
);
704 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
)
705 || optimize_size
) && (m
> 2 || m
< -1))
711 se
->expr
= gfc_build_const (type
, integer_one_node
);
715 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
716 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
718 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
719 build_int_cst (TREE_TYPE (lhs
), -1));
720 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
721 build_int_cst (TREE_TYPE (lhs
), 1));
724 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
727 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
728 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
729 build_int_cst (type
, 0));
733 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
734 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
735 build_int_cst (type
, 0));
736 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
740 memset (vartmp
, 0, sizeof (vartmp
));
744 tmp
= gfc_build_const (type
, integer_one_node
);
745 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
748 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
754 /* Power op (**). Constant integer exponent has special handling. */
757 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
759 tree gfc_int4_type_node
;
766 gfc_init_se (&lse
, se
);
767 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
768 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
769 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
771 gfc_init_se (&rse
, se
);
772 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
773 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
775 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
776 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
777 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
780 gfc_int4_type_node
= gfc_get_int_type (4);
782 kind
= expr
->value
.op
.op1
->ts
.kind
;
783 switch (expr
->value
.op
.op2
->ts
.type
)
786 ikind
= expr
->value
.op
.op2
->ts
.kind
;
791 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
813 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
814 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
839 switch (expr
->value
.op
.op1
->ts
.type
)
842 if (kind
== 3) /* Case 16 was not handled properly above. */
844 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
848 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
852 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
864 fndecl
= built_in_decls
[BUILT_IN_POWF
];
867 fndecl
= built_in_decls
[BUILT_IN_POW
];
871 fndecl
= built_in_decls
[BUILT_IN_POWL
];
882 fndecl
= gfor_fndecl_math_cpowf
;
885 fndecl
= gfor_fndecl_math_cpow
;
888 fndecl
= gfor_fndecl_math_cpowl10
;
891 fndecl
= gfor_fndecl_math_cpowl16
;
903 se
->expr
= build_call_expr (fndecl
, 2, lse
.expr
, rse
.expr
);
907 /* Generate code to allocate a string temporary. */
910 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
915 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
917 if (gfc_can_put_var_on_stack (len
))
919 /* Create a temporary variable to hold the result. */
920 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
921 build_int_cst (gfc_charlen_type_node
, 1));
922 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
923 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
924 var
= gfc_create_var (tmp
, "str");
925 var
= gfc_build_addr_expr (type
, var
);
929 /* Allocate a temporary to hold the result. */
930 var
= gfc_create_var (type
, "pstr");
931 tmp
= build_call_expr (gfor_fndecl_internal_malloc
, 1, len
);
932 tmp
= convert (type
, tmp
);
933 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
935 /* Free the temporary afterwards. */
936 tmp
= convert (pvoid_type_node
, var
);
937 tmp
= build_call_expr (gfor_fndecl_internal_free
, 1, tmp
);
938 gfc_add_expr_to_block (&se
->post
, tmp
);
945 /* Handle a string concatenation operation. A temporary will be allocated to
949 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
958 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
959 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
961 gfc_init_se (&lse
, se
);
962 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
963 gfc_conv_string_parameter (&lse
);
964 gfc_init_se (&rse
, se
);
965 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
966 gfc_conv_string_parameter (&rse
);
968 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
969 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
971 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
972 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
973 if (len
== NULL_TREE
)
975 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
976 lse
.string_length
, rse
.string_length
);
979 type
= build_pointer_type (type
);
981 var
= gfc_conv_string_tmp (se
, type
, len
);
983 /* Do the actual concatenation. */
984 tmp
= build_call_expr (gfor_fndecl_concat_string
, 6,
986 lse
.string_length
, lse
.expr
,
987 rse
.string_length
, rse
.expr
);
988 gfc_add_expr_to_block (&se
->pre
, tmp
);
990 /* Add the cleanup for the operands. */
991 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
992 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
995 se
->string_length
= len
;
998 /* Translates an op expression. Common (binary) cases are handled by this
999 function, others are passed on. Recursion is used in either case.
1000 We use the fact that (op1.ts == op2.ts) (except for the power
1002 Operators need no special handling for scalarized expressions as long as
1003 they call gfc_conv_simple_val to get their operands.
1004 Character strings get special handling. */
1007 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
1009 enum tree_code code
;
1019 switch (expr
->value
.op
.operator)
1021 case INTRINSIC_UPLUS
:
1022 case INTRINSIC_PARENTHESES
:
1023 gfc_conv_expr (se
, expr
->value
.op
.op1
);
1026 case INTRINSIC_UMINUS
:
1027 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
1031 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
1034 case INTRINSIC_PLUS
:
1038 case INTRINSIC_MINUS
:
1042 case INTRINSIC_TIMES
:
1046 case INTRINSIC_DIVIDE
:
1047 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1048 an integer, we must round towards zero, so we use a
1050 if (expr
->ts
.type
== BT_INTEGER
)
1051 code
= TRUNC_DIV_EXPR
;
1056 case INTRINSIC_POWER
:
1057 gfc_conv_power_op (se
, expr
);
1060 case INTRINSIC_CONCAT
:
1061 gfc_conv_concat_op (se
, expr
);
1065 code
= TRUTH_ANDIF_EXPR
;
1070 code
= TRUTH_ORIF_EXPR
;
1074 /* EQV and NEQV only work on logicals, but since we represent them
1075 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1084 case INTRINSIC_NEQV
:
1114 case INTRINSIC_USER
:
1115 case INTRINSIC_ASSIGN
:
1116 /* These should be converted into function calls by the frontend. */
1120 fatal_error ("Unknown intrinsic op");
1124 /* The only exception to this is **, which is handled separately anyway. */
1125 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1127 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1131 gfc_init_se (&lse
, se
);
1132 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1133 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1136 gfc_init_se (&rse
, se
);
1137 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1138 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1142 gfc_conv_string_parameter (&lse
);
1143 gfc_conv_string_parameter (&rse
);
1145 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1146 rse
.string_length
, rse
.expr
);
1147 rse
.expr
= integer_zero_node
;
1148 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1151 type
= gfc_typenode_for_spec (&expr
->ts
);
1155 /* The result of logical ops is always boolean_type_node. */
1156 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1157 se
->expr
= convert (type
, tmp
);
1160 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1162 /* Add the post blocks. */
1163 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1164 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1167 /* If a string's length is one, we convert it to a single character. */
1170 gfc_to_single_character (tree len
, tree str
)
1172 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1174 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1175 && TREE_INT_CST_HIGH (len
) == 0)
1177 str
= fold_convert (pchar_type_node
, str
);
1178 return build_fold_indirect_ref (str
);
1184 /* Compare two strings. If they are all single characters, the result is the
1185 subtraction of them. Otherwise, we build a library call. */
1188 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1195 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1196 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1198 type
= gfc_get_int_type (gfc_default_integer_kind
);
1200 sc1
= gfc_to_single_character (len1
, str1
);
1201 sc2
= gfc_to_single_character (len2
, str2
);
1203 /* Deal with single character specially. */
1204 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1206 sc1
= fold_convert (type
, sc1
);
1207 sc2
= fold_convert (type
, sc2
);
1208 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1211 /* Build a call for the comparison. */
1212 tmp
= build_call_expr (gfor_fndecl_compare_string
, 4,
1213 len1
, str1
, len2
, str2
);
1218 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1222 if (sym
->attr
.dummy
)
1224 tmp
= gfc_get_symbol_decl (sym
);
1225 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1226 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1230 if (!sym
->backend_decl
)
1231 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1233 tmp
= sym
->backend_decl
;
1234 if (sym
->attr
.cray_pointee
)
1235 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1236 gfc_get_symbol_decl (sym
->cp_pointer
));
1237 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1239 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1240 tmp
= build_fold_addr_expr (tmp
);
1247 /* Translate the call for an elemental subroutine call used in an operator
1248 assignment. This is a simplified version of gfc_conv_function_call. */
1251 gfc_conv_operator_assign (gfc_se
*lse
, gfc_se
*rse
, gfc_symbol
*sym
)
1258 /* Only elemental subroutines with two arguments. */
1259 gcc_assert (sym
->attr
.elemental
&& sym
->attr
.subroutine
);
1260 gcc_assert (sym
->formal
->next
->next
== NULL
);
1262 gfc_init_block (&block
);
1264 gfc_add_block_to_block (&block
, &lse
->pre
);
1265 gfc_add_block_to_block (&block
, &rse
->pre
);
1267 /* Build the argument list for the call, including hidden string lengths. */
1268 args
= gfc_chainon_list (NULL_TREE
, build_fold_addr_expr (lse
->expr
));
1269 args
= gfc_chainon_list (args
, build_fold_addr_expr (rse
->expr
));
1270 if (lse
->string_length
!= NULL_TREE
)
1271 args
= gfc_chainon_list (args
, lse
->string_length
);
1272 if (rse
->string_length
!= NULL_TREE
)
1273 args
= gfc_chainon_list (args
, rse
->string_length
);
1275 /* Build the function call. */
1276 gfc_init_se (&se
, NULL
);
1277 gfc_conv_function_val (&se
, sym
);
1278 tmp
= TREE_TYPE (TREE_TYPE (TREE_TYPE (se
.expr
)));
1279 tmp
= build_call_list (tmp
, se
.expr
, args
);
1280 gfc_add_expr_to_block (&block
, tmp
);
1282 gfc_add_block_to_block (&block
, &lse
->post
);
1283 gfc_add_block_to_block (&block
, &rse
->post
);
1285 return gfc_finish_block (&block
);
1289 /* Initialize MAPPING. */
1292 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1294 mapping
->syms
= NULL
;
1295 mapping
->charlens
= NULL
;
1299 /* Free all memory held by MAPPING (but not MAPPING itself). */
1302 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1304 gfc_interface_sym_mapping
*sym
;
1305 gfc_interface_sym_mapping
*nextsym
;
1307 gfc_charlen
*nextcl
;
1309 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1311 nextsym
= sym
->next
;
1312 gfc_free_symbol (sym
->new->n
.sym
);
1313 gfc_free (sym
->new);
1316 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1319 gfc_free_expr (cl
->length
);
1325 /* Return a copy of gfc_charlen CL. Add the returned structure to
1326 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1328 static gfc_charlen
*
1329 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1334 new = gfc_get_charlen ();
1335 new->next
= mapping
->charlens
;
1336 new->length
= gfc_copy_expr (cl
->length
);
1338 mapping
->charlens
= new;
1343 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1344 array variable that can be used as the actual argument for dummy
1345 argument SYM. Add any initialization code to BLOCK. PACKED is as
1346 for gfc_get_nodesc_array_type and DATA points to the first element
1347 in the passed array. */
1350 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1351 gfc_packed packed
, tree data
)
1356 type
= gfc_typenode_for_spec (&sym
->ts
);
1357 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1359 var
= gfc_create_var (type
, "ifm");
1360 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1366 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1367 and offset of descriptorless array type TYPE given that it has the same
1368 size as DESC. Add any set-up code to BLOCK. */
1371 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1378 offset
= gfc_index_zero_node
;
1379 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1381 dim
= gfc_rank_cst
[n
];
1382 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1383 if (GFC_TYPE_ARRAY_LBOUND (type
, n
) == NULL_TREE
)
1385 GFC_TYPE_ARRAY_LBOUND (type
, n
)
1386 = gfc_conv_descriptor_lbound (desc
, dim
);
1387 GFC_TYPE_ARRAY_UBOUND (type
, n
)
1388 = gfc_conv_descriptor_ubound (desc
, dim
);
1390 else if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1392 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1393 gfc_conv_descriptor_ubound (desc
, dim
),
1394 gfc_conv_descriptor_lbound (desc
, dim
));
1395 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1396 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1398 tmp
= gfc_evaluate_now (tmp
, block
);
1399 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1401 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1402 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1403 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1404 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1406 offset
= gfc_evaluate_now (offset
, block
);
1407 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1411 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1412 in SE. The caller may still use se->expr and se->string_length after
1413 calling this function. */
1416 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1417 gfc_symbol
* sym
, gfc_se
* se
)
1419 gfc_interface_sym_mapping
*sm
;
1423 gfc_symbol
*new_sym
;
1425 gfc_symtree
*new_symtree
;
1427 /* Create a new symbol to represent the actual argument. */
1428 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1429 new_sym
->ts
= sym
->ts
;
1430 new_sym
->attr
.referenced
= 1;
1431 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1432 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1433 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1434 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1436 /* Create a fake symtree for it. */
1438 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1439 new_symtree
->n
.sym
= new_sym
;
1440 gcc_assert (new_symtree
== root
);
1442 /* Create a dummy->actual mapping. */
1443 sm
= gfc_getmem (sizeof (*sm
));
1444 sm
->next
= mapping
->syms
;
1446 sm
->new = new_symtree
;
1449 /* Stabilize the argument's value. */
1450 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1452 if (sym
->ts
.type
== BT_CHARACTER
)
1454 /* Create a copy of the dummy argument's length. */
1455 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1457 /* If the length is specified as "*", record the length that
1458 the caller is passing. We should use the callee's length
1459 in all other cases. */
1460 if (!new_sym
->ts
.cl
->length
)
1462 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1463 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1467 /* Use the passed value as-is if the argument is a function. */
1468 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1471 /* If the argument is either a string or a pointer to a string,
1472 convert it to a boundless character type. */
1473 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1475 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1476 tmp
= build_pointer_type (tmp
);
1477 if (sym
->attr
.pointer
)
1478 value
= build_fold_indirect_ref (se
->expr
);
1481 value
= fold_convert (tmp
, value
);
1484 /* If the argument is a scalar, a pointer to an array or an allocatable,
1486 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1487 value
= build_fold_indirect_ref (se
->expr
);
1489 /* For character(*), use the actual argument's descriptor. */
1490 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1491 value
= build_fold_indirect_ref (se
->expr
);
1493 /* If the argument is an array descriptor, use it to determine
1494 information about the actual argument's shape. */
1495 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1496 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1498 /* Get the actual argument's descriptor. */
1499 desc
= build_fold_indirect_ref (se
->expr
);
1501 /* Create the replacement variable. */
1502 tmp
= gfc_conv_descriptor_data_get (desc
);
1503 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1506 /* Use DESC to work out the upper bounds, strides and offset. */
1507 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1510 /* Otherwise we have a packed array. */
1511 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
,
1512 PACKED_FULL
, se
->expr
);
1514 new_sym
->backend_decl
= value
;
1518 /* Called once all dummy argument mappings have been added to MAPPING,
1519 but before the mapping is used to evaluate expressions. Pre-evaluate
1520 the length of each argument, adding any initialization code to PRE and
1521 any finalization code to POST. */
1524 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1525 stmtblock_t
* pre
, stmtblock_t
* post
)
1527 gfc_interface_sym_mapping
*sym
;
1531 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1532 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1533 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1535 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1536 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1537 gfc_init_se (&se
, NULL
);
1538 gfc_conv_expr (&se
, expr
);
1540 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1541 gfc_add_block_to_block (pre
, &se
.pre
);
1542 gfc_add_block_to_block (post
, &se
.post
);
1544 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1549 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1553 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1554 gfc_constructor
* c
)
1556 for (; c
; c
= c
->next
)
1558 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1561 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1562 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1563 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1569 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1573 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1578 for (; ref
; ref
= ref
->next
)
1582 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1584 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1585 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1586 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1588 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1595 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1596 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1602 /* EXPR is a copy of an expression that appeared in the interface
1603 associated with MAPPING. Walk it recursively looking for references to
1604 dummy arguments that MAPPING maps to actual arguments. Replace each such
1605 reference with a reference to the associated actual argument. */
1608 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1611 gfc_interface_sym_mapping
*sym
;
1612 gfc_actual_arglist
*actual
;
1613 int seen_result
= 0;
1618 /* Copying an expression does not copy its length, so do that here. */
1619 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1621 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1622 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1625 /* Apply the mapping to any references. */
1626 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1628 /* ...and to the expression's symbol, if it has one. */
1630 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1631 if (sym
->old
== expr
->symtree
->n
.sym
)
1632 expr
->symtree
= sym
->new;
1634 /* ...and to subexpressions in expr->value. */
1635 switch (expr
->expr_type
)
1638 if (expr
->symtree
->n
.sym
->attr
.result
)
1642 case EXPR_SUBSTRING
:
1646 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1647 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1651 if (expr
->value
.function
.actual
->expr
->expr_type
== EXPR_VARIABLE
1652 && gfc_apply_interface_mapping_to_expr (mapping
,
1653 expr
->value
.function
.actual
->expr
)
1654 && expr
->value
.function
.esym
== NULL
1655 && expr
->value
.function
.isym
!= NULL
1656 && expr
->value
.function
.isym
->generic_id
== GFC_ISYM_LEN
)
1659 new_expr
= gfc_copy_expr (expr
->value
.function
.actual
->expr
->ts
.cl
->length
);
1661 gfc_free (new_expr
);
1662 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1666 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1667 if (sym
->old
== expr
->value
.function
.esym
)
1668 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1670 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1671 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1675 case EXPR_STRUCTURE
:
1676 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1683 /* Evaluate interface expression EXPR using MAPPING. Store the result
1687 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1688 gfc_se
* se
, gfc_expr
* expr
)
1690 expr
= gfc_copy_expr (expr
);
1691 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1692 gfc_conv_expr (se
, expr
);
1693 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1694 gfc_free_expr (expr
);
1697 /* Returns a reference to a temporary array into which a component of
1698 an actual argument derived type array is copied and then returned
1699 after the function call.
1700 TODO Get rid of this kludge, when array descriptors are capable of
1701 handling arrays with a bigger stride in bytes than size. */
1704 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1705 int g77
, sym_intent intent
)
1721 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1723 gfc_init_se (&lse
, NULL
);
1724 gfc_init_se (&rse
, NULL
);
1726 /* Walk the argument expression. */
1727 rss
= gfc_walk_expr (expr
);
1729 gcc_assert (rss
!= gfc_ss_terminator
);
1731 /* Initialize the scalarizer. */
1732 gfc_init_loopinfo (&loop
);
1733 gfc_add_ss_to_loop (&loop
, rss
);
1735 /* Calculate the bounds of the scalarization. */
1736 gfc_conv_ss_startstride (&loop
);
1738 /* Build an ss for the temporary. */
1739 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1740 if (GFC_ARRAY_TYPE_P (base_type
)
1741 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1742 base_type
= gfc_get_element_type (base_type
);
1744 loop
.temp_ss
= gfc_get_ss ();;
1745 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1746 loop
.temp_ss
->data
.temp
.type
= base_type
;
1748 if (expr
->ts
.type
== BT_CHARACTER
)
1750 gfc_ref
*char_ref
= expr
->ref
;
1752 for (; char_ref
; char_ref
= char_ref
->next
)
1753 if (char_ref
->type
== REF_SUBSTRING
)
1757 expr
->ts
.cl
= gfc_get_charlen ();
1758 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1759 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1761 gfc_init_se (&tmp_se
, NULL
);
1762 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1763 gfc_array_index_type
);
1764 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1765 tmp_se
.expr
, gfc_index_one_node
);
1766 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1767 gfc_init_se (&tmp_se
, NULL
);
1768 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1769 gfc_array_index_type
);
1770 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1772 expr
->ts
.cl
->backend_decl
= tmp
;
1776 loop
.temp_ss
->data
.temp
.type
1777 = gfc_typenode_for_spec (&expr
->ts
);
1778 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1781 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1782 loop
.temp_ss
->next
= gfc_ss_terminator
;
1784 /* Associate the SS with the loop. */
1785 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1787 /* Setup the scalarizing loops. */
1788 gfc_conv_loop_setup (&loop
);
1790 /* Pass the temporary descriptor back to the caller. */
1791 info
= &loop
.temp_ss
->data
.info
;
1792 parmse
->expr
= info
->descriptor
;
1794 /* Setup the gfc_se structures. */
1795 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1796 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1799 lse
.ss
= loop
.temp_ss
;
1800 gfc_mark_ss_chain_used (rss
, 1);
1801 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1803 /* Start the scalarized loop body. */
1804 gfc_start_scalarized_body (&loop
, &body
);
1806 /* Translate the expression. */
1807 gfc_conv_expr (&rse
, expr
);
1809 gfc_conv_tmp_array_ref (&lse
);
1810 gfc_advance_se_ss_chain (&lse
);
1812 if (intent
!= INTENT_OUT
)
1814 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1815 gfc_add_expr_to_block (&body
, tmp
);
1816 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1817 gfc_trans_scalarizing_loops (&loop
, &body
);
1821 /* Make sure that the temporary declaration survives by merging
1822 all the loop declarations into the current context. */
1823 for (n
= 0; n
< loop
.dimen
; n
++)
1825 gfc_merge_block_scope (&body
);
1826 body
= loop
.code
[loop
.order
[n
]];
1828 gfc_merge_block_scope (&body
);
1831 /* Add the post block after the second loop, so that any
1832 freeing of allocated memory is done at the right time. */
1833 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1835 /**********Copy the temporary back again.*********/
1837 gfc_init_se (&lse
, NULL
);
1838 gfc_init_se (&rse
, NULL
);
1840 /* Walk the argument expression. */
1841 lss
= gfc_walk_expr (expr
);
1842 rse
.ss
= loop
.temp_ss
;
1845 /* Initialize the scalarizer. */
1846 gfc_init_loopinfo (&loop2
);
1847 gfc_add_ss_to_loop (&loop2
, lss
);
1849 /* Calculate the bounds of the scalarization. */
1850 gfc_conv_ss_startstride (&loop2
);
1852 /* Setup the scalarizing loops. */
1853 gfc_conv_loop_setup (&loop2
);
1855 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1856 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1858 gfc_mark_ss_chain_used (lss
, 1);
1859 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1861 /* Declare the variable to hold the temporary offset and start the
1862 scalarized loop body. */
1863 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1864 gfc_start_scalarized_body (&loop2
, &body
);
1866 /* Build the offsets for the temporary from the loop variables. The
1867 temporary array has lbounds of zero and strides of one in all
1868 dimensions, so this is very simple. The offset is only computed
1869 outside the innermost loop, so the overall transfer could be
1870 optimized further. */
1871 info
= &rse
.ss
->data
.info
;
1873 tmp_index
= gfc_index_zero_node
;
1874 for (n
= info
->dimen
- 1; n
> 0; n
--)
1877 tmp
= rse
.loop
->loopvar
[n
];
1878 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1879 tmp
, rse
.loop
->from
[n
]);
1880 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1883 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1884 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1885 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1886 tmp_str
, gfc_index_one_node
);
1888 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1892 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1893 tmp_index
, rse
.loop
->from
[0]);
1894 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1896 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1897 rse
.loop
->loopvar
[0], offset
);
1899 /* Now use the offset for the reference. */
1900 tmp
= build_fold_indirect_ref (info
->data
);
1901 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1903 if (expr
->ts
.type
== BT_CHARACTER
)
1904 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1906 gfc_conv_expr (&lse
, expr
);
1908 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1910 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1911 gfc_add_expr_to_block (&body
, tmp
);
1913 /* Generate the copying loops. */
1914 gfc_trans_scalarizing_loops (&loop2
, &body
);
1916 /* Wrap the whole thing up by adding the second loop to the post-block
1917 and following it by the post-block of the first loop. In this way,
1918 if the temporary needs freeing, it is done after use! */
1919 if (intent
!= INTENT_IN
)
1921 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1922 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1925 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1927 gfc_cleanup_loop (&loop
);
1928 gfc_cleanup_loop (&loop2
);
1930 /* Pass the string length to the argument expression. */
1931 if (expr
->ts
.type
== BT_CHARACTER
)
1932 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1934 /* We want either the address for the data or the address of the descriptor,
1935 depending on the mode of passing array arguments. */
1937 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1939 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1944 /* Is true if an array reference is followed by a component or substring
1948 is_aliased_array (gfc_expr
* e
)
1954 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1956 if (ref
->type
== REF_ARRAY
1957 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1961 && ref
->type
!= REF_ARRAY
)
1967 /* Generate the code for argument list functions. */
1970 conv_arglist_function (gfc_se
*se
, gfc_expr
*expr
, const char *name
)
1972 /* Pass by value for g77 %VAL(arg), pass the address
1973 indirectly for %LOC, else by reference. Thus %REF
1974 is a "do-nothing" and %LOC is the same as an F95
1976 if (strncmp (name
, "%VAL", 4) == 0)
1977 gfc_conv_expr (se
, expr
);
1978 else if (strncmp (name
, "%LOC", 4) == 0)
1980 gfc_conv_expr_reference (se
, expr
);
1981 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
1983 else if (strncmp (name
, "%REF", 4) == 0)
1984 gfc_conv_expr_reference (se
, expr
);
1986 gfc_error ("Unknown argument list function at %L", &expr
->where
);
1990 /* Generate code for a procedure call. Note can return se->post != NULL.
1991 If se->direct_byref is set then se->expr contains the return parameter.
1992 Return nonzero, if the call has alternate specifiers. */
1995 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1996 gfc_actual_arglist
* arg
, tree append_args
)
1998 gfc_interface_mapping mapping
;
2012 gfc_formal_arglist
*formal
;
2013 int has_alternate_specifier
= 0;
2014 bool need_interface_mapping
;
2021 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
2023 arglist
= NULL_TREE
;
2024 retargs
= NULL_TREE
;
2025 stringargs
= NULL_TREE
;
2031 if (!sym
->attr
.elemental
)
2033 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
2034 if (se
->ss
->useflags
)
2036 gcc_assert (gfc_return_by_reference (sym
)
2037 && sym
->result
->attr
.dimension
);
2038 gcc_assert (se
->loop
!= NULL
);
2040 /* Access the previously obtained result. */
2041 gfc_conv_tmp_array_ref (se
);
2042 gfc_advance_se_ss_chain (se
);
2046 info
= &se
->ss
->data
.info
;
2051 gfc_init_block (&post
);
2052 gfc_init_interface_mapping (&mapping
);
2053 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
2054 && sym
->ts
.cl
->length
2055 && sym
->ts
.cl
->length
->expr_type
2057 || sym
->attr
.dimension
);
2058 formal
= sym
->formal
;
2059 /* Evaluate the arguments. */
2060 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
2063 fsym
= formal
? formal
->sym
: NULL
;
2064 parm_kind
= MISSING
;
2068 if (se
->ignore_optional
)
2070 /* Some intrinsics have already been resolved to the correct
2074 else if (arg
->label
)
2076 has_alternate_specifier
= 1;
2081 /* Pass a NULL pointer for an absent arg. */
2082 gfc_init_se (&parmse
, NULL
);
2083 parmse
.expr
= null_pointer_node
;
2084 if (arg
->missing_arg_type
== BT_CHARACTER
)
2085 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
2088 else if (se
->ss
&& se
->ss
->useflags
)
2090 /* An elemental function inside a scalarized loop. */
2091 gfc_init_se (&parmse
, se
);
2092 gfc_conv_expr_reference (&parmse
, e
);
2093 parm_kind
= ELEMENTAL
;
2097 /* A scalar or transformational function. */
2098 gfc_init_se (&parmse
, NULL
);
2099 argss
= gfc_walk_expr (e
);
2101 if (argss
== gfc_ss_terminator
)
2104 if (fsym
&& fsym
->attr
.value
)
2106 gfc_conv_expr (&parmse
, e
);
2108 else if (arg
->name
&& arg
->name
[0] == '%')
2109 /* Argument list functions %VAL, %LOC and %REF are signalled
2110 through arg->name. */
2111 conv_arglist_function (&parmse
, arg
->expr
, arg
->name
);
2112 else if ((e
->expr_type
== EXPR_FUNCTION
)
2113 && e
->symtree
->n
.sym
->attr
.pointer
2114 && fsym
&& fsym
->attr
.target
)
2116 gfc_conv_expr (&parmse
, e
);
2117 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2121 gfc_conv_expr_reference (&parmse
, e
);
2122 if (fsym
&& fsym
->attr
.pointer
2123 && fsym
->attr
.flavor
!= FL_PROCEDURE
2124 && e
->expr_type
!= EXPR_NULL
)
2126 /* Scalar pointer dummy args require an extra level of
2127 indirection. The null pointer already contains
2128 this level of indirection. */
2129 parm_kind
= SCALAR_POINTER
;
2130 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
2136 /* If the procedure requires an explicit interface, the actual
2137 argument is passed according to the corresponding formal
2138 argument. If the corresponding formal argument is a POINTER,
2139 ALLOCATABLE or assumed shape, we do not use g77's calling
2140 convention, and pass the address of the array descriptor
2141 instead. Otherwise we use g77's calling convention. */
2144 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
2145 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
2146 f
= f
|| !sym
->attr
.always_explicit
;
2148 if (e
->expr_type
== EXPR_VARIABLE
2149 && is_aliased_array (e
))
2150 /* The actual argument is a component reference to an
2151 array of derived types. In this case, the argument
2152 is converted to a temporary, which is passed and then
2153 written back after the procedure call. */
2154 gfc_conv_aliased_arg (&parmse
, e
, f
,
2155 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
2157 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2159 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2160 allocated on entry, it must be deallocated. */
2161 if (fsym
&& fsym
->attr
.allocatable
2162 && fsym
->attr
.intent
== INTENT_OUT
)
2164 tmp
= build_fold_indirect_ref (parmse
.expr
);
2165 tmp
= gfc_trans_dealloc_allocated (tmp
);
2166 gfc_add_expr_to_block (&se
->pre
, tmp
);
2176 /* If an optional argument is itself an optional dummy
2177 argument, check its presence and substitute a null
2179 if (e
->expr_type
== EXPR_VARIABLE
2180 && e
->symtree
->n
.sym
->attr
.optional
2181 && fsym
->attr
.optional
)
2182 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2184 /* If an INTENT(OUT) dummy of derived type has a default
2185 initializer, it must be (re)initialized here. */
2186 if (fsym
->attr
.intent
== INTENT_OUT
2187 && fsym
->ts
.type
== BT_DERIVED
2190 gcc_assert (!fsym
->attr
.allocatable
);
2191 tmp
= gfc_trans_assignment (e
, fsym
->value
, false);
2192 gfc_add_expr_to_block (&se
->pre
, tmp
);
2195 /* Obtain the character length of an assumed character
2196 length procedure from the typespec. */
2197 if (fsym
->ts
.type
== BT_CHARACTER
2198 && parmse
.string_length
== NULL_TREE
2199 && e
->ts
.type
== BT_PROCEDURE
2200 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2201 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2203 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2204 parmse
.string_length
2205 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2209 if (need_interface_mapping
)
2210 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2213 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2214 gfc_add_block_to_block (&post
, &parmse
.post
);
2216 /* Allocated allocatable components of derived types must be
2217 deallocated for INTENT(OUT) dummy arguments and non-variable
2218 scalars. Non-variable arrays are dealt with in trans-array.c
2219 (gfc_conv_array_parameter). */
2220 if (e
&& e
->ts
.type
== BT_DERIVED
2221 && e
->ts
.derived
->attr
.alloc_comp
2222 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2224 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2227 tmp
= build_fold_indirect_ref (parmse
.expr
);
2228 parm_rank
= e
->rank
;
2236 case (SCALAR_POINTER
):
2237 tmp
= build_fold_indirect_ref (tmp
);
2244 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2245 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2246 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2247 tmp
, build_empty_stmt ());
2249 if (e
->expr_type
!= EXPR_VARIABLE
)
2250 /* Don't deallocate non-variables until they have been used. */
2251 gfc_add_expr_to_block (&se
->post
, tmp
);
2254 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2255 gfc_add_expr_to_block (&se
->pre
, tmp
);
2259 /* Character strings are passed as two parameters, a length and a
2261 if (parmse
.string_length
!= NULL_TREE
)
2262 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2264 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2266 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2269 if (ts
.type
== BT_CHARACTER
)
2271 if (sym
->ts
.cl
->length
== NULL
)
2273 /* Assumed character length results are not allowed by 5.1.1.5 of the
2274 standard and are trapped in resolve.c; except in the case of SPREAD
2275 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2276 we take the character length of the first argument for the result.
2277 For dummies, we have to look through the formal argument list for
2278 this function and use the character length found there.*/
2279 if (!sym
->attr
.dummy
)
2280 cl
.backend_decl
= TREE_VALUE (stringargs
);
2283 formal
= sym
->ns
->proc_name
->formal
;
2284 for (; formal
; formal
= formal
->next
)
2285 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2286 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2293 /* Calculate the length of the returned string. */
2294 gfc_init_se (&parmse
, NULL
);
2295 if (need_interface_mapping
)
2296 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2298 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2299 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2300 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2302 tmp
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2303 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
2304 build_int_cst (gfc_charlen_type_node
, 0));
2305 cl
.backend_decl
= tmp
;
2308 /* Set up a charlen structure for it. */
2313 len
= cl
.backend_decl
;
2316 byref
= gfc_return_by_reference (sym
);
2319 if (se
->direct_byref
)
2320 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2321 else if (sym
->result
->attr
.dimension
)
2323 gcc_assert (se
->loop
&& info
);
2325 /* Set the type of the array. */
2326 tmp
= gfc_typenode_for_spec (&ts
);
2327 info
->dimen
= se
->loop
->dimen
;
2329 /* Evaluate the bounds of the result, if known. */
2330 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2332 /* Create a temporary to store the result. In case the function
2333 returns a pointer, the temporary will be a shallow copy and
2334 mustn't be deallocated. */
2335 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2336 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2337 false, !sym
->attr
.pointer
, callee_alloc
);
2339 /* Pass the temporary as the first argument. */
2340 tmp
= info
->descriptor
;
2341 tmp
= build_fold_addr_expr (tmp
);
2342 retargs
= gfc_chainon_list (retargs
, tmp
);
2344 else if (ts
.type
== BT_CHARACTER
)
2346 /* Pass the string length. */
2347 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2348 type
= build_pointer_type (type
);
2350 /* Return an address to a char[0:len-1]* temporary for
2351 character pointers. */
2352 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2354 /* Build char[0:len-1] * pstr. */
2355 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2356 build_int_cst (gfc_charlen_type_node
, 1));
2357 tmp
= build_range_type (gfc_array_index_type
,
2358 gfc_index_zero_node
, tmp
);
2359 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2360 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2362 /* Provide an address expression for the function arguments. */
2363 var
= build_fold_addr_expr (var
);
2366 var
= gfc_conv_string_tmp (se
, type
, len
);
2368 retargs
= gfc_chainon_list (retargs
, var
);
2372 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2374 type
= gfc_get_complex_type (ts
.kind
);
2375 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2376 retargs
= gfc_chainon_list (retargs
, var
);
2379 /* Add the string length to the argument list. */
2380 if (ts
.type
== BT_CHARACTER
)
2381 retargs
= gfc_chainon_list (retargs
, len
);
2383 gfc_free_interface_mapping (&mapping
);
2385 /* Add the return arguments. */
2386 arglist
= chainon (retargs
, arglist
);
2388 /* Add the hidden string length parameters to the arguments. */
2389 arglist
= chainon (arglist
, stringargs
);
2391 /* We may want to append extra arguments here. This is used e.g. for
2392 calls to libgfortran_matmul_??, which need extra information. */
2393 if (append_args
!= NULL_TREE
)
2394 arglist
= chainon (arglist
, append_args
);
2396 /* Generate the actual call. */
2397 gfc_conv_function_val (se
, sym
);
2399 /* If there are alternate return labels, function type should be
2400 integer. Can't modify the type in place though, since it can be shared
2401 with other functions. For dummy arguments, the typing is done to
2402 to this result, even if it has to be repeated for each call. */
2403 if (has_alternate_specifier
2404 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2406 if (!sym
->attr
.dummy
)
2408 TREE_TYPE (sym
->backend_decl
)
2409 = build_function_type (integer_type_node
,
2410 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2411 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2414 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
2417 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2418 se
->expr
= build_call_list (TREE_TYPE (fntype
), se
->expr
, arglist
);
2420 /* If we have a pointer function, but we don't want a pointer, e.g.
2423 where f is pointer valued, we have to dereference the result. */
2424 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2425 se
->expr
= build_fold_indirect_ref (se
->expr
);
2427 /* f2c calling conventions require a scalar default real function to
2428 return a double precision result. Convert this back to default
2429 real. We only care about the cases that can happen in Fortran 77.
2431 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2432 && sym
->ts
.kind
== gfc_default_real_kind
2433 && !sym
->attr
.always_explicit
)
2434 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2436 /* A pure function may still have side-effects - it may modify its
2438 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2440 if (!sym
->attr
.pure
)
2441 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2446 /* Add the function call to the pre chain. There is no expression. */
2447 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2448 se
->expr
= NULL_TREE
;
2450 if (!se
->direct_byref
)
2452 if (sym
->attr
.dimension
)
2454 if (flag_bounds_check
)
2456 /* Check the data pointer hasn't been modified. This would
2457 happen in a function returning a pointer. */
2458 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2459 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2461 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2463 se
->expr
= info
->descriptor
;
2464 /* Bundle in the string length. */
2465 se
->string_length
= len
;
2467 else if (sym
->ts
.type
== BT_CHARACTER
)
2469 /* Dereference for character pointer results. */
2470 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2471 se
->expr
= build_fold_indirect_ref (var
);
2475 se
->string_length
= len
;
2479 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2480 se
->expr
= build_fold_indirect_ref (var
);
2485 /* Follow the function call with the argument post block. */
2487 gfc_add_block_to_block (&se
->pre
, &post
);
2489 gfc_add_block_to_block (&se
->post
, &post
);
2491 return has_alternate_specifier
;
2495 /* Generate code to copy a string. */
2498 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2499 tree slength
, tree src
)
2501 tree tmp
, dlen
, slen
;
2509 stmtblock_t tempblock
;
2511 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2512 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2514 /* Deal with single character specially. */
2515 dsc
= gfc_to_single_character (dlen
, dest
);
2516 ssc
= gfc_to_single_character (slen
, src
);
2517 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2519 gfc_add_modify_expr (block
, dsc
, ssc
);
2523 /* Do nothing if the destination length is zero. */
2524 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2525 build_int_cst (gfc_charlen_type_node
, 0));
2527 /* The following code was previously in _gfortran_copy_string:
2529 // The two strings may overlap so we use memmove.
2531 copy_string (GFC_INTEGER_4 destlen, char * dest,
2532 GFC_INTEGER_4 srclen, const char * src)
2534 if (srclen >= destlen)
2536 // This will truncate if too long.
2537 memmove (dest, src, destlen);
2541 memmove (dest, src, srclen);
2543 memset (&dest[srclen], ' ', destlen - srclen);
2547 We're now doing it here for better optimization, but the logic
2550 /* Truncate string if source is too long. */
2551 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2552 tmp2
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2553 3, dest
, src
, dlen
);
2555 /* Else copy and pad with spaces. */
2556 tmp3
= build_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
],
2557 3, dest
, src
, slen
);
2559 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2560 fold_convert (pchar_type_node
, slen
));
2561 tmp4
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
], 3,
2563 build_int_cst (gfc_get_int_type (gfc_c_int_kind
),
2564 lang_hooks
.to_target_charset (' ')),
2565 fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2568 gfc_init_block (&tempblock
);
2569 gfc_add_expr_to_block (&tempblock
, tmp3
);
2570 gfc_add_expr_to_block (&tempblock
, tmp4
);
2571 tmp3
= gfc_finish_block (&tempblock
);
2573 /* The whole copy_string function is there. */
2574 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2575 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2576 gfc_add_expr_to_block (block
, tmp
);
2580 /* Translate a statement function.
2581 The value of a statement function reference is obtained by evaluating the
2582 expression using the values of the actual arguments for the values of the
2583 corresponding dummy arguments. */
2586 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2590 gfc_formal_arglist
*fargs
;
2591 gfc_actual_arglist
*args
;
2594 gfc_saved_var
*saved_vars
;
2600 sym
= expr
->symtree
->n
.sym
;
2601 args
= expr
->value
.function
.actual
;
2602 gfc_init_se (&lse
, NULL
);
2603 gfc_init_se (&rse
, NULL
);
2606 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2608 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2609 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2611 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2613 /* Each dummy shall be specified, explicitly or implicitly, to be
2615 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2618 /* Create a temporary to hold the value. */
2619 type
= gfc_typenode_for_spec (&fsym
->ts
);
2620 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2622 if (fsym
->ts
.type
== BT_CHARACTER
)
2624 /* Copy string arguments. */
2627 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2628 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2630 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2631 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2634 gfc_conv_expr (&rse
, args
->expr
);
2635 gfc_conv_string_parameter (&rse
);
2636 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2637 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2639 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2641 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2642 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2646 /* For everything else, just evaluate the expression. */
2647 gfc_conv_expr (&lse
, args
->expr
);
2649 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2650 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2651 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2657 /* Use the temporary variables in place of the real ones. */
2658 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2659 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2661 gfc_conv_expr (se
, sym
->value
);
2663 if (sym
->ts
.type
== BT_CHARACTER
)
2665 gfc_conv_const_charlen (sym
->ts
.cl
);
2667 /* Force the expression to the correct length. */
2668 if (!INTEGER_CST_P (se
->string_length
)
2669 || tree_int_cst_lt (se
->string_length
,
2670 sym
->ts
.cl
->backend_decl
))
2672 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2673 tmp
= gfc_create_var (type
, sym
->name
);
2674 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2675 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2676 se
->string_length
, se
->expr
);
2679 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2682 /* Restore the original variables. */
2683 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2684 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2685 gfc_free (saved_vars
);
2689 /* Translate a function expression. */
2692 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2696 if (expr
->value
.function
.isym
)
2698 gfc_conv_intrinsic_function (se
, expr
);
2702 /* We distinguish statement functions from general functions to improve
2703 runtime performance. */
2704 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2706 gfc_conv_statement_function (se
, expr
);
2710 /* expr.value.function.esym is the resolved (specific) function symbol for
2711 most functions. However this isn't set for dummy procedures. */
2712 sym
= expr
->value
.function
.esym
;
2714 sym
= expr
->symtree
->n
.sym
;
2715 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
, NULL_TREE
);
2720 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2722 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2723 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2725 gfc_conv_tmp_array_ref (se
);
2726 gfc_advance_se_ss_chain (se
);
2730 /* Build a static initializer. EXPR is the expression for the initial value.
2731 The other parameters describe the variable of the component being
2732 initialized. EXPR may be null. */
2735 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2736 bool array
, bool pointer
)
2740 if (!(expr
|| pointer
))
2745 /* Arrays need special handling. */
2747 return gfc_build_null_descriptor (type
);
2749 return gfc_conv_array_initializer (type
, expr
);
2752 return fold_convert (type
, null_pointer_node
);
2758 gfc_init_se (&se
, NULL
);
2759 gfc_conv_structure (&se
, expr
, 1);
2763 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2766 gfc_init_se (&se
, NULL
);
2767 gfc_conv_constant (&se
, expr
);
2774 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2786 gfc_start_block (&block
);
2788 /* Initialize the scalarizer. */
2789 gfc_init_loopinfo (&loop
);
2791 gfc_init_se (&lse
, NULL
);
2792 gfc_init_se (&rse
, NULL
);
2795 rss
= gfc_walk_expr (expr
);
2796 if (rss
== gfc_ss_terminator
)
2798 /* The rhs is scalar. Add a ss for the expression. */
2799 rss
= gfc_get_ss ();
2800 rss
->next
= gfc_ss_terminator
;
2801 rss
->type
= GFC_SS_SCALAR
;
2805 /* Create a SS for the destination. */
2806 lss
= gfc_get_ss ();
2807 lss
->type
= GFC_SS_COMPONENT
;
2809 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2810 lss
->next
= gfc_ss_terminator
;
2811 lss
->data
.info
.dimen
= cm
->as
->rank
;
2812 lss
->data
.info
.descriptor
= dest
;
2813 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2814 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2815 for (n
= 0; n
< cm
->as
->rank
; n
++)
2817 lss
->data
.info
.dim
[n
] = n
;
2818 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2819 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2821 mpz_init (lss
->shape
[n
]);
2822 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2823 cm
->as
->lower
[n
]->value
.integer
);
2824 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2827 /* Associate the SS with the loop. */
2828 gfc_add_ss_to_loop (&loop
, lss
);
2829 gfc_add_ss_to_loop (&loop
, rss
);
2831 /* Calculate the bounds of the scalarization. */
2832 gfc_conv_ss_startstride (&loop
);
2834 /* Setup the scalarizing loops. */
2835 gfc_conv_loop_setup (&loop
);
2837 /* Setup the gfc_se structures. */
2838 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2839 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2842 gfc_mark_ss_chain_used (rss
, 1);
2844 gfc_mark_ss_chain_used (lss
, 1);
2846 /* Start the scalarized loop body. */
2847 gfc_start_scalarized_body (&loop
, &body
);
2849 gfc_conv_tmp_array_ref (&lse
);
2850 if (cm
->ts
.type
== BT_CHARACTER
)
2851 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2853 gfc_conv_expr (&rse
, expr
);
2855 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2856 gfc_add_expr_to_block (&body
, tmp
);
2858 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2860 /* Generate the copying loops. */
2861 gfc_trans_scalarizing_loops (&loop
, &body
);
2863 /* Wrap the whole thing up. */
2864 gfc_add_block_to_block (&block
, &loop
.pre
);
2865 gfc_add_block_to_block (&block
, &loop
.post
);
2867 for (n
= 0; n
< cm
->as
->rank
; n
++)
2868 mpz_clear (lss
->shape
[n
]);
2869 gfc_free (lss
->shape
);
2871 gfc_cleanup_loop (&loop
);
2873 return gfc_finish_block (&block
);
2877 /* Assign a single component of a derived type constructor. */
2880 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2890 gfc_start_block (&block
);
2894 gfc_init_se (&se
, NULL
);
2895 /* Pointer component. */
2898 /* Array pointer. */
2899 if (expr
->expr_type
== EXPR_NULL
)
2900 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2903 rss
= gfc_walk_expr (expr
);
2904 se
.direct_byref
= 1;
2906 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2907 gfc_add_block_to_block (&block
, &se
.pre
);
2908 gfc_add_block_to_block (&block
, &se
.post
);
2913 /* Scalar pointers. */
2914 se
.want_pointer
= 1;
2915 gfc_conv_expr (&se
, expr
);
2916 gfc_add_block_to_block (&block
, &se
.pre
);
2917 gfc_add_modify_expr (&block
, dest
,
2918 fold_convert (TREE_TYPE (dest
), se
.expr
));
2919 gfc_add_block_to_block (&block
, &se
.post
);
2922 else if (cm
->dimension
)
2924 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2925 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2926 else if (cm
->allocatable
)
2930 gfc_init_se (&se
, NULL
);
2932 rss
= gfc_walk_expr (expr
);
2933 se
.want_pointer
= 0;
2934 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2935 gfc_add_block_to_block (&block
, &se
.pre
);
2937 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2938 gfc_add_modify_expr (&block
, dest
, tmp
);
2940 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2941 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2944 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2945 TREE_TYPE(cm
->backend_decl
),
2948 gfc_add_expr_to_block (&block
, tmp
);
2950 gfc_add_block_to_block (&block
, &se
.post
);
2951 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2953 /* Shift the lbound and ubound of temporaries to being unity, rather
2954 than zero, based. Calculate the offset for all cases. */
2955 offset
= gfc_conv_descriptor_offset (dest
);
2956 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2957 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2958 for (n
= 0; n
< expr
->rank
; n
++)
2960 if (expr
->expr_type
!= EXPR_VARIABLE
2961 && expr
->expr_type
!= EXPR_CONSTANT
)
2963 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2964 gfc_add_modify_expr (&block
, tmp
,
2965 fold_build2 (PLUS_EXPR
,
2966 gfc_array_index_type
,
2967 tmp
, gfc_index_one_node
));
2968 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2969 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2971 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2972 gfc_conv_descriptor_lbound (dest
,
2974 gfc_conv_descriptor_stride (dest
,
2976 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2977 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2978 gfc_add_modify_expr (&block
, offset
, tmp
);
2983 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2984 gfc_add_expr_to_block (&block
, tmp
);
2987 else if (expr
->ts
.type
== BT_DERIVED
)
2989 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2991 gfc_init_se (&se
, NULL
);
2992 gfc_conv_expr (&se
, expr
);
2993 gfc_add_modify_expr (&block
, dest
,
2994 fold_convert (TREE_TYPE (dest
), se
.expr
));
2998 /* Nested constructors. */
2999 tmp
= gfc_trans_structure_assign (dest
, expr
);
3000 gfc_add_expr_to_block (&block
, tmp
);
3005 /* Scalar component. */
3006 gfc_init_se (&se
, NULL
);
3007 gfc_init_se (&lse
, NULL
);
3009 gfc_conv_expr (&se
, expr
);
3010 if (cm
->ts
.type
== BT_CHARACTER
)
3011 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
3013 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
3014 gfc_add_expr_to_block (&block
, tmp
);
3016 return gfc_finish_block (&block
);
3019 /* Assign a derived type constructor to a variable. */
3022 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
3030 gfc_start_block (&block
);
3031 cm
= expr
->ts
.derived
->components
;
3032 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3034 /* Skip absent members in default initializers. */
3038 field
= cm
->backend_decl
;
3039 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
3040 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
3041 gfc_add_expr_to_block (&block
, tmp
);
3043 return gfc_finish_block (&block
);
3046 /* Build an expression for a constructor. If init is nonzero then
3047 this is part of a static variable initializer. */
3050 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
3057 VEC(constructor_elt
,gc
) *v
= NULL
;
3059 gcc_assert (se
->ss
== NULL
);
3060 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
3061 type
= gfc_typenode_for_spec (&expr
->ts
);
3065 /* Create a temporary variable and fill it in. */
3066 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
3067 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
3068 gfc_add_expr_to_block (&se
->pre
, tmp
);
3072 cm
= expr
->ts
.derived
->components
;
3074 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
3076 /* Skip absent members in default initializers and allocatable
3077 components. Although the latter have a default initializer
3078 of EXPR_NULL,... by default, the static nullify is not needed
3079 since this is done every time we come into scope. */
3080 if (!c
->expr
|| cm
->allocatable
)
3083 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
3084 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
3086 /* Append it to the constructor list. */
3087 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
3089 se
->expr
= build_constructor (type
, v
);
3093 /* Translate a substring expression. */
3096 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
3102 gcc_assert (ref
->type
== REF_SUBSTRING
);
3104 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
3105 expr
->value
.character
.string
);
3106 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
3107 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
3109 gfc_conv_substring(se
,ref
,expr
->ts
.kind
,NULL
,&expr
->where
);
3113 /* Entry point for expression translation. Evaluates a scalar quantity.
3114 EXPR is the expression to be translated, and SE is the state structure if
3115 called from within the scalarized. */
3118 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
3120 if (se
->ss
&& se
->ss
->expr
== expr
3121 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
3123 /* Substitute a scalar expression evaluated outside the scalarization
3125 se
->expr
= se
->ss
->data
.scalar
.expr
;
3126 se
->string_length
= se
->ss
->string_length
;
3127 gfc_advance_se_ss_chain (se
);
3131 switch (expr
->expr_type
)
3134 gfc_conv_expr_op (se
, expr
);
3138 gfc_conv_function_expr (se
, expr
);
3142 gfc_conv_constant (se
, expr
);
3146 gfc_conv_variable (se
, expr
);
3150 se
->expr
= null_pointer_node
;
3153 case EXPR_SUBSTRING
:
3154 gfc_conv_substring_expr (se
, expr
);
3157 case EXPR_STRUCTURE
:
3158 gfc_conv_structure (se
, expr
, 0);
3162 gfc_conv_array_constructor_expr (se
, expr
);
3171 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3172 of an assignment. */
3174 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3176 gfc_conv_expr (se
, expr
);
3177 /* All numeric lvalues should have empty post chains. If not we need to
3178 figure out a way of rewriting an lvalue so that it has no post chain. */
3179 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3182 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3183 numeric expressions. Used for scalar values where inserting cleanup code
3186 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3190 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3191 gfc_conv_expr (se
, expr
);
3194 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3195 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3197 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3201 /* Helper to translate and expression and convert it to a particular type. */
3203 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3205 gfc_conv_expr_val (se
, expr
);
3206 se
->expr
= convert (type
, se
->expr
);
3210 /* Converts an expression so that it can be passed by reference. Scalar
3214 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3218 if (se
->ss
&& se
->ss
->expr
== expr
3219 && se
->ss
->type
== GFC_SS_REFERENCE
)
3221 se
->expr
= se
->ss
->data
.scalar
.expr
;
3222 se
->string_length
= se
->ss
->string_length
;
3223 gfc_advance_se_ss_chain (se
);
3227 if (expr
->ts
.type
== BT_CHARACTER
)
3229 gfc_conv_expr (se
, expr
);
3230 gfc_conv_string_parameter (se
);
3234 if (expr
->expr_type
== EXPR_VARIABLE
)
3236 se
->want_pointer
= 1;
3237 gfc_conv_expr (se
, expr
);
3240 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3241 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3242 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3248 gfc_conv_expr (se
, expr
);
3250 /* Create a temporary var to hold the value. */
3251 if (TREE_CONSTANT (se
->expr
))
3253 tree tmp
= se
->expr
;
3254 STRIP_TYPE_NOPS (tmp
);
3255 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (tmp
));
3256 DECL_INITIAL (var
) = tmp
;
3257 TREE_STATIC (var
) = 1;
3262 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3263 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3265 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3267 /* Take the address of that value. */
3268 se
->expr
= build_fold_addr_expr (var
);
3273 gfc_trans_pointer_assign (gfc_code
* code
)
3275 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3279 /* Generate code for a pointer assignment. */
3282 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3292 gfc_start_block (&block
);
3294 gfc_init_se (&lse
, NULL
);
3296 lss
= gfc_walk_expr (expr1
);
3297 rss
= gfc_walk_expr (expr2
);
3298 if (lss
== gfc_ss_terminator
)
3300 /* Scalar pointers. */
3301 lse
.want_pointer
= 1;
3302 gfc_conv_expr (&lse
, expr1
);
3303 gcc_assert (rss
== gfc_ss_terminator
);
3304 gfc_init_se (&rse
, NULL
);
3305 rse
.want_pointer
= 1;
3306 gfc_conv_expr (&rse
, expr2
);
3307 gfc_add_block_to_block (&block
, &lse
.pre
);
3308 gfc_add_block_to_block (&block
, &rse
.pre
);
3309 gfc_add_modify_expr (&block
, lse
.expr
,
3310 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3311 gfc_add_block_to_block (&block
, &rse
.post
);
3312 gfc_add_block_to_block (&block
, &lse
.post
);
3316 /* Array pointer. */
3317 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3318 switch (expr2
->expr_type
)
3321 /* Just set the data pointer to null. */
3322 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3326 /* Assign directly to the pointer's descriptor. */
3327 lse
.direct_byref
= 1;
3328 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3332 /* Assign to a temporary descriptor and then copy that
3333 temporary to the pointer. */
3335 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3338 lse
.direct_byref
= 1;
3339 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3340 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3343 gfc_add_block_to_block (&block
, &lse
.pre
);
3344 gfc_add_block_to_block (&block
, &lse
.post
);
3346 return gfc_finish_block (&block
);
3350 /* Makes sure se is suitable for passing as a function string parameter. */
3351 /* TODO: Need to check all callers fo this function. It may be abused. */
3354 gfc_conv_string_parameter (gfc_se
* se
)
3358 if (TREE_CODE (se
->expr
) == STRING_CST
)
3360 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3364 type
= TREE_TYPE (se
->expr
);
3365 if (TYPE_STRING_FLAG (type
))
3367 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3368 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3371 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3372 gcc_assert (se
->string_length
3373 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3377 /* Generate code for assignment of scalar variables. Includes character
3378 strings and derived types with allocatable components. */
3381 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3382 bool l_is_temp
, bool r_is_var
)
3388 gfc_init_block (&block
);
3390 if (ts
.type
== BT_CHARACTER
)
3392 gcc_assert (lse
->string_length
!= NULL_TREE
3393 && rse
->string_length
!= NULL_TREE
);
3395 gfc_conv_string_parameter (lse
);
3396 gfc_conv_string_parameter (rse
);
3398 gfc_add_block_to_block (&block
, &lse
->pre
);
3399 gfc_add_block_to_block (&block
, &rse
->pre
);
3401 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3402 rse
->string_length
, rse
->expr
);
3404 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3408 /* Are the rhs and the lhs the same? */
3411 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3412 build_fold_addr_expr (lse
->expr
),
3413 build_fold_addr_expr (rse
->expr
));
3414 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3417 /* Deallocate the lhs allocated components as long as it is not
3418 the same as the rhs. */
3421 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3423 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3424 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3427 gfc_add_block_to_block (&block
, &lse
->pre
);
3428 gfc_add_block_to_block (&block
, &rse
->pre
);
3430 gfc_add_modify_expr (&block
, lse
->expr
,
3431 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3433 /* Do a deep copy if the rhs is a variable, if it is not the
3437 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3438 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3439 gfc_add_expr_to_block (&block
, tmp
);
3444 gfc_add_block_to_block (&block
, &lse
->pre
);
3445 gfc_add_block_to_block (&block
, &rse
->pre
);
3447 gfc_add_modify_expr (&block
, lse
->expr
,
3448 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3451 gfc_add_block_to_block (&block
, &lse
->post
);
3452 gfc_add_block_to_block (&block
, &rse
->post
);
3454 return gfc_finish_block (&block
);
3458 /* Try to translate array(:) = func (...), where func is a transformational
3459 array function, without using a temporary. Returns NULL is this isn't the
3463 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3468 bool seen_array_ref
;
3470 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3471 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3474 /* Elemental functions don't need a temporary anyway. */
3475 if (expr2
->value
.function
.esym
!= NULL
3476 && expr2
->value
.function
.esym
->attr
.elemental
)
3479 /* Fail if EXPR1 can't be expressed as a descriptor. */
3480 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3483 /* Functions returning pointers need temporaries. */
3484 if (expr2
->symtree
->n
.sym
->attr
.pointer
3485 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3488 /* Character array functions need temporaries unless the
3489 character lengths are the same. */
3490 if (expr2
->ts
.type
== BT_CHARACTER
&& expr2
->rank
> 0)
3492 if (expr1
->ts
.cl
->length
== NULL
3493 || expr1
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3496 if (expr2
->ts
.cl
->length
== NULL
3497 || expr2
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
3500 if (mpz_cmp (expr1
->ts
.cl
->length
->value
.integer
,
3501 expr2
->ts
.cl
->length
->value
.integer
) != 0)
3505 /* Check that no LHS component references appear during an array
3506 reference. This is needed because we do not have the means to
3507 span any arbitrary stride with an array descriptor. This check
3508 is not needed for the rhs because the function result has to be
3510 seen_array_ref
= false;
3511 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3513 if (ref
->type
== REF_ARRAY
)
3514 seen_array_ref
= true;
3515 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3519 /* Check for a dependency. */
3520 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3521 expr2
->value
.function
.esym
,
3522 expr2
->value
.function
.actual
))
3525 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3527 gcc_assert (expr2
->value
.function
.isym
3528 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3529 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3531 ss
= gfc_walk_expr (expr1
);
3532 gcc_assert (ss
!= gfc_ss_terminator
);
3533 gfc_init_se (&se
, NULL
);
3534 gfc_start_block (&se
.pre
);
3535 se
.want_pointer
= 1;
3537 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3539 se
.direct_byref
= 1;
3540 se
.ss
= gfc_walk_expr (expr2
);
3541 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3542 gfc_conv_function_expr (&se
, expr2
);
3543 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3545 return gfc_finish_block (&se
.pre
);
3548 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3551 is_zero_initializer_p (gfc_expr
* expr
)
3553 if (expr
->expr_type
!= EXPR_CONSTANT
)
3555 /* We ignore Hollerith constants for the time being. */
3559 switch (expr
->ts
.type
)
3562 return mpz_cmp_si (expr
->value
.integer
, 0) == 0;
3565 return mpfr_zero_p (expr
->value
.real
)
3566 && MPFR_SIGN (expr
->value
.real
) >= 0;
3569 return expr
->value
.logical
== 0;
3572 return mpfr_zero_p (expr
->value
.complex.r
)
3573 && MPFR_SIGN (expr
->value
.complex.r
) >= 0
3574 && mpfr_zero_p (expr
->value
.complex.i
)
3575 && MPFR_SIGN (expr
->value
.complex.i
) >= 0;
3583 /* Try to efficiently translate array(:) = 0. Return NULL if this
3587 gfc_trans_zero_assign (gfc_expr
* expr
)
3589 tree dest
, len
, type
;
3593 sym
= expr
->symtree
->n
.sym
;
3594 dest
= gfc_get_symbol_decl (sym
);
3596 type
= TREE_TYPE (dest
);
3597 if (POINTER_TYPE_P (type
))
3598 type
= TREE_TYPE (type
);
3599 if (!GFC_ARRAY_TYPE_P (type
))
3602 /* Determine the length of the array. */
3603 len
= GFC_TYPE_ARRAY_SIZE (type
);
3604 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3607 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3608 TYPE_SIZE_UNIT (gfc_get_element_type (type
)));
3610 /* Convert arguments to the correct types. */
3611 if (!POINTER_TYPE_P (TREE_TYPE (dest
)))
3612 dest
= gfc_build_addr_expr (pvoid_type_node
, dest
);
3614 dest
= fold_convert (pvoid_type_node
, dest
);
3615 len
= fold_convert (size_type_node
, len
);
3617 /* Construct call to __builtin_memset. */
3618 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMSET
],
3619 3, dest
, integer_zero_node
, len
);
3620 return fold_convert (void_type_node
, tmp
);
3624 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3625 that constructs the call to __builtin_memcpy. */
3628 gfc_build_memcpy_call (tree dst
, tree src
, tree len
)
3632 /* Convert arguments to the correct types. */
3633 if (!POINTER_TYPE_P (TREE_TYPE (dst
)))
3634 dst
= gfc_build_addr_expr (pvoid_type_node
, dst
);
3636 dst
= fold_convert (pvoid_type_node
, dst
);
3638 if (!POINTER_TYPE_P (TREE_TYPE (src
)))
3639 src
= gfc_build_addr_expr (pvoid_type_node
, src
);
3641 src
= fold_convert (pvoid_type_node
, src
);
3643 len
= fold_convert (size_type_node
, len
);
3645 /* Construct call to __builtin_memcpy. */
3646 tmp
= build_call_expr (built_in_decls
[BUILT_IN_MEMCPY
], 3, dst
, src
, len
);
3647 return fold_convert (void_type_node
, tmp
);
3651 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3652 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3653 source/rhs, both are gfc_full_array_ref_p which have been checked for
3657 gfc_trans_array_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3659 tree dst
, dlen
, dtype
;
3660 tree src
, slen
, stype
;
3662 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3663 src
= gfc_get_symbol_decl (expr2
->symtree
->n
.sym
);
3665 dtype
= TREE_TYPE (dst
);
3666 if (POINTER_TYPE_P (dtype
))
3667 dtype
= TREE_TYPE (dtype
);
3668 stype
= TREE_TYPE (src
);
3669 if (POINTER_TYPE_P (stype
))
3670 stype
= TREE_TYPE (stype
);
3672 if (!GFC_ARRAY_TYPE_P (dtype
) || !GFC_ARRAY_TYPE_P (stype
))
3675 /* Determine the lengths of the arrays. */
3676 dlen
= GFC_TYPE_ARRAY_SIZE (dtype
);
3677 if (!dlen
|| TREE_CODE (dlen
) != INTEGER_CST
)
3679 dlen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, dlen
,
3680 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3682 slen
= GFC_TYPE_ARRAY_SIZE (stype
);
3683 if (!slen
|| TREE_CODE (slen
) != INTEGER_CST
)
3685 slen
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, slen
,
3686 TYPE_SIZE_UNIT (gfc_get_element_type (stype
)));
3688 /* Sanity check that they are the same. This should always be
3689 the case, as we should already have checked for conformance. */
3690 if (!tree_int_cst_equal (slen
, dlen
))
3693 return gfc_build_memcpy_call (dst
, src
, dlen
);
3697 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3698 this can't be done. EXPR1 is the destination/lhs for which
3699 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3702 gfc_trans_array_constructor_copy (gfc_expr
* expr1
, gfc_expr
* expr2
)
3704 unsigned HOST_WIDE_INT nelem
;
3709 nelem
= gfc_constant_array_constructor_p (expr2
->value
.constructor
);
3713 dst
= gfc_get_symbol_decl (expr1
->symtree
->n
.sym
);
3714 dtype
= TREE_TYPE (dst
);
3715 if (POINTER_TYPE_P (dtype
))
3716 dtype
= TREE_TYPE (dtype
);
3717 if (!GFC_ARRAY_TYPE_P (dtype
))
3720 /* Determine the lengths of the array. */
3721 len
= GFC_TYPE_ARRAY_SIZE (dtype
);
3722 if (!len
|| TREE_CODE (len
) != INTEGER_CST
)
3725 /* Confirm that the constructor is the same size. */
3726 if (compare_tree_int (len
, nelem
) != 0)
3729 len
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, len
,
3730 TYPE_SIZE_UNIT (gfc_get_element_type (dtype
)));
3732 stype
= gfc_typenode_for_spec (&expr2
->ts
);
3733 src
= gfc_build_constant_array_constructor (expr2
, stype
);
3735 stype
= TREE_TYPE (src
);
3736 if (POINTER_TYPE_P (stype
))
3737 stype
= TREE_TYPE (stype
);
3739 return gfc_build_memcpy_call (dst
, src
, len
);
3743 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3744 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3747 gfc_trans_assignment_1 (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3752 gfc_ss
*lss_section
;
3760 /* Assignment of the form lhs = rhs. */
3761 gfc_start_block (&block
);
3763 gfc_init_se (&lse
, NULL
);
3764 gfc_init_se (&rse
, NULL
);
3767 lss
= gfc_walk_expr (expr1
);
3769 if (lss
!= gfc_ss_terminator
)
3771 /* The assignment needs scalarization. */
3774 /* Find a non-scalar SS from the lhs. */
3775 while (lss_section
!= gfc_ss_terminator
3776 && lss_section
->type
!= GFC_SS_SECTION
)
3777 lss_section
= lss_section
->next
;
3779 gcc_assert (lss_section
!= gfc_ss_terminator
);
3781 /* Initialize the scalarizer. */
3782 gfc_init_loopinfo (&loop
);
3785 rss
= gfc_walk_expr (expr2
);
3786 if (rss
== gfc_ss_terminator
)
3788 /* The rhs is scalar. Add a ss for the expression. */
3789 rss
= gfc_get_ss ();
3790 rss
->next
= gfc_ss_terminator
;
3791 rss
->type
= GFC_SS_SCALAR
;
3794 /* Associate the SS with the loop. */
3795 gfc_add_ss_to_loop (&loop
, lss
);
3796 gfc_add_ss_to_loop (&loop
, rss
);
3798 /* Calculate the bounds of the scalarization. */
3799 gfc_conv_ss_startstride (&loop
);
3800 /* Resolve any data dependencies in the statement. */
3801 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3802 /* Setup the scalarizing loops. */
3803 gfc_conv_loop_setup (&loop
);
3805 /* Setup the gfc_se structures. */
3806 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3807 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3810 gfc_mark_ss_chain_used (rss
, 1);
3811 if (loop
.temp_ss
== NULL
)
3814 gfc_mark_ss_chain_used (lss
, 1);
3818 lse
.ss
= loop
.temp_ss
;
3819 gfc_mark_ss_chain_used (lss
, 3);
3820 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3823 /* Start the scalarized loop body. */
3824 gfc_start_scalarized_body (&loop
, &body
);
3827 gfc_init_block (&body
);
3829 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3831 /* Translate the expression. */
3832 gfc_conv_expr (&rse
, expr2
);
3836 gfc_conv_tmp_array_ref (&lse
);
3837 gfc_advance_se_ss_chain (&lse
);
3840 gfc_conv_expr (&lse
, expr1
);
3842 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3843 l_is_temp
|| init_flag
,
3844 expr2
->expr_type
== EXPR_VARIABLE
);
3845 gfc_add_expr_to_block (&body
, tmp
);
3847 if (lss
== gfc_ss_terminator
)
3849 /* Use the scalar assignment as is. */
3850 gfc_add_block_to_block (&block
, &body
);
3854 gcc_assert (lse
.ss
== gfc_ss_terminator
3855 && rse
.ss
== gfc_ss_terminator
);
3859 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3861 /* We need to copy the temporary to the actual lhs. */
3862 gfc_init_se (&lse
, NULL
);
3863 gfc_init_se (&rse
, NULL
);
3864 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3865 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3867 rse
.ss
= loop
.temp_ss
;
3870 gfc_conv_tmp_array_ref (&rse
);
3871 gfc_advance_se_ss_chain (&rse
);
3872 gfc_conv_expr (&lse
, expr1
);
3874 gcc_assert (lse
.ss
== gfc_ss_terminator
3875 && rse
.ss
== gfc_ss_terminator
);
3877 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3879 gfc_add_expr_to_block (&body
, tmp
);
3882 /* Generate the copying loops. */
3883 gfc_trans_scalarizing_loops (&loop
, &body
);
3885 /* Wrap the whole thing up. */
3886 gfc_add_block_to_block (&block
, &loop
.pre
);
3887 gfc_add_block_to_block (&block
, &loop
.post
);
3889 gfc_cleanup_loop (&loop
);
3892 return gfc_finish_block (&block
);
3896 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
3899 copyable_array_p (gfc_expr
* expr
)
3901 /* First check it's an array. */
3902 if (expr
->rank
< 1 || !expr
->ref
)
3905 /* Next check that it's of a simple enough type. */
3906 switch (expr
->ts
.type
)
3918 return !expr
->ts
.derived
->attr
.alloc_comp
;
3927 /* Translate an assignment. */
3930 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
, bool init_flag
)
3934 /* Special case a single function returning an array. */
3935 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3937 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3942 /* Special case assigning an array to zero. */
3943 if (expr1
->expr_type
== EXPR_VARIABLE
3946 && expr1
->ref
->next
== NULL
3947 && gfc_full_array_ref_p (expr1
->ref
)
3948 && is_zero_initializer_p (expr2
))
3950 tmp
= gfc_trans_zero_assign (expr1
);
3955 /* Special case copying one array to another. */
3956 if (expr1
->expr_type
== EXPR_VARIABLE
3957 && copyable_array_p (expr1
)
3958 && gfc_full_array_ref_p (expr1
->ref
)
3959 && expr2
->expr_type
== EXPR_VARIABLE
3960 && copyable_array_p (expr2
)
3961 && gfc_full_array_ref_p (expr2
->ref
)
3962 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
)
3963 && !gfc_check_dependency (expr1
, expr2
, 0))
3965 tmp
= gfc_trans_array_copy (expr1
, expr2
);
3970 /* Special case initializing an array from a constant array constructor. */
3971 if (expr1
->expr_type
== EXPR_VARIABLE
3972 && copyable_array_p (expr1
)
3973 && gfc_full_array_ref_p (expr1
->ref
)
3974 && expr2
->expr_type
== EXPR_ARRAY
3975 && gfc_compare_types (&expr1
->ts
, &expr2
->ts
))
3977 tmp
= gfc_trans_array_constructor_copy (expr1
, expr2
);
3982 /* Fallback to the scalarizer to generate explicit loops. */
3983 return gfc_trans_assignment_1 (expr1
, expr2
, init_flag
);
3987 gfc_trans_init_assign (gfc_code
* code
)
3989 return gfc_trans_assignment (code
->expr
, code
->expr2
, true);
3993 gfc_trans_assign (gfc_code
* code
)
3995 return gfc_trans_assignment (code
->expr
, code
->expr2
, false);