1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
43 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
45 /* Copy the scalarization loop variables. */
48 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
51 dest
->loop
= src
->loop
;
55 /* Initialize a simple expression holder.
57 Care must be taken when multiple se are created with the same parent.
58 The child se must be kept in sync. The easiest way is to delay creation
59 of a child se until after after the previous se has been translated. */
62 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
64 memset (se
, 0, sizeof (gfc_se
));
65 gfc_init_block (&se
->pre
);
66 gfc_init_block (&se
->post
);
71 gfc_copy_se_loopvars (se
, parent
);
75 /* Advances to the next SS in the chain. Use this rather than setting
76 se->ss = se->ss->next because all the parents needs to be kept in sync.
80 gfc_advance_se_ss_chain (gfc_se
* se
)
84 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
87 /* Walk down the parent chain. */
90 /* Simple consistency check. */
91 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
100 /* Ensures the result of the expression as either a temporary variable
101 or a constant so that it can be used repeatedly. */
104 gfc_make_safe_expr (gfc_se
* se
)
108 if (CONSTANT_CLASS_P (se
->expr
))
111 /* We need a temporary for this result. */
112 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
113 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
118 /* Return an expression which determines if a dummy parameter is present.
119 Also used for arguments to procedures with multiple entry points. */
122 gfc_conv_expr_present (gfc_symbol
* sym
)
126 gcc_assert (sym
->attr
.dummy
);
128 decl
= gfc_get_symbol_decl (sym
);
129 if (TREE_CODE (decl
) != PARM_DECL
)
131 /* Array parameters use a temporary descriptor, we want the real
133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
134 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
135 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
137 return build2 (NE_EXPR
, boolean_type_node
, decl
,
138 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
142 /* Get the character length of an expression, looking through gfc_refs
146 gfc_get_expr_charlen (gfc_expr
*e
)
151 gcc_assert (e
->expr_type
== EXPR_VARIABLE
152 && e
->ts
.type
== BT_CHARACTER
);
154 length
= NULL
; /* To silence compiler warning. */
156 /* First candidate: if the variable is of type CHARACTER, the
157 expression's length could be the length of the character
159 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
160 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
162 /* Look through the reference chain for component references. */
163 for (r
= e
->ref
; r
; r
= r
->next
)
168 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
169 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
177 /* We should never got substring references here. These will be
178 broken down by the scalarizer. */
183 gcc_assert (length
!= NULL
);
189 /* Generate code to initialize a string length variable. Returns the
193 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
198 gfc_init_se (&se
, NULL
);
199 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
200 gfc_add_block_to_block (pblock
, &se
.pre
);
202 tmp
= cl
->backend_decl
;
203 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
208 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
)
216 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
217 type
= build_pointer_type (type
);
220 gfc_init_se (&start
, se
);
221 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
222 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
224 if (integer_onep (start
.expr
))
225 gfc_conv_string_parameter (se
);
228 /* Change the start of the string. */
229 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
232 tmp
= gfc_build_indirect_ref (se
->expr
);
233 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
234 se
->expr
= gfc_build_addr_expr (type
, tmp
);
237 /* Length = end + 1 - start. */
238 gfc_init_se (&end
, se
);
239 if (ref
->u
.ss
.end
== NULL
)
240 end
.expr
= se
->string_length
;
243 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
244 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
247 build2 (MINUS_EXPR
, gfc_charlen_type_node
,
248 fold_convert (gfc_charlen_type_node
, integer_one_node
),
250 tmp
= build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
251 se
->string_length
= fold (tmp
);
255 /* Convert a derived type component reference. */
258 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
265 c
= ref
->u
.c
.component
;
267 gcc_assert (c
->backend_decl
);
269 field
= c
->backend_decl
;
270 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
272 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
276 if (c
->ts
.type
== BT_CHARACTER
)
278 tmp
= c
->ts
.cl
->backend_decl
;
279 /* Components must always be constant length. */
280 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
281 se
->string_length
= tmp
;
284 if (c
->pointer
&& c
->dimension
== 0)
285 se
->expr
= gfc_build_indirect_ref (se
->expr
);
289 /* Return the contents of a variable. Also handles reference/pointer
290 variables (all Fortran pointer references are implicit). */
293 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
298 sym
= expr
->symtree
->n
.sym
;
301 /* Check that something hasn't gone horribly wrong. */
302 gcc_assert (se
->ss
!= gfc_ss_terminator
);
303 gcc_assert (se
->ss
->expr
== expr
);
305 /* A scalarized term. We already know the descriptor. */
306 se
->expr
= se
->ss
->data
.info
.descriptor
;
307 se
->string_length
= se
->ss
->string_length
;
308 ref
= se
->ss
->data
.info
.ref
;
312 tree se_expr
= NULL_TREE
;
314 se
->expr
= gfc_get_symbol_decl (sym
);
316 /* Special case for assigning the return value of a function.
317 Self recursive functions must have an explicit return value. */
318 if (se
->expr
== current_function_decl
&& sym
->attr
.function
319 && (sym
->result
== sym
))
320 se_expr
= gfc_get_fake_result_decl (sym
);
322 /* Similarly for alternate entry points. */
323 else if (sym
->attr
.function
&& sym
->attr
.entry
324 && (sym
->result
== sym
)
325 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
)
327 gfc_entry_list
*el
= NULL
;
329 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
332 se_expr
= gfc_get_fake_result_decl (sym
);
337 else if (sym
->attr
.result
338 && sym
->ns
->proc_name
->backend_decl
== current_function_decl
339 && sym
->ns
->proc_name
->attr
.entry_master
340 && !gfc_return_by_reference (sym
->ns
->proc_name
))
341 se_expr
= gfc_get_fake_result_decl (sym
);
346 /* Procedure actual arguments. */
347 else if (sym
->attr
.flavor
== FL_PROCEDURE
348 && se
->expr
!= current_function_decl
)
350 gcc_assert (se
->want_pointer
);
351 if (!sym
->attr
.dummy
)
353 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
354 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
359 /* Dereference scalar dummy variables. */
361 && sym
->ts
.type
!= BT_CHARACTER
362 && !sym
->attr
.dimension
)
363 se
->expr
= gfc_build_indirect_ref (se
->expr
);
365 /* Dereference pointer variables. */
366 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
369 || sym
->attr
.function
370 || !sym
->attr
.dimension
)
371 && sym
->ts
.type
!= BT_CHARACTER
)
372 se
->expr
= gfc_build_indirect_ref (se
->expr
);
377 /* For character variables, also get the length. */
378 if (sym
->ts
.type
== BT_CHARACTER
)
380 se
->string_length
= sym
->ts
.cl
->backend_decl
;
381 gcc_assert (se
->string_length
);
389 /* Return the descriptor if that's what we want and this is an array
390 section reference. */
391 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
393 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
394 /* Return the descriptor for array pointers and allocations. */
396 && ref
->next
== NULL
&& (se
->descriptor_only
))
399 gfc_conv_array_ref (se
, &ref
->u
.ar
);
400 /* Return a pointer to an element. */
404 gfc_conv_component_ref (se
, ref
);
408 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
417 /* Pointer assignment, allocation or pass by reference. Arrays are handled
419 if (se
->want_pointer
)
421 if (expr
->ts
.type
== BT_CHARACTER
)
422 gfc_conv_string_parameter (se
);
424 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
427 gfc_advance_se_ss_chain (se
);
431 /* Unary ops are easy... Or they would be if ! was a valid op. */
434 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
439 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
440 /* Initialize the operand. */
441 gfc_init_se (&operand
, se
);
442 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
443 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
445 type
= gfc_typenode_for_spec (&expr
->ts
);
447 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
448 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
449 All other unary operators have an equivalent GIMPLE unary operator. */
450 if (code
== TRUTH_NOT_EXPR
)
451 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
452 convert (type
, integer_zero_node
));
454 se
->expr
= build1 (code
, type
, operand
.expr
);
458 /* Expand power operator to optimal multiplications when a value is raised
459 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
460 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
461 Programming", 3rd Edition, 1998. */
463 /* This code is mostly duplicated from expand_powi in the backend.
464 We establish the "optimal power tree" lookup table with the defined size.
465 The items in the table are the exponents used to calculate the index
466 exponents. Any integer n less than the value can get an "addition chain",
467 with the first node being one. */
468 #define POWI_TABLE_SIZE 256
470 /* The table is from builtins.c. */
471 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
473 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
474 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
475 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
476 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
477 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
478 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
479 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
480 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
481 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
482 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
483 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
484 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
485 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
486 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
487 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
488 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
489 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
490 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
491 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
492 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
493 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
494 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
495 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
496 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
497 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
498 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
499 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
500 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
501 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
502 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
503 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
504 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
507 /* If n is larger than lookup table's max index, we use the "window
509 #define POWI_WINDOW_SIZE 3
511 /* Recursive function to expand the power operator. The temporary
512 values are put in tmpvar. The function returns tmpvar[1] ** n. */
514 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
521 if (n
< POWI_TABLE_SIZE
)
526 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
527 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
531 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
532 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
533 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
537 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
541 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
542 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
544 if (n
< POWI_TABLE_SIZE
)
551 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
552 return 1. Else return 0 and a call to runtime library functions
553 will have to be built. */
555 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
560 tree vartmp
[POWI_TABLE_SIZE
];
564 type
= TREE_TYPE (lhs
);
565 n
= abs (TREE_INT_CST_LOW (rhs
));
566 sgn
= tree_int_cst_sgn (rhs
);
568 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
569 && (n
> 2 || n
< -1))
575 se
->expr
= gfc_build_const (type
, integer_one_node
);
578 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
579 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
581 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
582 fold_convert (TREE_TYPE (lhs
), integer_minus_one_node
));
583 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
584 convert (TREE_TYPE (lhs
), integer_one_node
));
587 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
590 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
591 se
->expr
= build3 (COND_EXPR
, type
, tmp
,
592 convert (type
, integer_one_node
),
593 convert (type
, integer_zero_node
));
597 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
598 tmp
= build3 (COND_EXPR
, type
, tmp
,
599 convert (type
, integer_minus_one_node
),
600 convert (type
, integer_zero_node
));
601 se
->expr
= build3 (COND_EXPR
, type
, cond
,
602 convert (type
, integer_one_node
),
607 memset (vartmp
, 0, sizeof (vartmp
));
611 tmp
= gfc_build_const (type
, integer_one_node
);
612 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
615 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
621 /* Power op (**). Constant integer exponent has special handling. */
624 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
626 tree gfc_int4_type_node
;
634 gfc_init_se (&lse
, se
);
635 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
636 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
638 gfc_init_se (&rse
, se
);
639 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
640 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
642 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
643 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
644 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
647 gfc_int4_type_node
= gfc_get_int_type (4);
649 kind
= expr
->value
.op
.op1
->ts
.kind
;
650 switch (expr
->value
.op
.op2
->ts
.type
)
653 ikind
= expr
->value
.op
.op2
->ts
.kind
;
658 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
676 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
677 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
694 switch (expr
->value
.op
.op1
->ts
.type
)
697 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
701 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
705 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
717 fndecl
= built_in_decls
[BUILT_IN_POWF
];
720 fndecl
= built_in_decls
[BUILT_IN_POW
];
731 fndecl
= gfor_fndecl_math_cpowf
;
734 fndecl
= gfor_fndecl_math_cpow
;
746 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
747 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
748 se
->expr
= fold (gfc_build_function_call (fndecl
, tmp
));
752 /* Generate code to allocate a string temporary. */
755 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
761 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
763 if (gfc_can_put_var_on_stack (len
))
765 /* Create a temporary variable to hold the result. */
766 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
767 convert (gfc_charlen_type_node
, integer_one_node
));
768 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
769 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
770 var
= gfc_create_var (tmp
, "str");
771 var
= gfc_build_addr_expr (type
, var
);
775 /* Allocate a temporary to hold the result. */
776 var
= gfc_create_var (type
, "pstr");
777 args
= gfc_chainon_list (NULL_TREE
, len
);
778 tmp
= gfc_build_function_call (gfor_fndecl_internal_malloc
, args
);
779 tmp
= convert (type
, tmp
);
780 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
782 /* Free the temporary afterwards. */
783 tmp
= convert (pvoid_type_node
, var
);
784 args
= gfc_chainon_list (NULL_TREE
, tmp
);
785 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
786 gfc_add_expr_to_block (&se
->post
, tmp
);
793 /* Handle a string concatenation operation. A temporary will be allocated to
797 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
807 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
808 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
810 gfc_init_se (&lse
, se
);
811 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
812 gfc_conv_string_parameter (&lse
);
813 gfc_init_se (&rse
, se
);
814 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
815 gfc_conv_string_parameter (&rse
);
817 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
818 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
820 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
821 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
822 if (len
== NULL_TREE
)
824 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
825 lse
.string_length
, rse
.string_length
);
828 type
= build_pointer_type (type
);
830 var
= gfc_conv_string_tmp (se
, type
, len
);
832 /* Do the actual concatenation. */
834 args
= gfc_chainon_list (args
, len
);
835 args
= gfc_chainon_list (args
, var
);
836 args
= gfc_chainon_list (args
, lse
.string_length
);
837 args
= gfc_chainon_list (args
, lse
.expr
);
838 args
= gfc_chainon_list (args
, rse
.string_length
);
839 args
= gfc_chainon_list (args
, rse
.expr
);
840 tmp
= gfc_build_function_call (gfor_fndecl_concat_string
, args
);
841 gfc_add_expr_to_block (&se
->pre
, tmp
);
843 /* Add the cleanup for the operands. */
844 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
845 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
848 se
->string_length
= len
;
852 /* Translates an op expression. Common (binary) cases are handled by this
853 function, others are passed on. Recursion is used in either case.
854 We use the fact that (op1.ts == op2.ts) (except for the power
856 Operators need no special handling for scalarized expressions as long as
857 they call gfc_conv_simple_val to get their operands.
858 Character strings get special handling. */
861 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
873 switch (expr
->value
.op
.operator)
875 case INTRINSIC_UPLUS
:
876 gfc_conv_expr (se
, expr
->value
.op
.op1
);
879 case INTRINSIC_UMINUS
:
880 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
884 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
891 case INTRINSIC_MINUS
:
895 case INTRINSIC_TIMES
:
899 case INTRINSIC_DIVIDE
:
900 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
901 an integer, we must round towards zero, so we use a
903 if (expr
->ts
.type
== BT_INTEGER
)
904 code
= TRUNC_DIV_EXPR
;
909 case INTRINSIC_POWER
:
910 gfc_conv_power_op (se
, expr
);
913 case INTRINSIC_CONCAT
:
914 gfc_conv_concat_op (se
, expr
);
918 code
= TRUTH_ANDIF_EXPR
;
923 code
= TRUTH_ORIF_EXPR
;
927 /* EQV and NEQV only work on logicals, but since we represent them
928 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
968 case INTRINSIC_ASSIGN
:
969 /* These should be converted into function calls by the frontend. */
973 fatal_error ("Unknown intrinsic op");
977 /* The only exception to this is **, which is handled separately anyway. */
978 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
980 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
984 gfc_init_se (&lse
, se
);
985 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
986 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
989 gfc_init_se (&rse
, se
);
990 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
991 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
993 /* For string comparisons we generate a library call, and compare the return
997 gfc_conv_string_parameter (&lse
);
998 gfc_conv_string_parameter (&rse
);
1000 tmp
= gfc_chainon_list (tmp
, lse
.string_length
);
1001 tmp
= gfc_chainon_list (tmp
, lse
.expr
);
1002 tmp
= gfc_chainon_list (tmp
, rse
.string_length
);
1003 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
1005 /* Build a call for the comparison. */
1006 lse
.expr
= gfc_build_function_call (gfor_fndecl_compare_string
, tmp
);
1007 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1009 rse
.expr
= integer_zero_node
;
1012 type
= gfc_typenode_for_spec (&expr
->ts
);
1016 /* The result of logical ops is always boolean_type_node. */
1017 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1018 se
->expr
= convert (type
, tmp
);
1021 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1023 /* Add the post blocks. */
1024 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1025 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1030 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1034 if (sym
->attr
.dummy
)
1036 tmp
= gfc_get_symbol_decl (sym
);
1037 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1038 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1044 if (!sym
->backend_decl
)
1045 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1047 tmp
= sym
->backend_decl
;
1048 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1049 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
1054 /* Generate code for a procedure call. Note can return se->post != NULL.
1055 If se->direct_byref is set then se->expr contains the return parameter. */
1058 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1059 gfc_actual_arglist
* arg
)
1072 gfc_formal_arglist
*formal
;
1074 arglist
= NULL_TREE
;
1075 stringargs
= NULL_TREE
;
1081 if (!sym
->attr
.elemental
)
1083 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1084 if (se
->ss
->useflags
)
1086 gcc_assert (gfc_return_by_reference (sym
)
1087 && sym
->result
->attr
.dimension
);
1088 gcc_assert (se
->loop
!= NULL
);
1090 /* Access the previously obtained result. */
1091 gfc_conv_tmp_array_ref (se
);
1092 gfc_advance_se_ss_chain (se
);
1096 info
= &se
->ss
->data
.info
;
1101 byref
= gfc_return_by_reference (sym
);
1104 if (se
->direct_byref
)
1105 arglist
= gfc_chainon_list (arglist
, se
->expr
);
1106 else if (sym
->result
->attr
.dimension
)
1108 gcc_assert (se
->loop
&& se
->ss
);
1109 /* Set the type of the array. */
1110 tmp
= gfc_typenode_for_spec (&sym
->ts
);
1111 info
->dimen
= se
->loop
->dimen
;
1112 /* Allocate a temporary to store the result. */
1113 gfc_trans_allocate_temp_array (se
->loop
, info
, tmp
);
1115 /* Zero the first stride to indicate a temporary. */
1117 gfc_conv_descriptor_stride (info
->descriptor
, gfc_rank_cst
[0]);
1118 gfc_add_modify_expr (&se
->pre
, tmp
,
1119 convert (TREE_TYPE (tmp
), integer_zero_node
));
1120 /* Pass the temporary as the first argument. */
1121 tmp
= info
->descriptor
;
1122 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1123 arglist
= gfc_chainon_list (arglist
, tmp
);
1125 else if (sym
->ts
.type
== BT_CHARACTER
)
1127 gcc_assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
1128 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1129 len
= gfc_conv_mpz_to_tree
1130 (sym
->ts
.cl
->length
->value
.integer
, sym
->ts
.cl
->length
->ts
.kind
);
1131 sym
->ts
.cl
->backend_decl
= len
;
1132 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1133 type
= build_pointer_type (type
);
1135 var
= gfc_conv_string_tmp (se
, type
, len
);
1136 arglist
= gfc_chainon_list (arglist
, var
);
1137 arglist
= gfc_chainon_list (arglist
,
1138 convert (gfc_charlen_type_node
, len
));
1144 formal
= sym
->formal
;
1145 /* Evaluate the arguments. */
1146 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1148 if (arg
->expr
== NULL
)
1151 if (se
->ignore_optional
)
1153 /* Some intrinsics have already been resolved to the correct
1157 else if (arg
->label
)
1159 has_alternate_specifier
= 1;
1164 /* Pass a NULL pointer for an absent arg. */
1165 gfc_init_se (&parmse
, NULL
);
1166 parmse
.expr
= null_pointer_node
;
1167 if (arg
->missing_arg_type
== BT_CHARACTER
)
1170 gfc_chainon_list (stringargs
,
1171 convert (gfc_charlen_type_node
,
1172 integer_zero_node
));
1176 else if (se
->ss
&& se
->ss
->useflags
)
1178 /* An elemental function inside a scalarized loop. */
1179 gfc_init_se (&parmse
, se
);
1180 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1184 /* A scalar or transformational function. */
1185 gfc_init_se (&parmse
, NULL
);
1186 argss
= gfc_walk_expr (arg
->expr
);
1188 if (argss
== gfc_ss_terminator
)
1190 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1191 if (formal
&& formal
->sym
->attr
.pointer
1192 && arg
->expr
->expr_type
!= EXPR_NULL
)
1194 /* Scalar pointer dummy args require an extra level of
1195 indirection. The null pointer already contains
1196 this level of indirection. */
1197 parmse
.expr
= gfc_build_addr_expr (NULL
, parmse
.expr
);
1202 /* If the procedure requires an explicit interface, the
1203 actual argument is passed according to the
1204 corresponding formal argument. If the corresponding
1205 formal argument is a POINTER or assumed shape, we do
1206 not use g77's calling convention, and pass the
1207 address of the array descriptor instead. Otherwise we
1208 use g77's calling convention. */
1210 f
= (formal
!= NULL
)
1211 && !formal
->sym
->attr
.pointer
1212 && formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
;
1213 f
= f
|| !sym
->attr
.always_explicit
;
1214 gfc_conv_array_parameter (&parmse
, arg
->expr
, argss
, f
);
1218 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
1219 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
1221 /* Character strings are passed as two parameters, a length and a
1223 if (parmse
.string_length
!= NULL_TREE
)
1224 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
1226 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
1229 /* Add the hidden string length parameters to the arguments. */
1230 arglist
= chainon (arglist
, stringargs
);
1232 /* Generate the actual call. */
1233 gfc_conv_function_val (se
, sym
);
1234 /* If there are alternate return labels, function type should be
1236 if (has_alternate_specifier
)
1237 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
1239 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
1240 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
1241 arglist
, NULL_TREE
);
1243 /* If we have a pointer function, but we don't want a pointer, e.g.
1246 where f is pointer valued, we have to dereference the result. */
1247 if (!se
->want_pointer
&& !byref
1248 && (sym
->attr
.pointer
|| (sym
->result
&& sym
->result
->attr
.pointer
)))
1249 se
->expr
= gfc_build_indirect_ref (se
->expr
);
1251 /* A pure function may still have side-effects - it may modify its
1253 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1255 if (!sym
->attr
.pure
)
1256 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1261 /* Add the function call to the pre chain. There is no expression. */
1262 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
1263 se
->expr
= NULL_TREE
;
1265 if (!se
->direct_byref
)
1267 if (sym
->result
->attr
.dimension
)
1269 if (flag_bounds_check
)
1271 /* Check the data pointer hasn't been modified. This would
1272 happen in a function returning a pointer. */
1273 tmp
= gfc_conv_descriptor_data (info
->descriptor
);
1274 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, info
->data
);
1275 gfc_trans_runtime_check (tmp
, gfc_strconst_fault
, &se
->pre
);
1277 se
->expr
= info
->descriptor
;
1279 else if (sym
->ts
.type
== BT_CHARACTER
)
1282 se
->string_length
= len
;
1291 /* Generate code to copy a string. */
1294 gfc_trans_string_copy (stmtblock_t
* block
, tree dlen
, tree dest
,
1295 tree slen
, tree src
)
1300 tmp
= gfc_chainon_list (tmp
, dlen
);
1301 tmp
= gfc_chainon_list (tmp
, dest
);
1302 tmp
= gfc_chainon_list (tmp
, slen
);
1303 tmp
= gfc_chainon_list (tmp
, src
);
1304 tmp
= gfc_build_function_call (gfor_fndecl_copy_string
, tmp
);
1305 gfc_add_expr_to_block (block
, tmp
);
1309 /* Translate a statement function.
1310 The value of a statement function reference is obtained by evaluating the
1311 expression using the values of the actual arguments for the values of the
1312 corresponding dummy arguments. */
1315 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
1319 gfc_formal_arglist
*fargs
;
1320 gfc_actual_arglist
*args
;
1323 gfc_saved_var
*saved_vars
;
1329 sym
= expr
->symtree
->n
.sym
;
1330 args
= expr
->value
.function
.actual
;
1331 gfc_init_se (&lse
, NULL
);
1332 gfc_init_se (&rse
, NULL
);
1335 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
1337 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
1338 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
1340 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1342 /* Each dummy shall be specified, explicitly or implicitly, to be
1344 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
1347 /* Create a temporary to hold the value. */
1348 type
= gfc_typenode_for_spec (&fsym
->ts
);
1349 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
1351 if (fsym
->ts
.type
== BT_CHARACTER
)
1353 /* Copy string arguments. */
1356 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
1357 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1359 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1360 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
1363 gfc_conv_expr (&rse
, args
->expr
);
1364 gfc_conv_string_parameter (&rse
);
1365 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1366 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1368 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
1370 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1371 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1375 /* For everything else, just evaluate the expression. */
1376 gfc_conv_expr (&lse
, args
->expr
);
1378 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1379 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
1380 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1386 /* Use the temporary variables in place of the real ones. */
1387 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1388 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
1390 gfc_conv_expr (se
, sym
->value
);
1392 if (sym
->ts
.type
== BT_CHARACTER
)
1394 gfc_conv_const_charlen (sym
->ts
.cl
);
1396 /* Force the expression to the correct length. */
1397 if (!INTEGER_CST_P (se
->string_length
)
1398 || tree_int_cst_lt (se
->string_length
,
1399 sym
->ts
.cl
->backend_decl
))
1401 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1402 tmp
= gfc_create_var (type
, sym
->name
);
1403 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
1404 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
1405 se
->string_length
, se
->expr
);
1408 se
->string_length
= sym
->ts
.cl
->backend_decl
;
1411 /* Restore the original variables. */
1412 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1413 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
1414 gfc_free (saved_vars
);
1418 /* Translate a function expression. */
1421 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
1425 if (expr
->value
.function
.isym
)
1427 gfc_conv_intrinsic_function (se
, expr
);
1431 /* We distinguish statement functions from general functions to improve
1432 runtime performance. */
1433 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1435 gfc_conv_statement_function (se
, expr
);
1439 /* expr.value.function.esym is the resolved (specific) function symbol for
1440 most functions. However this isn't set for dummy procedures. */
1441 sym
= expr
->value
.function
.esym
;
1443 sym
= expr
->symtree
->n
.sym
;
1444 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1449 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
1451 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1452 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
1454 gfc_conv_tmp_array_ref (se
);
1455 gfc_advance_se_ss_chain (se
);
1459 /* Build a static initializer. EXPR is the expression for the initial value.
1460 The other parameters describe the variable of the component being
1461 initialized. EXPR may be null. */
1464 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
1465 bool array
, bool pointer
)
1469 if (!(expr
|| pointer
))
1474 /* Arrays need special handling. */
1476 return gfc_build_null_descriptor (type
);
1478 return gfc_conv_array_initializer (type
, expr
);
1481 return fold_convert (type
, null_pointer_node
);
1487 gfc_init_se (&se
, NULL
);
1488 gfc_conv_structure (&se
, expr
, 1);
1492 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
1495 gfc_init_se (&se
, NULL
);
1496 gfc_conv_constant (&se
, expr
);
1503 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
1515 gfc_start_block (&block
);
1517 /* Initialize the scalarizer. */
1518 gfc_init_loopinfo (&loop
);
1520 gfc_init_se (&lse
, NULL
);
1521 gfc_init_se (&rse
, NULL
);
1524 rss
= gfc_walk_expr (expr
);
1525 if (rss
== gfc_ss_terminator
)
1527 /* The rhs is scalar. Add a ss for the expression. */
1528 rss
= gfc_get_ss ();
1529 rss
->next
= gfc_ss_terminator
;
1530 rss
->type
= GFC_SS_SCALAR
;
1534 /* Create a SS for the destination. */
1535 lss
= gfc_get_ss ();
1536 lss
->type
= GFC_SS_COMPONENT
;
1538 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
1539 lss
->next
= gfc_ss_terminator
;
1540 lss
->data
.info
.dimen
= cm
->as
->rank
;
1541 lss
->data
.info
.descriptor
= dest
;
1542 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
1543 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
1544 for (n
= 0; n
< cm
->as
->rank
; n
++)
1546 lss
->data
.info
.dim
[n
] = n
;
1547 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
1548 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1550 mpz_init (lss
->shape
[n
]);
1551 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1552 cm
->as
->lower
[n
]->value
.integer
);
1553 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
1556 /* Associate the SS with the loop. */
1557 gfc_add_ss_to_loop (&loop
, lss
);
1558 gfc_add_ss_to_loop (&loop
, rss
);
1560 /* Calculate the bounds of the scalarization. */
1561 gfc_conv_ss_startstride (&loop
);
1563 /* Setup the scalarizing loops. */
1564 gfc_conv_loop_setup (&loop
);
1566 /* Setup the gfc_se structures. */
1567 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1568 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1571 gfc_mark_ss_chain_used (rss
, 1);
1573 gfc_mark_ss_chain_used (lss
, 1);
1575 /* Start the scalarized loop body. */
1576 gfc_start_scalarized_body (&loop
, &body
);
1578 gfc_conv_tmp_array_ref (&lse
);
1579 gfc_conv_expr (&rse
, expr
);
1581 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
.type
);
1582 gfc_add_expr_to_block (&body
, tmp
);
1584 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1586 /* Generate the copying loops. */
1587 gfc_trans_scalarizing_loops (&loop
, &body
);
1589 /* Wrap the whole thing up. */
1590 gfc_add_block_to_block (&block
, &loop
.pre
);
1591 gfc_add_block_to_block (&block
, &loop
.post
);
1593 for (n
= 0; n
< cm
->as
->rank
; n
++)
1594 mpz_clear (lss
->shape
[n
]);
1595 gfc_free (lss
->shape
);
1597 gfc_cleanup_loop (&loop
);
1599 return gfc_finish_block (&block
);
1602 /* Assign a single component of a derived type constructor. */
1605 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
1612 gfc_start_block (&block
);
1615 gfc_init_se (&se
, NULL
);
1616 /* Pointer component. */
1619 /* Array pointer. */
1620 if (expr
->expr_type
== EXPR_NULL
)
1622 dest
= gfc_conv_descriptor_data (dest
);
1623 tmp
= fold_convert (TREE_TYPE (se
.expr
),
1625 gfc_add_modify_expr (&block
, dest
, tmp
);
1629 rss
= gfc_walk_expr (expr
);
1630 se
.direct_byref
= 1;
1632 gfc_conv_expr_descriptor (&se
, expr
, rss
);
1633 gfc_add_block_to_block (&block
, &se
.pre
);
1634 gfc_add_block_to_block (&block
, &se
.post
);
1639 /* Scalar pointers. */
1640 se
.want_pointer
= 1;
1641 gfc_conv_expr (&se
, expr
);
1642 gfc_add_block_to_block (&block
, &se
.pre
);
1643 gfc_add_modify_expr (&block
, dest
,
1644 fold_convert (TREE_TYPE (dest
), se
.expr
));
1645 gfc_add_block_to_block (&block
, &se
.post
);
1648 else if (cm
->dimension
)
1650 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
1651 gfc_add_expr_to_block (&block
, tmp
);
1653 else if (expr
->ts
.type
== BT_DERIVED
)
1655 /* Nested derived type. */
1656 tmp
= gfc_trans_structure_assign (dest
, expr
);
1657 gfc_add_expr_to_block (&block
, tmp
);
1661 /* Scalar component. */
1664 gfc_init_se (&se
, NULL
);
1665 gfc_init_se (&lse
, NULL
);
1667 gfc_conv_expr (&se
, expr
);
1668 if (cm
->ts
.type
== BT_CHARACTER
)
1669 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
1671 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
.type
);
1672 gfc_add_expr_to_block (&block
, tmp
);
1674 return gfc_finish_block (&block
);
1677 /* Assign a derived type constructor to a variable. */
1680 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
1688 gfc_start_block (&block
);
1689 cm
= expr
->ts
.derived
->components
;
1690 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
1692 /* Skip absent members in default initializers. */
1696 field
= cm
->backend_decl
;
1697 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
1698 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
1699 gfc_add_expr_to_block (&block
, tmp
);
1701 return gfc_finish_block (&block
);
1704 /* Build an expression for a constructor. If init is nonzero then
1705 this is part of a static variable initializer. */
1708 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
1718 gcc_assert (se
->ss
== NULL
);
1719 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
1720 type
= gfc_typenode_for_spec (&expr
->ts
);
1724 /* Create a temporary variable and fill it in. */
1725 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
1726 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
1727 gfc_add_expr_to_block (&se
->pre
, tmp
);
1731 head
= build1 (CONSTRUCTOR
, type
, NULL_TREE
);
1734 cm
= expr
->ts
.derived
->components
;
1735 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
1737 /* Skip absent members in default initializers. */
1741 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
1742 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
1744 /* Build a TREE_CHAIN to hold it. */
1745 val
= tree_cons (cm
->backend_decl
, val
, NULL_TREE
);
1747 /* Add it to the list. */
1748 if (tail
== NULL_TREE
)
1749 TREE_OPERAND(head
, 0) = tail
= val
;
1752 TREE_CHAIN (tail
) = val
;
1760 /* Translate a substring expression. */
1763 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
1769 gcc_assert (ref
->type
== REF_SUBSTRING
);
1771 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
1772 expr
->value
.character
.string
);
1773 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
1774 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
1776 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
1780 /* Entry point for expression translation. */
1783 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
1785 if (se
->ss
&& se
->ss
->expr
== expr
1786 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
1788 /* Substitute a scalar expression evaluated outside the scalarization
1790 se
->expr
= se
->ss
->data
.scalar
.expr
;
1791 se
->string_length
= se
->ss
->string_length
;
1792 gfc_advance_se_ss_chain (se
);
1796 switch (expr
->expr_type
)
1799 gfc_conv_expr_op (se
, expr
);
1803 gfc_conv_function_expr (se
, expr
);
1807 gfc_conv_constant (se
, expr
);
1811 gfc_conv_variable (se
, expr
);
1815 se
->expr
= null_pointer_node
;
1818 case EXPR_SUBSTRING
:
1819 gfc_conv_substring_expr (se
, expr
);
1822 case EXPR_STRUCTURE
:
1823 gfc_conv_structure (se
, expr
, 0);
1827 gfc_conv_array_constructor_expr (se
, expr
);
1837 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
1839 gfc_conv_expr (se
, expr
);
1840 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1841 figure out a way of rewriting an lvalue so that it has no post chain. */
1842 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
|| !se
->post
.head
);
1846 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
1850 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1851 gfc_conv_expr (se
, expr
);
1854 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1855 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
1860 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
1862 gfc_conv_expr_val (se
, expr
);
1863 se
->expr
= convert (type
, se
->expr
);
1867 /* Converts an expression so that it can be passed by reference. Scalar
1871 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
1875 if (se
->ss
&& se
->ss
->expr
== expr
1876 && se
->ss
->type
== GFC_SS_REFERENCE
)
1878 se
->expr
= se
->ss
->data
.scalar
.expr
;
1879 se
->string_length
= se
->ss
->string_length
;
1880 gfc_advance_se_ss_chain (se
);
1884 if (expr
->ts
.type
== BT_CHARACTER
)
1886 gfc_conv_expr (se
, expr
);
1887 gfc_conv_string_parameter (se
);
1891 if (expr
->expr_type
== EXPR_VARIABLE
)
1893 se
->want_pointer
= 1;
1894 gfc_conv_expr (se
, expr
);
1897 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1898 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
1899 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1905 gfc_conv_expr (se
, expr
);
1907 /* Create a temporary var to hold the value. */
1908 if (TREE_CONSTANT (se
->expr
))
1910 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (se
->expr
));
1911 DECL_INITIAL (var
) = se
->expr
;
1916 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1917 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
1919 gfc_add_block_to_block (&se
->pre
, &se
->post
);
1921 /* Take the address of that value. */
1922 se
->expr
= gfc_build_addr_expr (NULL
, var
);
1927 gfc_trans_pointer_assign (gfc_code
* code
)
1929 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
1933 /* Generate code for a pointer assignment. */
1936 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
1944 gfc_start_block (&block
);
1946 gfc_init_se (&lse
, NULL
);
1948 lss
= gfc_walk_expr (expr1
);
1949 rss
= gfc_walk_expr (expr2
);
1950 if (lss
== gfc_ss_terminator
)
1952 /* Scalar pointers. */
1953 lse
.want_pointer
= 1;
1954 gfc_conv_expr (&lse
, expr1
);
1955 gcc_assert (rss
== gfc_ss_terminator
);
1956 gfc_init_se (&rse
, NULL
);
1957 rse
.want_pointer
= 1;
1958 gfc_conv_expr (&rse
, expr2
);
1959 gfc_add_block_to_block (&block
, &lse
.pre
);
1960 gfc_add_block_to_block (&block
, &rse
.pre
);
1961 gfc_add_modify_expr (&block
, lse
.expr
,
1962 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
1963 gfc_add_block_to_block (&block
, &rse
.post
);
1964 gfc_add_block_to_block (&block
, &lse
.post
);
1968 /* Array pointer. */
1969 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
1970 /* Implement Nullify. */
1971 if (expr2
->expr_type
== EXPR_NULL
)
1973 lse
.expr
= gfc_conv_descriptor_data (lse
.expr
);
1974 rse
.expr
= fold_convert (TREE_TYPE (lse
.expr
), null_pointer_node
);
1975 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
1979 lse
.direct_byref
= 1;
1980 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
1982 gfc_add_block_to_block (&block
, &lse
.pre
);
1983 gfc_add_block_to_block (&block
, &lse
.post
);
1985 return gfc_finish_block (&block
);
1989 /* Makes sure se is suitable for passing as a function string parameter. */
1990 /* TODO: Need to check all callers fo this function. It may be abused. */
1993 gfc_conv_string_parameter (gfc_se
* se
)
1997 if (TREE_CODE (se
->expr
) == STRING_CST
)
1999 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2003 type
= TREE_TYPE (se
->expr
);
2004 if (TYPE_STRING_FLAG (type
))
2006 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
2007 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2010 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
2011 gcc_assert (se
->string_length
2012 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
2016 /* Generate code for assignment of scalar variables. Includes character
2020 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, bt type
)
2024 gfc_init_block (&block
);
2026 if (type
== BT_CHARACTER
)
2028 gcc_assert (lse
->string_length
!= NULL_TREE
2029 && rse
->string_length
!= NULL_TREE
);
2031 gfc_conv_string_parameter (lse
);
2032 gfc_conv_string_parameter (rse
);
2034 gfc_add_block_to_block (&block
, &lse
->pre
);
2035 gfc_add_block_to_block (&block
, &rse
->pre
);
2037 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
2038 rse
->string_length
, rse
->expr
);
2042 gfc_add_block_to_block (&block
, &lse
->pre
);
2043 gfc_add_block_to_block (&block
, &rse
->pre
);
2045 gfc_add_modify_expr (&block
, lse
->expr
,
2046 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
2049 gfc_add_block_to_block (&block
, &lse
->post
);
2050 gfc_add_block_to_block (&block
, &rse
->post
);
2052 return gfc_finish_block (&block
);
2056 /* Try to translate array(:) = func (...), where func is a transformational
2057 array function, without using a temporary. Returns NULL is this isn't the
2061 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
2066 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2067 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
2070 /* Elemental functions don't need a temporary anyway. */
2071 if (expr2
->symtree
->n
.sym
->attr
.elemental
)
2074 /* Check for a dependency. */
2075 if (gfc_check_fncall_dependency (expr1
, expr2
))
2078 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2080 gcc_assert (expr2
->value
.function
.isym
2081 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
2082 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
2084 ss
= gfc_walk_expr (expr1
);
2085 gcc_assert (ss
!= gfc_ss_terminator
);
2086 gfc_init_se (&se
, NULL
);
2087 gfc_start_block (&se
.pre
);
2088 se
.want_pointer
= 1;
2090 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
2092 se
.direct_byref
= 1;
2093 se
.ss
= gfc_walk_expr (expr2
);
2094 gcc_assert (se
.ss
!= gfc_ss_terminator
);
2095 gfc_conv_function_expr (&se
, expr2
);
2096 gfc_add_block_to_block (&se
.pre
, &se
.post
);
2098 return gfc_finish_block (&se
.pre
);
2102 /* Translate an assignment. Most of the code is concerned with
2103 setting up the scalarizer. */
2106 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
2111 gfc_ss
*lss_section
;
2118 /* Special case a single function returning an array. */
2119 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2121 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2126 /* Assignment of the form lhs = rhs. */
2127 gfc_start_block (&block
);
2129 gfc_init_se (&lse
, NULL
);
2130 gfc_init_se (&rse
, NULL
);
2133 lss
= gfc_walk_expr (expr1
);
2135 if (lss
!= gfc_ss_terminator
)
2137 /* The assignment needs scalarization. */
2140 /* Find a non-scalar SS from the lhs. */
2141 while (lss_section
!= gfc_ss_terminator
2142 && lss_section
->type
!= GFC_SS_SECTION
)
2143 lss_section
= lss_section
->next
;
2145 gcc_assert (lss_section
!= gfc_ss_terminator
);
2147 /* Initialize the scalarizer. */
2148 gfc_init_loopinfo (&loop
);
2151 rss
= gfc_walk_expr (expr2
);
2152 if (rss
== gfc_ss_terminator
)
2154 /* The rhs is scalar. Add a ss for the expression. */
2155 rss
= gfc_get_ss ();
2156 rss
->next
= gfc_ss_terminator
;
2157 rss
->type
= GFC_SS_SCALAR
;
2160 /* Associate the SS with the loop. */
2161 gfc_add_ss_to_loop (&loop
, lss
);
2162 gfc_add_ss_to_loop (&loop
, rss
);
2164 /* Calculate the bounds of the scalarization. */
2165 gfc_conv_ss_startstride (&loop
);
2166 /* Resolve any data dependencies in the statement. */
2167 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2168 /* Setup the scalarizing loops. */
2169 gfc_conv_loop_setup (&loop
);
2171 /* Setup the gfc_se structures. */
2172 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2173 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2176 gfc_mark_ss_chain_used (rss
, 1);
2177 if (loop
.temp_ss
== NULL
)
2180 gfc_mark_ss_chain_used (lss
, 1);
2184 lse
.ss
= loop
.temp_ss
;
2185 gfc_mark_ss_chain_used (lss
, 3);
2186 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2189 /* Start the scalarized loop body. */
2190 gfc_start_scalarized_body (&loop
, &body
);
2193 gfc_init_block (&body
);
2195 /* Translate the expression. */
2196 gfc_conv_expr (&rse
, expr2
);
2198 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2200 gfc_conv_tmp_array_ref (&lse
);
2201 gfc_advance_se_ss_chain (&lse
);
2204 gfc_conv_expr (&lse
, expr1
);
2206 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2207 gfc_add_expr_to_block (&body
, tmp
);
2209 if (lss
== gfc_ss_terminator
)
2211 /* Use the scalar assignment as is. */
2212 gfc_add_block_to_block (&block
, &body
);
2216 gcc_assert (lse
.ss
== gfc_ss_terminator
2217 && rse
.ss
== gfc_ss_terminator
);
2219 if (loop
.temp_ss
!= NULL
)
2221 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2223 /* We need to copy the temporary to the actual lhs. */
2224 gfc_init_se (&lse
, NULL
);
2225 gfc_init_se (&rse
, NULL
);
2226 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2227 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2229 rse
.ss
= loop
.temp_ss
;
2232 gfc_conv_tmp_array_ref (&rse
);
2233 gfc_advance_se_ss_chain (&rse
);
2234 gfc_conv_expr (&lse
, expr1
);
2236 gcc_assert (lse
.ss
== gfc_ss_terminator
2237 && rse
.ss
== gfc_ss_terminator
);
2239 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2240 gfc_add_expr_to_block (&body
, tmp
);
2242 /* Generate the copying loops. */
2243 gfc_trans_scalarizing_loops (&loop
, &body
);
2245 /* Wrap the whole thing up. */
2246 gfc_add_block_to_block (&block
, &loop
.pre
);
2247 gfc_add_block_to_block (&block
, &loop
.post
);
2249 gfc_cleanup_loop (&loop
);
2252 return gfc_finish_block (&block
);
2256 gfc_trans_assign (gfc_code
* code
)
2258 return gfc_trans_assignment (code
->expr
, code
->expr2
);