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
);
360 /* Dereference the expression, where needed. Since characters
361 are entirely different from other types, they are treated
363 if (sym
->ts
.type
== BT_CHARACTER
)
365 /* Dereference character pointer dummy arguments
367 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
368 && ((sym
->attr
.dummy
)
369 || (sym
->attr
.function
370 || sym
->attr
.result
)))
371 se
->expr
= gfc_build_indirect_ref (se
->expr
);
375 /* Dereference non-charcter scalar dummy arguments. */
376 if ((sym
->attr
.dummy
) && (!sym
->attr
.dimension
))
377 se
->expr
= gfc_build_indirect_ref (se
->expr
);
379 /* Dereference scalar hidden result. */
380 if ((gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
)
381 && (sym
->attr
.function
|| sym
->attr
.result
)
382 && (!sym
->attr
.dimension
))
383 se
->expr
= gfc_build_indirect_ref (se
->expr
);
385 /* Dereference non-character pointer variables.
386 These must be dummys or results or scalars. */
387 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
388 && ((sym
->attr
.dummy
)
389 || (sym
->attr
.function
|| sym
->attr
.result
)
390 || (!sym
->attr
.dimension
)))
391 se
->expr
= gfc_build_indirect_ref (se
->expr
);
397 /* For character variables, also get the length. */
398 if (sym
->ts
.type
== BT_CHARACTER
)
400 se
->string_length
= sym
->ts
.cl
->backend_decl
;
401 gcc_assert (se
->string_length
);
409 /* Return the descriptor if that's what we want and this is an array
410 section reference. */
411 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
413 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
414 /* Return the descriptor for array pointers and allocations. */
416 && ref
->next
== NULL
&& (se
->descriptor_only
))
419 gfc_conv_array_ref (se
, &ref
->u
.ar
);
420 /* Return a pointer to an element. */
424 gfc_conv_component_ref (se
, ref
);
428 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
437 /* Pointer assignment, allocation or pass by reference. Arrays are handled
439 if (se
->want_pointer
)
441 if (expr
->ts
.type
== BT_CHARACTER
)
442 gfc_conv_string_parameter (se
);
444 se
->expr
= gfc_build_addr_expr (NULL
, se
->expr
);
447 gfc_advance_se_ss_chain (se
);
451 /* Unary ops are easy... Or they would be if ! was a valid op. */
454 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
459 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
460 /* Initialize the operand. */
461 gfc_init_se (&operand
, se
);
462 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
463 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
465 type
= gfc_typenode_for_spec (&expr
->ts
);
467 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
468 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
469 All other unary operators have an equivalent GIMPLE unary operator. */
470 if (code
== TRUTH_NOT_EXPR
)
471 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
472 convert (type
, integer_zero_node
));
474 se
->expr
= build1 (code
, type
, operand
.expr
);
478 /* Expand power operator to optimal multiplications when a value is raised
479 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
480 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
481 Programming", 3rd Edition, 1998. */
483 /* This code is mostly duplicated from expand_powi in the backend.
484 We establish the "optimal power tree" lookup table with the defined size.
485 The items in the table are the exponents used to calculate the index
486 exponents. Any integer n less than the value can get an "addition chain",
487 with the first node being one. */
488 #define POWI_TABLE_SIZE 256
490 /* The table is from builtins.c. */
491 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
493 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
494 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
495 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
496 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
497 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
498 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
499 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
500 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
501 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
502 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
503 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
504 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
505 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
506 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
507 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
508 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
509 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
510 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
511 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
512 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
513 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
514 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
515 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
516 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
517 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
518 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
519 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
520 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
521 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
522 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
523 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
524 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
527 /* If n is larger than lookup table's max index, we use the "window
529 #define POWI_WINDOW_SIZE 3
531 /* Recursive function to expand the power operator. The temporary
532 values are put in tmpvar. The function returns tmpvar[1] ** n. */
534 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
541 if (n
< POWI_TABLE_SIZE
)
546 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
547 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
551 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
552 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
553 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
557 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
561 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
562 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
564 if (n
< POWI_TABLE_SIZE
)
571 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
572 return 1. Else return 0 and a call to runtime library functions
573 will have to be built. */
575 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
580 tree vartmp
[POWI_TABLE_SIZE
];
584 type
= TREE_TYPE (lhs
);
585 n
= abs (TREE_INT_CST_LOW (rhs
));
586 sgn
= tree_int_cst_sgn (rhs
);
588 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
589 && (n
> 2 || n
< -1))
595 se
->expr
= gfc_build_const (type
, integer_one_node
);
598 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
599 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
601 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
602 fold_convert (TREE_TYPE (lhs
), integer_minus_one_node
));
603 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
604 convert (TREE_TYPE (lhs
), integer_one_node
));
607 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
610 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
611 se
->expr
= build3 (COND_EXPR
, type
, tmp
,
612 convert (type
, integer_one_node
),
613 convert (type
, integer_zero_node
));
617 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
618 tmp
= build3 (COND_EXPR
, type
, tmp
,
619 convert (type
, integer_minus_one_node
),
620 convert (type
, integer_zero_node
));
621 se
->expr
= build3 (COND_EXPR
, type
, cond
,
622 convert (type
, integer_one_node
),
627 memset (vartmp
, 0, sizeof (vartmp
));
631 tmp
= gfc_build_const (type
, integer_one_node
);
632 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
635 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
641 /* Power op (**). Constant integer exponent has special handling. */
644 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
646 tree gfc_int4_type_node
;
654 gfc_init_se (&lse
, se
);
655 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
656 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
658 gfc_init_se (&rse
, se
);
659 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
660 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
662 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
663 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
664 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
667 gfc_int4_type_node
= gfc_get_int_type (4);
669 kind
= expr
->value
.op
.op1
->ts
.kind
;
670 switch (expr
->value
.op
.op2
->ts
.type
)
673 ikind
= expr
->value
.op
.op2
->ts
.kind
;
678 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
696 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
697 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
714 switch (expr
->value
.op
.op1
->ts
.type
)
717 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
721 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
725 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
737 fndecl
= built_in_decls
[BUILT_IN_POWF
];
740 fndecl
= built_in_decls
[BUILT_IN_POW
];
751 fndecl
= gfor_fndecl_math_cpowf
;
754 fndecl
= gfor_fndecl_math_cpow
;
766 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
767 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
768 se
->expr
= fold (gfc_build_function_call (fndecl
, tmp
));
772 /* Generate code to allocate a string temporary. */
775 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
781 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
783 if (gfc_can_put_var_on_stack (len
))
785 /* Create a temporary variable to hold the result. */
786 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
787 convert (gfc_charlen_type_node
, integer_one_node
));
788 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
789 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
790 var
= gfc_create_var (tmp
, "str");
791 var
= gfc_build_addr_expr (type
, var
);
795 /* Allocate a temporary to hold the result. */
796 var
= gfc_create_var (type
, "pstr");
797 args
= gfc_chainon_list (NULL_TREE
, len
);
798 tmp
= gfc_build_function_call (gfor_fndecl_internal_malloc
, args
);
799 tmp
= convert (type
, tmp
);
800 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
802 /* Free the temporary afterwards. */
803 tmp
= convert (pvoid_type_node
, var
);
804 args
= gfc_chainon_list (NULL_TREE
, tmp
);
805 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
806 gfc_add_expr_to_block (&se
->post
, tmp
);
813 /* Handle a string concatenation operation. A temporary will be allocated to
817 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
827 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
828 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
830 gfc_init_se (&lse
, se
);
831 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
832 gfc_conv_string_parameter (&lse
);
833 gfc_init_se (&rse
, se
);
834 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
835 gfc_conv_string_parameter (&rse
);
837 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
838 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
840 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
841 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
842 if (len
== NULL_TREE
)
844 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
845 lse
.string_length
, rse
.string_length
);
848 type
= build_pointer_type (type
);
850 var
= gfc_conv_string_tmp (se
, type
, len
);
852 /* Do the actual concatenation. */
854 args
= gfc_chainon_list (args
, len
);
855 args
= gfc_chainon_list (args
, var
);
856 args
= gfc_chainon_list (args
, lse
.string_length
);
857 args
= gfc_chainon_list (args
, lse
.expr
);
858 args
= gfc_chainon_list (args
, rse
.string_length
);
859 args
= gfc_chainon_list (args
, rse
.expr
);
860 tmp
= gfc_build_function_call (gfor_fndecl_concat_string
, args
);
861 gfc_add_expr_to_block (&se
->pre
, tmp
);
863 /* Add the cleanup for the operands. */
864 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
865 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
868 se
->string_length
= len
;
872 /* Translates an op expression. Common (binary) cases are handled by this
873 function, others are passed on. Recursion is used in either case.
874 We use the fact that (op1.ts == op2.ts) (except for the power
876 Operators need no special handling for scalarized expressions as long as
877 they call gfc_conv_simple_val to get their operands.
878 Character strings get special handling. */
881 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
893 switch (expr
->value
.op
.operator)
895 case INTRINSIC_UPLUS
:
896 gfc_conv_expr (se
, expr
->value
.op
.op1
);
899 case INTRINSIC_UMINUS
:
900 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
904 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
911 case INTRINSIC_MINUS
:
915 case INTRINSIC_TIMES
:
919 case INTRINSIC_DIVIDE
:
920 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
921 an integer, we must round towards zero, so we use a
923 if (expr
->ts
.type
== BT_INTEGER
)
924 code
= TRUNC_DIV_EXPR
;
929 case INTRINSIC_POWER
:
930 gfc_conv_power_op (se
, expr
);
933 case INTRINSIC_CONCAT
:
934 gfc_conv_concat_op (se
, expr
);
938 code
= TRUTH_ANDIF_EXPR
;
943 code
= TRUTH_ORIF_EXPR
;
947 /* EQV and NEQV only work on logicals, but since we represent them
948 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
988 case INTRINSIC_ASSIGN
:
989 /* These should be converted into function calls by the frontend. */
993 fatal_error ("Unknown intrinsic op");
997 /* The only exception to this is **, which is handled separately anyway. */
998 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1000 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1004 gfc_init_se (&lse
, se
);
1005 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1006 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1009 gfc_init_se (&rse
, se
);
1010 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1011 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1013 /* For string comparisons we generate a library call, and compare the return
1017 gfc_conv_string_parameter (&lse
);
1018 gfc_conv_string_parameter (&rse
);
1020 tmp
= gfc_chainon_list (tmp
, lse
.string_length
);
1021 tmp
= gfc_chainon_list (tmp
, lse
.expr
);
1022 tmp
= gfc_chainon_list (tmp
, rse
.string_length
);
1023 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
1025 /* Build a call for the comparison. */
1026 lse
.expr
= gfc_build_function_call (gfor_fndecl_compare_string
, tmp
);
1027 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1029 rse
.expr
= integer_zero_node
;
1032 type
= gfc_typenode_for_spec (&expr
->ts
);
1036 /* The result of logical ops is always boolean_type_node. */
1037 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1038 se
->expr
= convert (type
, tmp
);
1041 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1043 /* Add the post blocks. */
1044 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1045 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1050 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1054 if (sym
->attr
.dummy
)
1056 tmp
= gfc_get_symbol_decl (sym
);
1057 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1058 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1064 if (!sym
->backend_decl
)
1065 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1067 tmp
= sym
->backend_decl
;
1068 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1069 se
->expr
= gfc_build_addr_expr (NULL
, tmp
);
1074 /* Generate code for a procedure call. Note can return se->post != NULL.
1075 If se->direct_byref is set then se->expr contains the return parameter. */
1078 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1079 gfc_actual_arglist
* arg
)
1092 gfc_formal_arglist
*formal
;
1094 arglist
= NULL_TREE
;
1095 stringargs
= NULL_TREE
;
1099 /* Obtain the string length now because it is needed often below. */
1100 if (sym
->ts
.type
== BT_CHARACTER
)
1102 gcc_assert (sym
->ts
.cl
&& sym
->ts
.cl
->length
1103 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1104 len
= gfc_conv_mpz_to_tree
1105 (sym
->ts
.cl
->length
->value
.integer
, sym
->ts
.cl
->length
->ts
.kind
);
1110 if (!sym
->attr
.elemental
)
1112 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1113 if (se
->ss
->useflags
)
1115 gcc_assert (gfc_return_by_reference (sym
)
1116 && sym
->result
->attr
.dimension
);
1117 gcc_assert (se
->loop
!= NULL
);
1119 /* Access the previously obtained result. */
1120 gfc_conv_tmp_array_ref (se
);
1121 gfc_advance_se_ss_chain (se
);
1123 /* Bundle in the string length. */
1124 se
->string_length
=len
;
1128 info
= &se
->ss
->data
.info
;
1133 byref
= gfc_return_by_reference (sym
);
1136 if (se
->direct_byref
)
1138 arglist
= gfc_chainon_list (arglist
, se
->expr
);
1140 /* Add string length to argument list. */
1141 if (sym
->ts
.type
== BT_CHARACTER
)
1143 sym
->ts
.cl
->backend_decl
= len
;
1144 arglist
= gfc_chainon_list (arglist
,
1145 convert (gfc_charlen_type_node
, len
));
1148 else if (sym
->result
->attr
.dimension
)
1150 gcc_assert (se
->loop
&& se
->ss
);
1152 /* Set the type of the array. */
1153 tmp
= gfc_typenode_for_spec (&sym
->ts
);
1154 info
->dimen
= se
->loop
->dimen
;
1156 /* Allocate a temporary to store the result. */
1157 gfc_trans_allocate_temp_array (se
->loop
, info
, tmp
);
1159 /* Zero the first stride to indicate a temporary. */
1161 gfc_conv_descriptor_stride (info
->descriptor
, gfc_rank_cst
[0]);
1162 gfc_add_modify_expr (&se
->pre
, tmp
,
1163 convert (TREE_TYPE (tmp
), integer_zero_node
));
1165 /* Pass the temporary as the first argument. */
1166 tmp
= info
->descriptor
;
1167 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1168 arglist
= gfc_chainon_list (arglist
, tmp
);
1170 /* Add string length to argument list. */
1171 if (sym
->ts
.type
== BT_CHARACTER
)
1173 sym
->ts
.cl
->backend_decl
= len
;
1174 arglist
= gfc_chainon_list (arglist
,
1175 convert (gfc_charlen_type_node
, len
));
1179 else if (sym
->ts
.type
== BT_CHARACTER
)
1182 /* Pass the string length. */
1183 sym
->ts
.cl
->backend_decl
= len
;
1184 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1185 type
= build_pointer_type (type
);
1187 /* Return an address to a char[4]* temporary for character pointers. */
1188 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1190 /* Build char[4] * pstr. */
1191 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
1192 convert (gfc_charlen_type_node
, integer_one_node
));
1193 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1194 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
1195 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
1197 /* Provide an address expression for the function arguments. */
1198 var
= gfc_build_addr_expr (NULL
, var
);
1202 var
= gfc_conv_string_tmp (se
, type
, len
);
1204 arglist
= gfc_chainon_list (arglist
, var
);
1205 arglist
= gfc_chainon_list (arglist
,
1206 convert (gfc_charlen_type_node
, len
));
1210 gcc_assert (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
);
1212 type
= gfc_get_complex_type (sym
->ts
.kind
);
1213 var
= gfc_build_addr_expr (NULL
, gfc_create_var (type
, "cmplx"));
1214 arglist
= gfc_chainon_list (arglist
, var
);
1218 formal
= sym
->formal
;
1219 /* Evaluate the arguments. */
1220 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1222 if (arg
->expr
== NULL
)
1225 if (se
->ignore_optional
)
1227 /* Some intrinsics have already been resolved to the correct
1231 else if (arg
->label
)
1233 has_alternate_specifier
= 1;
1238 /* Pass a NULL pointer for an absent arg. */
1239 gfc_init_se (&parmse
, NULL
);
1240 parmse
.expr
= null_pointer_node
;
1241 if (arg
->missing_arg_type
== BT_CHARACTER
)
1244 gfc_chainon_list (stringargs
,
1245 convert (gfc_charlen_type_node
,
1246 integer_zero_node
));
1250 else if (se
->ss
&& se
->ss
->useflags
)
1252 /* An elemental function inside a scalarized loop. */
1253 gfc_init_se (&parmse
, se
);
1254 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1258 /* A scalar or transformational function. */
1259 gfc_init_se (&parmse
, NULL
);
1260 argss
= gfc_walk_expr (arg
->expr
);
1262 if (argss
== gfc_ss_terminator
)
1264 gfc_conv_expr_reference (&parmse
, arg
->expr
);
1265 if (formal
&& formal
->sym
->attr
.pointer
1266 && arg
->expr
->expr_type
!= EXPR_NULL
)
1268 /* Scalar pointer dummy args require an extra level of
1269 indirection. The null pointer already contains
1270 this level of indirection. */
1271 parmse
.expr
= gfc_build_addr_expr (NULL
, parmse
.expr
);
1276 /* If the procedure requires an explicit interface, the
1277 actual argument is passed according to the
1278 corresponding formal argument. If the corresponding
1279 formal argument is a POINTER or assumed shape, we do
1280 not use g77's calling convention, and pass the
1281 address of the array descriptor instead. Otherwise we
1282 use g77's calling convention. */
1284 f
= (formal
!= NULL
)
1285 && !formal
->sym
->attr
.pointer
1286 && formal
->sym
->as
->type
!= AS_ASSUMED_SHAPE
;
1287 f
= f
|| !sym
->attr
.always_explicit
;
1288 gfc_conv_array_parameter (&parmse
, arg
->expr
, argss
, f
);
1292 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
1293 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
1295 /* Character strings are passed as two parameters, a length and a
1297 if (parmse
.string_length
!= NULL_TREE
)
1298 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
1300 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
1303 /* Add the hidden string length parameters to the arguments. */
1304 arglist
= chainon (arglist
, stringargs
);
1306 /* Generate the actual call. */
1307 gfc_conv_function_val (se
, sym
);
1308 /* If there are alternate return labels, function type should be
1310 if (has_alternate_specifier
)
1311 TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) = integer_type_node
;
1313 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
1314 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
1315 arglist
, NULL_TREE
);
1320 /* If we have a pointer function, but we don't want a pointer, e.g.
1323 where f is pointer valued, we have to dereference the result. */
1324 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
1325 se
->expr
= gfc_build_indirect_ref (se
->expr
);
1327 /* f2c calling conventions require a scalar default real function to
1328 return a double precision result. Convert this back to default
1329 real. We only care about the cases that can happen in Fortran 77.
1331 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
1332 && sym
->ts
.kind
== gfc_default_real_kind
1333 && !sym
->attr
.always_explicit
)
1334 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
1336 /* A pure function may still have side-effects - it may modify its
1338 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1340 if (!sym
->attr
.pure
)
1341 TREE_SIDE_EFFECTS (se
->expr
) = 1;
1346 /* Add the function call to the pre chain. There is no expression. */
1347 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
1348 se
->expr
= NULL_TREE
;
1350 if (!se
->direct_byref
)
1352 if (sym
->attr
.dimension
)
1354 if (flag_bounds_check
)
1356 /* Check the data pointer hasn't been modified. This would
1357 happen in a function returning a pointer. */
1358 tmp
= gfc_conv_descriptor_data (info
->descriptor
);
1359 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, info
->data
);
1360 gfc_trans_runtime_check (tmp
, gfc_strconst_fault
, &se
->pre
);
1362 se
->expr
= info
->descriptor
;
1363 /* Bundle in the string length. */
1364 se
->string_length
= len
;
1366 else if (sym
->ts
.type
== BT_CHARACTER
)
1368 /* Dereference for character pointer results. */
1369 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1370 se
->expr
= gfc_build_indirect_ref (var
);
1374 se
->string_length
= len
;
1378 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
1379 se
->expr
= gfc_build_indirect_ref (var
);
1386 /* Generate code to copy a string. */
1389 gfc_trans_string_copy (stmtblock_t
* block
, tree dlen
, tree dest
,
1390 tree slen
, tree src
)
1395 tmp
= gfc_chainon_list (tmp
, dlen
);
1396 tmp
= gfc_chainon_list (tmp
, dest
);
1397 tmp
= gfc_chainon_list (tmp
, slen
);
1398 tmp
= gfc_chainon_list (tmp
, src
);
1399 tmp
= gfc_build_function_call (gfor_fndecl_copy_string
, tmp
);
1400 gfc_add_expr_to_block (block
, tmp
);
1404 /* Translate a statement function.
1405 The value of a statement function reference is obtained by evaluating the
1406 expression using the values of the actual arguments for the values of the
1407 corresponding dummy arguments. */
1410 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
1414 gfc_formal_arglist
*fargs
;
1415 gfc_actual_arglist
*args
;
1418 gfc_saved_var
*saved_vars
;
1424 sym
= expr
->symtree
->n
.sym
;
1425 args
= expr
->value
.function
.actual
;
1426 gfc_init_se (&lse
, NULL
);
1427 gfc_init_se (&rse
, NULL
);
1430 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
1432 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
1433 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
1435 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1437 /* Each dummy shall be specified, explicitly or implicitly, to be
1439 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
1442 /* Create a temporary to hold the value. */
1443 type
= gfc_typenode_for_spec (&fsym
->ts
);
1444 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
1446 if (fsym
->ts
.type
== BT_CHARACTER
)
1448 /* Copy string arguments. */
1451 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
1452 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
1454 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
1455 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
1458 gfc_conv_expr (&rse
, args
->expr
);
1459 gfc_conv_string_parameter (&rse
);
1460 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1461 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1463 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
1465 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1466 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
1470 /* For everything else, just evaluate the expression. */
1471 gfc_conv_expr (&lse
, args
->expr
);
1473 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1474 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
1475 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
1481 /* Use the temporary variables in place of the real ones. */
1482 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1483 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
1485 gfc_conv_expr (se
, sym
->value
);
1487 if (sym
->ts
.type
== BT_CHARACTER
)
1489 gfc_conv_const_charlen (sym
->ts
.cl
);
1491 /* Force the expression to the correct length. */
1492 if (!INTEGER_CST_P (se
->string_length
)
1493 || tree_int_cst_lt (se
->string_length
,
1494 sym
->ts
.cl
->backend_decl
))
1496 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
1497 tmp
= gfc_create_var (type
, sym
->name
);
1498 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
1499 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
1500 se
->string_length
, se
->expr
);
1503 se
->string_length
= sym
->ts
.cl
->backend_decl
;
1506 /* Restore the original variables. */
1507 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
1508 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
1509 gfc_free (saved_vars
);
1513 /* Translate a function expression. */
1516 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
1520 if (expr
->value
.function
.isym
)
1522 gfc_conv_intrinsic_function (se
, expr
);
1526 /* We distinguish statement functions from general functions to improve
1527 runtime performance. */
1528 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1530 gfc_conv_statement_function (se
, expr
);
1534 /* expr.value.function.esym is the resolved (specific) function symbol for
1535 most functions. However this isn't set for dummy procedures. */
1536 sym
= expr
->value
.function
.esym
;
1538 sym
= expr
->symtree
->n
.sym
;
1539 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
1544 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
1546 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
1547 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
1549 gfc_conv_tmp_array_ref (se
);
1550 gfc_advance_se_ss_chain (se
);
1554 /* Build a static initializer. EXPR is the expression for the initial value.
1555 The other parameters describe the variable of the component being
1556 initialized. EXPR may be null. */
1559 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
1560 bool array
, bool pointer
)
1564 if (!(expr
|| pointer
))
1569 /* Arrays need special handling. */
1571 return gfc_build_null_descriptor (type
);
1573 return gfc_conv_array_initializer (type
, expr
);
1576 return fold_convert (type
, null_pointer_node
);
1582 gfc_init_se (&se
, NULL
);
1583 gfc_conv_structure (&se
, expr
, 1);
1587 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
1590 gfc_init_se (&se
, NULL
);
1591 gfc_conv_constant (&se
, expr
);
1598 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
1610 gfc_start_block (&block
);
1612 /* Initialize the scalarizer. */
1613 gfc_init_loopinfo (&loop
);
1615 gfc_init_se (&lse
, NULL
);
1616 gfc_init_se (&rse
, NULL
);
1619 rss
= gfc_walk_expr (expr
);
1620 if (rss
== gfc_ss_terminator
)
1622 /* The rhs is scalar. Add a ss for the expression. */
1623 rss
= gfc_get_ss ();
1624 rss
->next
= gfc_ss_terminator
;
1625 rss
->type
= GFC_SS_SCALAR
;
1629 /* Create a SS for the destination. */
1630 lss
= gfc_get_ss ();
1631 lss
->type
= GFC_SS_COMPONENT
;
1633 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
1634 lss
->next
= gfc_ss_terminator
;
1635 lss
->data
.info
.dimen
= cm
->as
->rank
;
1636 lss
->data
.info
.descriptor
= dest
;
1637 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
1638 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
1639 for (n
= 0; n
< cm
->as
->rank
; n
++)
1641 lss
->data
.info
.dim
[n
] = n
;
1642 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
1643 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
1645 mpz_init (lss
->shape
[n
]);
1646 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
1647 cm
->as
->lower
[n
]->value
.integer
);
1648 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
1651 /* Associate the SS with the loop. */
1652 gfc_add_ss_to_loop (&loop
, lss
);
1653 gfc_add_ss_to_loop (&loop
, rss
);
1655 /* Calculate the bounds of the scalarization. */
1656 gfc_conv_ss_startstride (&loop
);
1658 /* Setup the scalarizing loops. */
1659 gfc_conv_loop_setup (&loop
);
1661 /* Setup the gfc_se structures. */
1662 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1663 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1666 gfc_mark_ss_chain_used (rss
, 1);
1668 gfc_mark_ss_chain_used (lss
, 1);
1670 /* Start the scalarized loop body. */
1671 gfc_start_scalarized_body (&loop
, &body
);
1673 gfc_conv_tmp_array_ref (&lse
);
1674 gfc_conv_expr (&rse
, expr
);
1676 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
.type
);
1677 gfc_add_expr_to_block (&body
, tmp
);
1679 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1681 /* Generate the copying loops. */
1682 gfc_trans_scalarizing_loops (&loop
, &body
);
1684 /* Wrap the whole thing up. */
1685 gfc_add_block_to_block (&block
, &loop
.pre
);
1686 gfc_add_block_to_block (&block
, &loop
.post
);
1688 for (n
= 0; n
< cm
->as
->rank
; n
++)
1689 mpz_clear (lss
->shape
[n
]);
1690 gfc_free (lss
->shape
);
1692 gfc_cleanup_loop (&loop
);
1694 return gfc_finish_block (&block
);
1697 /* Assign a single component of a derived type constructor. */
1700 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
1707 gfc_start_block (&block
);
1710 gfc_init_se (&se
, NULL
);
1711 /* Pointer component. */
1714 /* Array pointer. */
1715 if (expr
->expr_type
== EXPR_NULL
)
1717 dest
= gfc_conv_descriptor_data (dest
);
1718 tmp
= fold_convert (TREE_TYPE (se
.expr
),
1720 gfc_add_modify_expr (&block
, dest
, tmp
);
1724 rss
= gfc_walk_expr (expr
);
1725 se
.direct_byref
= 1;
1727 gfc_conv_expr_descriptor (&se
, expr
, rss
);
1728 gfc_add_block_to_block (&block
, &se
.pre
);
1729 gfc_add_block_to_block (&block
, &se
.post
);
1734 /* Scalar pointers. */
1735 se
.want_pointer
= 1;
1736 gfc_conv_expr (&se
, expr
);
1737 gfc_add_block_to_block (&block
, &se
.pre
);
1738 gfc_add_modify_expr (&block
, dest
,
1739 fold_convert (TREE_TYPE (dest
), se
.expr
));
1740 gfc_add_block_to_block (&block
, &se
.post
);
1743 else if (cm
->dimension
)
1745 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
1746 gfc_add_expr_to_block (&block
, tmp
);
1748 else if (expr
->ts
.type
== BT_DERIVED
)
1750 /* Nested derived type. */
1751 tmp
= gfc_trans_structure_assign (dest
, expr
);
1752 gfc_add_expr_to_block (&block
, tmp
);
1756 /* Scalar component. */
1759 gfc_init_se (&se
, NULL
);
1760 gfc_init_se (&lse
, NULL
);
1762 gfc_conv_expr (&se
, expr
);
1763 if (cm
->ts
.type
== BT_CHARACTER
)
1764 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
1766 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
.type
);
1767 gfc_add_expr_to_block (&block
, tmp
);
1769 return gfc_finish_block (&block
);
1772 /* Assign a derived type constructor to a variable. */
1775 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
1783 gfc_start_block (&block
);
1784 cm
= expr
->ts
.derived
->components
;
1785 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
1787 /* Skip absent members in default initializers. */
1791 field
= cm
->backend_decl
;
1792 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
1793 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
1794 gfc_add_expr_to_block (&block
, tmp
);
1796 return gfc_finish_block (&block
);
1799 /* Build an expression for a constructor. If init is nonzero then
1800 this is part of a static variable initializer. */
1803 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
1813 gcc_assert (se
->ss
== NULL
);
1814 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
1815 type
= gfc_typenode_for_spec (&expr
->ts
);
1819 /* Create a temporary variable and fill it in. */
1820 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
1821 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
1822 gfc_add_expr_to_block (&se
->pre
, tmp
);
1826 head
= build1 (CONSTRUCTOR
, type
, NULL_TREE
);
1829 cm
= expr
->ts
.derived
->components
;
1830 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
1832 /* Skip absent members in default initializers. */
1836 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
1837 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
1839 /* Build a TREE_CHAIN to hold it. */
1840 val
= tree_cons (cm
->backend_decl
, val
, NULL_TREE
);
1842 /* Add it to the list. */
1843 if (tail
== NULL_TREE
)
1844 TREE_OPERAND(head
, 0) = tail
= val
;
1847 TREE_CHAIN (tail
) = val
;
1855 /* Translate a substring expression. */
1858 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
1864 gcc_assert (ref
->type
== REF_SUBSTRING
);
1866 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
1867 expr
->value
.character
.string
);
1868 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
1869 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
1871 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
1875 /* Entry point for expression translation. */
1878 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
1880 if (se
->ss
&& se
->ss
->expr
== expr
1881 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
1883 /* Substitute a scalar expression evaluated outside the scalarization
1885 se
->expr
= se
->ss
->data
.scalar
.expr
;
1886 se
->string_length
= se
->ss
->string_length
;
1887 gfc_advance_se_ss_chain (se
);
1891 switch (expr
->expr_type
)
1894 gfc_conv_expr_op (se
, expr
);
1898 gfc_conv_function_expr (se
, expr
);
1902 gfc_conv_constant (se
, expr
);
1906 gfc_conv_variable (se
, expr
);
1910 se
->expr
= null_pointer_node
;
1913 case EXPR_SUBSTRING
:
1914 gfc_conv_substring_expr (se
, expr
);
1917 case EXPR_STRUCTURE
:
1918 gfc_conv_structure (se
, expr
, 0);
1922 gfc_conv_array_constructor_expr (se
, expr
);
1932 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
1934 gfc_conv_expr (se
, expr
);
1935 /* AFAICS all numeric lvalues have empty post chains. If not we need to
1936 figure out a way of rewriting an lvalue so that it has no post chain. */
1937 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
|| !se
->post
.head
);
1941 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
1945 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
1946 gfc_conv_expr (se
, expr
);
1949 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1950 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
1955 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
1957 gfc_conv_expr_val (se
, expr
);
1958 se
->expr
= convert (type
, se
->expr
);
1962 /* Converts an expression so that it can be passed by reference. Scalar
1966 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
1970 if (se
->ss
&& se
->ss
->expr
== expr
1971 && se
->ss
->type
== GFC_SS_REFERENCE
)
1973 se
->expr
= se
->ss
->data
.scalar
.expr
;
1974 se
->string_length
= se
->ss
->string_length
;
1975 gfc_advance_se_ss_chain (se
);
1979 if (expr
->ts
.type
== BT_CHARACTER
)
1981 gfc_conv_expr (se
, expr
);
1982 gfc_conv_string_parameter (se
);
1986 if (expr
->expr_type
== EXPR_VARIABLE
)
1988 se
->want_pointer
= 1;
1989 gfc_conv_expr (se
, expr
);
1992 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
1993 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
1994 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2000 gfc_conv_expr (se
, expr
);
2002 /* Create a temporary var to hold the value. */
2003 if (TREE_CONSTANT (se
->expr
))
2005 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (se
->expr
));
2006 DECL_INITIAL (var
) = se
->expr
;
2011 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
2012 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
2014 gfc_add_block_to_block (&se
->pre
, &se
->post
);
2016 /* Take the address of that value. */
2017 se
->expr
= gfc_build_addr_expr (NULL
, var
);
2022 gfc_trans_pointer_assign (gfc_code
* code
)
2024 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
2028 /* Generate code for a pointer assignment. */
2031 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
2039 gfc_start_block (&block
);
2041 gfc_init_se (&lse
, NULL
);
2043 lss
= gfc_walk_expr (expr1
);
2044 rss
= gfc_walk_expr (expr2
);
2045 if (lss
== gfc_ss_terminator
)
2047 /* Scalar pointers. */
2048 lse
.want_pointer
= 1;
2049 gfc_conv_expr (&lse
, expr1
);
2050 gcc_assert (rss
== gfc_ss_terminator
);
2051 gfc_init_se (&rse
, NULL
);
2052 rse
.want_pointer
= 1;
2053 gfc_conv_expr (&rse
, expr2
);
2054 gfc_add_block_to_block (&block
, &lse
.pre
);
2055 gfc_add_block_to_block (&block
, &rse
.pre
);
2056 gfc_add_modify_expr (&block
, lse
.expr
,
2057 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
2058 gfc_add_block_to_block (&block
, &rse
.post
);
2059 gfc_add_block_to_block (&block
, &lse
.post
);
2063 /* Array pointer. */
2064 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2065 /* Implement Nullify. */
2066 if (expr2
->expr_type
== EXPR_NULL
)
2068 lse
.expr
= gfc_conv_descriptor_data (lse
.expr
);
2069 rse
.expr
= fold_convert (TREE_TYPE (lse
.expr
), null_pointer_node
);
2070 gfc_add_modify_expr (&block
, lse
.expr
, rse
.expr
);
2074 lse
.direct_byref
= 1;
2075 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2077 gfc_add_block_to_block (&block
, &lse
.pre
);
2078 gfc_add_block_to_block (&block
, &lse
.post
);
2080 return gfc_finish_block (&block
);
2084 /* Makes sure se is suitable for passing as a function string parameter. */
2085 /* TODO: Need to check all callers fo this function. It may be abused. */
2088 gfc_conv_string_parameter (gfc_se
* se
)
2092 if (TREE_CODE (se
->expr
) == STRING_CST
)
2094 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2098 type
= TREE_TYPE (se
->expr
);
2099 if (TYPE_STRING_FLAG (type
))
2101 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
2102 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
2105 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
2106 gcc_assert (se
->string_length
2107 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
2111 /* Generate code for assignment of scalar variables. Includes character
2115 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, bt type
)
2119 gfc_init_block (&block
);
2121 if (type
== BT_CHARACTER
)
2123 gcc_assert (lse
->string_length
!= NULL_TREE
2124 && rse
->string_length
!= NULL_TREE
);
2126 gfc_conv_string_parameter (lse
);
2127 gfc_conv_string_parameter (rse
);
2129 gfc_add_block_to_block (&block
, &lse
->pre
);
2130 gfc_add_block_to_block (&block
, &rse
->pre
);
2132 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
2133 rse
->string_length
, rse
->expr
);
2137 gfc_add_block_to_block (&block
, &lse
->pre
);
2138 gfc_add_block_to_block (&block
, &rse
->pre
);
2140 gfc_add_modify_expr (&block
, lse
->expr
,
2141 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
2144 gfc_add_block_to_block (&block
, &lse
->post
);
2145 gfc_add_block_to_block (&block
, &rse
->post
);
2147 return gfc_finish_block (&block
);
2151 /* Try to translate array(:) = func (...), where func is a transformational
2152 array function, without using a temporary. Returns NULL is this isn't the
2156 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
2161 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2162 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
2165 /* Elemental functions don't need a temporary anyway. */
2166 if (expr2
->symtree
->n
.sym
->attr
.elemental
)
2169 /* Check for a dependency. */
2170 if (gfc_check_fncall_dependency (expr1
, expr2
))
2173 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2175 gcc_assert (expr2
->value
.function
.isym
2176 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
2177 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
2179 ss
= gfc_walk_expr (expr1
);
2180 gcc_assert (ss
!= gfc_ss_terminator
);
2181 gfc_init_se (&se
, NULL
);
2182 gfc_start_block (&se
.pre
);
2183 se
.want_pointer
= 1;
2185 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
2187 se
.direct_byref
= 1;
2188 se
.ss
= gfc_walk_expr (expr2
);
2189 gcc_assert (se
.ss
!= gfc_ss_terminator
);
2190 gfc_conv_function_expr (&se
, expr2
);
2191 gfc_add_block_to_block (&se
.pre
, &se
.post
);
2193 return gfc_finish_block (&se
.pre
);
2197 /* Translate an assignment. Most of the code is concerned with
2198 setting up the scalarizer. */
2201 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
2206 gfc_ss
*lss_section
;
2213 /* Special case a single function returning an array. */
2214 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2216 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2221 /* Assignment of the form lhs = rhs. */
2222 gfc_start_block (&block
);
2224 gfc_init_se (&lse
, NULL
);
2225 gfc_init_se (&rse
, NULL
);
2228 lss
= gfc_walk_expr (expr1
);
2230 if (lss
!= gfc_ss_terminator
)
2232 /* The assignment needs scalarization. */
2235 /* Find a non-scalar SS from the lhs. */
2236 while (lss_section
!= gfc_ss_terminator
2237 && lss_section
->type
!= GFC_SS_SECTION
)
2238 lss_section
= lss_section
->next
;
2240 gcc_assert (lss_section
!= gfc_ss_terminator
);
2242 /* Initialize the scalarizer. */
2243 gfc_init_loopinfo (&loop
);
2246 rss
= gfc_walk_expr (expr2
);
2247 if (rss
== gfc_ss_terminator
)
2249 /* The rhs is scalar. Add a ss for the expression. */
2250 rss
= gfc_get_ss ();
2251 rss
->next
= gfc_ss_terminator
;
2252 rss
->type
= GFC_SS_SCALAR
;
2255 /* Associate the SS with the loop. */
2256 gfc_add_ss_to_loop (&loop
, lss
);
2257 gfc_add_ss_to_loop (&loop
, rss
);
2259 /* Calculate the bounds of the scalarization. */
2260 gfc_conv_ss_startstride (&loop
);
2261 /* Resolve any data dependencies in the statement. */
2262 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2263 /* Setup the scalarizing loops. */
2264 gfc_conv_loop_setup (&loop
);
2266 /* Setup the gfc_se structures. */
2267 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2268 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2271 gfc_mark_ss_chain_used (rss
, 1);
2272 if (loop
.temp_ss
== NULL
)
2275 gfc_mark_ss_chain_used (lss
, 1);
2279 lse
.ss
= loop
.temp_ss
;
2280 gfc_mark_ss_chain_used (lss
, 3);
2281 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2284 /* Start the scalarized loop body. */
2285 gfc_start_scalarized_body (&loop
, &body
);
2288 gfc_init_block (&body
);
2290 /* Translate the expression. */
2291 gfc_conv_expr (&rse
, expr2
);
2293 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2295 gfc_conv_tmp_array_ref (&lse
);
2296 gfc_advance_se_ss_chain (&lse
);
2299 gfc_conv_expr (&lse
, expr1
);
2301 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2302 gfc_add_expr_to_block (&body
, tmp
);
2304 if (lss
== gfc_ss_terminator
)
2306 /* Use the scalar assignment as is. */
2307 gfc_add_block_to_block (&block
, &body
);
2311 gcc_assert (lse
.ss
== gfc_ss_terminator
2312 && rse
.ss
== gfc_ss_terminator
);
2314 if (loop
.temp_ss
!= NULL
)
2316 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2318 /* We need to copy the temporary to the actual lhs. */
2319 gfc_init_se (&lse
, NULL
);
2320 gfc_init_se (&rse
, NULL
);
2321 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2322 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2324 rse
.ss
= loop
.temp_ss
;
2327 gfc_conv_tmp_array_ref (&rse
);
2328 gfc_advance_se_ss_chain (&rse
);
2329 gfc_conv_expr (&lse
, expr1
);
2331 gcc_assert (lse
.ss
== gfc_ss_terminator
2332 && rse
.ss
== gfc_ss_terminator
);
2334 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2335 gfc_add_expr_to_block (&body
, tmp
);
2337 /* Generate the copying loops. */
2338 gfc_trans_scalarizing_loops (&loop
, &body
);
2340 /* Wrap the whole thing up. */
2341 gfc_add_block_to_block (&block
, &loop
.pre
);
2342 gfc_add_block_to_block (&block
, &loop
.post
);
2344 gfc_cleanup_loop (&loop
);
2347 return gfc_finish_block (&block
);
2351 gfc_trans_assign (gfc_code
* code
)
2353 return gfc_trans_assignment (code
->expr
, code
->expr2
);