1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 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, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree
gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
);
46 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
*,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se
* dest
, gfc_se
* src
)
55 dest
->loop
= src
->loop
;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se
* se
, gfc_se
* parent
)
68 memset (se
, 0, sizeof (gfc_se
));
69 gfc_init_block (&se
->pre
);
70 gfc_init_block (&se
->post
);
75 gfc_copy_se_loopvars (se
, parent
);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se
* se
)
88 gcc_assert (se
!= NULL
&& se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p
->parent
== NULL
|| p
->parent
->ss
== p
->ss
);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se
* se
)
112 if (CONSTANT_CLASS_P (se
->expr
))
115 /* We need a temporary for this result. */
116 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
117 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol
* sym
)
130 gcc_assert (sym
->attr
.dummy
);
132 decl
= gfc_get_symbol_decl (sym
);
133 if (TREE_CODE (decl
) != PARM_DECL
)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl
))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl
)));
139 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
141 return build2 (NE_EXPR
, boolean_type_node
, decl
,
142 fold_convert (TREE_TYPE (decl
), null_pointer_node
));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se
* se
, gfc_expr
* arg
, gfc_typespec ts
)
154 present
= gfc_conv_expr_present (arg
->symtree
->n
.sym
);
155 tmp
= build3 (COND_EXPR
, TREE_TYPE (se
->expr
), present
, se
->expr
,
156 build_int_cst (TREE_TYPE (se
->expr
), 0));
157 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
159 if (ts
.type
== BT_CHARACTER
)
161 tmp
= build_int_cst (gfc_charlen_type_node
, 0);
162 tmp
= build3 (COND_EXPR
, gfc_charlen_type_node
, present
,
163 se
->string_length
, tmp
);
164 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
165 se
->string_length
= tmp
;
171 /* Get the character length of an expression, looking through gfc_refs
175 gfc_get_expr_charlen (gfc_expr
*e
)
180 gcc_assert (e
->expr_type
== EXPR_VARIABLE
181 && e
->ts
.type
== BT_CHARACTER
);
183 length
= NULL
; /* To silence compiler warning. */
185 /* First candidate: if the variable is of type CHARACTER, the
186 expression's length could be the length of the character
188 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
189 length
= e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
191 /* Look through the reference chain for component references. */
192 for (r
= e
->ref
; r
; r
= r
->next
)
197 if (r
->u
.c
.component
->ts
.type
== BT_CHARACTER
)
198 length
= r
->u
.c
.component
->ts
.cl
->backend_decl
;
206 /* We should never got substring references here. These will be
207 broken down by the scalarizer. */
212 gcc_assert (length
!= NULL
);
218 /* Generate code to initialize a string length variable. Returns the
222 gfc_trans_init_string_length (gfc_charlen
* cl
, stmtblock_t
* pblock
)
227 gfc_init_se (&se
, NULL
);
228 gfc_conv_expr_type (&se
, cl
->length
, gfc_charlen_type_node
);
229 gfc_add_block_to_block (pblock
, &se
.pre
);
231 tmp
= cl
->backend_decl
;
232 gfc_add_modify_expr (pblock
, tmp
, se
.expr
);
237 gfc_conv_substring (gfc_se
* se
, gfc_ref
* ref
, int kind
)
245 type
= gfc_get_character_type (kind
, ref
->u
.ss
.length
);
246 type
= build_pointer_type (type
);
249 gfc_init_se (&start
, se
);
250 gfc_conv_expr_type (&start
, ref
->u
.ss
.start
, gfc_charlen_type_node
);
251 gfc_add_block_to_block (&se
->pre
, &start
.pre
);
253 if (integer_onep (start
.expr
))
254 gfc_conv_string_parameter (se
);
257 /* Change the start of the string. */
258 if (TYPE_STRING_FLAG (TREE_TYPE (se
->expr
)))
261 tmp
= build_fold_indirect_ref (se
->expr
);
262 tmp
= gfc_build_array_ref (tmp
, start
.expr
);
263 se
->expr
= gfc_build_addr_expr (type
, tmp
);
266 /* Length = end + 1 - start. */
267 gfc_init_se (&end
, se
);
268 if (ref
->u
.ss
.end
== NULL
)
269 end
.expr
= se
->string_length
;
272 gfc_conv_expr_type (&end
, ref
->u
.ss
.end
, gfc_charlen_type_node
);
273 gfc_add_block_to_block (&se
->pre
, &end
.pre
);
275 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
,
276 build_int_cst (gfc_charlen_type_node
, 1),
278 tmp
= fold_build2 (PLUS_EXPR
, gfc_charlen_type_node
, end
.expr
, tmp
);
279 tmp
= fold_build2 (MAX_EXPR
, gfc_charlen_type_node
, tmp
,
280 build_int_cst (gfc_charlen_type_node
, 0));
281 se
->string_length
= tmp
;
285 /* Convert a derived type component reference. */
288 gfc_conv_component_ref (gfc_se
* se
, gfc_ref
* ref
)
295 c
= ref
->u
.c
.component
;
297 gcc_assert (c
->backend_decl
);
299 field
= c
->backend_decl
;
300 gcc_assert (TREE_CODE (field
) == FIELD_DECL
);
302 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), decl
, field
, NULL_TREE
);
306 if (c
->ts
.type
== BT_CHARACTER
)
308 tmp
= c
->ts
.cl
->backend_decl
;
309 /* Components must always be constant length. */
310 gcc_assert (tmp
&& INTEGER_CST_P (tmp
));
311 se
->string_length
= tmp
;
314 if (c
->pointer
&& c
->dimension
== 0 && c
->ts
.type
!= BT_CHARACTER
)
315 se
->expr
= build_fold_indirect_ref (se
->expr
);
319 /* Return the contents of a variable. Also handles reference/pointer
320 variables (all Fortran pointer references are implicit). */
323 gfc_conv_variable (gfc_se
* se
, gfc_expr
* expr
)
330 bool alternate_entry
;
333 sym
= expr
->symtree
->n
.sym
;
336 /* Check that something hasn't gone horribly wrong. */
337 gcc_assert (se
->ss
!= gfc_ss_terminator
);
338 gcc_assert (se
->ss
->expr
== expr
);
340 /* A scalarized term. We already know the descriptor. */
341 se
->expr
= se
->ss
->data
.info
.descriptor
;
342 se
->string_length
= se
->ss
->string_length
;
343 for (ref
= se
->ss
->data
.info
.ref
; ref
; ref
= ref
->next
)
344 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
349 tree se_expr
= NULL_TREE
;
351 se
->expr
= gfc_get_symbol_decl (sym
);
353 /* Deal with references to a parent results or entries by storing
354 the current_function_decl and moving to the parent_decl. */
355 return_value
= sym
->attr
.function
&& sym
->result
== sym
;
356 alternate_entry
= sym
->attr
.function
&& sym
->attr
.entry
357 && sym
->result
== sym
;
358 entry_master
= sym
->attr
.result
359 && sym
->ns
->proc_name
->attr
.entry_master
360 && !gfc_return_by_reference (sym
->ns
->proc_name
);
361 parent_decl
= DECL_CONTEXT (current_function_decl
);
363 if ((se
->expr
== parent_decl
&& return_value
)
364 || (sym
->ns
&& sym
->ns
->proc_name
366 && sym
->ns
->proc_name
->backend_decl
== parent_decl
367 && (alternate_entry
|| entry_master
)))
372 /* Special case for assigning the return value of a function.
373 Self recursive functions must have an explicit return value. */
374 if (return_value
&& (se
->expr
== current_function_decl
|| parent_flag
))
375 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
377 /* Similarly for alternate entry points. */
378 else if (alternate_entry
379 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
382 gfc_entry_list
*el
= NULL
;
384 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
387 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
392 else if (entry_master
393 && (sym
->ns
->proc_name
->backend_decl
== current_function_decl
395 se_expr
= gfc_get_fake_result_decl (sym
, parent_flag
);
400 /* Procedure actual arguments. */
401 else if (sym
->attr
.flavor
== FL_PROCEDURE
402 && se
->expr
!= current_function_decl
)
404 gcc_assert (se
->want_pointer
);
405 if (!sym
->attr
.dummy
)
407 gcc_assert (TREE_CODE (se
->expr
) == FUNCTION_DECL
);
408 se
->expr
= build_fold_addr_expr (se
->expr
);
414 /* Dereference the expression, where needed. Since characters
415 are entirely different from other types, they are treated
417 if (sym
->ts
.type
== BT_CHARACTER
)
419 /* Dereference character pointer dummy arguments
421 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
423 || sym
->attr
.function
424 || sym
->attr
.result
))
425 se
->expr
= build_fold_indirect_ref (se
->expr
);
429 /* Dereference non-character scalar dummy arguments. */
430 if (sym
->attr
.dummy
&& !sym
->attr
.dimension
)
431 se
->expr
= build_fold_indirect_ref (se
->expr
);
433 /* Dereference scalar hidden result. */
434 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_COMPLEX
435 && (sym
->attr
.function
|| sym
->attr
.result
)
436 && !sym
->attr
.dimension
&& !sym
->attr
.pointer
)
437 se
->expr
= build_fold_indirect_ref (se
->expr
);
439 /* Dereference non-character pointer variables.
440 These must be dummies, results, or scalars. */
441 if ((sym
->attr
.pointer
|| sym
->attr
.allocatable
)
443 || sym
->attr
.function
445 || !sym
->attr
.dimension
))
446 se
->expr
= build_fold_indirect_ref (se
->expr
);
452 /* For character variables, also get the length. */
453 if (sym
->ts
.type
== BT_CHARACTER
)
455 /* If the character length of an entry isn't set, get the length from
456 the master function instead. */
457 if (sym
->attr
.entry
&& !sym
->ts
.cl
->backend_decl
)
458 se
->string_length
= sym
->ns
->proc_name
->ts
.cl
->backend_decl
;
460 se
->string_length
= sym
->ts
.cl
->backend_decl
;
461 gcc_assert (se
->string_length
);
469 /* Return the descriptor if that's what we want and this is an array
470 section reference. */
471 if (se
->descriptor_only
&& ref
->u
.ar
.type
!= AR_ELEMENT
)
473 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
474 /* Return the descriptor for array pointers and allocations. */
476 && ref
->next
== NULL
&& (se
->descriptor_only
))
479 gfc_conv_array_ref (se
, &ref
->u
.ar
, sym
, &expr
->where
);
480 /* Return a pointer to an element. */
484 gfc_conv_component_ref (se
, ref
);
488 gfc_conv_substring (se
, ref
, expr
->ts
.kind
);
497 /* Pointer assignment, allocation or pass by reference. Arrays are handled
499 if (se
->want_pointer
)
501 if (expr
->ts
.type
== BT_CHARACTER
)
502 gfc_conv_string_parameter (se
);
504 se
->expr
= build_fold_addr_expr (se
->expr
);
509 /* Unary ops are easy... Or they would be if ! was a valid op. */
512 gfc_conv_unary_op (enum tree_code code
, gfc_se
* se
, gfc_expr
* expr
)
517 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
518 /* Initialize the operand. */
519 gfc_init_se (&operand
, se
);
520 gfc_conv_expr_val (&operand
, expr
->value
.op
.op1
);
521 gfc_add_block_to_block (&se
->pre
, &operand
.pre
);
523 type
= gfc_typenode_for_spec (&expr
->ts
);
525 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
526 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
527 All other unary operators have an equivalent GIMPLE unary operator. */
528 if (code
== TRUTH_NOT_EXPR
)
529 se
->expr
= build2 (EQ_EXPR
, type
, operand
.expr
,
530 build_int_cst (type
, 0));
532 se
->expr
= build1 (code
, type
, operand
.expr
);
536 /* Expand power operator to optimal multiplications when a value is raised
537 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
538 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
539 Programming", 3rd Edition, 1998. */
541 /* This code is mostly duplicated from expand_powi in the backend.
542 We establish the "optimal power tree" lookup table with the defined size.
543 The items in the table are the exponents used to calculate the index
544 exponents. Any integer n less than the value can get an "addition chain",
545 with the first node being one. */
546 #define POWI_TABLE_SIZE 256
548 /* The table is from builtins.c. */
549 static const unsigned char powi_table
[POWI_TABLE_SIZE
] =
551 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
552 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
553 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
554 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
555 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
556 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
557 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
558 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
559 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
560 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
561 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
562 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
563 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
564 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
565 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
566 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
567 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
568 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
569 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
570 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
571 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
572 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
573 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
574 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
575 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
576 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
577 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
578 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
579 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
580 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
581 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
582 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
585 /* If n is larger than lookup table's max index, we use the "window
587 #define POWI_WINDOW_SIZE 3
589 /* Recursive function to expand the power operator. The temporary
590 values are put in tmpvar. The function returns tmpvar[1] ** n. */
592 gfc_conv_powi (gfc_se
* se
, int n
, tree
* tmpvar
)
599 if (n
< POWI_TABLE_SIZE
)
604 op0
= gfc_conv_powi (se
, n
- powi_table
[n
], tmpvar
);
605 op1
= gfc_conv_powi (se
, powi_table
[n
], tmpvar
);
609 digit
= n
& ((1 << POWI_WINDOW_SIZE
) - 1);
610 op0
= gfc_conv_powi (se
, n
- digit
, tmpvar
);
611 op1
= gfc_conv_powi (se
, digit
, tmpvar
);
615 op0
= gfc_conv_powi (se
, n
>> 1, tmpvar
);
619 tmp
= fold_build2 (MULT_EXPR
, TREE_TYPE (op0
), op0
, op1
);
620 tmp
= gfc_evaluate_now (tmp
, &se
->pre
);
622 if (n
< POWI_TABLE_SIZE
)
629 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
630 return 1. Else return 0 and a call to runtime library functions
631 will have to be built. */
633 gfc_conv_cst_int_power (gfc_se
* se
, tree lhs
, tree rhs
)
638 tree vartmp
[POWI_TABLE_SIZE
];
642 type
= TREE_TYPE (lhs
);
643 n
= abs (TREE_INT_CST_LOW (rhs
));
644 sgn
= tree_int_cst_sgn (rhs
);
646 if (((FLOAT_TYPE_P (type
) && !flag_unsafe_math_optimizations
) || optimize_size
)
647 && (n
> 2 || n
< -1))
653 se
->expr
= gfc_build_const (type
, integer_one_node
);
656 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
657 if ((sgn
== -1) && (TREE_CODE (type
) == INTEGER_TYPE
))
659 tmp
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
660 build_int_cst (TREE_TYPE (lhs
), -1));
661 cond
= build2 (EQ_EXPR
, boolean_type_node
, lhs
,
662 build_int_cst (TREE_TYPE (lhs
), 1));
665 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
668 tmp
= build2 (TRUTH_OR_EXPR
, boolean_type_node
, tmp
, cond
);
669 se
->expr
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, 1),
670 build_int_cst (type
, 0));
674 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
675 tmp
= build3 (COND_EXPR
, type
, tmp
, build_int_cst (type
, -1),
676 build_int_cst (type
, 0));
677 se
->expr
= build3 (COND_EXPR
, type
, cond
, build_int_cst (type
, 1), tmp
);
681 memset (vartmp
, 0, sizeof (vartmp
));
685 tmp
= gfc_build_const (type
, integer_one_node
);
686 vartmp
[1] = build2 (RDIV_EXPR
, type
, tmp
, vartmp
[1]);
689 se
->expr
= gfc_conv_powi (se
, n
, vartmp
);
695 /* Power op (**). Constant integer exponent has special handling. */
698 gfc_conv_power_op (gfc_se
* se
, gfc_expr
* expr
)
700 tree gfc_int4_type_node
;
708 gfc_init_se (&lse
, se
);
709 gfc_conv_expr_val (&lse
, expr
->value
.op
.op1
);
710 lse
.expr
= gfc_evaluate_now (lse
.expr
, &lse
.pre
);
711 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
713 gfc_init_se (&rse
, se
);
714 gfc_conv_expr_val (&rse
, expr
->value
.op
.op2
);
715 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
717 if (expr
->value
.op
.op2
->ts
.type
== BT_INTEGER
718 && expr
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
)
719 if (gfc_conv_cst_int_power (se
, lse
.expr
, rse
.expr
))
722 gfc_int4_type_node
= gfc_get_int_type (4);
724 kind
= expr
->value
.op
.op1
->ts
.kind
;
725 switch (expr
->value
.op
.op2
->ts
.type
)
728 ikind
= expr
->value
.op
.op2
->ts
.kind
;
733 rse
.expr
= convert (gfc_int4_type_node
, rse
.expr
);
755 if (expr
->value
.op
.op1
->ts
.type
== BT_INTEGER
)
756 lse
.expr
= convert (gfc_int4_type_node
, lse
.expr
);
781 switch (expr
->value
.op
.op1
->ts
.type
)
784 if (kind
== 3) /* Case 16 was not handled properly above. */
786 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].integer
;
790 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].real
;
794 fndecl
= gfor_fndecl_math_powi
[kind
][ikind
].cmplx
;
806 fndecl
= built_in_decls
[BUILT_IN_POWF
];
809 fndecl
= built_in_decls
[BUILT_IN_POW
];
813 fndecl
= built_in_decls
[BUILT_IN_POWL
];
824 fndecl
= gfor_fndecl_math_cpowf
;
827 fndecl
= gfor_fndecl_math_cpow
;
830 fndecl
= gfor_fndecl_math_cpowl10
;
833 fndecl
= gfor_fndecl_math_cpowl16
;
845 tmp
= gfc_chainon_list (NULL_TREE
, lse
.expr
);
846 tmp
= gfc_chainon_list (tmp
, rse
.expr
);
847 se
->expr
= build_function_call_expr (fndecl
, tmp
);
851 /* Generate code to allocate a string temporary. */
854 gfc_conv_string_tmp (gfc_se
* se
, tree type
, tree len
)
860 gcc_assert (TREE_TYPE (len
) == gfc_charlen_type_node
);
862 if (gfc_can_put_var_on_stack (len
))
864 /* Create a temporary variable to hold the result. */
865 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
866 build_int_cst (gfc_charlen_type_node
, 1));
867 tmp
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
868 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
869 var
= gfc_create_var (tmp
, "str");
870 var
= gfc_build_addr_expr (type
, var
);
874 /* Allocate a temporary to hold the result. */
875 var
= gfc_create_var (type
, "pstr");
876 args
= gfc_chainon_list (NULL_TREE
, len
);
877 tmp
= build_function_call_expr (gfor_fndecl_internal_malloc
, args
);
878 tmp
= convert (type
, tmp
);
879 gfc_add_modify_expr (&se
->pre
, var
, tmp
);
881 /* Free the temporary afterwards. */
882 tmp
= convert (pvoid_type_node
, var
);
883 args
= gfc_chainon_list (NULL_TREE
, tmp
);
884 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
885 gfc_add_expr_to_block (&se
->post
, tmp
);
892 /* Handle a string concatenation operation. A temporary will be allocated to
896 gfc_conv_concat_op (gfc_se
* se
, gfc_expr
* expr
)
906 gcc_assert (expr
->value
.op
.op1
->ts
.type
== BT_CHARACTER
907 && expr
->value
.op
.op2
->ts
.type
== BT_CHARACTER
);
909 gfc_init_se (&lse
, se
);
910 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
911 gfc_conv_string_parameter (&lse
);
912 gfc_init_se (&rse
, se
);
913 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
914 gfc_conv_string_parameter (&rse
);
916 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
917 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
919 type
= gfc_get_character_type (expr
->ts
.kind
, expr
->ts
.cl
);
920 len
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
921 if (len
== NULL_TREE
)
923 len
= fold_build2 (PLUS_EXPR
, TREE_TYPE (lse
.string_length
),
924 lse
.string_length
, rse
.string_length
);
927 type
= build_pointer_type (type
);
929 var
= gfc_conv_string_tmp (se
, type
, len
);
931 /* Do the actual concatenation. */
933 args
= gfc_chainon_list (args
, len
);
934 args
= gfc_chainon_list (args
, var
);
935 args
= gfc_chainon_list (args
, lse
.string_length
);
936 args
= gfc_chainon_list (args
, lse
.expr
);
937 args
= gfc_chainon_list (args
, rse
.string_length
);
938 args
= gfc_chainon_list (args
, rse
.expr
);
939 tmp
= build_function_call_expr (gfor_fndecl_concat_string
, args
);
940 gfc_add_expr_to_block (&se
->pre
, tmp
);
942 /* Add the cleanup for the operands. */
943 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
944 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
947 se
->string_length
= len
;
950 /* Translates an op expression. Common (binary) cases are handled by this
951 function, others are passed on. Recursion is used in either case.
952 We use the fact that (op1.ts == op2.ts) (except for the power
954 Operators need no special handling for scalarized expressions as long as
955 they call gfc_conv_simple_val to get their operands.
956 Character strings get special handling. */
959 gfc_conv_expr_op (gfc_se
* se
, gfc_expr
* expr
)
971 switch (expr
->value
.op
.operator)
973 case INTRINSIC_UPLUS
:
974 case INTRINSIC_PARENTHESES
:
975 gfc_conv_expr (se
, expr
->value
.op
.op1
);
978 case INTRINSIC_UMINUS
:
979 gfc_conv_unary_op (NEGATE_EXPR
, se
, expr
);
983 gfc_conv_unary_op (TRUTH_NOT_EXPR
, se
, expr
);
990 case INTRINSIC_MINUS
:
994 case INTRINSIC_TIMES
:
998 case INTRINSIC_DIVIDE
:
999 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1000 an integer, we must round towards zero, so we use a
1002 if (expr
->ts
.type
== BT_INTEGER
)
1003 code
= TRUNC_DIV_EXPR
;
1008 case INTRINSIC_POWER
:
1009 gfc_conv_power_op (se
, expr
);
1012 case INTRINSIC_CONCAT
:
1013 gfc_conv_concat_op (se
, expr
);
1017 code
= TRUTH_ANDIF_EXPR
;
1022 code
= TRUTH_ORIF_EXPR
;
1026 /* EQV and NEQV only work on logicals, but since we represent them
1027 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1036 case INTRINSIC_NEQV
:
1066 case INTRINSIC_USER
:
1067 case INTRINSIC_ASSIGN
:
1068 /* These should be converted into function calls by the frontend. */
1072 fatal_error ("Unknown intrinsic op");
1076 /* The only exception to this is **, which is handled separately anyway. */
1077 gcc_assert (expr
->value
.op
.op1
->ts
.type
== expr
->value
.op
.op2
->ts
.type
);
1079 if (checkstring
&& expr
->value
.op
.op1
->ts
.type
!= BT_CHARACTER
)
1083 gfc_init_se (&lse
, se
);
1084 gfc_conv_expr (&lse
, expr
->value
.op
.op1
);
1085 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
1088 gfc_init_se (&rse
, se
);
1089 gfc_conv_expr (&rse
, expr
->value
.op
.op2
);
1090 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
1094 gfc_conv_string_parameter (&lse
);
1095 gfc_conv_string_parameter (&rse
);
1097 lse
.expr
= gfc_build_compare_string (lse
.string_length
, lse
.expr
,
1098 rse
.string_length
, rse
.expr
);
1099 rse
.expr
= integer_zero_node
;
1100 gfc_add_block_to_block (&lse
.post
, &rse
.post
);
1103 type
= gfc_typenode_for_spec (&expr
->ts
);
1107 /* The result of logical ops is always boolean_type_node. */
1108 tmp
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1109 se
->expr
= convert (type
, tmp
);
1112 se
->expr
= fold_build2 (code
, type
, lse
.expr
, rse
.expr
);
1114 /* Add the post blocks. */
1115 gfc_add_block_to_block (&se
->post
, &rse
.post
);
1116 gfc_add_block_to_block (&se
->post
, &lse
.post
);
1119 /* If a string's length is one, we convert it to a single character. */
1122 gfc_to_single_character (tree len
, tree str
)
1124 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str
)));
1126 if (INTEGER_CST_P (len
) && TREE_INT_CST_LOW (len
) == 1
1127 && TREE_INT_CST_HIGH (len
) == 0)
1129 str
= fold_convert (pchar_type_node
, str
);
1130 return build_fold_indirect_ref (str
);
1136 /* Compare two strings. If they are all single characters, the result is the
1137 subtraction of them. Otherwise, we build a library call. */
1140 gfc_build_compare_string (tree len1
, tree str1
, tree len2
, tree str2
)
1147 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1
)));
1148 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2
)));
1150 type
= gfc_get_int_type (gfc_default_integer_kind
);
1152 sc1
= gfc_to_single_character (len1
, str1
);
1153 sc2
= gfc_to_single_character (len2
, str2
);
1155 /* Deal with single character specially. */
1156 if (sc1
!= NULL_TREE
&& sc2
!= NULL_TREE
)
1158 sc1
= fold_convert (type
, sc1
);
1159 sc2
= fold_convert (type
, sc2
);
1160 tmp
= fold_build2 (MINUS_EXPR
, type
, sc1
, sc2
);
1165 tmp
= gfc_chainon_list (tmp
, len1
);
1166 tmp
= gfc_chainon_list (tmp
, str1
);
1167 tmp
= gfc_chainon_list (tmp
, len2
);
1168 tmp
= gfc_chainon_list (tmp
, str2
);
1170 /* Build a call for the comparison. */
1171 tmp
= build_function_call_expr (gfor_fndecl_compare_string
, tmp
);
1178 gfc_conv_function_val (gfc_se
* se
, gfc_symbol
* sym
)
1182 if (sym
->attr
.dummy
)
1184 tmp
= gfc_get_symbol_decl (sym
);
1185 gcc_assert (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
1186 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp
))) == FUNCTION_TYPE
);
1190 if (!sym
->backend_decl
)
1191 sym
->backend_decl
= gfc_get_extern_function_decl (sym
);
1193 tmp
= sym
->backend_decl
;
1194 if (sym
->attr
.cray_pointee
)
1195 tmp
= convert (build_pointer_type (TREE_TYPE (tmp
)),
1196 gfc_get_symbol_decl (sym
->cp_pointer
));
1197 if (!POINTER_TYPE_P (TREE_TYPE (tmp
)))
1199 gcc_assert (TREE_CODE (tmp
) == FUNCTION_DECL
);
1200 tmp
= build_fold_addr_expr (tmp
);
1207 /* Initialize MAPPING. */
1210 gfc_init_interface_mapping (gfc_interface_mapping
* mapping
)
1212 mapping
->syms
= NULL
;
1213 mapping
->charlens
= NULL
;
1217 /* Free all memory held by MAPPING (but not MAPPING itself). */
1220 gfc_free_interface_mapping (gfc_interface_mapping
* mapping
)
1222 gfc_interface_sym_mapping
*sym
;
1223 gfc_interface_sym_mapping
*nextsym
;
1225 gfc_charlen
*nextcl
;
1227 for (sym
= mapping
->syms
; sym
; sym
= nextsym
)
1229 nextsym
= sym
->next
;
1230 gfc_free_symbol (sym
->new->n
.sym
);
1231 gfc_free (sym
->new);
1234 for (cl
= mapping
->charlens
; cl
; cl
= nextcl
)
1237 gfc_free_expr (cl
->length
);
1243 /* Return a copy of gfc_charlen CL. Add the returned structure to
1244 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1246 static gfc_charlen
*
1247 gfc_get_interface_mapping_charlen (gfc_interface_mapping
* mapping
,
1252 new = gfc_get_charlen ();
1253 new->next
= mapping
->charlens
;
1254 new->length
= gfc_copy_expr (cl
->length
);
1256 mapping
->charlens
= new;
1261 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1262 array variable that can be used as the actual argument for dummy
1263 argument SYM. Add any initialization code to BLOCK. PACKED is as
1264 for gfc_get_nodesc_array_type and DATA points to the first element
1265 in the passed array. */
1268 gfc_get_interface_mapping_array (stmtblock_t
* block
, gfc_symbol
* sym
,
1269 int packed
, tree data
)
1274 type
= gfc_typenode_for_spec (&sym
->ts
);
1275 type
= gfc_get_nodesc_array_type (type
, sym
->as
, packed
);
1277 var
= gfc_create_var (type
, "ifm");
1278 gfc_add_modify_expr (block
, var
, fold_convert (type
, data
));
1284 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1285 and offset of descriptorless array type TYPE given that it has the same
1286 size as DESC. Add any set-up code to BLOCK. */
1289 gfc_set_interface_mapping_bounds (stmtblock_t
* block
, tree type
, tree desc
)
1296 offset
= gfc_index_zero_node
;
1297 for (n
= 0; n
< GFC_TYPE_ARRAY_RANK (type
); n
++)
1299 GFC_TYPE_ARRAY_STRIDE (type
, n
) = gfc_conv_array_stride (desc
, n
);
1300 if (GFC_TYPE_ARRAY_UBOUND (type
, n
) == NULL_TREE
)
1302 dim
= gfc_rank_cst
[n
];
1303 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1304 gfc_conv_descriptor_ubound (desc
, dim
),
1305 gfc_conv_descriptor_lbound (desc
, dim
));
1306 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1307 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1309 tmp
= gfc_evaluate_now (tmp
, block
);
1310 GFC_TYPE_ARRAY_UBOUND (type
, n
) = tmp
;
1312 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1313 GFC_TYPE_ARRAY_LBOUND (type
, n
),
1314 GFC_TYPE_ARRAY_STRIDE (type
, n
));
1315 offset
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp
);
1317 offset
= gfc_evaluate_now (offset
, block
);
1318 GFC_TYPE_ARRAY_OFFSET (type
) = offset
;
1322 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1323 in SE. The caller may still use se->expr and se->string_length after
1324 calling this function. */
1327 gfc_add_interface_mapping (gfc_interface_mapping
* mapping
,
1328 gfc_symbol
* sym
, gfc_se
* se
)
1330 gfc_interface_sym_mapping
*sm
;
1334 gfc_symbol
*new_sym
;
1336 gfc_symtree
*new_symtree
;
1338 /* Create a new symbol to represent the actual argument. */
1339 new_sym
= gfc_new_symbol (sym
->name
, NULL
);
1340 new_sym
->ts
= sym
->ts
;
1341 new_sym
->attr
.referenced
= 1;
1342 new_sym
->attr
.dimension
= sym
->attr
.dimension
;
1343 new_sym
->attr
.pointer
= sym
->attr
.pointer
;
1344 new_sym
->attr
.allocatable
= sym
->attr
.allocatable
;
1345 new_sym
->attr
.flavor
= sym
->attr
.flavor
;
1347 /* Create a fake symtree for it. */
1349 new_symtree
= gfc_new_symtree (&root
, sym
->name
);
1350 new_symtree
->n
.sym
= new_sym
;
1351 gcc_assert (new_symtree
== root
);
1353 /* Create a dummy->actual mapping. */
1354 sm
= gfc_getmem (sizeof (*sm
));
1355 sm
->next
= mapping
->syms
;
1357 sm
->new = new_symtree
;
1360 /* Stabilize the argument's value. */
1361 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1363 if (sym
->ts
.type
== BT_CHARACTER
)
1365 /* Create a copy of the dummy argument's length. */
1366 new_sym
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, sym
->ts
.cl
);
1368 /* If the length is specified as "*", record the length that
1369 the caller is passing. We should use the callee's length
1370 in all other cases. */
1371 if (!new_sym
->ts
.cl
->length
)
1373 se
->string_length
= gfc_evaluate_now (se
->string_length
, &se
->pre
);
1374 new_sym
->ts
.cl
->backend_decl
= se
->string_length
;
1378 /* Use the passed value as-is if the argument is a function. */
1379 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1382 /* If the argument is either a string or a pointer to a string,
1383 convert it to a boundless character type. */
1384 else if (!sym
->attr
.dimension
&& sym
->ts
.type
== BT_CHARACTER
)
1386 tmp
= gfc_get_character_type_len (sym
->ts
.kind
, NULL
);
1387 tmp
= build_pointer_type (tmp
);
1388 if (sym
->attr
.pointer
)
1389 value
= build_fold_indirect_ref (se
->expr
);
1392 value
= fold_convert (tmp
, value
);
1395 /* If the argument is a scalar, a pointer to an array or an allocatable,
1397 else if (!sym
->attr
.dimension
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
1398 value
= build_fold_indirect_ref (se
->expr
);
1400 /* For character(*), use the actual argument's descriptor. */
1401 else if (sym
->ts
.type
== BT_CHARACTER
&& !new_sym
->ts
.cl
->length
)
1402 value
= build_fold_indirect_ref (se
->expr
);
1404 /* If the argument is an array descriptor, use it to determine
1405 information about the actual argument's shape. */
1406 else if (POINTER_TYPE_P (TREE_TYPE (se
->expr
))
1407 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se
->expr
))))
1409 /* Get the actual argument's descriptor. */
1410 desc
= build_fold_indirect_ref (se
->expr
);
1412 /* Create the replacement variable. */
1413 tmp
= gfc_conv_descriptor_data_get (desc
);
1414 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 0, tmp
);
1416 /* Use DESC to work out the upper bounds, strides and offset. */
1417 gfc_set_interface_mapping_bounds (&se
->pre
, TREE_TYPE (value
), desc
);
1420 /* Otherwise we have a packed array. */
1421 value
= gfc_get_interface_mapping_array (&se
->pre
, sym
, 2, se
->expr
);
1423 new_sym
->backend_decl
= value
;
1427 /* Called once all dummy argument mappings have been added to MAPPING,
1428 but before the mapping is used to evaluate expressions. Pre-evaluate
1429 the length of each argument, adding any initialization code to PRE and
1430 any finalization code to POST. */
1433 gfc_finish_interface_mapping (gfc_interface_mapping
* mapping
,
1434 stmtblock_t
* pre
, stmtblock_t
* post
)
1436 gfc_interface_sym_mapping
*sym
;
1440 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1441 if (sym
->new->n
.sym
->ts
.type
== BT_CHARACTER
1442 && !sym
->new->n
.sym
->ts
.cl
->backend_decl
)
1444 expr
= sym
->new->n
.sym
->ts
.cl
->length
;
1445 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1446 gfc_init_se (&se
, NULL
);
1447 gfc_conv_expr (&se
, expr
);
1449 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1450 gfc_add_block_to_block (pre
, &se
.pre
);
1451 gfc_add_block_to_block (post
, &se
.post
);
1453 sym
->new->n
.sym
->ts
.cl
->backend_decl
= se
.expr
;
1458 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1462 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping
* mapping
,
1463 gfc_constructor
* c
)
1465 for (; c
; c
= c
->next
)
1467 gfc_apply_interface_mapping_to_expr (mapping
, c
->expr
);
1470 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->start
);
1471 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->end
);
1472 gfc_apply_interface_mapping_to_expr (mapping
, c
->iterator
->step
);
1478 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1482 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping
* mapping
,
1487 for (; ref
; ref
= ref
->next
)
1491 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1493 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.start
[n
]);
1494 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.end
[n
]);
1495 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.stride
[n
]);
1497 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ar
.offset
);
1504 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.start
);
1505 gfc_apply_interface_mapping_to_expr (mapping
, ref
->u
.ss
.end
);
1511 /* EXPR is a copy of an expression that appeared in the interface
1512 associated with MAPPING. Walk it recursively looking for references to
1513 dummy arguments that MAPPING maps to actual arguments. Replace each such
1514 reference with a reference to the associated actual argument. */
1517 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping
* mapping
,
1520 gfc_interface_sym_mapping
*sym
;
1521 gfc_actual_arglist
*actual
;
1526 /* Copying an expression does not copy its length, so do that here. */
1527 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.cl
)
1529 expr
->ts
.cl
= gfc_get_interface_mapping_charlen (mapping
, expr
->ts
.cl
);
1530 gfc_apply_interface_mapping_to_expr (mapping
, expr
->ts
.cl
->length
);
1533 /* Apply the mapping to any references. */
1534 gfc_apply_interface_mapping_to_ref (mapping
, expr
->ref
);
1536 /* ...and to the expression's symbol, if it has one. */
1538 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1539 if (sym
->old
== expr
->symtree
->n
.sym
)
1540 expr
->symtree
= sym
->new;
1542 /* ...and to subexpressions in expr->value. */
1543 switch (expr
->expr_type
)
1548 case EXPR_SUBSTRING
:
1552 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op1
);
1553 gfc_apply_interface_mapping_to_expr (mapping
, expr
->value
.op
.op2
);
1557 for (sym
= mapping
->syms
; sym
; sym
= sym
->next
)
1558 if (sym
->old
== expr
->value
.function
.esym
)
1559 expr
->value
.function
.esym
= sym
->new->n
.sym
;
1561 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
1562 gfc_apply_interface_mapping_to_expr (mapping
, actual
->expr
);
1566 case EXPR_STRUCTURE
:
1567 gfc_apply_interface_mapping_to_cons (mapping
, expr
->value
.constructor
);
1573 /* Evaluate interface expression EXPR using MAPPING. Store the result
1577 gfc_apply_interface_mapping (gfc_interface_mapping
* mapping
,
1578 gfc_se
* se
, gfc_expr
* expr
)
1580 expr
= gfc_copy_expr (expr
);
1581 gfc_apply_interface_mapping_to_expr (mapping
, expr
);
1582 gfc_conv_expr (se
, expr
);
1583 se
->expr
= gfc_evaluate_now (se
->expr
, &se
->pre
);
1584 gfc_free_expr (expr
);
1587 /* Returns a reference to a temporary array into which a component of
1588 an actual argument derived type array is copied and then returned
1589 after the function call.
1590 TODO Get rid of this kludge, when array descriptors are capable of
1591 handling aliased arrays. */
1594 gfc_conv_aliased_arg (gfc_se
* parmse
, gfc_expr
* expr
,
1595 int g77
, sym_intent intent
)
1611 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
1613 gfc_init_se (&lse
, NULL
);
1614 gfc_init_se (&rse
, NULL
);
1616 /* Walk the argument expression. */
1617 rss
= gfc_walk_expr (expr
);
1619 gcc_assert (rss
!= gfc_ss_terminator
);
1621 /* Initialize the scalarizer. */
1622 gfc_init_loopinfo (&loop
);
1623 gfc_add_ss_to_loop (&loop
, rss
);
1625 /* Calculate the bounds of the scalarization. */
1626 gfc_conv_ss_startstride (&loop
);
1628 /* Build an ss for the temporary. */
1629 base_type
= gfc_typenode_for_spec (&expr
->ts
);
1630 if (GFC_ARRAY_TYPE_P (base_type
)
1631 || GFC_DESCRIPTOR_TYPE_P (base_type
))
1632 base_type
= gfc_get_element_type (base_type
);
1634 loop
.temp_ss
= gfc_get_ss ();;
1635 loop
.temp_ss
->type
= GFC_SS_TEMP
;
1636 loop
.temp_ss
->data
.temp
.type
= base_type
;
1638 if (expr
->ts
.type
== BT_CHARACTER
)
1640 gfc_ref
*char_ref
= expr
->ref
;
1642 for (; expr
->ts
.cl
== NULL
&& char_ref
; char_ref
= char_ref
->next
)
1643 if (char_ref
->type
== REF_SUBSTRING
)
1647 expr
->ts
.cl
= gfc_get_charlen ();
1648 expr
->ts
.cl
->next
= char_ref
->u
.ss
.length
->next
;
1649 char_ref
->u
.ss
.length
->next
= expr
->ts
.cl
;
1651 gfc_init_se (&tmp_se
, NULL
);
1652 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.end
,
1653 gfc_array_index_type
);
1654 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1655 tmp_se
.expr
, gfc_index_one_node
);
1656 tmp
= gfc_evaluate_now (tmp
, &parmse
->pre
);
1657 gfc_init_se (&tmp_se
, NULL
);
1658 gfc_conv_expr_type (&tmp_se
, char_ref
->u
.ss
.start
,
1659 gfc_array_index_type
);
1660 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1662 expr
->ts
.cl
->backend_decl
= tmp
;
1666 loop
.temp_ss
->data
.temp
.type
1667 = gfc_typenode_for_spec (&expr
->ts
);
1668 loop
.temp_ss
->string_length
= expr
->ts
.cl
->backend_decl
;
1671 loop
.temp_ss
->data
.temp
.dimen
= loop
.dimen
;
1672 loop
.temp_ss
->next
= gfc_ss_terminator
;
1674 /* Associate the SS with the loop. */
1675 gfc_add_ss_to_loop (&loop
, loop
.temp_ss
);
1677 /* Setup the scalarizing loops. */
1678 gfc_conv_loop_setup (&loop
);
1680 /* Pass the temporary descriptor back to the caller. */
1681 info
= &loop
.temp_ss
->data
.info
;
1682 parmse
->expr
= info
->descriptor
;
1684 /* Setup the gfc_se structures. */
1685 gfc_copy_loopinfo_to_se (&lse
, &loop
);
1686 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1689 lse
.ss
= loop
.temp_ss
;
1690 gfc_mark_ss_chain_used (rss
, 1);
1691 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1693 /* Start the scalarized loop body. */
1694 gfc_start_scalarized_body (&loop
, &body
);
1696 /* Translate the expression. */
1697 gfc_conv_expr (&rse
, expr
);
1699 gfc_conv_tmp_array_ref (&lse
);
1700 gfc_advance_se_ss_chain (&lse
);
1702 if (intent
!= INTENT_OUT
)
1704 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, false);
1705 gfc_add_expr_to_block (&body
, tmp
);
1706 gcc_assert (rse
.ss
== gfc_ss_terminator
);
1707 gfc_trans_scalarizing_loops (&loop
, &body
);
1711 /* Make sure that the temporary declaration survives. */
1712 tmp
= gfc_finish_block (&body
);
1713 gfc_add_expr_to_block (&loop
.pre
, tmp
);
1716 /* Add the post block after the second loop, so that any
1717 freeing of allocated memory is done at the right time. */
1718 gfc_add_block_to_block (&parmse
->pre
, &loop
.pre
);
1720 /**********Copy the temporary back again.*********/
1722 gfc_init_se (&lse
, NULL
);
1723 gfc_init_se (&rse
, NULL
);
1725 /* Walk the argument expression. */
1726 lss
= gfc_walk_expr (expr
);
1727 rse
.ss
= loop
.temp_ss
;
1730 /* Initialize the scalarizer. */
1731 gfc_init_loopinfo (&loop2
);
1732 gfc_add_ss_to_loop (&loop2
, lss
);
1734 /* Calculate the bounds of the scalarization. */
1735 gfc_conv_ss_startstride (&loop2
);
1737 /* Setup the scalarizing loops. */
1738 gfc_conv_loop_setup (&loop2
);
1740 gfc_copy_loopinfo_to_se (&lse
, &loop2
);
1741 gfc_copy_loopinfo_to_se (&rse
, &loop2
);
1743 gfc_mark_ss_chain_used (lss
, 1);
1744 gfc_mark_ss_chain_used (loop
.temp_ss
, 1);
1746 /* Declare the variable to hold the temporary offset and start the
1747 scalarized loop body. */
1748 offset
= gfc_create_var (gfc_array_index_type
, NULL
);
1749 gfc_start_scalarized_body (&loop2
, &body
);
1751 /* Build the offsets for the temporary from the loop variables. The
1752 temporary array has lbounds of zero and strides of one in all
1753 dimensions, so this is very simple. The offset is only computed
1754 outside the innermost loop, so the overall transfer could be
1755 optimized further. */
1756 info
= &rse
.ss
->data
.info
;
1758 tmp_index
= gfc_index_zero_node
;
1759 for (n
= info
->dimen
- 1; n
> 0; n
--)
1762 tmp
= rse
.loop
->loopvar
[n
];
1763 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1764 tmp
, rse
.loop
->from
[n
]);
1765 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1768 tmp_str
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1769 rse
.loop
->to
[n
-1], rse
.loop
->from
[n
-1]);
1770 tmp_str
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1771 tmp_str
, gfc_index_one_node
);
1773 tmp_index
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
1777 tmp_index
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1778 tmp_index
, rse
.loop
->from
[0]);
1779 gfc_add_modify_expr (&rse
.loop
->code
[0], offset
, tmp_index
);
1781 tmp_index
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1782 rse
.loop
->loopvar
[0], offset
);
1784 /* Now use the offset for the reference. */
1785 tmp
= build_fold_indirect_ref (info
->data
);
1786 rse
.expr
= gfc_build_array_ref (tmp
, tmp_index
);
1788 if (expr
->ts
.type
== BT_CHARACTER
)
1789 rse
.string_length
= expr
->ts
.cl
->backend_decl
;
1791 gfc_conv_expr (&lse
, expr
);
1793 gcc_assert (lse
.ss
== gfc_ss_terminator
);
1795 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, false);
1796 gfc_add_expr_to_block (&body
, tmp
);
1798 /* Generate the copying loops. */
1799 gfc_trans_scalarizing_loops (&loop2
, &body
);
1801 /* Wrap the whole thing up by adding the second loop to the post-block
1802 and following it by the post-block of the first loop. In this way,
1803 if the temporary needs freeing, it is done after use! */
1804 if (intent
!= INTENT_IN
)
1806 gfc_add_block_to_block (&parmse
->post
, &loop2
.pre
);
1807 gfc_add_block_to_block (&parmse
->post
, &loop2
.post
);
1810 gfc_add_block_to_block (&parmse
->post
, &loop
.post
);
1812 gfc_cleanup_loop (&loop
);
1813 gfc_cleanup_loop (&loop2
);
1815 /* Pass the string length to the argument expression. */
1816 if (expr
->ts
.type
== BT_CHARACTER
)
1817 parmse
->string_length
= expr
->ts
.cl
->backend_decl
;
1819 /* We want either the address for the data or the address of the descriptor,
1820 depending on the mode of passing array arguments. */
1822 parmse
->expr
= gfc_conv_descriptor_data_get (parmse
->expr
);
1824 parmse
->expr
= build_fold_addr_expr (parmse
->expr
);
1829 /* Is true if the last array reference is followed by a component reference. */
1832 is_aliased_array (gfc_expr
* e
)
1838 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1840 if (ref
->type
== REF_ARRAY
)
1843 if (ref
->next
== NULL
1844 && ref
->type
!= REF_ARRAY
)
1850 /* Generate code for a procedure call. Note can return se->post != NULL.
1851 If se->direct_byref is set then se->expr contains the return parameter.
1852 Return nonzero, if the call has alternate specifiers. */
1855 gfc_conv_function_call (gfc_se
* se
, gfc_symbol
* sym
,
1856 gfc_actual_arglist
* arg
)
1858 gfc_interface_mapping mapping
;
1872 gfc_formal_arglist
*formal
;
1873 int has_alternate_specifier
= 0;
1874 bool need_interface_mapping
;
1881 enum {MISSING
= 0, ELEMENTAL
, SCALAR
, SCALAR_POINTER
, ARRAY
};
1883 arglist
= NULL_TREE
;
1884 retargs
= NULL_TREE
;
1885 stringargs
= NULL_TREE
;
1891 if (!sym
->attr
.elemental
)
1893 gcc_assert (se
->ss
->type
== GFC_SS_FUNCTION
);
1894 if (se
->ss
->useflags
)
1896 gcc_assert (gfc_return_by_reference (sym
)
1897 && sym
->result
->attr
.dimension
);
1898 gcc_assert (se
->loop
!= NULL
);
1900 /* Access the previously obtained result. */
1901 gfc_conv_tmp_array_ref (se
);
1902 gfc_advance_se_ss_chain (se
);
1906 info
= &se
->ss
->data
.info
;
1911 gfc_init_block (&post
);
1912 gfc_init_interface_mapping (&mapping
);
1913 need_interface_mapping
= ((sym
->ts
.type
== BT_CHARACTER
1914 && sym
->ts
.cl
->length
1915 && sym
->ts
.cl
->length
->expr_type
1917 || sym
->attr
.dimension
);
1918 formal
= sym
->formal
;
1919 /* Evaluate the arguments. */
1920 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
1923 fsym
= formal
? formal
->sym
: NULL
;
1924 parm_kind
= MISSING
;
1928 if (se
->ignore_optional
)
1930 /* Some intrinsics have already been resolved to the correct
1934 else if (arg
->label
)
1936 has_alternate_specifier
= 1;
1941 /* Pass a NULL pointer for an absent arg. */
1942 gfc_init_se (&parmse
, NULL
);
1943 parmse
.expr
= null_pointer_node
;
1944 if (arg
->missing_arg_type
== BT_CHARACTER
)
1945 parmse
.string_length
= build_int_cst (gfc_charlen_type_node
, 0);
1948 else if (se
->ss
&& se
->ss
->useflags
)
1950 /* An elemental function inside a scalarized loop. */
1951 gfc_init_se (&parmse
, se
);
1952 gfc_conv_expr_reference (&parmse
, e
);
1953 parm_kind
= ELEMENTAL
;
1957 /* A scalar or transformational function. */
1958 gfc_init_se (&parmse
, NULL
);
1959 argss
= gfc_walk_expr (e
);
1961 if (argss
== gfc_ss_terminator
)
1963 gfc_conv_expr_reference (&parmse
, e
);
1965 if (fsym
&& fsym
->attr
.pointer
1966 && e
->expr_type
!= EXPR_NULL
)
1968 /* Scalar pointer dummy args require an extra level of
1969 indirection. The null pointer already contains
1970 this level of indirection. */
1971 parm_kind
= SCALAR_POINTER
;
1972 parmse
.expr
= build_fold_addr_expr (parmse
.expr
);
1977 /* If the procedure requires an explicit interface, the actual
1978 argument is passed according to the corresponding formal
1979 argument. If the corresponding formal argument is a POINTER,
1980 ALLOCATABLE or assumed shape, we do not use g77's calling
1981 convention, and pass the address of the array descriptor
1982 instead. Otherwise we use g77's calling convention. */
1985 && !(fsym
->attr
.pointer
|| fsym
->attr
.allocatable
)
1986 && fsym
->as
->type
!= AS_ASSUMED_SHAPE
;
1987 f
= f
|| !sym
->attr
.always_explicit
;
1989 if (e
->expr_type
== EXPR_VARIABLE
1990 && is_aliased_array (e
))
1991 /* The actual argument is a component reference to an
1992 array of derived types. In this case, the argument
1993 is converted to a temporary, which is passed and then
1994 written back after the procedure call. */
1995 gfc_conv_aliased_arg (&parmse
, e
, f
,
1996 fsym
? fsym
->attr
.intent
: INTENT_INOUT
);
1998 gfc_conv_array_parameter (&parmse
, e
, argss
, f
);
2000 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2001 allocated on entry, it must be deallocated. */
2002 if (fsym
&& fsym
->attr
.allocatable
2003 && fsym
->attr
.intent
== INTENT_OUT
)
2005 tmp
= e
->symtree
->n
.sym
->backend_decl
;
2006 if (e
->symtree
->n
.sym
->attr
.dummy
)
2007 tmp
= build_fold_indirect_ref (tmp
);
2008 tmp
= gfc_trans_dealloc_allocated (tmp
);
2009 gfc_add_expr_to_block (&se
->pre
, tmp
);
2019 /* If an optional argument is itself an optional dummy
2020 argument, check its presence and substitute a null
2022 if (e
->expr_type
== EXPR_VARIABLE
2023 && e
->symtree
->n
.sym
->attr
.optional
2024 && fsym
->attr
.optional
)
2025 gfc_conv_missing_dummy (&parmse
, e
, fsym
->ts
);
2027 /* If an INTENT(OUT) dummy of derived type has a default
2028 initializer, it must be (re)initialized here. */
2029 if (fsym
->attr
.intent
== INTENT_OUT
2030 && fsym
->ts
.type
== BT_DERIVED
2033 gcc_assert (!fsym
->attr
.allocatable
);
2034 tmp
= gfc_trans_assignment (e
, fsym
->value
);
2035 gfc_add_expr_to_block (&se
->pre
, tmp
);
2038 /* Obtain the character length of an assumed character
2039 length procedure from the typespec. */
2040 if (fsym
->ts
.type
== BT_CHARACTER
2041 && parmse
.string_length
== NULL_TREE
2042 && e
->ts
.type
== BT_PROCEDURE
2043 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2044 && e
->symtree
->n
.sym
->ts
.cl
->length
!= NULL
)
2046 gfc_conv_const_charlen (e
->symtree
->n
.sym
->ts
.cl
);
2047 parmse
.string_length
2048 = e
->symtree
->n
.sym
->ts
.cl
->backend_decl
;
2052 if (need_interface_mapping
)
2053 gfc_add_interface_mapping (&mapping
, fsym
, &parmse
);
2056 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2057 gfc_add_block_to_block (&post
, &parmse
.post
);
2059 /* Allocated allocatable components of derived types must be
2060 deallocated for INTENT(OUT) dummy arguments and non-variable
2061 scalars. Non-variable arrays are dealt with in trans-array.c
2062 (gfc_conv_array_parameter). */
2063 if (e
&& e
->ts
.type
== BT_DERIVED
2064 && e
->ts
.derived
->attr
.alloc_comp
2065 && ((formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
)
2067 (e
->expr_type
!= EXPR_VARIABLE
&& !e
->rank
)))
2070 tmp
= build_fold_indirect_ref (parmse
.expr
);
2071 parm_rank
= e
->rank
;
2079 case (SCALAR_POINTER
):
2080 tmp
= build_fold_indirect_ref (tmp
);
2087 tmp
= gfc_deallocate_alloc_comp (e
->ts
.derived
, tmp
, parm_rank
);
2088 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
->attr
.optional
)
2089 tmp
= build3_v (COND_EXPR
, gfc_conv_expr_present (e
->symtree
->n
.sym
),
2090 tmp
, build_empty_stmt ());
2092 if (e
->expr_type
!= EXPR_VARIABLE
)
2093 /* Don't deallocate non-variables until they have been used. */
2094 gfc_add_expr_to_block (&se
->post
, tmp
);
2097 gcc_assert (formal
&& formal
->sym
->attr
.intent
== INTENT_OUT
);
2098 gfc_add_expr_to_block (&se
->pre
, tmp
);
2102 /* Character strings are passed as two parameters, a length and a
2104 if (parmse
.string_length
!= NULL_TREE
)
2105 stringargs
= gfc_chainon_list (stringargs
, parmse
.string_length
);
2107 arglist
= gfc_chainon_list (arglist
, parmse
.expr
);
2109 gfc_finish_interface_mapping (&mapping
, &se
->pre
, &se
->post
);
2112 if (ts
.type
== BT_CHARACTER
)
2114 if (sym
->ts
.cl
->length
== NULL
)
2116 /* Assumed character length results are not allowed by 5.1.1.5 of the
2117 standard and are trapped in resolve.c; except in the case of SPREAD
2118 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2119 we take the character length of the first argument for the result.
2120 For dummies, we have to look through the formal argument list for
2121 this function and use the character length found there.*/
2122 if (!sym
->attr
.dummy
)
2123 cl
.backend_decl
= TREE_VALUE (stringargs
);
2126 formal
= sym
->ns
->proc_name
->formal
;
2127 for (; formal
; formal
= formal
->next
)
2128 if (strcmp (formal
->sym
->name
, sym
->name
) == 0)
2129 cl
.backend_decl
= formal
->sym
->ts
.cl
->backend_decl
;
2134 /* Calculate the length of the returned string. */
2135 gfc_init_se (&parmse
, NULL
);
2136 if (need_interface_mapping
)
2137 gfc_apply_interface_mapping (&mapping
, &parmse
, sym
->ts
.cl
->length
);
2139 gfc_conv_expr (&parmse
, sym
->ts
.cl
->length
);
2140 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
2141 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
2142 cl
.backend_decl
= fold_convert (gfc_charlen_type_node
, parmse
.expr
);
2145 /* Set up a charlen structure for it. */
2150 len
= cl
.backend_decl
;
2153 byref
= gfc_return_by_reference (sym
);
2156 if (se
->direct_byref
)
2157 retargs
= gfc_chainon_list (retargs
, se
->expr
);
2158 else if (sym
->result
->attr
.dimension
)
2160 gcc_assert (se
->loop
&& info
);
2162 /* Set the type of the array. */
2163 tmp
= gfc_typenode_for_spec (&ts
);
2164 info
->dimen
= se
->loop
->dimen
;
2166 /* Evaluate the bounds of the result, if known. */
2167 gfc_set_loop_bounds_from_array_spec (&mapping
, se
, sym
->result
->as
);
2169 /* Create a temporary to store the result. In case the function
2170 returns a pointer, the temporary will be a shallow copy and
2171 mustn't be deallocated. */
2172 callee_alloc
= sym
->attr
.allocatable
|| sym
->attr
.pointer
;
2173 gfc_trans_create_temp_array (&se
->pre
, &se
->post
, se
->loop
, info
, tmp
,
2174 false, !sym
->attr
.pointer
, callee_alloc
,
2177 /* Pass the temporary as the first argument. */
2178 tmp
= info
->descriptor
;
2179 tmp
= build_fold_addr_expr (tmp
);
2180 retargs
= gfc_chainon_list (retargs
, tmp
);
2182 else if (ts
.type
== BT_CHARACTER
)
2184 /* Pass the string length. */
2185 type
= gfc_get_character_type (ts
.kind
, ts
.cl
);
2186 type
= build_pointer_type (type
);
2188 /* Return an address to a char[0:len-1]* temporary for
2189 character pointers. */
2190 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2192 /* Build char[0:len-1] * pstr. */
2193 tmp
= fold_build2 (MINUS_EXPR
, gfc_charlen_type_node
, len
,
2194 build_int_cst (gfc_charlen_type_node
, 1));
2195 tmp
= build_range_type (gfc_array_index_type
,
2196 gfc_index_zero_node
, tmp
);
2197 tmp
= build_array_type (gfc_character1_type_node
, tmp
);
2198 var
= gfc_create_var (build_pointer_type (tmp
), "pstr");
2200 /* Provide an address expression for the function arguments. */
2201 var
= build_fold_addr_expr (var
);
2204 var
= gfc_conv_string_tmp (se
, type
, len
);
2206 retargs
= gfc_chainon_list (retargs
, var
);
2210 gcc_assert (gfc_option
.flag_f2c
&& ts
.type
== BT_COMPLEX
);
2212 type
= gfc_get_complex_type (ts
.kind
);
2213 var
= build_fold_addr_expr (gfc_create_var (type
, "cmplx"));
2214 retargs
= gfc_chainon_list (retargs
, var
);
2217 /* Add the string length to the argument list. */
2218 if (ts
.type
== BT_CHARACTER
)
2219 retargs
= gfc_chainon_list (retargs
, len
);
2221 gfc_free_interface_mapping (&mapping
);
2223 /* Add the return arguments. */
2224 arglist
= chainon (retargs
, arglist
);
2226 /* Add the hidden string length parameters to the arguments. */
2227 arglist
= chainon (arglist
, stringargs
);
2229 /* Generate the actual call. */
2230 gfc_conv_function_val (se
, sym
);
2231 /* If there are alternate return labels, function type should be
2232 integer. Can't modify the type in place though, since it can be shared
2233 with other functions. */
2234 if (has_alternate_specifier
2235 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se
->expr
))) != integer_type_node
)
2237 gcc_assert (! sym
->attr
.dummy
);
2238 TREE_TYPE (sym
->backend_decl
)
2239 = build_function_type (integer_type_node
,
2240 TYPE_ARG_TYPES (TREE_TYPE (sym
->backend_decl
)));
2241 se
->expr
= build_fold_addr_expr (sym
->backend_decl
);
2244 fntype
= TREE_TYPE (TREE_TYPE (se
->expr
));
2245 se
->expr
= build3 (CALL_EXPR
, TREE_TYPE (fntype
), se
->expr
,
2246 arglist
, NULL_TREE
);
2248 /* If we have a pointer function, but we don't want a pointer, e.g.
2251 where f is pointer valued, we have to dereference the result. */
2252 if (!se
->want_pointer
&& !byref
&& sym
->attr
.pointer
)
2253 se
->expr
= build_fold_indirect_ref (se
->expr
);
2255 /* f2c calling conventions require a scalar default real function to
2256 return a double precision result. Convert this back to default
2257 real. We only care about the cases that can happen in Fortran 77.
2259 if (gfc_option
.flag_f2c
&& sym
->ts
.type
== BT_REAL
2260 && sym
->ts
.kind
== gfc_default_real_kind
2261 && !sym
->attr
.always_explicit
)
2262 se
->expr
= fold_convert (gfc_get_real_type (sym
->ts
.kind
), se
->expr
);
2264 /* A pure function may still have side-effects - it may modify its
2266 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2268 if (!sym
->attr
.pure
)
2269 TREE_SIDE_EFFECTS (se
->expr
) = 1;
2274 /* Add the function call to the pre chain. There is no expression. */
2275 gfc_add_expr_to_block (&se
->pre
, se
->expr
);
2276 se
->expr
= NULL_TREE
;
2278 if (!se
->direct_byref
)
2280 if (sym
->attr
.dimension
)
2282 if (flag_bounds_check
)
2284 /* Check the data pointer hasn't been modified. This would
2285 happen in a function returning a pointer. */
2286 tmp
= gfc_conv_descriptor_data_get (info
->descriptor
);
2287 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
,
2289 gfc_trans_runtime_check (tmp
, gfc_msg_fault
, &se
->pre
, NULL
);
2291 se
->expr
= info
->descriptor
;
2292 /* Bundle in the string length. */
2293 se
->string_length
= len
;
2295 else if (sym
->ts
.type
== BT_CHARACTER
)
2297 /* Dereference for character pointer results. */
2298 if (sym
->attr
.pointer
|| sym
->attr
.allocatable
)
2299 se
->expr
= build_fold_indirect_ref (var
);
2303 se
->string_length
= len
;
2307 gcc_assert (sym
->ts
.type
== BT_COMPLEX
&& gfc_option
.flag_f2c
);
2308 se
->expr
= build_fold_indirect_ref (var
);
2313 /* Follow the function call with the argument post block. */
2315 gfc_add_block_to_block (&se
->pre
, &post
);
2317 gfc_add_block_to_block (&se
->post
, &post
);
2319 return has_alternate_specifier
;
2323 /* Generate code to copy a string. */
2326 gfc_trans_string_copy (stmtblock_t
* block
, tree dlength
, tree dest
,
2327 tree slength
, tree src
)
2329 tree tmp
, dlen
, slen
;
2337 stmtblock_t tempblock
;
2339 dlen
= fold_convert (size_type_node
, gfc_evaluate_now (dlength
, block
));
2340 slen
= fold_convert (size_type_node
, gfc_evaluate_now (slength
, block
));
2342 /* Deal with single character specially. */
2343 dsc
= gfc_to_single_character (dlen
, dest
);
2344 ssc
= gfc_to_single_character (slen
, src
);
2345 if (dsc
!= NULL_TREE
&& ssc
!= NULL_TREE
)
2347 gfc_add_modify_expr (block
, dsc
, ssc
);
2351 /* Do nothing if the destination length is zero. */
2352 cond
= fold_build2 (GT_EXPR
, boolean_type_node
, dlen
,
2353 build_int_cst (gfc_charlen_type_node
, 0));
2355 /* The following code was previously in _gfortran_copy_string:
2357 // The two strings may overlap so we use memmove.
2359 copy_string (GFC_INTEGER_4 destlen, char * dest,
2360 GFC_INTEGER_4 srclen, const char * src)
2362 if (srclen >= destlen)
2364 // This will truncate if too long.
2365 memmove (dest, src, destlen);
2369 memmove (dest, src, srclen);
2371 memset (&dest[srclen], ' ', destlen - srclen);
2375 We're now doing it here for better optimization, but the logic
2378 /* Truncate string if source is too long. */
2379 cond2
= fold_build2 (GE_EXPR
, boolean_type_node
, slen
, dlen
);
2380 tmp2
= gfc_chainon_list (NULL_TREE
, dest
);
2381 tmp2
= gfc_chainon_list (tmp2
, src
);
2382 tmp2
= gfc_chainon_list (tmp2
, dlen
);
2383 tmp2
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp2
);
2385 /* Else copy and pad with spaces. */
2386 tmp3
= gfc_chainon_list (NULL_TREE
, dest
);
2387 tmp3
= gfc_chainon_list (tmp3
, src
);
2388 tmp3
= gfc_chainon_list (tmp3
, slen
);
2389 tmp3
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMMOVE
], tmp3
);
2391 tmp4
= fold_build2 (PLUS_EXPR
, pchar_type_node
, dest
,
2392 fold_convert (pchar_type_node
, slen
));
2393 tmp4
= gfc_chainon_list (NULL_TREE
, tmp4
);
2394 tmp4
= gfc_chainon_list (tmp4
, build_int_cst
2395 (gfc_get_int_type (gfc_c_int_kind
),
2396 lang_hooks
.to_target_charset (' ')));
2397 tmp4
= gfc_chainon_list (tmp4
, fold_build2 (MINUS_EXPR
, TREE_TYPE(dlen
),
2399 tmp4
= build_function_call_expr (built_in_decls
[BUILT_IN_MEMSET
], tmp4
);
2401 gfc_init_block (&tempblock
);
2402 gfc_add_expr_to_block (&tempblock
, tmp3
);
2403 gfc_add_expr_to_block (&tempblock
, tmp4
);
2404 tmp3
= gfc_finish_block (&tempblock
);
2406 /* The whole copy_string function is there. */
2407 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond2
, tmp2
, tmp3
);
2408 tmp
= fold_build3 (COND_EXPR
, void_type_node
, cond
, tmp
, build_empty_stmt ());
2409 gfc_add_expr_to_block (block
, tmp
);
2413 /* Translate a statement function.
2414 The value of a statement function reference is obtained by evaluating the
2415 expression using the values of the actual arguments for the values of the
2416 corresponding dummy arguments. */
2419 gfc_conv_statement_function (gfc_se
* se
, gfc_expr
* expr
)
2423 gfc_formal_arglist
*fargs
;
2424 gfc_actual_arglist
*args
;
2427 gfc_saved_var
*saved_vars
;
2433 sym
= expr
->symtree
->n
.sym
;
2434 args
= expr
->value
.function
.actual
;
2435 gfc_init_se (&lse
, NULL
);
2436 gfc_init_se (&rse
, NULL
);
2439 for (fargs
= sym
->formal
; fargs
; fargs
= fargs
->next
)
2441 saved_vars
= (gfc_saved_var
*)gfc_getmem (n
* sizeof (gfc_saved_var
));
2442 temp_vars
= (tree
*)gfc_getmem (n
* sizeof (tree
));
2444 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2446 /* Each dummy shall be specified, explicitly or implicitly, to be
2448 gcc_assert (fargs
->sym
->attr
.dimension
== 0);
2451 /* Create a temporary to hold the value. */
2452 type
= gfc_typenode_for_spec (&fsym
->ts
);
2453 temp_vars
[n
] = gfc_create_var (type
, fsym
->name
);
2455 if (fsym
->ts
.type
== BT_CHARACTER
)
2457 /* Copy string arguments. */
2460 gcc_assert (fsym
->ts
.cl
&& fsym
->ts
.cl
->length
2461 && fsym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
2463 arglen
= TYPE_MAX_VALUE (TYPE_DOMAIN (type
));
2464 tmp
= gfc_build_addr_expr (build_pointer_type (type
),
2467 gfc_conv_expr (&rse
, args
->expr
);
2468 gfc_conv_string_parameter (&rse
);
2469 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2470 gfc_add_block_to_block (&se
->pre
, &rse
.pre
);
2472 gfc_trans_string_copy (&se
->pre
, arglen
, tmp
, rse
.string_length
,
2474 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2475 gfc_add_block_to_block (&se
->pre
, &rse
.post
);
2479 /* For everything else, just evaluate the expression. */
2480 gfc_conv_expr (&lse
, args
->expr
);
2482 gfc_add_block_to_block (&se
->pre
, &lse
.pre
);
2483 gfc_add_modify_expr (&se
->pre
, temp_vars
[n
], lse
.expr
);
2484 gfc_add_block_to_block (&se
->pre
, &lse
.post
);
2490 /* Use the temporary variables in place of the real ones. */
2491 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2492 gfc_shadow_sym (fargs
->sym
, temp_vars
[n
], &saved_vars
[n
]);
2494 gfc_conv_expr (se
, sym
->value
);
2496 if (sym
->ts
.type
== BT_CHARACTER
)
2498 gfc_conv_const_charlen (sym
->ts
.cl
);
2500 /* Force the expression to the correct length. */
2501 if (!INTEGER_CST_P (se
->string_length
)
2502 || tree_int_cst_lt (se
->string_length
,
2503 sym
->ts
.cl
->backend_decl
))
2505 type
= gfc_get_character_type (sym
->ts
.kind
, sym
->ts
.cl
);
2506 tmp
= gfc_create_var (type
, sym
->name
);
2507 tmp
= gfc_build_addr_expr (build_pointer_type (type
), tmp
);
2508 gfc_trans_string_copy (&se
->pre
, sym
->ts
.cl
->backend_decl
, tmp
,
2509 se
->string_length
, se
->expr
);
2512 se
->string_length
= sym
->ts
.cl
->backend_decl
;
2515 /* Restore the original variables. */
2516 for (fargs
= sym
->formal
, n
= 0; fargs
; fargs
= fargs
->next
, n
++)
2517 gfc_restore_sym (fargs
->sym
, &saved_vars
[n
]);
2518 gfc_free (saved_vars
);
2522 /* Translate a function expression. */
2525 gfc_conv_function_expr (gfc_se
* se
, gfc_expr
* expr
)
2529 if (expr
->value
.function
.isym
)
2531 gfc_conv_intrinsic_function (se
, expr
);
2535 /* We distinguish statement functions from general functions to improve
2536 runtime performance. */
2537 if (expr
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2539 gfc_conv_statement_function (se
, expr
);
2543 /* expr.value.function.esym is the resolved (specific) function symbol for
2544 most functions. However this isn't set for dummy procedures. */
2545 sym
= expr
->value
.function
.esym
;
2547 sym
= expr
->symtree
->n
.sym
;
2548 gfc_conv_function_call (se
, sym
, expr
->value
.function
.actual
);
2553 gfc_conv_array_constructor_expr (gfc_se
* se
, gfc_expr
* expr
)
2555 gcc_assert (se
->ss
!= NULL
&& se
->ss
!= gfc_ss_terminator
);
2556 gcc_assert (se
->ss
->expr
== expr
&& se
->ss
->type
== GFC_SS_CONSTRUCTOR
);
2558 gfc_conv_tmp_array_ref (se
);
2559 gfc_advance_se_ss_chain (se
);
2563 /* Build a static initializer. EXPR is the expression for the initial value.
2564 The other parameters describe the variable of the component being
2565 initialized. EXPR may be null. */
2568 gfc_conv_initializer (gfc_expr
* expr
, gfc_typespec
* ts
, tree type
,
2569 bool array
, bool pointer
)
2573 if (!(expr
|| pointer
))
2578 /* Arrays need special handling. */
2580 return gfc_build_null_descriptor (type
);
2582 return gfc_conv_array_initializer (type
, expr
);
2585 return fold_convert (type
, null_pointer_node
);
2591 gfc_init_se (&se
, NULL
);
2592 gfc_conv_structure (&se
, expr
, 1);
2596 return gfc_conv_string_init (ts
->cl
->backend_decl
,expr
);
2599 gfc_init_se (&se
, NULL
);
2600 gfc_conv_constant (&se
, expr
);
2607 gfc_trans_subarray_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2619 gfc_start_block (&block
);
2621 /* Initialize the scalarizer. */
2622 gfc_init_loopinfo (&loop
);
2624 gfc_init_se (&lse
, NULL
);
2625 gfc_init_se (&rse
, NULL
);
2628 rss
= gfc_walk_expr (expr
);
2629 if (rss
== gfc_ss_terminator
)
2631 /* The rhs is scalar. Add a ss for the expression. */
2632 rss
= gfc_get_ss ();
2633 rss
->next
= gfc_ss_terminator
;
2634 rss
->type
= GFC_SS_SCALAR
;
2638 /* Create a SS for the destination. */
2639 lss
= gfc_get_ss ();
2640 lss
->type
= GFC_SS_COMPONENT
;
2642 lss
->shape
= gfc_get_shape (cm
->as
->rank
);
2643 lss
->next
= gfc_ss_terminator
;
2644 lss
->data
.info
.dimen
= cm
->as
->rank
;
2645 lss
->data
.info
.descriptor
= dest
;
2646 lss
->data
.info
.data
= gfc_conv_array_data (dest
);
2647 lss
->data
.info
.offset
= gfc_conv_array_offset (dest
);
2648 for (n
= 0; n
< cm
->as
->rank
; n
++)
2650 lss
->data
.info
.dim
[n
] = n
;
2651 lss
->data
.info
.start
[n
] = gfc_conv_array_lbound (dest
, n
);
2652 lss
->data
.info
.stride
[n
] = gfc_index_one_node
;
2654 mpz_init (lss
->shape
[n
]);
2655 mpz_sub (lss
->shape
[n
], cm
->as
->upper
[n
]->value
.integer
,
2656 cm
->as
->lower
[n
]->value
.integer
);
2657 mpz_add_ui (lss
->shape
[n
], lss
->shape
[n
], 1);
2660 /* Associate the SS with the loop. */
2661 gfc_add_ss_to_loop (&loop
, lss
);
2662 gfc_add_ss_to_loop (&loop
, rss
);
2664 /* Calculate the bounds of the scalarization. */
2665 gfc_conv_ss_startstride (&loop
);
2667 /* Setup the scalarizing loops. */
2668 gfc_conv_loop_setup (&loop
);
2670 /* Setup the gfc_se structures. */
2671 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2672 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2675 gfc_mark_ss_chain_used (rss
, 1);
2677 gfc_mark_ss_chain_used (lss
, 1);
2679 /* Start the scalarized loop body. */
2680 gfc_start_scalarized_body (&loop
, &body
);
2682 gfc_conv_tmp_array_ref (&lse
);
2683 if (cm
->ts
.type
== BT_CHARACTER
)
2684 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2686 gfc_conv_expr (&rse
, expr
);
2688 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, cm
->ts
, true, false);
2689 gfc_add_expr_to_block (&body
, tmp
);
2691 gcc_assert (rse
.ss
== gfc_ss_terminator
);
2693 /* Generate the copying loops. */
2694 gfc_trans_scalarizing_loops (&loop
, &body
);
2696 /* Wrap the whole thing up. */
2697 gfc_add_block_to_block (&block
, &loop
.pre
);
2698 gfc_add_block_to_block (&block
, &loop
.post
);
2700 for (n
= 0; n
< cm
->as
->rank
; n
++)
2701 mpz_clear (lss
->shape
[n
]);
2702 gfc_free (lss
->shape
);
2704 gfc_cleanup_loop (&loop
);
2706 return gfc_finish_block (&block
);
2710 /* Assign a single component of a derived type constructor. */
2713 gfc_trans_subcomponent_assign (tree dest
, gfc_component
* cm
, gfc_expr
* expr
)
2723 gfc_start_block (&block
);
2727 gfc_init_se (&se
, NULL
);
2728 /* Pointer component. */
2731 /* Array pointer. */
2732 if (expr
->expr_type
== EXPR_NULL
)
2733 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2736 rss
= gfc_walk_expr (expr
);
2737 se
.direct_byref
= 1;
2739 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2740 gfc_add_block_to_block (&block
, &se
.pre
);
2741 gfc_add_block_to_block (&block
, &se
.post
);
2746 /* Scalar pointers. */
2747 se
.want_pointer
= 1;
2748 gfc_conv_expr (&se
, expr
);
2749 gfc_add_block_to_block (&block
, &se
.pre
);
2750 gfc_add_modify_expr (&block
, dest
,
2751 fold_convert (TREE_TYPE (dest
), se
.expr
));
2752 gfc_add_block_to_block (&block
, &se
.post
);
2755 else if (cm
->dimension
)
2757 if (cm
->allocatable
&& expr
->expr_type
== EXPR_NULL
)
2758 gfc_conv_descriptor_data_set (&block
, dest
, null_pointer_node
);
2759 else if (cm
->allocatable
)
2763 gfc_init_se (&se
, NULL
);
2765 rss
= gfc_walk_expr (expr
);
2766 se
.want_pointer
= 0;
2767 gfc_conv_expr_descriptor (&se
, expr
, rss
);
2768 gfc_add_block_to_block (&block
, &se
.pre
);
2770 tmp
= fold_convert (TREE_TYPE (dest
), se
.expr
);
2771 gfc_add_modify_expr (&block
, dest
, tmp
);
2773 if (cm
->ts
.type
== BT_DERIVED
&& cm
->ts
.derived
->attr
.alloc_comp
)
2774 tmp
= gfc_copy_alloc_comp (cm
->ts
.derived
, se
.expr
, dest
,
2777 tmp
= gfc_duplicate_allocatable (dest
, se
.expr
,
2778 TREE_TYPE(cm
->backend_decl
),
2781 gfc_add_expr_to_block (&block
, tmp
);
2783 gfc_add_block_to_block (&block
, &se
.post
);
2784 gfc_conv_descriptor_data_set (&block
, se
.expr
, null_pointer_node
);
2786 /* Shift the lbound and ubound of temporaries to being unity, rather
2787 than zero, based. Calculate the offset for all cases. */
2788 offset
= gfc_conv_descriptor_offset (dest
);
2789 gfc_add_modify_expr (&block
, offset
, gfc_index_zero_node
);
2790 tmp2
=gfc_create_var (gfc_array_index_type
, NULL
);
2791 for (n
= 0; n
< expr
->rank
; n
++)
2793 if (expr
->expr_type
!= EXPR_VARIABLE
2794 && expr
->expr_type
!= EXPR_CONSTANT
)
2796 tmp
= gfc_conv_descriptor_ubound (dest
, gfc_rank_cst
[n
]);
2797 gfc_add_modify_expr (&block
, tmp
,
2798 fold_build2 (PLUS_EXPR
,
2799 gfc_array_index_type
,
2800 tmp
, gfc_index_one_node
));
2801 tmp
= gfc_conv_descriptor_lbound (dest
, gfc_rank_cst
[n
]);
2802 gfc_add_modify_expr (&block
, tmp
, gfc_index_one_node
);
2804 tmp
= fold_build2 (MULT_EXPR
, gfc_array_index_type
,
2805 gfc_conv_descriptor_lbound (dest
,
2807 gfc_conv_descriptor_stride (dest
,
2809 gfc_add_modify_expr (&block
, tmp2
, tmp
);
2810 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, offset
, tmp2
);
2811 gfc_add_modify_expr (&block
, offset
, tmp
);
2816 tmp
= gfc_trans_subarray_assign (dest
, cm
, expr
);
2817 gfc_add_expr_to_block (&block
, tmp
);
2820 else if (expr
->ts
.type
== BT_DERIVED
)
2822 if (expr
->expr_type
!= EXPR_STRUCTURE
)
2824 gfc_init_se (&se
, NULL
);
2825 gfc_conv_expr (&se
, expr
);
2826 gfc_add_modify_expr (&block
, dest
,
2827 fold_convert (TREE_TYPE (dest
), se
.expr
));
2831 /* Nested constructors. */
2832 tmp
= gfc_trans_structure_assign (dest
, expr
);
2833 gfc_add_expr_to_block (&block
, tmp
);
2838 /* Scalar component. */
2839 gfc_init_se (&se
, NULL
);
2840 gfc_init_se (&lse
, NULL
);
2842 gfc_conv_expr (&se
, expr
);
2843 if (cm
->ts
.type
== BT_CHARACTER
)
2844 lse
.string_length
= cm
->ts
.cl
->backend_decl
;
2846 tmp
= gfc_trans_scalar_assign (&lse
, &se
, cm
->ts
, true, false);
2847 gfc_add_expr_to_block (&block
, tmp
);
2849 return gfc_finish_block (&block
);
2852 /* Assign a derived type constructor to a variable. */
2855 gfc_trans_structure_assign (tree dest
, gfc_expr
* expr
)
2863 gfc_start_block (&block
);
2864 cm
= expr
->ts
.derived
->components
;
2865 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2867 /* Skip absent members in default initializers. */
2871 field
= cm
->backend_decl
;
2872 tmp
= build3 (COMPONENT_REF
, TREE_TYPE (field
), dest
, field
, NULL_TREE
);
2873 tmp
= gfc_trans_subcomponent_assign (tmp
, cm
, c
->expr
);
2874 gfc_add_expr_to_block (&block
, tmp
);
2876 return gfc_finish_block (&block
);
2879 /* Build an expression for a constructor. If init is nonzero then
2880 this is part of a static variable initializer. */
2883 gfc_conv_structure (gfc_se
* se
, gfc_expr
* expr
, int init
)
2890 VEC(constructor_elt
,gc
) *v
= NULL
;
2892 gcc_assert (se
->ss
== NULL
);
2893 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
2894 type
= gfc_typenode_for_spec (&expr
->ts
);
2898 /* Create a temporary variable and fill it in. */
2899 se
->expr
= gfc_create_var (type
, expr
->ts
.derived
->name
);
2900 tmp
= gfc_trans_structure_assign (se
->expr
, expr
);
2901 gfc_add_expr_to_block (&se
->pre
, tmp
);
2905 cm
= expr
->ts
.derived
->components
;
2907 for (c
= expr
->value
.constructor
; c
; c
= c
->next
, cm
= cm
->next
)
2909 /* Skip absent members in default initializers and allocatable
2910 components. Although the latter have a default initializer
2911 of EXPR_NULL,... by default, the static nullify is not needed
2912 since this is done every time we come into scope. */
2913 if (!c
->expr
|| cm
->allocatable
)
2916 val
= gfc_conv_initializer (c
->expr
, &cm
->ts
,
2917 TREE_TYPE (cm
->backend_decl
), cm
->dimension
, cm
->pointer
);
2919 /* Append it to the constructor list. */
2920 CONSTRUCTOR_APPEND_ELT (v
, cm
->backend_decl
, val
);
2922 se
->expr
= build_constructor (type
, v
);
2926 /* Translate a substring expression. */
2929 gfc_conv_substring_expr (gfc_se
* se
, gfc_expr
* expr
)
2935 gcc_assert (ref
->type
== REF_SUBSTRING
);
2937 se
->expr
= gfc_build_string_const(expr
->value
.character
.length
,
2938 expr
->value
.character
.string
);
2939 se
->string_length
= TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se
->expr
)));
2940 TYPE_STRING_FLAG (TREE_TYPE (se
->expr
))=1;
2942 gfc_conv_substring(se
,ref
,expr
->ts
.kind
);
2946 /* Entry point for expression translation. Evaluates a scalar quantity.
2947 EXPR is the expression to be translated, and SE is the state structure if
2948 called from within the scalarized. */
2951 gfc_conv_expr (gfc_se
* se
, gfc_expr
* expr
)
2953 if (se
->ss
&& se
->ss
->expr
== expr
2954 && (se
->ss
->type
== GFC_SS_SCALAR
|| se
->ss
->type
== GFC_SS_REFERENCE
))
2956 /* Substitute a scalar expression evaluated outside the scalarization
2958 se
->expr
= se
->ss
->data
.scalar
.expr
;
2959 se
->string_length
= se
->ss
->string_length
;
2960 gfc_advance_se_ss_chain (se
);
2964 switch (expr
->expr_type
)
2967 gfc_conv_expr_op (se
, expr
);
2971 gfc_conv_function_expr (se
, expr
);
2975 gfc_conv_constant (se
, expr
);
2979 gfc_conv_variable (se
, expr
);
2983 se
->expr
= null_pointer_node
;
2986 case EXPR_SUBSTRING
:
2987 gfc_conv_substring_expr (se
, expr
);
2990 case EXPR_STRUCTURE
:
2991 gfc_conv_structure (se
, expr
, 0);
2995 gfc_conv_array_constructor_expr (se
, expr
);
3004 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3005 of an assignment. */
3007 gfc_conv_expr_lhs (gfc_se
* se
, gfc_expr
* expr
)
3009 gfc_conv_expr (se
, expr
);
3010 /* All numeric lvalues should have empty post chains. If not we need to
3011 figure out a way of rewriting an lvalue so that it has no post chain. */
3012 gcc_assert (expr
->ts
.type
== BT_CHARACTER
|| !se
->post
.head
);
3015 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3016 numeric expressions. Used for scalar values where inserting cleanup code
3019 gfc_conv_expr_val (gfc_se
* se
, gfc_expr
* expr
)
3023 gcc_assert (expr
->ts
.type
!= BT_CHARACTER
);
3024 gfc_conv_expr (se
, expr
);
3027 val
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3028 gfc_add_modify_expr (&se
->pre
, val
, se
->expr
);
3030 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3034 /* Helper to translate and expression and convert it to a particular type. */
3036 gfc_conv_expr_type (gfc_se
* se
, gfc_expr
* expr
, tree type
)
3038 gfc_conv_expr_val (se
, expr
);
3039 se
->expr
= convert (type
, se
->expr
);
3043 /* Converts an expression so that it can be passed by reference. Scalar
3047 gfc_conv_expr_reference (gfc_se
* se
, gfc_expr
* expr
)
3051 if (se
->ss
&& se
->ss
->expr
== expr
3052 && se
->ss
->type
== GFC_SS_REFERENCE
)
3054 se
->expr
= se
->ss
->data
.scalar
.expr
;
3055 se
->string_length
= se
->ss
->string_length
;
3056 gfc_advance_se_ss_chain (se
);
3060 if (expr
->ts
.type
== BT_CHARACTER
)
3062 gfc_conv_expr (se
, expr
);
3063 gfc_conv_string_parameter (se
);
3067 if (expr
->expr_type
== EXPR_VARIABLE
)
3069 se
->want_pointer
= 1;
3070 gfc_conv_expr (se
, expr
);
3073 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3074 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3075 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3081 gfc_conv_expr (se
, expr
);
3083 /* Create a temporary var to hold the value. */
3084 if (TREE_CONSTANT (se
->expr
))
3086 var
= build_decl (CONST_DECL
, NULL
, TREE_TYPE (se
->expr
));
3087 DECL_INITIAL (var
) = se
->expr
;
3092 var
= gfc_create_var (TREE_TYPE (se
->expr
), NULL
);
3093 gfc_add_modify_expr (&se
->pre
, var
, se
->expr
);
3095 gfc_add_block_to_block (&se
->pre
, &se
->post
);
3097 /* Take the address of that value. */
3098 se
->expr
= build_fold_addr_expr (var
);
3103 gfc_trans_pointer_assign (gfc_code
* code
)
3105 return gfc_trans_pointer_assignment (code
->expr
, code
->expr2
);
3109 /* Generate code for a pointer assignment. */
3112 gfc_trans_pointer_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3122 gfc_start_block (&block
);
3124 gfc_init_se (&lse
, NULL
);
3126 lss
= gfc_walk_expr (expr1
);
3127 rss
= gfc_walk_expr (expr2
);
3128 if (lss
== gfc_ss_terminator
)
3130 /* Scalar pointers. */
3131 lse
.want_pointer
= 1;
3132 gfc_conv_expr (&lse
, expr1
);
3133 gcc_assert (rss
== gfc_ss_terminator
);
3134 gfc_init_se (&rse
, NULL
);
3135 rse
.want_pointer
= 1;
3136 gfc_conv_expr (&rse
, expr2
);
3137 gfc_add_block_to_block (&block
, &lse
.pre
);
3138 gfc_add_block_to_block (&block
, &rse
.pre
);
3139 gfc_add_modify_expr (&block
, lse
.expr
,
3140 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3141 gfc_add_block_to_block (&block
, &rse
.post
);
3142 gfc_add_block_to_block (&block
, &lse
.post
);
3146 /* Array pointer. */
3147 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3148 switch (expr2
->expr_type
)
3151 /* Just set the data pointer to null. */
3152 gfc_conv_descriptor_data_set (&lse
.pre
, lse
.expr
, null_pointer_node
);
3156 /* Assign directly to the pointer's descriptor. */
3157 lse
.direct_byref
= 1;
3158 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3162 /* Assign to a temporary descriptor and then copy that
3163 temporary to the pointer. */
3165 tmp
= gfc_create_var (TREE_TYPE (desc
), "ptrtemp");
3168 lse
.direct_byref
= 1;
3169 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3170 gfc_add_modify_expr (&lse
.pre
, desc
, tmp
);
3173 gfc_add_block_to_block (&block
, &lse
.pre
);
3174 gfc_add_block_to_block (&block
, &lse
.post
);
3176 return gfc_finish_block (&block
);
3180 /* Makes sure se is suitable for passing as a function string parameter. */
3181 /* TODO: Need to check all callers fo this function. It may be abused. */
3184 gfc_conv_string_parameter (gfc_se
* se
)
3188 if (TREE_CODE (se
->expr
) == STRING_CST
)
3190 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3194 type
= TREE_TYPE (se
->expr
);
3195 if (TYPE_STRING_FLAG (type
))
3197 gcc_assert (TREE_CODE (se
->expr
) != INDIRECT_REF
);
3198 se
->expr
= gfc_build_addr_expr (pchar_type_node
, se
->expr
);
3201 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se
->expr
)));
3202 gcc_assert (se
->string_length
3203 && TREE_CODE (TREE_TYPE (se
->string_length
)) == INTEGER_TYPE
);
3207 /* Generate code for assignment of scalar variables. Includes character
3208 strings and derived types with allocatable components. */
3211 gfc_trans_scalar_assign (gfc_se
* lse
, gfc_se
* rse
, gfc_typespec ts
,
3212 bool l_is_temp
, bool r_is_var
)
3218 gfc_init_block (&block
);
3220 if (ts
.type
== BT_CHARACTER
)
3222 gcc_assert (lse
->string_length
!= NULL_TREE
3223 && rse
->string_length
!= NULL_TREE
);
3225 gfc_conv_string_parameter (lse
);
3226 gfc_conv_string_parameter (rse
);
3228 gfc_add_block_to_block (&block
, &lse
->pre
);
3229 gfc_add_block_to_block (&block
, &rse
->pre
);
3231 gfc_trans_string_copy (&block
, lse
->string_length
, lse
->expr
,
3232 rse
->string_length
, rse
->expr
);
3234 else if (ts
.type
== BT_DERIVED
&& ts
.derived
->attr
.alloc_comp
)
3238 /* Are the rhs and the lhs the same? */
3241 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
,
3242 build_fold_addr_expr (lse
->expr
),
3243 build_fold_addr_expr (rse
->expr
));
3244 cond
= gfc_evaluate_now (cond
, &lse
->pre
);
3247 /* Deallocate the lhs allocated components as long as it is not
3248 the same as the rhs. */
3251 tmp
= gfc_deallocate_alloc_comp (ts
.derived
, lse
->expr
, 0);
3253 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3254 gfc_add_expr_to_block (&lse
->pre
, tmp
);
3257 gfc_add_block_to_block (&block
, &lse
->pre
);
3258 gfc_add_block_to_block (&block
, &rse
->pre
);
3260 gfc_add_modify_expr (&block
, lse
->expr
,
3261 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3263 /* Do a deep copy if the rhs is a variable, if it is not the
3267 tmp
= gfc_copy_alloc_comp (ts
.derived
, rse
->expr
, lse
->expr
, 0);
3268 tmp
= build3_v (COND_EXPR
, cond
, build_empty_stmt (), tmp
);
3269 gfc_add_expr_to_block (&block
, tmp
);
3274 gfc_add_block_to_block (&block
, &lse
->pre
);
3275 gfc_add_block_to_block (&block
, &rse
->pre
);
3277 gfc_add_modify_expr (&block
, lse
->expr
,
3278 fold_convert (TREE_TYPE (lse
->expr
), rse
->expr
));
3281 gfc_add_block_to_block (&block
, &lse
->post
);
3282 gfc_add_block_to_block (&block
, &rse
->post
);
3284 return gfc_finish_block (&block
);
3288 /* Try to translate array(:) = func (...), where func is a transformational
3289 array function, without using a temporary. Returns NULL is this isn't the
3293 gfc_trans_arrayfunc_assign (gfc_expr
* expr1
, gfc_expr
* expr2
)
3298 bool seen_array_ref
;
3300 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3301 if (expr2
->value
.function
.isym
&& !gfc_is_intrinsic_libcall (expr2
))
3304 /* Elemental functions don't need a temporary anyway. */
3305 if (expr2
->value
.function
.esym
!= NULL
3306 && expr2
->value
.function
.esym
->attr
.elemental
)
3309 /* Fail if EXPR1 can't be expressed as a descriptor. */
3310 if (gfc_ref_needs_temporary_p (expr1
->ref
))
3313 /* Functions returning pointers need temporaries. */
3314 if (expr2
->symtree
->n
.sym
->attr
.pointer
3315 || expr2
->symtree
->n
.sym
->attr
.allocatable
)
3318 /* Check that no LHS component references appear during an array
3319 reference. This is needed because we do not have the means to
3320 span any arbitrary stride with an array descriptor. This check
3321 is not needed for the rhs because the function result has to be
3323 seen_array_ref
= false;
3324 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
3326 if (ref
->type
== REF_ARRAY
)
3327 seen_array_ref
= true;
3328 else if (ref
->type
== REF_COMPONENT
&& seen_array_ref
)
3332 /* Check for a dependency. */
3333 if (gfc_check_fncall_dependency (expr1
, INTENT_OUT
,
3334 expr2
->value
.function
.esym
,
3335 expr2
->value
.function
.actual
))
3338 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3340 gcc_assert (expr2
->value
.function
.isym
3341 || (gfc_return_by_reference (expr2
->value
.function
.esym
)
3342 && expr2
->value
.function
.esym
->result
->attr
.dimension
));
3344 ss
= gfc_walk_expr (expr1
);
3345 gcc_assert (ss
!= gfc_ss_terminator
);
3346 gfc_init_se (&se
, NULL
);
3347 gfc_start_block (&se
.pre
);
3348 se
.want_pointer
= 1;
3350 gfc_conv_array_parameter (&se
, expr1
, ss
, 0);
3352 se
.direct_byref
= 1;
3353 se
.ss
= gfc_walk_expr (expr2
);
3354 gcc_assert (se
.ss
!= gfc_ss_terminator
);
3355 gfc_conv_function_expr (&se
, expr2
);
3356 gfc_add_block_to_block (&se
.pre
, &se
.post
);
3358 return gfc_finish_block (&se
.pre
);
3362 /* Translate an assignment. Most of the code is concerned with
3363 setting up the scalarizer. */
3366 gfc_trans_assignment (gfc_expr
* expr1
, gfc_expr
* expr2
)
3371 gfc_ss
*lss_section
;
3379 /* Special case a single function returning an array. */
3380 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3382 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3387 /* Assignment of the form lhs = rhs. */
3388 gfc_start_block (&block
);
3390 gfc_init_se (&lse
, NULL
);
3391 gfc_init_se (&rse
, NULL
);
3394 lss
= gfc_walk_expr (expr1
);
3396 if (lss
!= gfc_ss_terminator
)
3398 /* The assignment needs scalarization. */
3401 /* Find a non-scalar SS from the lhs. */
3402 while (lss_section
!= gfc_ss_terminator
3403 && lss_section
->type
!= GFC_SS_SECTION
)
3404 lss_section
= lss_section
->next
;
3406 gcc_assert (lss_section
!= gfc_ss_terminator
);
3408 /* Initialize the scalarizer. */
3409 gfc_init_loopinfo (&loop
);
3412 rss
= gfc_walk_expr (expr2
);
3413 if (rss
== gfc_ss_terminator
)
3415 /* The rhs is scalar. Add a ss for the expression. */
3416 rss
= gfc_get_ss ();
3417 rss
->next
= gfc_ss_terminator
;
3418 rss
->type
= GFC_SS_SCALAR
;
3421 /* Associate the SS with the loop. */
3422 gfc_add_ss_to_loop (&loop
, lss
);
3423 gfc_add_ss_to_loop (&loop
, rss
);
3425 /* Calculate the bounds of the scalarization. */
3426 gfc_conv_ss_startstride (&loop
);
3427 /* Resolve any data dependencies in the statement. */
3428 gfc_conv_resolve_dependencies (&loop
, lss
, rss
);
3429 /* Setup the scalarizing loops. */
3430 gfc_conv_loop_setup (&loop
);
3432 /* Setup the gfc_se structures. */
3433 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3434 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3437 gfc_mark_ss_chain_used (rss
, 1);
3438 if (loop
.temp_ss
== NULL
)
3441 gfc_mark_ss_chain_used (lss
, 1);
3445 lse
.ss
= loop
.temp_ss
;
3446 gfc_mark_ss_chain_used (lss
, 3);
3447 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3450 /* Start the scalarized loop body. */
3451 gfc_start_scalarized_body (&loop
, &body
);
3454 gfc_init_block (&body
);
3456 l_is_temp
= (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
);
3458 /* Translate the expression. */
3459 gfc_conv_expr (&rse
, expr2
);
3463 gfc_conv_tmp_array_ref (&lse
);
3464 gfc_advance_se_ss_chain (&lse
);
3467 gfc_conv_expr (&lse
, expr1
);
3469 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, l_is_temp
,
3470 expr2
->expr_type
== EXPR_VARIABLE
);
3471 gfc_add_expr_to_block (&body
, tmp
);
3473 if (lss
== gfc_ss_terminator
)
3475 /* Use the scalar assignment as is. */
3476 gfc_add_block_to_block (&block
, &body
);
3480 gcc_assert (lse
.ss
== gfc_ss_terminator
3481 && rse
.ss
== gfc_ss_terminator
);
3485 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3487 /* We need to copy the temporary to the actual lhs. */
3488 gfc_init_se (&lse
, NULL
);
3489 gfc_init_se (&rse
, NULL
);
3490 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3491 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3493 rse
.ss
= loop
.temp_ss
;
3496 gfc_conv_tmp_array_ref (&rse
);
3497 gfc_advance_se_ss_chain (&rse
);
3498 gfc_conv_expr (&lse
, expr1
);
3500 gcc_assert (lse
.ss
== gfc_ss_terminator
3501 && rse
.ss
== gfc_ss_terminator
);
3503 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, false);
3504 gfc_add_expr_to_block (&body
, tmp
);
3507 /* Generate the copying loops. */
3508 gfc_trans_scalarizing_loops (&loop
, &body
);
3510 /* Wrap the whole thing up. */
3511 gfc_add_block_to_block (&block
, &loop
.pre
);
3512 gfc_add_block_to_block (&block
, &loop
.post
);
3514 gfc_cleanup_loop (&loop
);
3517 return gfc_finish_block (&block
);
3521 gfc_trans_assign (gfc_code
* code
)
3523 return gfc_trans_assignment (code
->expr
, code
->expr2
);