1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2015 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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
29 #include "double-int.h"
37 #include "fold-const.h"
38 #include "stringpool.h"
42 #include "trans-stmt.h"
43 #include "trans-types.h"
44 #include "trans-array.h"
45 #include "trans-const.h"
47 #include "dependency.h"
50 typedef struct iter_info
56 struct iter_info
*next
;
60 typedef struct forall_info
67 struct forall_info
*prev_nest
;
72 static void gfc_trans_where_2 (gfc_code
*, tree
, bool,
73 forall_info
*, stmtblock_t
*);
75 /* Translate a F95 label number to a LABEL_EXPR. */
78 gfc_trans_label_here (gfc_code
* code
)
80 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
84 /* Given a variable expression which has been ASSIGNed to, find the decl
85 containing the auxiliary variables. For variables in common blocks this
89 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
91 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
92 gfc_conv_expr (se
, expr
);
93 /* Deals with variable in common block. Get the field declaration. */
94 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
95 se
->expr
= TREE_OPERAND (se
->expr
, 1);
96 /* Deals with dummy argument. Get the parameter declaration. */
97 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
98 se
->expr
= TREE_OPERAND (se
->expr
, 0);
101 /* Translate a label assignment statement. */
104 gfc_trans_label_assign (gfc_code
* code
)
113 /* Start a new block. */
114 gfc_init_se (&se
, NULL
);
115 gfc_start_block (&se
.pre
);
116 gfc_conv_label_variable (&se
, code
->expr1
);
118 len
= GFC_DECL_STRING_LEN (se
.expr
);
119 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
121 label_tree
= gfc_get_label_decl (code
->label1
);
123 if (code
->label1
->defined
== ST_LABEL_TARGET
124 || code
->label1
->defined
== ST_LABEL_DO_TARGET
)
126 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
127 len_tree
= integer_minus_one_node
;
131 gfc_expr
*format
= code
->label1
->format
;
133 label_len
= format
->value
.character
.length
;
134 len_tree
= build_int_cst (gfc_charlen_type_node
, label_len
);
135 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
136 format
->value
.character
.string
);
137 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
140 gfc_add_modify (&se
.pre
, len
, len_tree
);
141 gfc_add_modify (&se
.pre
, addr
, label_tree
);
143 return gfc_finish_block (&se
.pre
);
146 /* Translate a GOTO statement. */
149 gfc_trans_goto (gfc_code
* code
)
151 locus loc
= code
->loc
;
157 if (code
->label1
!= NULL
)
158 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
161 gfc_init_se (&se
, NULL
);
162 gfc_start_block (&se
.pre
);
163 gfc_conv_label_variable (&se
, code
->expr1
);
164 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
165 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
166 build_int_cst (TREE_TYPE (tmp
), -1));
167 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
168 "Assigned label is not a target label");
170 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
172 /* We're going to ignore a label list. It does not really change the
173 statement's semantics (because it is just a further restriction on
174 what's legal code); before, we were comparing label addresses here, but
175 that's a very fragile business and may break with optimization. So
178 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
180 gfc_add_expr_to_block (&se
.pre
, target
);
181 return gfc_finish_block (&se
.pre
);
185 /* Translate an ENTRY statement. Just adds a label for this entry point. */
187 gfc_trans_entry (gfc_code
* code
)
189 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
193 /* Replace a gfc_ss structure by another both in the gfc_se struct
194 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
195 to replace a variable ss by the corresponding temporary. */
198 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
200 gfc_ss
**sess
, **loopss
;
202 /* The old_ss is a ss for a single variable. */
203 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
205 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
208 gcc_assert (*sess
!= gfc_ss_terminator
);
211 new_ss
->next
= old_ss
->next
;
214 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
215 loopss
= &((*loopss
)->loop_chain
))
216 if (*loopss
== old_ss
)
218 gcc_assert (*loopss
!= gfc_ss_terminator
);
221 new_ss
->loop_chain
= old_ss
->loop_chain
;
222 new_ss
->loop
= old_ss
->loop
;
224 gfc_free_ss (old_ss
);
228 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
229 elemental subroutines. Make temporaries for output arguments if any such
230 dependencies are found. Output arguments are chosen because internal_unpack
231 can be used, as is, to copy the result back to the variable. */
233 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
234 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
235 gfc_dep_check check_variable
)
237 gfc_actual_arglist
*arg0
;
239 gfc_formal_arglist
*formal
;
247 if (loopse
->ss
== NULL
)
252 formal
= gfc_sym_get_dummy_args (sym
);
254 /* Loop over all the arguments testing for dependencies. */
255 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
261 /* Obtain the info structure for the current argument. */
262 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
263 if (ss
->info
->expr
== e
)
266 /* If there is a dependency, create a temporary and use it
267 instead of the variable. */
268 fsym
= formal
? formal
->sym
: NULL
;
269 if (e
->expr_type
== EXPR_VARIABLE
271 && fsym
->attr
.intent
!= INTENT_IN
272 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
273 sym
, arg0
, check_variable
))
275 tree initial
, temptype
;
276 stmtblock_t temp_post
;
279 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
281 gfc_mark_ss_chain_used (tmp_ss
, 1);
282 tmp_ss
->info
->expr
= ss
->info
->expr
;
283 replace_ss (loopse
, ss
, tmp_ss
);
285 /* Obtain the argument descriptor for unpacking. */
286 gfc_init_se (&parmse
, NULL
);
287 parmse
.want_pointer
= 1;
288 gfc_conv_expr_descriptor (&parmse
, e
);
289 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
291 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
292 initialize the array temporary with a copy of the values. */
293 if (fsym
->attr
.intent
== INTENT_INOUT
294 || (fsym
->ts
.type
==BT_DERIVED
295 && fsym
->attr
.intent
== INTENT_OUT
))
296 initial
= parmse
.expr
;
297 /* For class expressions, we always initialize with the copy of
299 else if (e
->ts
.type
== BT_CLASS
)
300 initial
= parmse
.expr
;
304 if (e
->ts
.type
!= BT_CLASS
)
306 /* Find the type of the temporary to create; we don't use the type
307 of e itself as this breaks for subcomponent-references in e
308 (where the type of e is that of the final reference, but
309 parmse.expr's type corresponds to the full derived-type). */
310 /* TODO: Fix this somehow so we don't need a temporary of the whole
311 array but instead only the components referenced. */
312 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
313 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
314 temptype
= TREE_TYPE (temptype
);
315 temptype
= gfc_get_element_type (temptype
);
319 /* For class arrays signal that the size of the dynamic type has to
320 be obtained from the vtable, using the 'initial' expression. */
321 temptype
= NULL_TREE
;
323 /* Generate the temporary. Cleaning up the temporary should be the
324 very last thing done, so we add the code to a new block and add it
325 to se->post as last instructions. */
326 size
= gfc_create_var (gfc_array_index_type
, NULL
);
327 data
= gfc_create_var (pvoid_type_node
, NULL
);
328 gfc_init_block (&temp_post
);
329 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
330 temptype
, initial
, false, true,
331 false, &arg
->expr
->where
);
332 gfc_add_modify (&se
->pre
, size
, tmp
);
333 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
334 gfc_add_modify (&se
->pre
, data
, tmp
);
336 /* Update other ss' delta. */
337 gfc_set_delta (loopse
->loop
);
339 /* Copy the result back using unpack..... */
340 if (e
->ts
.type
!= BT_CLASS
)
341 tmp
= build_call_expr_loc (input_location
,
342 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
345 /* ... except for class results where the copy is
347 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
348 tmp
= gfc_conv_descriptor_data_get (tmp
);
349 tmp
= build_call_expr_loc (input_location
,
350 builtin_decl_explicit (BUILT_IN_MEMCPY
),
352 fold_convert (size_type_node
, size
));
354 gfc_add_expr_to_block (&se
->post
, tmp
);
356 /* parmse.pre is already added above. */
357 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
358 gfc_add_block_to_block (&se
->post
, &temp_post
);
364 /* Get the interface symbol for the procedure corresponding to the given call.
365 We can't get the procedure symbol directly as we have to handle the case
366 of (deferred) type-bound procedures. */
369 get_proc_ifc_for_call (gfc_code
*c
)
373 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
375 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
377 /* Fall back/last resort try. */
379 sym
= c
->resolved_sym
;
385 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
388 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
389 tree mask
, tree count1
, bool invert
)
393 int has_alternate_specifier
;
394 gfc_dep_check check_variable
;
395 tree index
= NULL_TREE
;
396 tree maskexpr
= NULL_TREE
;
399 /* A CALL starts a new block because the actual arguments may have to
400 be evaluated first. */
401 gfc_init_se (&se
, NULL
);
402 gfc_start_block (&se
.pre
);
404 gcc_assert (code
->resolved_sym
);
406 ss
= gfc_ss_terminator
;
407 if (code
->resolved_sym
->attr
.elemental
)
408 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
409 get_proc_ifc_for_call (code
),
412 /* Is not an elemental subroutine call with array valued arguments. */
413 if (ss
== gfc_ss_terminator
)
416 /* Translate the call. */
417 has_alternate_specifier
418 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
421 /* A subroutine without side-effect, by definition, does nothing! */
422 TREE_SIDE_EFFECTS (se
.expr
) = 1;
424 /* Chain the pieces together and return the block. */
425 if (has_alternate_specifier
)
427 gfc_code
*select_code
;
429 select_code
= code
->next
;
430 gcc_assert(select_code
->op
== EXEC_SELECT
);
431 sym
= select_code
->expr1
->symtree
->n
.sym
;
432 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
433 if (sym
->backend_decl
== NULL
)
434 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
435 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
438 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
440 gfc_add_block_to_block (&se
.pre
, &se
.post
);
445 /* An elemental subroutine call with array valued arguments has
453 /* gfc_walk_elemental_function_args renders the ss chain in the
454 reverse order to the actual argument order. */
455 ss
= gfc_reverse_ss (ss
);
457 /* Initialize the loop. */
458 gfc_init_se (&loopse
, NULL
);
459 gfc_init_loopinfo (&loop
);
460 gfc_add_ss_to_loop (&loop
, ss
);
462 gfc_conv_ss_startstride (&loop
);
463 /* TODO: gfc_conv_loop_setup generates a temporary for vector
464 subscripts. This could be prevented in the elemental case
465 as temporaries are handled separatedly
466 (below in gfc_conv_elemental_dependencies). */
467 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
468 gfc_mark_ss_chain_used (ss
, 1);
470 /* Convert the arguments, checking for dependencies. */
471 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
474 /* For operator assignment, do dependency checking. */
475 if (dependency_check
)
476 check_variable
= ELEM_CHECK_VARIABLE
;
478 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
480 gfc_init_se (&depse
, NULL
);
481 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
482 code
->ext
.actual
, check_variable
);
484 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
485 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
487 /* Generate the loop body. */
488 gfc_start_scalarized_body (&loop
, &body
);
489 gfc_init_block (&block
);
493 /* Form the mask expression according to the mask. */
495 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
497 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
498 TREE_TYPE (maskexpr
), maskexpr
);
501 /* Add the subroutine call to the block. */
502 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
503 code
->ext
.actual
, code
->expr1
,
508 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
509 build_empty_stmt (input_location
));
510 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
511 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
512 gfc_array_index_type
,
513 count1
, gfc_index_one_node
);
514 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
517 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
519 gfc_add_block_to_block (&block
, &loopse
.pre
);
520 gfc_add_block_to_block (&block
, &loopse
.post
);
522 /* Finish up the loop block and the loop. */
523 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
524 gfc_trans_scalarizing_loops (&loop
, &body
);
525 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
526 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
527 gfc_add_block_to_block (&se
.pre
, &se
.post
);
528 gfc_cleanup_loop (&loop
);
531 return gfc_finish_block (&se
.pre
);
535 /* Translate the RETURN statement. */
538 gfc_trans_return (gfc_code
* code
)
546 /* If code->expr is not NULL, this return statement must appear
547 in a subroutine and current_fake_result_decl has already
550 result
= gfc_get_fake_result_decl (NULL
, 0);
554 "An alternate return at %L without a * dummy argument",
555 &code
->expr1
->where
);
556 return gfc_generate_return ();
559 /* Start a new block for this statement. */
560 gfc_init_se (&se
, NULL
);
561 gfc_start_block (&se
.pre
);
563 gfc_conv_expr (&se
, code
->expr1
);
565 /* Note that the actually returned expression is a simple value and
566 does not depend on any pointers or such; thus we can clean-up with
567 se.post before returning. */
568 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
569 result
, fold_convert (TREE_TYPE (result
),
571 gfc_add_expr_to_block (&se
.pre
, tmp
);
572 gfc_add_block_to_block (&se
.pre
, &se
.post
);
574 tmp
= gfc_generate_return ();
575 gfc_add_expr_to_block (&se
.pre
, tmp
);
576 return gfc_finish_block (&se
.pre
);
579 return gfc_generate_return ();
583 /* Translate the PAUSE statement. We have to translate this statement
584 to a runtime library call. */
587 gfc_trans_pause (gfc_code
* code
)
589 tree gfc_int4_type_node
= gfc_get_int_type (4);
593 /* Start a new block for this statement. */
594 gfc_init_se (&se
, NULL
);
595 gfc_start_block (&se
.pre
);
598 if (code
->expr1
== NULL
)
600 tmp
= build_int_cst (gfc_int4_type_node
, 0);
601 tmp
= build_call_expr_loc (input_location
,
602 gfor_fndecl_pause_string
, 2,
603 build_int_cst (pchar_type_node
, 0), tmp
);
605 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
607 gfc_conv_expr (&se
, code
->expr1
);
608 tmp
= build_call_expr_loc (input_location
,
609 gfor_fndecl_pause_numeric
, 1,
610 fold_convert (gfc_int4_type_node
, se
.expr
));
614 gfc_conv_expr_reference (&se
, code
->expr1
);
615 tmp
= build_call_expr_loc (input_location
,
616 gfor_fndecl_pause_string
, 2,
617 se
.expr
, se
.string_length
);
620 gfc_add_expr_to_block (&se
.pre
, tmp
);
622 gfc_add_block_to_block (&se
.pre
, &se
.post
);
624 return gfc_finish_block (&se
.pre
);
628 /* Translate the STOP statement. We have to translate this statement
629 to a runtime library call. */
632 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
634 tree gfc_int4_type_node
= gfc_get_int_type (4);
638 /* Start a new block for this statement. */
639 gfc_init_se (&se
, NULL
);
640 gfc_start_block (&se
.pre
);
642 if (code
->expr1
== NULL
)
644 tmp
= build_int_cst (gfc_int4_type_node
, 0);
645 tmp
= build_call_expr_loc (input_location
,
647 ? (flag_coarray
== GFC_FCOARRAY_LIB
648 ? gfor_fndecl_caf_error_stop_str
649 : gfor_fndecl_error_stop_string
)
650 : gfor_fndecl_stop_string
,
651 2, build_int_cst (pchar_type_node
, 0), tmp
);
653 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
655 gfc_conv_expr (&se
, code
->expr1
);
656 tmp
= build_call_expr_loc (input_location
,
658 ? (flag_coarray
== GFC_FCOARRAY_LIB
659 ? gfor_fndecl_caf_error_stop
660 : gfor_fndecl_error_stop_numeric
)
661 : gfor_fndecl_stop_numeric_f08
, 1,
662 fold_convert (gfc_int4_type_node
, se
.expr
));
666 gfc_conv_expr_reference (&se
, code
->expr1
);
667 tmp
= build_call_expr_loc (input_location
,
669 ? (flag_coarray
== GFC_FCOARRAY_LIB
670 ? gfor_fndecl_caf_error_stop_str
671 : gfor_fndecl_error_stop_string
)
672 : gfor_fndecl_stop_string
,
673 2, se
.expr
, se
.string_length
);
676 gfc_add_expr_to_block (&se
.pre
, tmp
);
678 gfc_add_block_to_block (&se
.pre
, &se
.post
);
680 return gfc_finish_block (&se
.pre
);
685 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
688 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
689 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
691 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
692 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
693 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
698 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
699 gfc_init_se (&argse
, NULL
);
700 gfc_conv_expr_val (&argse
, code
->expr2
);
703 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
704 stat
= null_pointer_node
;
708 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
709 gfc_init_se (&argse
, NULL
);
710 gfc_conv_expr_val (&argse
, code
->expr4
);
711 lock_acquired
= argse
.expr
;
713 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
714 lock_acquired
= null_pointer_node
;
716 gfc_start_block (&se
.pre
);
717 if (flag_coarray
== GFC_FCOARRAY_LIB
)
719 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
720 tree index
= size_zero_node
;
721 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
723 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
724 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
725 != INTMOD_ISO_FORTRAN_ENV
726 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
727 != ISOFORTRAN_LOCK_TYPE
)
729 gfc_error ("Sorry, the lock component of derived type at %L is not "
730 "yet supported", &code
->expr1
->where
);
734 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, code
->expr1
);
736 if (gfc_is_coindexed (code
->expr1
))
737 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
739 image_index
= integer_zero_node
;
741 /* For arrays, obtain the array index. */
742 if (gfc_expr_attr (code
->expr1
).dimension
)
744 tree desc
, tmp
, extent
, lbound
, ubound
;
745 gfc_array_ref
*ar
, ar2
;
748 /* TODO: Extend this, once DT components are supported. */
749 ar
= &code
->expr1
->ref
->u
.ar
;
751 memset (ar
, '\0', sizeof (*ar
));
755 gfc_init_se (&argse
, NULL
);
756 argse
.descriptor_only
= 1;
757 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
758 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
762 extent
= integer_one_node
;
763 for (i
= 0; i
< ar
->dimen
; i
++)
765 gfc_init_se (&argse
, NULL
);
766 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
767 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
768 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
769 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
770 integer_type_node
, argse
.expr
,
771 fold_convert(integer_type_node
, lbound
));
772 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
773 integer_type_node
, extent
, tmp
);
774 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
775 integer_type_node
, index
, tmp
);
776 if (i
< ar
->dimen
- 1)
778 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
779 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
780 tmp
= fold_convert (integer_type_node
, tmp
);
781 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
782 integer_type_node
, extent
, tmp
);
790 gfc_init_se (&argse
, NULL
);
791 gfc_conv_expr (&argse
, code
->expr3
);
792 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
794 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
798 errmsg
= null_pointer_node
;
799 errmsg_len
= integer_zero_node
;
802 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
805 stat
= gfc_create_var (integer_type_node
, "stat");
808 if (lock_acquired
!= null_pointer_node
809 && TREE_TYPE (lock_acquired
) != integer_type_node
)
811 lock_acquired2
= lock_acquired
;
812 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
816 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
817 token
, index
, image_index
,
818 lock_acquired
!= null_pointer_node
819 ? gfc_build_addr_expr (NULL
, lock_acquired
)
821 stat
!= null_pointer_node
822 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
825 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
826 token
, index
, image_index
,
827 stat
!= null_pointer_node
828 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
830 gfc_add_expr_to_block (&se
.pre
, tmp
);
832 if (stat2
!= NULL_TREE
)
833 gfc_add_modify (&se
.pre
, stat2
,
834 fold_convert (TREE_TYPE (stat2
), stat
));
836 if (lock_acquired2
!= NULL_TREE
)
837 gfc_add_modify (&se
.pre
, lock_acquired2
,
838 fold_convert (TREE_TYPE (lock_acquired2
),
841 return gfc_finish_block (&se
.pre
);
844 if (stat
!= NULL_TREE
)
845 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
847 if (lock_acquired
!= NULL_TREE
)
848 gfc_add_modify (&se
.pre
, lock_acquired
,
849 fold_convert (TREE_TYPE (lock_acquired
),
852 return gfc_finish_block (&se
.pre
);
857 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
861 tree images
= NULL_TREE
, stat
= NULL_TREE
,
862 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
864 /* Short cut: For single images without bound checking or without STAT=,
865 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
866 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
867 && flag_coarray
!= GFC_FCOARRAY_LIB
)
870 gfc_init_se (&se
, NULL
);
871 gfc_start_block (&se
.pre
);
873 if (code
->expr1
&& code
->expr1
->rank
== 0)
875 gfc_init_se (&argse
, NULL
);
876 gfc_conv_expr_val (&argse
, code
->expr1
);
882 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
883 gfc_init_se (&argse
, NULL
);
884 gfc_conv_expr_val (&argse
, code
->expr2
);
888 stat
= null_pointer_node
;
890 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
892 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
893 gfc_init_se (&argse
, NULL
);
894 gfc_conv_expr (&argse
, code
->expr3
);
895 gfc_conv_string_parameter (&argse
);
896 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
897 errmsglen
= argse
.string_length
;
899 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
901 errmsg
= null_pointer_node
;
902 errmsglen
= build_int_cst (integer_type_node
, 0);
905 /* Check SYNC IMAGES(imageset) for valid image index.
906 FIXME: Add a check for image-set arrays. */
907 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
908 && code
->expr1
->rank
== 0)
911 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
912 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
913 images
, build_int_cst (TREE_TYPE (images
), 1));
917 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
918 2, integer_zero_node
,
919 build_int_cst (integer_type_node
, -1));
920 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
922 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
924 build_int_cst (TREE_TYPE (images
), 1));
925 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
926 boolean_type_node
, cond
, cond2
);
928 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
929 &code
->expr1
->where
, "Invalid image number "
931 fold_convert (integer_type_node
, images
));
934 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
936 /* Set STAT to zero. */
938 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
940 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
942 /* SYNC ALL => stat == null_pointer_node
943 SYNC ALL(stat=s) => stat has an integer type
945 If "stat" has the wrong integer type, use a temp variable of
946 the right type and later cast the result back into "stat". */
947 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
949 if (TREE_TYPE (stat
) == integer_type_node
)
950 stat
= gfc_build_addr_expr (NULL
, stat
);
952 if(type
== EXEC_SYNC_MEMORY
)
953 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
954 3, stat
, errmsg
, errmsglen
);
956 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
957 3, stat
, errmsg
, errmsglen
);
959 gfc_add_expr_to_block (&se
.pre
, tmp
);
963 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
965 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
966 3, gfc_build_addr_expr (NULL
, tmp_stat
),
968 gfc_add_expr_to_block (&se
.pre
, tmp
);
970 gfc_add_modify (&se
.pre
, stat
,
971 fold_convert (TREE_TYPE (stat
), tmp_stat
));
978 gcc_assert (type
== EXEC_SYNC_IMAGES
);
982 len
= build_int_cst (integer_type_node
, -1);
983 images
= null_pointer_node
;
985 else if (code
->expr1
->rank
== 0)
987 len
= build_int_cst (integer_type_node
, 1);
988 images
= gfc_build_addr_expr (NULL_TREE
, images
);
993 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
994 gfc_fatal_error ("Sorry, only support for integer kind %d "
995 "implemented for image-set at %L",
996 gfc_c_int_kind
, &code
->expr1
->where
);
998 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1001 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1002 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1003 tmp
= gfc_get_element_type (tmp
);
1005 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1006 TREE_TYPE (len
), len
,
1007 fold_convert (TREE_TYPE (len
),
1008 TYPE_SIZE_UNIT (tmp
)));
1009 len
= fold_convert (integer_type_node
, len
);
1012 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1013 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1015 If "stat" has the wrong integer type, use a temp variable of
1016 the right type and later cast the result back into "stat". */
1017 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1019 if (TREE_TYPE (stat
) == integer_type_node
)
1020 stat
= gfc_build_addr_expr (NULL
, stat
);
1022 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1023 5, fold_convert (integer_type_node
, len
),
1024 images
, stat
, errmsg
, errmsglen
);
1025 gfc_add_expr_to_block (&se
.pre
, tmp
);
1029 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1031 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1032 5, fold_convert (integer_type_node
, len
),
1033 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1035 gfc_add_expr_to_block (&se
.pre
, tmp
);
1037 gfc_add_modify (&se
.pre
, stat
,
1038 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1042 return gfc_finish_block (&se
.pre
);
1046 /* Generate GENERIC for the IF construct. This function also deals with
1047 the simple IF statement, because the front end translates the IF
1048 statement into an IF construct.
1080 where COND_S is the simplified version of the predicate. PRE_COND_S
1081 are the pre side-effects produced by the translation of the
1083 We need to build the chain recursively otherwise we run into
1084 problems with folding incomplete statements. */
1087 gfc_trans_if_1 (gfc_code
* code
)
1090 tree stmt
, elsestmt
;
1094 /* Check for an unconditional ELSE clause. */
1096 return gfc_trans_code (code
->next
);
1098 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1099 gfc_init_se (&if_se
, NULL
);
1100 gfc_start_block (&if_se
.pre
);
1102 /* Calculate the IF condition expression. */
1103 if (code
->expr1
->where
.lb
)
1105 gfc_save_backend_locus (&saved_loc
);
1106 gfc_set_backend_locus (&code
->expr1
->where
);
1109 gfc_conv_expr_val (&if_se
, code
->expr1
);
1111 if (code
->expr1
->where
.lb
)
1112 gfc_restore_backend_locus (&saved_loc
);
1114 /* Translate the THEN clause. */
1115 stmt
= gfc_trans_code (code
->next
);
1117 /* Translate the ELSE clause. */
1119 elsestmt
= gfc_trans_if_1 (code
->block
);
1121 elsestmt
= build_empty_stmt (input_location
);
1123 /* Build the condition expression and add it to the condition block. */
1124 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1125 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1128 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1130 /* Finish off this statement. */
1131 return gfc_finish_block (&if_se
.pre
);
1135 gfc_trans_if (gfc_code
* code
)
1140 /* Create exit label so it is available for trans'ing the body code. */
1141 exit_label
= gfc_build_label_decl (NULL_TREE
);
1142 code
->exit_label
= exit_label
;
1144 /* Translate the actual code in code->block. */
1145 gfc_init_block (&body
);
1146 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1148 /* Add exit label. */
1149 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1151 return gfc_finish_block (&body
);
1155 /* Translate an arithmetic IF expression.
1157 IF (cond) label1, label2, label3 translates to
1169 An optimized version can be generated in case of equal labels.
1170 E.g., if label1 is equal to label2, we can translate it to
1179 gfc_trans_arithmetic_if (gfc_code
* code
)
1187 /* Start a new block. */
1188 gfc_init_se (&se
, NULL
);
1189 gfc_start_block (&se
.pre
);
1191 /* Pre-evaluate COND. */
1192 gfc_conv_expr_val (&se
, code
->expr1
);
1193 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1195 /* Build something to compare with. */
1196 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1198 if (code
->label1
->value
!= code
->label2
->value
)
1200 /* If (cond < 0) take branch1 else take branch2.
1201 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1202 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1203 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1205 if (code
->label1
->value
!= code
->label3
->value
)
1206 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1209 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1212 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1213 tmp
, branch1
, branch2
);
1216 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1218 if (code
->label1
->value
!= code
->label3
->value
1219 && code
->label2
->value
!= code
->label3
->value
)
1221 /* if (cond <= 0) take branch1 else take branch2. */
1222 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1223 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1225 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1226 tmp
, branch1
, branch2
);
1229 /* Append the COND_EXPR to the evaluation of COND, and return. */
1230 gfc_add_expr_to_block (&se
.pre
, branch1
);
1231 return gfc_finish_block (&se
.pre
);
1235 /* Translate a CRITICAL block. */
1237 gfc_trans_critical (gfc_code
*code
)
1240 tree tmp
, token
= NULL_TREE
;
1242 gfc_start_block (&block
);
1244 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1246 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1247 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1248 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1249 token
, integer_zero_node
, integer_one_node
,
1250 null_pointer_node
, null_pointer_node
,
1251 null_pointer_node
, integer_zero_node
);
1252 gfc_add_expr_to_block (&block
, tmp
);
1255 tmp
= gfc_trans_code (code
->block
->next
);
1256 gfc_add_expr_to_block (&block
, tmp
);
1258 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1260 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1261 token
, integer_zero_node
, integer_one_node
,
1262 null_pointer_node
, null_pointer_node
,
1264 gfc_add_expr_to_block (&block
, tmp
);
1268 return gfc_finish_block (&block
);
1272 /* Return true, when the class has a _len component. */
1275 class_has_len_component (gfc_symbol
*sym
)
1277 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1280 if (strcmp (comp
->name
, "_len") == 0)
1288 /* Do proper initialization for ASSOCIATE names. */
1291 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1302 bool need_len_assign
;
1304 gcc_assert (sym
->assoc
);
1305 e
= sym
->assoc
->target
;
1307 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1308 && (gfc_is_class_scalar_expr (e
)
1309 || gfc_is_class_array_ref (e
, NULL
));
1311 unlimited
= UNLIMITED_POLY (e
);
1313 /* Assignments to the string length need to be generated, when
1314 ( sym is a char array or
1315 sym has a _len component)
1316 and the associated expression is unlimited polymorphic, which is
1317 not (yet) correctly in 'unlimited', because for an already associated
1318 BT_DERIVED the u-poly flag is not set, i.e.,
1319 __tmp_CHARACTER_0_1 => w => arg
1320 ^ generated temp ^ from code, the w does not have the u-poly
1321 flag set, where UNLIMITED_POLY(e) expects it. */
1322 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1323 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1324 && (sym
->ts
.type
== BT_CHARACTER
1325 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1326 && class_has_len_component (sym
))));
1327 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1328 to array temporary) for arrays with either unknown shape or if associating
1330 if (sym
->attr
.dimension
&& !class_target
1331 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1335 bool cst_array_ctor
;
1337 desc
= sym
->backend_decl
;
1338 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1339 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1341 /* If association is to an expression, evaluate it and create temporary.
1342 Otherwise, get descriptor of target for pointer assignment. */
1343 gfc_init_se (&se
, NULL
);
1344 if (sym
->assoc
->variable
|| cst_array_ctor
)
1346 se
.direct_byref
= 1;
1351 gfc_conv_expr_descriptor (&se
, e
);
1353 /* If we didn't already do the pointer assignment, set associate-name
1354 descriptor to the one generated for the temporary. */
1355 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1359 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1361 /* The generated descriptor has lower bound zero (as array
1362 temporary), shift bounds so we get lower bounds of 1. */
1363 for (dim
= 0; dim
< e
->rank
; ++dim
)
1364 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1365 dim
, gfc_index_one_node
);
1368 /* If this is a subreference array pointer associate name use the
1369 associate variable element size for the value of 'span'. */
1370 if (sym
->attr
.subref_array_pointer
)
1372 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1373 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1374 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1375 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1376 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1379 /* Done, register stuff as init / cleanup code. */
1380 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1381 gfc_finish_block (&se
.post
));
1384 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1385 arrays to be assigned directly. */
1386 else if (class_target
&& sym
->attr
.dimension
1387 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1391 gfc_init_se (&se
, NULL
);
1392 se
.descriptor_only
= 1;
1393 /* In a select type the (temporary) associate variable shall point to
1394 a standard fortran array (lower bound == 1), but conv_expr ()
1395 just maps to the input array in the class object, whose lbound may
1396 be arbitrary. conv_expr_descriptor solves this by inserting a
1397 temporary array descriptor. */
1398 gfc_conv_expr_descriptor (&se
, e
);
1400 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1401 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1402 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1404 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1406 if (INDIRECT_REF_P (se
.expr
))
1407 tmp
= TREE_OPERAND (se
.expr
, 0);
1411 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1412 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1415 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1419 /* Recover the dtype, which has been overwritten by the
1420 assignment from an unlimited polymorphic object. */
1421 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1422 gfc_add_modify (&se
.pre
, tmp
,
1423 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1426 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1427 gfc_finish_block (&se
.post
));
1430 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1431 else if (gfc_is_associate_pointer (sym
))
1435 gcc_assert (!sym
->attr
.dimension
);
1437 gfc_init_se (&se
, NULL
);
1439 /* Class associate-names come this way because they are
1440 unconditionally associate pointers and the symbol is scalar. */
1441 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1444 /* For a class array we need a descriptor for the selector. */
1445 gfc_conv_expr_descriptor (&se
, e
);
1446 /* Needed to get/set the _len component below. */
1447 target_expr
= se
.expr
;
1449 /* Obtain a temporary class container for the result. */
1450 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1451 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1453 /* Set the offset. */
1454 desc
= gfc_class_data_get (se
.expr
);
1455 offset
= gfc_index_zero_node
;
1456 for (n
= 0; n
< e
->rank
; n
++)
1458 dim
= gfc_rank_cst
[n
];
1459 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1460 gfc_array_index_type
,
1461 gfc_conv_descriptor_stride_get (desc
, dim
),
1462 gfc_conv_descriptor_lbound_get (desc
, dim
));
1463 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1464 gfc_array_index_type
,
1467 if (need_len_assign
)
1470 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1471 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1472 /* Use the original class descriptor stored in the saved
1473 descriptor to get the target_expr. */
1475 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1477 /* Strip the _data component from the target_expr. */
1478 target_expr
= TREE_OPERAND (target_expr
, 0);
1479 /* Add a reference to the _len comp to the target expr. */
1480 tmp
= gfc_class_len_get (target_expr
);
1481 /* Get the component-ref for the temp structure's _len comp. */
1482 charlen
= gfc_class_len_get (se
.expr
);
1483 /* Add the assign to the beginning of the the block... */
1484 gfc_add_modify (&se
.pre
, charlen
,
1485 fold_convert (TREE_TYPE (charlen
), tmp
));
1486 /* and the oposite way at the end of the block, to hand changes
1487 on the string length back. */
1488 gfc_add_modify (&se
.post
, tmp
,
1489 fold_convert (TREE_TYPE (tmp
), charlen
));
1490 /* Length assignment done, prevent adding it again below. */
1491 need_len_assign
= false;
1493 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1495 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1496 && CLASS_DATA (e
)->attr
.dimension
)
1498 /* This is bound to be a class array element. */
1499 gfc_conv_expr_reference (&se
, e
);
1500 /* Get the _vptr component of the class object. */
1501 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1502 /* Obtain a temporary class container for the result. */
1503 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1504 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1508 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1509 which has the string length included. For CHARACTERS it is still
1510 needed and will be done at the end of this routine. */
1511 gfc_conv_expr (&se
, e
);
1512 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1515 tmp
= TREE_TYPE (sym
->backend_decl
);
1516 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1517 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1519 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1520 gfc_finish_block (&se
.post
));
1523 /* Do a simple assignment. This is for scalar expressions, where we
1524 can simply use expression assignment. */
1529 lhs
= gfc_lval_expr_from_sym (sym
);
1530 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1531 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1534 /* Set the stringlength, when needed. */
1535 if (need_len_assign
)
1538 gfc_init_se (&se
, NULL
);
1539 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1541 /* What about deferred strings? */
1542 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1543 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1546 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1547 gfc_get_symbol_decl (sym
);
1548 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1549 : gfc_class_len_get (sym
->backend_decl
);
1550 /* Prevent adding a noop len= len. */
1553 gfc_add_modify (&se
.pre
, charlen
,
1554 fold_convert (TREE_TYPE (charlen
), tmp
));
1555 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1556 gfc_finish_block (&se
.post
));
1562 /* Translate a BLOCK construct. This is basically what we would do for a
1566 gfc_trans_block_construct (gfc_code
* code
)
1570 gfc_wrapped_block block
;
1573 gfc_association_list
*ass
;
1575 ns
= code
->ext
.block
.ns
;
1577 sym
= ns
->proc_name
;
1580 /* Process local variables. */
1581 gcc_assert (!sym
->tlink
);
1583 gfc_process_block_locals (ns
);
1585 /* Generate code including exit-label. */
1586 gfc_init_block (&body
);
1587 exit_label
= gfc_build_label_decl (NULL_TREE
);
1588 code
->exit_label
= exit_label
;
1590 /* Generate !$ACC DECLARE directive. */
1591 if (ns
->oacc_declare_clauses
)
1593 tree tmp
= gfc_trans_oacc_declare (&body
, ns
);
1594 gfc_add_expr_to_block (&body
, tmp
);
1597 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1598 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1600 /* Finish everything. */
1601 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1602 gfc_trans_deferred_vars (sym
, &block
);
1603 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1604 trans_associate_var (ass
->st
->n
.sym
, &block
);
1606 return gfc_finish_wrapped_block (&block
);
1610 /* Translate the simple DO construct. This is where the loop variable has
1611 integer type and step +-1. We can't use this in the general case
1612 because integer overflow and floating point errors could give incorrect
1614 We translate a do loop from:
1616 DO dovar = from, to, step
1622 [Evaluate loop bounds and step]
1624 if ((step > 0) ? (dovar <= to) : (dovar => to))
1630 cond = (dovar == to);
1632 if (cond) goto end_label;
1637 This helps the optimizers by avoiding the extra induction variable
1638 used in the general case. */
1641 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1642 tree from
, tree to
, tree step
, tree exit_cond
)
1648 tree saved_dovar
= NULL
;
1653 type
= TREE_TYPE (dovar
);
1655 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1657 /* Initialize the DO variable: dovar = from. */
1658 gfc_add_modify_loc (loc
, pblock
, dovar
,
1659 fold_convert (TREE_TYPE(dovar
), from
));
1661 /* Save value for do-tinkering checking. */
1662 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1664 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1665 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1668 /* Cycle and exit statements are implemented with gotos. */
1669 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1670 exit_label
= gfc_build_label_decl (NULL_TREE
);
1672 /* Put the labels where they can be found later. See gfc_trans_do(). */
1673 code
->cycle_label
= cycle_label
;
1674 code
->exit_label
= exit_label
;
1677 gfc_start_block (&body
);
1679 /* Main loop body. */
1680 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1681 gfc_add_expr_to_block (&body
, tmp
);
1683 /* Label for cycle statements (if needed). */
1684 if (TREE_USED (cycle_label
))
1686 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1687 gfc_add_expr_to_block (&body
, tmp
);
1690 /* Check whether someone has modified the loop variable. */
1691 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1693 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1694 dovar
, saved_dovar
);
1695 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1696 "Loop variable has been modified");
1699 /* Exit the loop if there is an I/O result condition or error. */
1702 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1703 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1705 build_empty_stmt (loc
));
1706 gfc_add_expr_to_block (&body
, tmp
);
1709 /* Evaluate the loop condition. */
1710 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, dovar
,
1712 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1714 /* Increment the loop variable. */
1715 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1716 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1718 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1719 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1721 /* The loop exit. */
1722 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1723 TREE_USED (exit_label
) = 1;
1724 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1725 cond
, tmp
, build_empty_stmt (loc
));
1726 gfc_add_expr_to_block (&body
, tmp
);
1728 /* Finish the loop body. */
1729 tmp
= gfc_finish_block (&body
);
1730 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1732 /* Only execute the loop if the number of iterations is positive. */
1733 if (tree_int_cst_sgn (step
) > 0)
1734 cond
= fold_build2_loc (loc
, LE_EXPR
, boolean_type_node
, dovar
,
1737 cond
= fold_build2_loc (loc
, GE_EXPR
, boolean_type_node
, dovar
,
1739 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, cond
, tmp
,
1740 build_empty_stmt (loc
));
1741 gfc_add_expr_to_block (pblock
, tmp
);
1743 /* Add the exit label. */
1744 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1745 gfc_add_expr_to_block (pblock
, tmp
);
1747 return gfc_finish_block (pblock
);
1750 /* Translate the DO construct. This obviously is one of the most
1751 important ones to get right with any compiler, but especially
1754 We special case some loop forms as described in gfc_trans_simple_do.
1755 For other cases we implement them with a separate loop count,
1756 as described in the standard.
1758 We translate a do loop from:
1760 DO dovar = from, to, step
1766 [evaluate loop bounds and step]
1767 empty = (step > 0 ? to < from : to > from);
1768 countm1 = (to - from) / step;
1770 if (empty) goto exit_label;
1778 if (countm1t == 0) goto exit_label;
1782 countm1 is an unsigned integer. It is equal to the loop count minus one,
1783 because the loop count itself can overflow. */
1786 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
1790 tree saved_dovar
= NULL
;
1805 gfc_start_block (&block
);
1807 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1809 /* Evaluate all the expressions in the iterator. */
1810 gfc_init_se (&se
, NULL
);
1811 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
1812 gfc_add_block_to_block (&block
, &se
.pre
);
1814 type
= TREE_TYPE (dovar
);
1816 gfc_init_se (&se
, NULL
);
1817 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
1818 gfc_add_block_to_block (&block
, &se
.pre
);
1819 from
= gfc_evaluate_now (se
.expr
, &block
);
1821 gfc_init_se (&se
, NULL
);
1822 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
1823 gfc_add_block_to_block (&block
, &se
.pre
);
1824 to
= gfc_evaluate_now (se
.expr
, &block
);
1826 gfc_init_se (&se
, NULL
);
1827 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
1828 gfc_add_block_to_block (&block
, &se
.pre
);
1829 step
= gfc_evaluate_now (se
.expr
, &block
);
1831 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1833 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
1834 build_zero_cst (type
));
1835 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
1836 "DO step value is zero");
1839 /* Special case simple loops. */
1840 if (TREE_CODE (type
) == INTEGER_TYPE
1841 && (integer_onep (step
)
1842 || tree_int_cst_equal (step
, integer_minus_one_node
)))
1843 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
, exit_cond
);
1846 if (TREE_CODE (type
) == INTEGER_TYPE
)
1847 utype
= unsigned_type_for (type
);
1849 utype
= unsigned_type_for (gfc_array_index_type
);
1850 countm1
= gfc_create_var (utype
, "countm1");
1852 /* Cycle and exit statements are implemented with gotos. */
1853 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1854 exit_label
= gfc_build_label_decl (NULL_TREE
);
1855 TREE_USED (exit_label
) = 1;
1857 /* Put these labels where they can be found later. */
1858 code
->cycle_label
= cycle_label
;
1859 code
->exit_label
= exit_label
;
1861 /* Initialize the DO variable: dovar = from. */
1862 gfc_add_modify (&block
, dovar
, from
);
1864 /* Save value for do-tinkering checking. */
1865 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1867 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1868 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
1871 /* Initialize loop count and jump to exit label if the loop is empty.
1872 This code is executed before we enter the loop body. We generate:
1875 countm1 = (to - from) / step;
1881 countm1 = (from - to) / -step;
1887 if (TREE_CODE (type
) == INTEGER_TYPE
)
1889 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
1891 /* The distance from FROM to TO cannot always be represented in a signed
1892 type, thus use unsigned arithmetic, also to avoid any undefined
1894 tou
= fold_convert (utype
, to
);
1895 fromu
= fold_convert (utype
, from
);
1896 stepu
= fold_convert (utype
, step
);
1898 /* For a positive step, when to < from, exit, otherwise compute
1899 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
1900 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
1901 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
1902 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
1905 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
1906 fold_build2 (MODIFY_EXPR
, void_type_node
,
1908 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1909 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1910 exit_label
), NULL_TREE
));
1912 /* For a negative step, when to > from, exit, otherwise compute
1913 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
1914 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
1915 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
1916 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
1918 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
1919 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
1920 fold_build2 (MODIFY_EXPR
, void_type_node
,
1922 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1923 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1924 exit_label
), NULL_TREE
));
1926 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
1927 build_int_cst (TREE_TYPE (step
), 0));
1928 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
1930 gfc_add_expr_to_block (&block
, tmp
);
1936 /* TODO: We could use the same width as the real type.
1937 This would probably cause more problems that it solves
1938 when we implement "long double" types. */
1940 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
1941 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
1942 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
1943 gfc_add_modify (&block
, countm1
, tmp
);
1945 /* We need a special check for empty loops:
1946 empty = (step > 0 ? to < from : to > from); */
1947 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
1948 build_zero_cst (type
));
1949 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
1950 fold_build2_loc (loc
, LT_EXPR
,
1951 boolean_type_node
, to
, from
),
1952 fold_build2_loc (loc
, GT_EXPR
,
1953 boolean_type_node
, to
, from
));
1954 /* If the loop is empty, go directly to the exit label. */
1955 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1956 build1_v (GOTO_EXPR
, exit_label
),
1957 build_empty_stmt (input_location
));
1958 gfc_add_expr_to_block (&block
, tmp
);
1962 gfc_start_block (&body
);
1964 /* Main loop body. */
1965 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1966 gfc_add_expr_to_block (&body
, tmp
);
1968 /* Label for cycle statements (if needed). */
1969 if (TREE_USED (cycle_label
))
1971 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1972 gfc_add_expr_to_block (&body
, tmp
);
1975 /* Check whether someone has modified the loop variable. */
1976 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1978 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
1980 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1981 "Loop variable has been modified");
1984 /* Exit the loop if there is an I/O result condition or error. */
1987 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1988 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1990 build_empty_stmt (input_location
));
1991 gfc_add_expr_to_block (&body
, tmp
);
1994 /* Increment the loop variable. */
1995 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1996 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1998 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1999 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2001 /* Initialize countm1t. */
2002 tree countm1t
= gfc_create_var (utype
, "countm1t");
2003 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2005 /* Decrement the loop count. */
2006 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2007 build_int_cst (utype
, 1));
2008 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2010 /* End with the loop condition. Loop until countm1t == 0. */
2011 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2012 build_int_cst (utype
, 0));
2013 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2014 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2015 cond
, tmp
, build_empty_stmt (loc
));
2016 gfc_add_expr_to_block (&body
, tmp
);
2018 /* End of loop body. */
2019 tmp
= gfc_finish_block (&body
);
2021 /* The for loop itself. */
2022 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2023 gfc_add_expr_to_block (&block
, tmp
);
2025 /* Add the exit label. */
2026 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2027 gfc_add_expr_to_block (&block
, tmp
);
2029 return gfc_finish_block (&block
);
2033 /* Translate the DO WHILE construct.
2046 if (! cond) goto exit_label;
2052 Because the evaluation of the exit condition `cond' may have side
2053 effects, we can't do much for empty loop bodies. The backend optimizers
2054 should be smart enough to eliminate any dead loops. */
2057 gfc_trans_do_while (gfc_code
* code
)
2065 /* Everything we build here is part of the loop body. */
2066 gfc_start_block (&block
);
2068 /* Cycle and exit statements are implemented with gotos. */
2069 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2070 exit_label
= gfc_build_label_decl (NULL_TREE
);
2072 /* Put the labels where they can be found later. See gfc_trans_do(). */
2073 code
->cycle_label
= cycle_label
;
2074 code
->exit_label
= exit_label
;
2076 /* Create a GIMPLE version of the exit condition. */
2077 gfc_init_se (&cond
, NULL
);
2078 gfc_conv_expr_val (&cond
, code
->expr1
);
2079 gfc_add_block_to_block (&block
, &cond
.pre
);
2080 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2081 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2083 /* Build "IF (! cond) GOTO exit_label". */
2084 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2085 TREE_USED (exit_label
) = 1;
2086 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2087 void_type_node
, cond
.expr
, tmp
,
2088 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2089 gfc_add_expr_to_block (&block
, tmp
);
2091 /* The main body of the loop. */
2092 tmp
= gfc_trans_code (code
->block
->next
);
2093 gfc_add_expr_to_block (&block
, tmp
);
2095 /* Label for cycle statements (if needed). */
2096 if (TREE_USED (cycle_label
))
2098 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2099 gfc_add_expr_to_block (&block
, tmp
);
2102 /* End of loop body. */
2103 tmp
= gfc_finish_block (&block
);
2105 gfc_init_block (&block
);
2106 /* Build the loop. */
2107 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2108 void_type_node
, tmp
);
2109 gfc_add_expr_to_block (&block
, tmp
);
2111 /* Add the exit label. */
2112 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2113 gfc_add_expr_to_block (&block
, tmp
);
2115 return gfc_finish_block (&block
);
2119 /* Translate the SELECT CASE construct for INTEGER case expressions,
2120 without killing all potential optimizations. The problem is that
2121 Fortran allows unbounded cases, but the back-end does not, so we
2122 need to intercept those before we enter the equivalent SWITCH_EXPR
2125 For example, we translate this,
2128 CASE (:100,101,105:115)
2138 to the GENERIC equivalent,
2142 case (minimum value for typeof(expr) ... 100:
2148 case 200 ... (maximum value for typeof(expr):
2165 gfc_trans_integer_select (gfc_code
* code
)
2175 gfc_start_block (&block
);
2177 /* Calculate the switch expression. */
2178 gfc_init_se (&se
, NULL
);
2179 gfc_conv_expr_val (&se
, code
->expr1
);
2180 gfc_add_block_to_block (&block
, &se
.pre
);
2182 end_label
= gfc_build_label_decl (NULL_TREE
);
2184 gfc_init_block (&body
);
2186 for (c
= code
->block
; c
; c
= c
->block
)
2188 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2193 /* Assume it's the default case. */
2194 low
= high
= NULL_TREE
;
2198 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2201 /* If there's only a lower bound, set the high bound to the
2202 maximum value of the case expression. */
2204 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2209 /* Three cases are possible here:
2211 1) There is no lower bound, e.g. CASE (:N).
2212 2) There is a lower bound .NE. high bound, that is
2213 a case range, e.g. CASE (N:M) where M>N (we make
2214 sure that M>N during type resolution).
2215 3) There is a lower bound, and it has the same value
2216 as the high bound, e.g. CASE (N:N). This is our
2217 internal representation of CASE(N).
2219 In the first and second case, we need to set a value for
2220 high. In the third case, we don't because the GCC middle
2221 end represents a single case value by just letting high be
2222 a NULL_TREE. We can't do that because we need to be able
2223 to represent unbounded cases. */
2227 && mpz_cmp (cp
->low
->value
.integer
,
2228 cp
->high
->value
.integer
) != 0))
2229 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2232 /* Unbounded case. */
2234 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2237 /* Build a label. */
2238 label
= gfc_build_label_decl (NULL_TREE
);
2240 /* Add this case label.
2241 Add parameter 'label', make it match GCC backend. */
2242 tmp
= build_case_label (low
, high
, label
);
2243 gfc_add_expr_to_block (&body
, tmp
);
2246 /* Add the statements for this case. */
2247 tmp
= gfc_trans_code (c
->next
);
2248 gfc_add_expr_to_block (&body
, tmp
);
2250 /* Break to the end of the construct. */
2251 tmp
= build1_v (GOTO_EXPR
, end_label
);
2252 gfc_add_expr_to_block (&body
, tmp
);
2255 tmp
= gfc_finish_block (&body
);
2256 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2257 se
.expr
, tmp
, NULL_TREE
);
2258 gfc_add_expr_to_block (&block
, tmp
);
2260 tmp
= build1_v (LABEL_EXPR
, end_label
);
2261 gfc_add_expr_to_block (&block
, tmp
);
2263 return gfc_finish_block (&block
);
2267 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2269 There are only two cases possible here, even though the standard
2270 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2271 .FALSE., and DEFAULT.
2273 We never generate more than two blocks here. Instead, we always
2274 try to eliminate the DEFAULT case. This way, we can translate this
2275 kind of SELECT construct to a simple
2279 expression in GENERIC. */
2282 gfc_trans_logical_select (gfc_code
* code
)
2285 gfc_code
*t
, *f
, *d
;
2290 /* Assume we don't have any cases at all. */
2293 /* Now see which ones we actually do have. We can have at most two
2294 cases in a single case list: one for .TRUE. and one for .FALSE.
2295 The default case is always separate. If the cases for .TRUE. and
2296 .FALSE. are in the same case list, the block for that case list
2297 always executed, and we don't generate code a COND_EXPR. */
2298 for (c
= code
->block
; c
; c
= c
->block
)
2300 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2304 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2306 else /* if (cp->value.logical != 0), thus .TRUE. */
2314 /* Start a new block. */
2315 gfc_start_block (&block
);
2317 /* Calculate the switch expression. We always need to do this
2318 because it may have side effects. */
2319 gfc_init_se (&se
, NULL
);
2320 gfc_conv_expr_val (&se
, code
->expr1
);
2321 gfc_add_block_to_block (&block
, &se
.pre
);
2323 if (t
== f
&& t
!= NULL
)
2325 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2326 translate the code for these cases, append it to the current
2328 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2332 tree true_tree
, false_tree
, stmt
;
2334 true_tree
= build_empty_stmt (input_location
);
2335 false_tree
= build_empty_stmt (input_location
);
2337 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2338 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2339 make the missing case the default case. */
2340 if (t
!= NULL
&& f
!= NULL
)
2350 /* Translate the code for each of these blocks, and append it to
2351 the current block. */
2353 true_tree
= gfc_trans_code (t
->next
);
2356 false_tree
= gfc_trans_code (f
->next
);
2358 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2359 se
.expr
, true_tree
, false_tree
);
2360 gfc_add_expr_to_block (&block
, stmt
);
2363 return gfc_finish_block (&block
);
2367 /* The jump table types are stored in static variables to avoid
2368 constructing them from scratch every single time. */
2369 static GTY(()) tree select_struct
[2];
2371 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2372 Instead of generating compares and jumps, it is far simpler to
2373 generate a data structure describing the cases in order and call a
2374 library subroutine that locates the right case.
2375 This is particularly true because this is the only case where we
2376 might have to dispose of a temporary.
2377 The library subroutine returns a pointer to jump to or NULL if no
2378 branches are to be taken. */
2381 gfc_trans_character_select (gfc_code
*code
)
2383 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2384 stmtblock_t block
, body
;
2389 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2391 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2393 /* The jump table types are stored in static variables to avoid
2394 constructing them from scratch every single time. */
2395 static tree ss_string1
[2], ss_string1_len
[2];
2396 static tree ss_string2
[2], ss_string2_len
[2];
2397 static tree ss_target
[2];
2399 cp
= code
->block
->ext
.block
.case_list
;
2400 while (cp
->left
!= NULL
)
2403 /* Generate the body */
2404 gfc_start_block (&block
);
2405 gfc_init_se (&expr1se
, NULL
);
2406 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2408 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2410 end_label
= gfc_build_label_decl (NULL_TREE
);
2412 gfc_init_block (&body
);
2414 /* Attempt to optimize length 1 selects. */
2415 if (integer_onep (expr1se
.string_length
))
2417 for (d
= cp
; d
; d
= d
->right
)
2422 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2423 && d
->low
->ts
.type
== BT_CHARACTER
);
2424 if (d
->low
->value
.character
.length
> 1)
2426 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2427 if (d
->low
->value
.character
.string
[i
] != ' ')
2429 if (i
!= d
->low
->value
.character
.length
)
2431 if (optimize
&& d
->high
&& i
== 1)
2433 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2434 && d
->high
->ts
.type
== BT_CHARACTER
);
2435 if (d
->high
->value
.character
.length
> 1
2436 && (d
->low
->value
.character
.string
[0]
2437 == d
->high
->value
.character
.string
[0])
2438 && d
->high
->value
.character
.string
[1] != ' '
2439 && ((d
->low
->value
.character
.string
[1] < ' ')
2440 == (d
->high
->value
.character
.string
[1]
2450 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2451 && d
->high
->ts
.type
== BT_CHARACTER
);
2452 if (d
->high
->value
.character
.length
> 1)
2454 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2455 if (d
->high
->value
.character
.string
[i
] != ' ')
2457 if (i
!= d
->high
->value
.character
.length
)
2464 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2466 for (c
= code
->block
; c
; c
= c
->block
)
2468 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2474 /* Assume it's the default case. */
2475 low
= high
= NULL_TREE
;
2479 /* CASE ('ab') or CASE ('ab':'az') will never match
2480 any length 1 character. */
2481 if (cp
->low
->value
.character
.length
> 1
2482 && cp
->low
->value
.character
.string
[1] != ' ')
2485 if (cp
->low
->value
.character
.length
> 0)
2486 r
= cp
->low
->value
.character
.string
[0];
2489 low
= build_int_cst (ctype
, r
);
2491 /* If there's only a lower bound, set the high bound
2492 to the maximum value of the case expression. */
2494 high
= TYPE_MAX_VALUE (ctype
);
2500 || (cp
->low
->value
.character
.string
[0]
2501 != cp
->high
->value
.character
.string
[0]))
2503 if (cp
->high
->value
.character
.length
> 0)
2504 r
= cp
->high
->value
.character
.string
[0];
2507 high
= build_int_cst (ctype
, r
);
2510 /* Unbounded case. */
2512 low
= TYPE_MIN_VALUE (ctype
);
2515 /* Build a label. */
2516 label
= gfc_build_label_decl (NULL_TREE
);
2518 /* Add this case label.
2519 Add parameter 'label', make it match GCC backend. */
2520 tmp
= build_case_label (low
, high
, label
);
2521 gfc_add_expr_to_block (&body
, tmp
);
2524 /* Add the statements for this case. */
2525 tmp
= gfc_trans_code (c
->next
);
2526 gfc_add_expr_to_block (&body
, tmp
);
2528 /* Break to the end of the construct. */
2529 tmp
= build1_v (GOTO_EXPR
, end_label
);
2530 gfc_add_expr_to_block (&body
, tmp
);
2533 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2535 code
->expr1
->ts
.kind
);
2536 case_num
= gfc_create_var (ctype
, "case_num");
2537 gfc_add_modify (&block
, case_num
, tmp
);
2539 gfc_add_block_to_block (&block
, &expr1se
.post
);
2541 tmp
= gfc_finish_block (&body
);
2542 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2543 case_num
, tmp
, NULL_TREE
);
2544 gfc_add_expr_to_block (&block
, tmp
);
2546 tmp
= build1_v (LABEL_EXPR
, end_label
);
2547 gfc_add_expr_to_block (&block
, tmp
);
2549 return gfc_finish_block (&block
);
2553 if (code
->expr1
->ts
.kind
== 1)
2555 else if (code
->expr1
->ts
.kind
== 4)
2560 if (select_struct
[k
] == NULL
)
2563 select_struct
[k
] = make_node (RECORD_TYPE
);
2565 if (code
->expr1
->ts
.kind
== 1)
2566 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2567 else if (code
->expr1
->ts
.kind
== 4)
2568 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2573 #define ADD_FIELD(NAME, TYPE) \
2574 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2575 get_identifier (stringize(NAME)), \
2579 ADD_FIELD (string1
, pchartype
);
2580 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2582 ADD_FIELD (string2
, pchartype
);
2583 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2585 ADD_FIELD (target
, integer_type_node
);
2588 gfc_finish_type (select_struct
[k
]);
2592 for (d
= cp
; d
; d
= d
->right
)
2595 for (c
= code
->block
; c
; c
= c
->block
)
2597 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2599 label
= gfc_build_label_decl (NULL_TREE
);
2600 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2602 : build_int_cst (integer_type_node
, d
->n
),
2604 gfc_add_expr_to_block (&body
, tmp
);
2607 tmp
= gfc_trans_code (c
->next
);
2608 gfc_add_expr_to_block (&body
, tmp
);
2610 tmp
= build1_v (GOTO_EXPR
, end_label
);
2611 gfc_add_expr_to_block (&body
, tmp
);
2614 /* Generate the structure describing the branches */
2615 for (d
= cp
; d
; d
= d
->right
)
2617 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2619 gfc_init_se (&se
, NULL
);
2623 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2624 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2628 gfc_conv_expr_reference (&se
, d
->low
);
2630 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2631 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2634 if (d
->high
== NULL
)
2636 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2637 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2641 gfc_init_se (&se
, NULL
);
2642 gfc_conv_expr_reference (&se
, d
->high
);
2644 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2645 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2648 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2649 build_int_cst (integer_type_node
, d
->n
));
2651 tmp
= build_constructor (select_struct
[k
], node
);
2652 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2655 type
= build_array_type (select_struct
[k
],
2656 build_index_type (size_int (n
-1)));
2658 init
= build_constructor (type
, inits
);
2659 TREE_CONSTANT (init
) = 1;
2660 TREE_STATIC (init
) = 1;
2661 /* Create a static variable to hold the jump table. */
2662 tmp
= gfc_create_var (type
, "jumptable");
2663 TREE_CONSTANT (tmp
) = 1;
2664 TREE_STATIC (tmp
) = 1;
2665 TREE_READONLY (tmp
) = 1;
2666 DECL_INITIAL (tmp
) = init
;
2669 /* Build the library call */
2670 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
2672 if (code
->expr1
->ts
.kind
== 1)
2673 fndecl
= gfor_fndecl_select_string
;
2674 else if (code
->expr1
->ts
.kind
== 4)
2675 fndecl
= gfor_fndecl_select_string_char4
;
2679 tmp
= build_call_expr_loc (input_location
,
2681 build_int_cst (gfc_charlen_type_node
, n
),
2682 expr1se
.expr
, expr1se
.string_length
);
2683 case_num
= gfc_create_var (integer_type_node
, "case_num");
2684 gfc_add_modify (&block
, case_num
, tmp
);
2686 gfc_add_block_to_block (&block
, &expr1se
.post
);
2688 tmp
= gfc_finish_block (&body
);
2689 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2690 case_num
, tmp
, NULL_TREE
);
2691 gfc_add_expr_to_block (&block
, tmp
);
2693 tmp
= build1_v (LABEL_EXPR
, end_label
);
2694 gfc_add_expr_to_block (&block
, tmp
);
2696 return gfc_finish_block (&block
);
2700 /* Translate the three variants of the SELECT CASE construct.
2702 SELECT CASEs with INTEGER case expressions can be translated to an
2703 equivalent GENERIC switch statement, and for LOGICAL case
2704 expressions we build one or two if-else compares.
2706 SELECT CASEs with CHARACTER case expressions are a whole different
2707 story, because they don't exist in GENERIC. So we sort them and
2708 do a binary search at runtime.
2710 Fortran has no BREAK statement, and it does not allow jumps from
2711 one case block to another. That makes things a lot easier for
2715 gfc_trans_select (gfc_code
* code
)
2721 gcc_assert (code
&& code
->expr1
);
2722 gfc_init_block (&block
);
2724 /* Build the exit label and hang it in. */
2725 exit_label
= gfc_build_label_decl (NULL_TREE
);
2726 code
->exit_label
= exit_label
;
2728 /* Empty SELECT constructs are legal. */
2729 if (code
->block
== NULL
)
2730 body
= build_empty_stmt (input_location
);
2732 /* Select the correct translation function. */
2734 switch (code
->expr1
->ts
.type
)
2737 body
= gfc_trans_logical_select (code
);
2741 body
= gfc_trans_integer_select (code
);
2745 body
= gfc_trans_character_select (code
);
2749 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2753 /* Build everything together. */
2754 gfc_add_expr_to_block (&block
, body
);
2755 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2757 return gfc_finish_block (&block
);
2761 /* Traversal function to substitute a replacement symtree if the symbol
2762 in the expression is the same as that passed. f == 2 signals that
2763 that variable itself is not to be checked - only the references.
2764 This group of functions is used when the variable expression in a
2765 FORALL assignment has internal references. For example:
2766 FORALL (i = 1:4) p(p(i)) = i
2767 The only recourse here is to store a copy of 'p' for the index
2770 static gfc_symtree
*new_symtree
;
2771 static gfc_symtree
*old_symtree
;
2774 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2776 if (expr
->expr_type
!= EXPR_VARIABLE
)
2781 else if (expr
->symtree
->n
.sym
== sym
)
2782 expr
->symtree
= new_symtree
;
2788 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
2790 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
2794 forall_restore (gfc_expr
*expr
,
2795 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
2796 int *f ATTRIBUTE_UNUSED
)
2798 if (expr
->expr_type
!= EXPR_VARIABLE
)
2801 if (expr
->symtree
== new_symtree
)
2802 expr
->symtree
= old_symtree
;
2808 forall_restore_symtree (gfc_expr
*e
)
2810 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
2814 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2819 gfc_symbol
*new_sym
;
2820 gfc_symbol
*old_sym
;
2824 /* Build a copy of the lvalue. */
2825 old_symtree
= c
->expr1
->symtree
;
2826 old_sym
= old_symtree
->n
.sym
;
2827 e
= gfc_lval_expr_from_sym (old_sym
);
2828 if (old_sym
->attr
.dimension
)
2830 gfc_init_se (&tse
, NULL
);
2831 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
2832 gfc_add_block_to_block (pre
, &tse
.pre
);
2833 gfc_add_block_to_block (post
, &tse
.post
);
2834 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
2836 if (e
->ts
.type
!= BT_CHARACTER
)
2838 /* Use the variable offset for the temporary. */
2839 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
2840 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
2845 gfc_init_se (&tse
, NULL
);
2846 gfc_init_se (&rse
, NULL
);
2847 gfc_conv_expr (&rse
, e
);
2848 if (e
->ts
.type
== BT_CHARACTER
)
2850 tse
.string_length
= rse
.string_length
;
2851 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
2853 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
2855 gfc_add_block_to_block (pre
, &tse
.pre
);
2856 gfc_add_block_to_block (post
, &tse
.post
);
2860 tmp
= gfc_typenode_for_spec (&e
->ts
);
2861 tse
.expr
= gfc_create_var (tmp
, "temp");
2864 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
, true,
2865 e
->expr_type
== EXPR_VARIABLE
, true);
2866 gfc_add_expr_to_block (pre
, tmp
);
2870 /* Create a new symbol to represent the lvalue. */
2871 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
2872 new_sym
->ts
= old_sym
->ts
;
2873 new_sym
->attr
.referenced
= 1;
2874 new_sym
->attr
.temporary
= 1;
2875 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
2876 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
2878 /* Use the temporary as the backend_decl. */
2879 new_sym
->backend_decl
= tse
.expr
;
2881 /* Create a fake symtree for it. */
2883 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
2884 new_symtree
->n
.sym
= new_sym
;
2885 gcc_assert (new_symtree
== root
);
2887 /* Go through the expression reference replacing the old_symtree
2889 forall_replace_symtree (c
->expr1
, old_sym
, 2);
2891 /* Now we have made this temporary, we might as well use it for
2892 the right hand side. */
2893 forall_replace_symtree (c
->expr2
, old_sym
, 1);
2897 /* Handles dependencies in forall assignments. */
2899 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2906 lsym
= c
->expr1
->symtree
->n
.sym
;
2907 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
2909 /* Now check for dependencies within the 'variable'
2910 expression itself. These are treated by making a complete
2911 copy of variable and changing all the references to it
2912 point to the copy instead. Note that the shallow copy of
2913 the variable will not suffice for derived types with
2914 pointer components. We therefore leave these to their
2916 if (lsym
->ts
.type
== BT_DERIVED
2917 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
2921 if (find_forall_index (c
->expr1
, lsym
, 2))
2923 forall_make_variable_temp (c
, pre
, post
);
2927 /* Substrings with dependencies are treated in the same
2929 if (c
->expr1
->ts
.type
== BT_CHARACTER
2931 && c
->expr2
->expr_type
== EXPR_VARIABLE
2932 && lsym
== c
->expr2
->symtree
->n
.sym
)
2934 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
2935 if (lref
->type
== REF_SUBSTRING
)
2937 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
2938 if (rref
->type
== REF_SUBSTRING
)
2942 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
2944 forall_make_variable_temp (c
, pre
, post
);
2953 cleanup_forall_symtrees (gfc_code
*c
)
2955 forall_restore_symtree (c
->expr1
);
2956 forall_restore_symtree (c
->expr2
);
2957 free (new_symtree
->n
.sym
);
2962 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2963 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2964 indicates whether we should generate code to test the FORALLs mask
2965 array. OUTER is the loop header to be used for initializing mask
2968 The generated loop format is:
2969 count = (end - start + step) / step
2982 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
2983 int mask_flag
, stmtblock_t
*outer
)
2991 tree var
, start
, end
, step
;
2994 /* Initialize the mask index outside the FORALL nest. */
2995 if (mask_flag
&& forall_tmp
->mask
)
2996 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
2998 iter
= forall_tmp
->this_loop
;
2999 nvar
= forall_tmp
->nvar
;
3000 for (n
= 0; n
< nvar
; n
++)
3003 start
= iter
->start
;
3007 exit_label
= gfc_build_label_decl (NULL_TREE
);
3008 TREE_USED (exit_label
) = 1;
3010 /* The loop counter. */
3011 count
= gfc_create_var (TREE_TYPE (var
), "count");
3013 /* The body of the loop. */
3014 gfc_init_block (&block
);
3016 /* The exit condition. */
3017 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3018 count
, build_int_cst (TREE_TYPE (count
), 0));
3019 if (forall_tmp
->do_concurrent
)
3020 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3021 build_int_cst (integer_type_node
,
3022 annot_expr_ivdep_kind
));
3024 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3025 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3026 cond
, tmp
, build_empty_stmt (input_location
));
3027 gfc_add_expr_to_block (&block
, tmp
);
3029 /* The main loop body. */
3030 gfc_add_expr_to_block (&block
, body
);
3032 /* Increment the loop variable. */
3033 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3035 gfc_add_modify (&block
, var
, tmp
);
3037 /* Advance to the next mask element. Only do this for the
3039 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3041 tree maskindex
= forall_tmp
->maskindex
;
3042 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3043 maskindex
, gfc_index_one_node
);
3044 gfc_add_modify (&block
, maskindex
, tmp
);
3047 /* Decrement the loop counter. */
3048 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3049 build_int_cst (TREE_TYPE (var
), 1));
3050 gfc_add_modify (&block
, count
, tmp
);
3052 body
= gfc_finish_block (&block
);
3054 /* Loop var initialization. */
3055 gfc_init_block (&block
);
3056 gfc_add_modify (&block
, var
, start
);
3059 /* Initialize the loop counter. */
3060 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3062 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3064 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3066 gfc_add_modify (&block
, count
, tmp
);
3068 /* The loop expression. */
3069 tmp
= build1_v (LOOP_EXPR
, body
);
3070 gfc_add_expr_to_block (&block
, tmp
);
3072 /* The exit label. */
3073 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3074 gfc_add_expr_to_block (&block
, tmp
);
3076 body
= gfc_finish_block (&block
);
3083 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3084 is nonzero, the body is controlled by all masks in the forall nest.
3085 Otherwise, the innermost loop is not controlled by it's mask. This
3086 is used for initializing that mask. */
3089 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3094 forall_info
*forall_tmp
;
3095 tree mask
, maskindex
;
3097 gfc_start_block (&header
);
3099 forall_tmp
= nested_forall_info
;
3100 while (forall_tmp
!= NULL
)
3102 /* Generate body with masks' control. */
3105 mask
= forall_tmp
->mask
;
3106 maskindex
= forall_tmp
->maskindex
;
3108 /* If a mask was specified make the assignment conditional. */
3111 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3112 body
= build3_v (COND_EXPR
, tmp
, body
,
3113 build_empty_stmt (input_location
));
3116 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3117 forall_tmp
= forall_tmp
->prev_nest
;
3121 gfc_add_expr_to_block (&header
, body
);
3122 return gfc_finish_block (&header
);
3126 /* Allocate data for holding a temporary array. Returns either a local
3127 temporary array or a pointer variable. */
3130 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3137 if (INTEGER_CST_P (size
))
3138 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3139 size
, gfc_index_one_node
);
3143 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3144 type
= build_array_type (elem_type
, type
);
3145 if (gfc_can_put_var_on_stack (bytesize
))
3147 gcc_assert (INTEGER_CST_P (size
));
3148 tmpvar
= gfc_create_var (type
, "temp");
3153 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3154 *pdata
= convert (pvoid_type_node
, tmpvar
);
3156 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3157 gfc_add_modify (pblock
, tmpvar
, tmp
);
3163 /* Generate codes to copy the temporary to the actual lhs. */
3166 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3167 tree count1
, tree wheremask
, bool invert
)
3171 stmtblock_t block
, body
;
3177 lss
= gfc_walk_expr (expr
);
3179 if (lss
== gfc_ss_terminator
)
3181 gfc_start_block (&block
);
3183 gfc_init_se (&lse
, NULL
);
3185 /* Translate the expression. */
3186 gfc_conv_expr (&lse
, expr
);
3188 /* Form the expression for the temporary. */
3189 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3191 /* Use the scalar assignment as is. */
3192 gfc_add_block_to_block (&block
, &lse
.pre
);
3193 gfc_add_modify (&block
, lse
.expr
, tmp
);
3194 gfc_add_block_to_block (&block
, &lse
.post
);
3196 /* Increment the count1. */
3197 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3198 count1
, gfc_index_one_node
);
3199 gfc_add_modify (&block
, count1
, tmp
);
3201 tmp
= gfc_finish_block (&block
);
3205 gfc_start_block (&block
);
3207 gfc_init_loopinfo (&loop1
);
3208 gfc_init_se (&rse
, NULL
);
3209 gfc_init_se (&lse
, NULL
);
3211 /* Associate the lss with the loop. */
3212 gfc_add_ss_to_loop (&loop1
, lss
);
3214 /* Calculate the bounds of the scalarization. */
3215 gfc_conv_ss_startstride (&loop1
);
3216 /* Setup the scalarizing loops. */
3217 gfc_conv_loop_setup (&loop1
, &expr
->where
);
3219 gfc_mark_ss_chain_used (lss
, 1);
3221 /* Start the scalarized loop body. */
3222 gfc_start_scalarized_body (&loop1
, &body
);
3224 /* Setup the gfc_se structures. */
3225 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
3228 /* Form the expression of the temporary. */
3229 if (lss
!= gfc_ss_terminator
)
3230 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3231 /* Translate expr. */
3232 gfc_conv_expr (&lse
, expr
);
3234 /* Use the scalar assignment. */
3235 rse
.string_length
= lse
.string_length
;
3236 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true, true);
3238 /* Form the mask expression according to the mask tree list. */
3241 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3243 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3244 TREE_TYPE (wheremaskexpr
),
3246 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3248 build_empty_stmt (input_location
));
3251 gfc_add_expr_to_block (&body
, tmp
);
3253 /* Increment count1. */
3254 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3255 count1
, gfc_index_one_node
);
3256 gfc_add_modify (&body
, count1
, tmp
);
3258 /* Increment count3. */
3261 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3262 gfc_array_index_type
, count3
,
3263 gfc_index_one_node
);
3264 gfc_add_modify (&body
, count3
, tmp
);
3267 /* Generate the copying loops. */
3268 gfc_trans_scalarizing_loops (&loop1
, &body
);
3269 gfc_add_block_to_block (&block
, &loop1
.pre
);
3270 gfc_add_block_to_block (&block
, &loop1
.post
);
3271 gfc_cleanup_loop (&loop1
);
3273 tmp
= gfc_finish_block (&block
);
3279 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3280 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3281 and should not be freed. WHEREMASK is the conditional execution mask
3282 whose sense may be inverted by INVERT. */
3285 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3286 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3287 tree wheremask
, bool invert
)
3289 stmtblock_t block
, body1
;
3296 gfc_start_block (&block
);
3298 gfc_init_se (&rse
, NULL
);
3299 gfc_init_se (&lse
, NULL
);
3301 if (lss
== gfc_ss_terminator
)
3303 gfc_init_block (&body1
);
3304 gfc_conv_expr (&rse
, expr2
);
3305 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3309 /* Initialize the loop. */
3310 gfc_init_loopinfo (&loop
);
3312 /* We may need LSS to determine the shape of the expression. */
3313 gfc_add_ss_to_loop (&loop
, lss
);
3314 gfc_add_ss_to_loop (&loop
, rss
);
3316 gfc_conv_ss_startstride (&loop
);
3317 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3319 gfc_mark_ss_chain_used (rss
, 1);
3320 /* Start the loop body. */
3321 gfc_start_scalarized_body (&loop
, &body1
);
3323 /* Translate the expression. */
3324 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3326 gfc_conv_expr (&rse
, expr2
);
3328 /* Form the expression of the temporary. */
3329 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3332 /* Use the scalar assignment. */
3333 lse
.string_length
= rse
.string_length
;
3334 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
, true,
3335 expr2
->expr_type
== EXPR_VARIABLE
, true);
3337 /* Form the mask expression according to the mask tree list. */
3340 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3342 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3343 TREE_TYPE (wheremaskexpr
),
3345 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3347 build_empty_stmt (input_location
));
3350 gfc_add_expr_to_block (&body1
, tmp
);
3352 if (lss
== gfc_ss_terminator
)
3354 gfc_add_block_to_block (&block
, &body1
);
3356 /* Increment count1. */
3357 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3358 count1
, gfc_index_one_node
);
3359 gfc_add_modify (&block
, count1
, tmp
);
3363 /* Increment count1. */
3364 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3365 count1
, gfc_index_one_node
);
3366 gfc_add_modify (&body1
, count1
, tmp
);
3368 /* Increment count3. */
3371 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3372 gfc_array_index_type
,
3373 count3
, gfc_index_one_node
);
3374 gfc_add_modify (&body1
, count3
, tmp
);
3377 /* Generate the copying loops. */
3378 gfc_trans_scalarizing_loops (&loop
, &body1
);
3380 gfc_add_block_to_block (&block
, &loop
.pre
);
3381 gfc_add_block_to_block (&block
, &loop
.post
);
3383 gfc_cleanup_loop (&loop
);
3384 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3385 as tree nodes in SS may not be valid in different scope. */
3388 tmp
= gfc_finish_block (&block
);
3393 /* Calculate the size of temporary needed in the assignment inside forall.
3394 LSS and RSS are filled in this function. */
3397 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3398 stmtblock_t
* pblock
,
3399 gfc_ss
**lss
, gfc_ss
**rss
)
3407 *lss
= gfc_walk_expr (expr1
);
3410 size
= gfc_index_one_node
;
3411 if (*lss
!= gfc_ss_terminator
)
3413 gfc_init_loopinfo (&loop
);
3415 /* Walk the RHS of the expression. */
3416 *rss
= gfc_walk_expr (expr2
);
3417 if (*rss
== gfc_ss_terminator
)
3418 /* The rhs is scalar. Add a ss for the expression. */
3419 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3421 /* Associate the SS with the loop. */
3422 gfc_add_ss_to_loop (&loop
, *lss
);
3423 /* We don't actually need to add the rhs at this point, but it might
3424 make guessing the loop bounds a bit easier. */
3425 gfc_add_ss_to_loop (&loop
, *rss
);
3427 /* We only want the shape of the expression, not rest of the junk
3428 generated by the scalarizer. */
3429 loop
.array_parameter
= 1;
3431 /* Calculate the bounds of the scalarization. */
3432 save_flag
= gfc_option
.rtcheck
;
3433 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3434 gfc_conv_ss_startstride (&loop
);
3435 gfc_option
.rtcheck
= save_flag
;
3436 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3438 /* Figure out how many elements we need. */
3439 for (i
= 0; i
< loop
.dimen
; i
++)
3441 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3442 gfc_array_index_type
,
3443 gfc_index_one_node
, loop
.from
[i
]);
3444 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3445 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3446 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3447 gfc_array_index_type
, size
, tmp
);
3449 gfc_add_block_to_block (pblock
, &loop
.pre
);
3450 size
= gfc_evaluate_now (size
, pblock
);
3451 gfc_add_block_to_block (pblock
, &loop
.post
);
3453 /* TODO: write a function that cleans up a loopinfo without freeing
3454 the SS chains. Currently a NOP. */
3461 /* Calculate the overall iterator number of the nested forall construct.
3462 This routine actually calculates the number of times the body of the
3463 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3464 that by the expression INNER_SIZE. The BLOCK argument specifies the
3465 block in which to calculate the result, and the optional INNER_SIZE_BODY
3466 argument contains any statements that need to executed (inside the loop)
3467 to initialize or calculate INNER_SIZE. */
3470 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3471 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3473 forall_info
*forall_tmp
= nested_forall_info
;
3477 /* We can eliminate the innermost unconditional loops with constant
3479 if (INTEGER_CST_P (inner_size
))
3482 && !forall_tmp
->mask
3483 && INTEGER_CST_P (forall_tmp
->size
))
3485 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3486 gfc_array_index_type
,
3487 inner_size
, forall_tmp
->size
);
3488 forall_tmp
= forall_tmp
->prev_nest
;
3491 /* If there are no loops left, we have our constant result. */
3496 /* Otherwise, create a temporary variable to compute the result. */
3497 number
= gfc_create_var (gfc_array_index_type
, "num");
3498 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3500 gfc_start_block (&body
);
3501 if (inner_size_body
)
3502 gfc_add_block_to_block (&body
, inner_size_body
);
3504 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3505 gfc_array_index_type
, number
, inner_size
);
3508 gfc_add_modify (&body
, number
, tmp
);
3509 tmp
= gfc_finish_block (&body
);
3511 /* Generate loops. */
3512 if (forall_tmp
!= NULL
)
3513 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3515 gfc_add_expr_to_block (block
, tmp
);
3521 /* Allocate temporary for forall construct. SIZE is the size of temporary
3522 needed. PTEMP1 is returned for space free. */
3525 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3532 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3533 if (!integer_onep (unit
))
3534 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3535 gfc_array_index_type
, size
, unit
);
3540 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3543 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3548 /* Allocate temporary for forall construct according to the information in
3549 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3550 assignment inside forall. PTEMP1 is returned for space free. */
3553 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3554 tree inner_size
, stmtblock_t
* inner_size_body
,
3555 stmtblock_t
* block
, tree
* ptemp1
)
3559 /* Calculate the total size of temporary needed in forall construct. */
3560 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3561 inner_size_body
, block
);
3563 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3567 /* Handle assignments inside forall which need temporary.
3569 forall (i=start:end:stride; maskexpr)
3572 (where e,f<i> are arbitrary expressions possibly involving i
3573 and there is a dependency between e<i> and f<i>)
3575 masktmp(:) = maskexpr(:)
3580 for (i = start; i <= end; i += stride)
3584 for (i = start; i <= end; i += stride)
3586 if (masktmp[maskindex++])
3587 tmp[count1++] = f<i>
3591 for (i = start; i <= end; i += stride)
3593 if (masktmp[maskindex++])
3594 e<i> = tmp[count1++]
3599 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3600 tree wheremask
, bool invert
,
3601 forall_info
* nested_forall_info
,
3602 stmtblock_t
* block
)
3610 stmtblock_t inner_size_body
;
3612 /* Create vars. count1 is the current iterator number of the nested
3614 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3616 /* Count is the wheremask index. */
3619 count
= gfc_create_var (gfc_array_index_type
, "count");
3620 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3625 /* Initialize count1. */
3626 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3628 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3629 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3630 gfc_init_block (&inner_size_body
);
3631 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
3634 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3635 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
3637 if (!expr1
->ts
.u
.cl
->backend_decl
)
3640 gfc_init_se (&tse
, NULL
);
3641 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
3642 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
3644 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3645 expr1
->ts
.u
.cl
->backend_decl
);
3648 type
= gfc_typenode_for_spec (&expr1
->ts
);
3650 /* Allocate temporary for nested forall construct according to the
3651 information in nested_forall_info and inner_size. */
3652 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
3653 &inner_size_body
, block
, &ptemp1
);
3655 /* Generate codes to copy rhs to the temporary . */
3656 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
3659 /* Generate body and loops according to the information in
3660 nested_forall_info. */
3661 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3662 gfc_add_expr_to_block (block
, tmp
);
3665 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3669 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3671 /* Generate codes to copy the temporary to lhs. */
3672 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
3675 /* Generate body and loops according to the information in
3676 nested_forall_info. */
3677 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3678 gfc_add_expr_to_block (block
, tmp
);
3682 /* Free the temporary. */
3683 tmp
= gfc_call_free (ptemp1
);
3684 gfc_add_expr_to_block (block
, tmp
);
3689 /* Translate pointer assignment inside FORALL which need temporary. */
3692 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3693 forall_info
* nested_forall_info
,
3694 stmtblock_t
* block
)
3701 gfc_array_info
*info
;
3708 tree tmp
, tmp1
, ptemp1
;
3710 count
= gfc_create_var (gfc_array_index_type
, "count");
3711 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3713 inner_size
= gfc_index_one_node
;
3714 lss
= gfc_walk_expr (expr1
);
3715 rss
= gfc_walk_expr (expr2
);
3716 if (lss
== gfc_ss_terminator
)
3718 type
= gfc_typenode_for_spec (&expr1
->ts
);
3719 type
= build_pointer_type (type
);
3721 /* Allocate temporary for nested forall construct according to the
3722 information in nested_forall_info and inner_size. */
3723 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3724 inner_size
, NULL
, block
, &ptemp1
);
3725 gfc_start_block (&body
);
3726 gfc_init_se (&lse
, NULL
);
3727 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3728 gfc_init_se (&rse
, NULL
);
3729 rse
.want_pointer
= 1;
3730 gfc_conv_expr (&rse
, expr2
);
3731 gfc_add_block_to_block (&body
, &rse
.pre
);
3732 gfc_add_modify (&body
, lse
.expr
,
3733 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3734 gfc_add_block_to_block (&body
, &rse
.post
);
3736 /* Increment count. */
3737 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3738 count
, gfc_index_one_node
);
3739 gfc_add_modify (&body
, count
, tmp
);
3741 tmp
= gfc_finish_block (&body
);
3743 /* Generate body and loops according to the information in
3744 nested_forall_info. */
3745 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3746 gfc_add_expr_to_block (block
, tmp
);
3749 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3751 gfc_start_block (&body
);
3752 gfc_init_se (&lse
, NULL
);
3753 gfc_init_se (&rse
, NULL
);
3754 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3755 lse
.want_pointer
= 1;
3756 gfc_conv_expr (&lse
, expr1
);
3757 gfc_add_block_to_block (&body
, &lse
.pre
);
3758 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3759 gfc_add_block_to_block (&body
, &lse
.post
);
3760 /* Increment count. */
3761 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3762 count
, gfc_index_one_node
);
3763 gfc_add_modify (&body
, count
, tmp
);
3764 tmp
= gfc_finish_block (&body
);
3766 /* Generate body and loops according to the information in
3767 nested_forall_info. */
3768 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3769 gfc_add_expr_to_block (block
, tmp
);
3773 gfc_init_loopinfo (&loop
);
3775 /* Associate the SS with the loop. */
3776 gfc_add_ss_to_loop (&loop
, rss
);
3778 /* Setup the scalarizing loops and bounds. */
3779 gfc_conv_ss_startstride (&loop
);
3781 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3783 info
= &rss
->info
->data
.array
;
3784 desc
= info
->descriptor
;
3786 /* Make a new descriptor. */
3787 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3788 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
3789 loop
.from
, loop
.to
, 1,
3790 GFC_ARRAY_UNKNOWN
, true);
3792 /* Allocate temporary for nested forall construct. */
3793 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
3794 inner_size
, NULL
, block
, &ptemp1
);
3795 gfc_start_block (&body
);
3796 gfc_init_se (&lse
, NULL
);
3797 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3798 lse
.direct_byref
= 1;
3799 gfc_conv_expr_descriptor (&lse
, expr2
);
3801 gfc_add_block_to_block (&body
, &lse
.pre
);
3802 gfc_add_block_to_block (&body
, &lse
.post
);
3804 /* Increment count. */
3805 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3806 count
, gfc_index_one_node
);
3807 gfc_add_modify (&body
, count
, tmp
);
3809 tmp
= gfc_finish_block (&body
);
3811 /* Generate body and loops according to the information in
3812 nested_forall_info. */
3813 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3814 gfc_add_expr_to_block (block
, tmp
);
3817 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3819 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
3820 gfc_init_se (&lse
, NULL
);
3821 gfc_conv_expr_descriptor (&lse
, expr1
);
3822 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
3823 gfc_start_block (&body
);
3824 gfc_add_block_to_block (&body
, &lse
.pre
);
3825 gfc_add_block_to_block (&body
, &lse
.post
);
3827 /* Increment count. */
3828 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3829 count
, gfc_index_one_node
);
3830 gfc_add_modify (&body
, count
, tmp
);
3832 tmp
= gfc_finish_block (&body
);
3834 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3835 gfc_add_expr_to_block (block
, tmp
);
3837 /* Free the temporary. */
3840 tmp
= gfc_call_free (ptemp1
);
3841 gfc_add_expr_to_block (block
, tmp
);
3846 /* FORALL and WHERE statements are really nasty, especially when you nest
3847 them. All the rhs of a forall assignment must be evaluated before the
3848 actual assignments are performed. Presumably this also applies to all the
3849 assignments in an inner where statement. */
3851 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3852 linear array, relying on the fact that we process in the same order in all
3855 forall (i=start:end:stride; maskexpr)
3859 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3861 count = ((end + 1 - start) / stride)
3862 masktmp(:) = maskexpr(:)
3865 for (i = start; i <= end; i += stride)
3867 if (masktmp[maskindex++])
3871 for (i = start; i <= end; i += stride)
3873 if (masktmp[maskindex++])
3877 Note that this code only works when there are no dependencies.
3878 Forall loop with array assignments and data dependencies are a real pain,
3879 because the size of the temporary cannot always be determined before the
3880 loop is executed. This problem is compounded by the presence of nested
3885 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
3902 tree cycle_label
= NULL_TREE
;
3906 gfc_forall_iterator
*fa
;
3909 gfc_saved_var
*saved_vars
;
3910 iter_info
*this_forall
;
3914 /* Do nothing if the mask is false. */
3916 && code
->expr1
->expr_type
== EXPR_CONSTANT
3917 && !code
->expr1
->value
.logical
)
3918 return build_empty_stmt (input_location
);
3921 /* Count the FORALL index number. */
3922 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3926 /* Allocate the space for var, start, end, step, varexpr. */
3927 var
= XCNEWVEC (tree
, nvar
);
3928 start
= XCNEWVEC (tree
, nvar
);
3929 end
= XCNEWVEC (tree
, nvar
);
3930 step
= XCNEWVEC (tree
, nvar
);
3931 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
3932 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
3934 /* Allocate the space for info. */
3935 info
= XCNEW (forall_info
);
3937 gfc_start_block (&pre
);
3938 gfc_init_block (&post
);
3939 gfc_init_block (&block
);
3942 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3944 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
3946 /* Allocate space for this_forall. */
3947 this_forall
= XCNEW (iter_info
);
3949 /* Create a temporary variable for the FORALL index. */
3950 tmp
= gfc_typenode_for_spec (&sym
->ts
);
3951 var
[n
] = gfc_create_var (tmp
, sym
->name
);
3952 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
3954 /* Record it in this_forall. */
3955 this_forall
->var
= var
[n
];
3957 /* Replace the index symbol's backend_decl with the temporary decl. */
3958 sym
->backend_decl
= var
[n
];
3960 /* Work out the start, end and stride for the loop. */
3961 gfc_init_se (&se
, NULL
);
3962 gfc_conv_expr_val (&se
, fa
->start
);
3963 /* Record it in this_forall. */
3964 this_forall
->start
= se
.expr
;
3965 gfc_add_block_to_block (&block
, &se
.pre
);
3968 gfc_init_se (&se
, NULL
);
3969 gfc_conv_expr_val (&se
, fa
->end
);
3970 /* Record it in this_forall. */
3971 this_forall
->end
= se
.expr
;
3972 gfc_make_safe_expr (&se
);
3973 gfc_add_block_to_block (&block
, &se
.pre
);
3976 gfc_init_se (&se
, NULL
);
3977 gfc_conv_expr_val (&se
, fa
->stride
);
3978 /* Record it in this_forall. */
3979 this_forall
->step
= se
.expr
;
3980 gfc_make_safe_expr (&se
);
3981 gfc_add_block_to_block (&block
, &se
.pre
);
3984 /* Set the NEXT field of this_forall to NULL. */
3985 this_forall
->next
= NULL
;
3986 /* Link this_forall to the info construct. */
3987 if (info
->this_loop
)
3989 iter_info
*iter_tmp
= info
->this_loop
;
3990 while (iter_tmp
->next
!= NULL
)
3991 iter_tmp
= iter_tmp
->next
;
3992 iter_tmp
->next
= this_forall
;
3995 info
->this_loop
= this_forall
;
4001 /* Calculate the size needed for the current forall level. */
4002 size
= gfc_index_one_node
;
4003 for (n
= 0; n
< nvar
; n
++)
4005 /* size = (end + step - start) / step. */
4006 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4008 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4010 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4012 tmp
= convert (gfc_array_index_type
, tmp
);
4014 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4018 /* Record the nvar and size of current forall level. */
4024 /* If the mask is .true., consider the FORALL unconditional. */
4025 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4026 && code
->expr1
->value
.logical
)
4034 /* First we need to allocate the mask. */
4037 /* As the mask array can be very big, prefer compact boolean types. */
4038 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4039 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4040 size
, NULL
, &block
, &pmask
);
4041 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4043 /* Record them in the info structure. */
4044 info
->maskindex
= maskindex
;
4049 /* No mask was specified. */
4050 maskindex
= NULL_TREE
;
4051 mask
= pmask
= NULL_TREE
;
4054 /* Link the current forall level to nested_forall_info. */
4055 info
->prev_nest
= nested_forall_info
;
4056 nested_forall_info
= info
;
4058 /* Copy the mask into a temporary variable if required.
4059 For now we assume a mask temporary is needed. */
4062 /* As the mask array can be very big, prefer compact boolean types. */
4063 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4065 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4067 /* Start of mask assignment loop body. */
4068 gfc_start_block (&body
);
4070 /* Evaluate the mask expression. */
4071 gfc_init_se (&se
, NULL
);
4072 gfc_conv_expr_val (&se
, code
->expr1
);
4073 gfc_add_block_to_block (&body
, &se
.pre
);
4075 /* Store the mask. */
4076 se
.expr
= convert (mask_type
, se
.expr
);
4078 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4079 gfc_add_modify (&body
, tmp
, se
.expr
);
4081 /* Advance to the next mask element. */
4082 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4083 maskindex
, gfc_index_one_node
);
4084 gfc_add_modify (&body
, maskindex
, tmp
);
4086 /* Generate the loops. */
4087 tmp
= gfc_finish_block (&body
);
4088 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4089 gfc_add_expr_to_block (&block
, tmp
);
4092 if (code
->op
== EXEC_DO_CONCURRENT
)
4094 gfc_init_block (&body
);
4095 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4096 code
->cycle_label
= cycle_label
;
4097 tmp
= gfc_trans_code (code
->block
->next
);
4098 gfc_add_expr_to_block (&body
, tmp
);
4100 if (TREE_USED (cycle_label
))
4102 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4103 gfc_add_expr_to_block (&body
, tmp
);
4106 tmp
= gfc_finish_block (&body
);
4107 nested_forall_info
->do_concurrent
= true;
4108 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4109 gfc_add_expr_to_block (&block
, tmp
);
4113 c
= code
->block
->next
;
4115 /* TODO: loop merging in FORALL statements. */
4116 /* Now that we've got a copy of the mask, generate the assignment loops. */
4122 /* A scalar or array assignment. DO the simple check for
4123 lhs to rhs dependencies. These make a temporary for the
4124 rhs and form a second forall block to copy to variable. */
4125 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4127 /* Temporaries due to array assignment data dependencies introduce
4128 no end of problems. */
4130 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4131 nested_forall_info
, &block
);
4134 /* Use the normal assignment copying routines. */
4135 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4137 /* Generate body and loops. */
4138 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4140 gfc_add_expr_to_block (&block
, tmp
);
4143 /* Cleanup any temporary symtrees that have been made to deal
4144 with dependencies. */
4146 cleanup_forall_symtrees (c
);
4151 /* Translate WHERE or WHERE construct nested in FORALL. */
4152 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4155 /* Pointer assignment inside FORALL. */
4156 case EXEC_POINTER_ASSIGN
:
4157 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4159 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4160 nested_forall_info
, &block
);
4163 /* Use the normal assignment copying routines. */
4164 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4166 /* Generate body and loops. */
4167 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4169 gfc_add_expr_to_block (&block
, tmp
);
4174 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4175 gfc_add_expr_to_block (&block
, tmp
);
4178 /* Explicit subroutine calls are prevented by the frontend but interface
4179 assignments can legitimately produce them. */
4180 case EXEC_ASSIGN_CALL
:
4181 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4182 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4183 gfc_add_expr_to_block (&block
, tmp
);
4194 /* Restore the original index variables. */
4195 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4196 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4198 /* Free the space for var, start, end, step, varexpr. */
4206 for (this_forall
= info
->this_loop
; this_forall
;)
4208 iter_info
*next
= this_forall
->next
;
4213 /* Free the space for this forall_info. */
4218 /* Free the temporary for the mask. */
4219 tmp
= gfc_call_free (pmask
);
4220 gfc_add_expr_to_block (&block
, tmp
);
4223 pushdecl (maskindex
);
4225 gfc_add_block_to_block (&pre
, &block
);
4226 gfc_add_block_to_block (&pre
, &post
);
4228 return gfc_finish_block (&pre
);
4232 /* Translate the FORALL statement or construct. */
4234 tree
gfc_trans_forall (gfc_code
* code
)
4236 return gfc_trans_forall_1 (code
, NULL
);
4240 /* Translate the DO CONCURRENT construct. */
4242 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4244 return gfc_trans_forall_1 (code
, NULL
);
4248 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4249 If the WHERE construct is nested in FORALL, compute the overall temporary
4250 needed by the WHERE mask expression multiplied by the iterator number of
4252 ME is the WHERE mask expression.
4253 MASK is the current execution mask upon input, whose sense may or may
4254 not be inverted as specified by the INVERT argument.
4255 CMASK is the updated execution mask on output, or NULL if not required.
4256 PMASK is the pending execution mask on output, or NULL if not required.
4257 BLOCK is the block in which to place the condition evaluation loops. */
4260 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4261 tree mask
, bool invert
, tree cmask
, tree pmask
,
4262 tree mask_type
, stmtblock_t
* block
)
4267 stmtblock_t body
, body1
;
4268 tree count
, cond
, mtmp
;
4271 gfc_init_loopinfo (&loop
);
4273 lss
= gfc_walk_expr (me
);
4274 rss
= gfc_walk_expr (me
);
4276 /* Variable to index the temporary. */
4277 count
= gfc_create_var (gfc_array_index_type
, "count");
4278 /* Initialize count. */
4279 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4281 gfc_start_block (&body
);
4283 gfc_init_se (&rse
, NULL
);
4284 gfc_init_se (&lse
, NULL
);
4286 if (lss
== gfc_ss_terminator
)
4288 gfc_init_block (&body1
);
4292 /* Initialize the loop. */
4293 gfc_init_loopinfo (&loop
);
4295 /* We may need LSS to determine the shape of the expression. */
4296 gfc_add_ss_to_loop (&loop
, lss
);
4297 gfc_add_ss_to_loop (&loop
, rss
);
4299 gfc_conv_ss_startstride (&loop
);
4300 gfc_conv_loop_setup (&loop
, &me
->where
);
4302 gfc_mark_ss_chain_used (rss
, 1);
4303 /* Start the loop body. */
4304 gfc_start_scalarized_body (&loop
, &body1
);
4306 /* Translate the expression. */
4307 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4309 gfc_conv_expr (&rse
, me
);
4312 /* Variable to evaluate mask condition. */
4313 cond
= gfc_create_var (mask_type
, "cond");
4314 if (mask
&& (cmask
|| pmask
))
4315 mtmp
= gfc_create_var (mask_type
, "mask");
4316 else mtmp
= NULL_TREE
;
4318 gfc_add_block_to_block (&body1
, &lse
.pre
);
4319 gfc_add_block_to_block (&body1
, &rse
.pre
);
4321 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4323 if (mask
&& (cmask
|| pmask
))
4325 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4327 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4328 gfc_add_modify (&body1
, mtmp
, tmp
);
4333 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4336 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4338 gfc_add_modify (&body1
, tmp1
, tmp
);
4343 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4344 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4346 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4348 gfc_add_modify (&body1
, tmp1
, tmp
);
4351 gfc_add_block_to_block (&body1
, &lse
.post
);
4352 gfc_add_block_to_block (&body1
, &rse
.post
);
4354 if (lss
== gfc_ss_terminator
)
4356 gfc_add_block_to_block (&body
, &body1
);
4360 /* Increment count. */
4361 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4362 count
, gfc_index_one_node
);
4363 gfc_add_modify (&body1
, count
, tmp1
);
4365 /* Generate the copying loops. */
4366 gfc_trans_scalarizing_loops (&loop
, &body1
);
4368 gfc_add_block_to_block (&body
, &loop
.pre
);
4369 gfc_add_block_to_block (&body
, &loop
.post
);
4371 gfc_cleanup_loop (&loop
);
4372 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4373 as tree nodes in SS may not be valid in different scope. */
4376 tmp1
= gfc_finish_block (&body
);
4377 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4378 if (nested_forall_info
!= NULL
)
4379 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4381 gfc_add_expr_to_block (block
, tmp1
);
4385 /* Translate an assignment statement in a WHERE statement or construct
4386 statement. The MASK expression is used to control which elements
4387 of EXPR1 shall be assigned. The sense of MASK is specified by
4391 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4392 tree mask
, bool invert
,
4393 tree count1
, tree count2
,
4399 gfc_ss
*lss_section
;
4406 tree index
, maskexpr
;
4408 /* A defined assignment. */
4409 if (cnext
&& cnext
->resolved_sym
)
4410 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4413 /* TODO: handle this special case.
4414 Special case a single function returning an array. */
4415 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4417 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4423 /* Assignment of the form lhs = rhs. */
4424 gfc_start_block (&block
);
4426 gfc_init_se (&lse
, NULL
);
4427 gfc_init_se (&rse
, NULL
);
4430 lss
= gfc_walk_expr (expr1
);
4433 /* In each where-assign-stmt, the mask-expr and the variable being
4434 defined shall be arrays of the same shape. */
4435 gcc_assert (lss
!= gfc_ss_terminator
);
4437 /* The assignment needs scalarization. */
4440 /* Find a non-scalar SS from the lhs. */
4441 while (lss_section
!= gfc_ss_terminator
4442 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4443 lss_section
= lss_section
->next
;
4445 gcc_assert (lss_section
!= gfc_ss_terminator
);
4447 /* Initialize the scalarizer. */
4448 gfc_init_loopinfo (&loop
);
4451 rss
= gfc_walk_expr (expr2
);
4452 if (rss
== gfc_ss_terminator
)
4454 /* The rhs is scalar. Add a ss for the expression. */
4455 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4456 rss
->info
->where
= 1;
4459 /* Associate the SS with the loop. */
4460 gfc_add_ss_to_loop (&loop
, lss
);
4461 gfc_add_ss_to_loop (&loop
, rss
);
4463 /* Calculate the bounds of the scalarization. */
4464 gfc_conv_ss_startstride (&loop
);
4466 /* Resolve any data dependencies in the statement. */
4467 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4469 /* Setup the scalarizing loops. */
4470 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4472 /* Setup the gfc_se structures. */
4473 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4474 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4477 gfc_mark_ss_chain_used (rss
, 1);
4478 if (loop
.temp_ss
== NULL
)
4481 gfc_mark_ss_chain_used (lss
, 1);
4485 lse
.ss
= loop
.temp_ss
;
4486 gfc_mark_ss_chain_used (lss
, 3);
4487 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4490 /* Start the scalarized loop body. */
4491 gfc_start_scalarized_body (&loop
, &body
);
4493 /* Translate the expression. */
4494 gfc_conv_expr (&rse
, expr2
);
4495 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4496 gfc_conv_tmp_array_ref (&lse
);
4498 gfc_conv_expr (&lse
, expr1
);
4500 /* Form the mask expression according to the mask. */
4502 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4504 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4505 TREE_TYPE (maskexpr
), maskexpr
);
4507 /* Use the scalar assignment as is. */
4508 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4509 loop
.temp_ss
!= NULL
, false, true);
4511 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4513 gfc_add_expr_to_block (&body
, tmp
);
4515 if (lss
== gfc_ss_terminator
)
4517 /* Increment count1. */
4518 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4519 count1
, gfc_index_one_node
);
4520 gfc_add_modify (&body
, count1
, tmp
);
4522 /* Use the scalar assignment as is. */
4523 gfc_add_block_to_block (&block
, &body
);
4527 gcc_assert (lse
.ss
== gfc_ss_terminator
4528 && rse
.ss
== gfc_ss_terminator
);
4530 if (loop
.temp_ss
!= NULL
)
4532 /* Increment count1 before finish the main body of a scalarized
4534 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4535 gfc_array_index_type
, count1
, gfc_index_one_node
);
4536 gfc_add_modify (&body
, count1
, tmp
);
4537 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4539 /* We need to copy the temporary to the actual lhs. */
4540 gfc_init_se (&lse
, NULL
);
4541 gfc_init_se (&rse
, NULL
);
4542 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4543 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4545 rse
.ss
= loop
.temp_ss
;
4548 gfc_conv_tmp_array_ref (&rse
);
4549 gfc_conv_expr (&lse
, expr1
);
4551 gcc_assert (lse
.ss
== gfc_ss_terminator
4552 && rse
.ss
== gfc_ss_terminator
);
4554 /* Form the mask expression according to the mask tree list. */
4556 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4558 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4559 TREE_TYPE (maskexpr
), maskexpr
);
4561 /* Use the scalar assignment as is. */
4562 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, false,
4564 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4565 build_empty_stmt (input_location
));
4566 gfc_add_expr_to_block (&body
, tmp
);
4568 /* Increment count2. */
4569 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4570 gfc_array_index_type
, count2
,
4571 gfc_index_one_node
);
4572 gfc_add_modify (&body
, count2
, tmp
);
4576 /* Increment count1. */
4577 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4578 gfc_array_index_type
, count1
,
4579 gfc_index_one_node
);
4580 gfc_add_modify (&body
, count1
, tmp
);
4583 /* Generate the copying loops. */
4584 gfc_trans_scalarizing_loops (&loop
, &body
);
4586 /* Wrap the whole thing up. */
4587 gfc_add_block_to_block (&block
, &loop
.pre
);
4588 gfc_add_block_to_block (&block
, &loop
.post
);
4589 gfc_cleanup_loop (&loop
);
4592 return gfc_finish_block (&block
);
4596 /* Translate the WHERE construct or statement.
4597 This function can be called iteratively to translate the nested WHERE
4598 construct or statement.
4599 MASK is the control mask. */
4602 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4603 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4605 stmtblock_t inner_size_body
;
4606 tree inner_size
, size
;
4615 tree count1
, count2
;
4619 tree pcmask
= NULL_TREE
;
4620 tree ppmask
= NULL_TREE
;
4621 tree cmask
= NULL_TREE
;
4622 tree pmask
= NULL_TREE
;
4623 gfc_actual_arglist
*arg
;
4625 /* the WHERE statement or the WHERE construct statement. */
4626 cblock
= code
->block
;
4628 /* As the mask array can be very big, prefer compact boolean types. */
4629 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4631 /* Determine which temporary masks are needed. */
4634 /* One clause: No ELSEWHEREs. */
4635 need_cmask
= (cblock
->next
!= 0);
4638 else if (cblock
->block
->block
)
4640 /* Three or more clauses: Conditional ELSEWHEREs. */
4644 else if (cblock
->next
)
4646 /* Two clauses, the first non-empty. */
4648 need_pmask
= (mask
!= NULL_TREE
4649 && cblock
->block
->next
!= 0);
4651 else if (!cblock
->block
->next
)
4653 /* Two clauses, both empty. */
4657 /* Two clauses, the first empty, the second non-empty. */
4660 need_cmask
= (cblock
->block
->expr1
!= 0);
4669 if (need_cmask
|| need_pmask
)
4671 /* Calculate the size of temporary needed by the mask-expr. */
4672 gfc_init_block (&inner_size_body
);
4673 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
4674 &inner_size_body
, &lss
, &rss
);
4676 gfc_free_ss_chain (lss
);
4677 gfc_free_ss_chain (rss
);
4679 /* Calculate the total size of temporary needed. */
4680 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4681 &inner_size_body
, block
);
4683 /* Check whether the size is negative. */
4684 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
4685 gfc_index_zero_node
);
4686 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4687 cond
, gfc_index_zero_node
, size
);
4688 size
= gfc_evaluate_now (size
, block
);
4690 /* Allocate temporary for WHERE mask if needed. */
4692 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4695 /* Allocate temporary for !mask if needed. */
4697 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4703 /* Each time around this loop, the where clause is conditional
4704 on the value of mask and invert, which are updated at the
4705 bottom of the loop. */
4707 /* Has mask-expr. */
4710 /* Ensure that the WHERE mask will be evaluated exactly once.
4711 If there are no statements in this WHERE/ELSEWHERE clause,
4712 then we don't need to update the control mask (cmask).
4713 If this is the last clause of the WHERE construct, then
4714 we don't need to update the pending control mask (pmask). */
4716 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4718 cblock
->next
? cmask
: NULL_TREE
,
4719 cblock
->block
? pmask
: NULL_TREE
,
4722 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4724 (cblock
->next
|| cblock
->block
)
4725 ? cmask
: NULL_TREE
,
4726 NULL_TREE
, mask_type
, block
);
4730 /* It's a final elsewhere-stmt. No mask-expr is present. */
4734 /* The body of this where clause are controlled by cmask with
4735 sense specified by invert. */
4737 /* Get the assignment statement of a WHERE statement, or the first
4738 statement in where-body-construct of a WHERE construct. */
4739 cnext
= cblock
->next
;
4744 /* WHERE assignment statement. */
4745 case EXEC_ASSIGN_CALL
:
4747 arg
= cnext
->ext
.actual
;
4748 expr1
= expr2
= NULL
;
4749 for (; arg
; arg
= arg
->next
)
4761 expr1
= cnext
->expr1
;
4762 expr2
= cnext
->expr2
;
4764 if (nested_forall_info
!= NULL
)
4766 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4767 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4768 gfc_trans_assign_need_temp (expr1
, expr2
,
4770 nested_forall_info
, block
);
4773 /* Variables to control maskexpr. */
4774 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4775 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4776 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4777 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4779 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4784 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4786 gfc_add_expr_to_block (block
, tmp
);
4791 /* Variables to control maskexpr. */
4792 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4793 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4794 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4795 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4797 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4801 gfc_add_expr_to_block (block
, tmp
);
4806 /* WHERE or WHERE construct is part of a where-body-construct. */
4808 gfc_trans_where_2 (cnext
, cmask
, invert
,
4809 nested_forall_info
, block
);
4816 /* The next statement within the same where-body-construct. */
4817 cnext
= cnext
->next
;
4819 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4820 cblock
= cblock
->block
;
4821 if (mask
== NULL_TREE
)
4823 /* If we're the initial WHERE, we can simply invert the sense
4824 of the current mask to obtain the "mask" for the remaining
4831 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4837 /* If we allocated a pending mask array, deallocate it now. */
4840 tmp
= gfc_call_free (ppmask
);
4841 gfc_add_expr_to_block (block
, tmp
);
4844 /* If we allocated a current mask array, deallocate it now. */
4847 tmp
= gfc_call_free (pcmask
);
4848 gfc_add_expr_to_block (block
, tmp
);
4852 /* Translate a simple WHERE construct or statement without dependencies.
4853 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4854 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4855 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4858 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
4860 stmtblock_t block
, body
;
4861 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
4862 tree tmp
, cexpr
, tstmt
, estmt
;
4863 gfc_ss
*css
, *tdss
, *tsss
;
4864 gfc_se cse
, tdse
, tsse
, edse
, esse
;
4869 /* Allow the scalarizer to workshare simple where loops. */
4870 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
4871 ompws_flags
|= OMPWS_SCALARIZER_WS
;
4873 cond
= cblock
->expr1
;
4874 tdst
= cblock
->next
->expr1
;
4875 tsrc
= cblock
->next
->expr2
;
4876 edst
= eblock
? eblock
->next
->expr1
: NULL
;
4877 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
4879 gfc_start_block (&block
);
4880 gfc_init_loopinfo (&loop
);
4882 /* Handle the condition. */
4883 gfc_init_se (&cse
, NULL
);
4884 css
= gfc_walk_expr (cond
);
4885 gfc_add_ss_to_loop (&loop
, css
);
4887 /* Handle the then-clause. */
4888 gfc_init_se (&tdse
, NULL
);
4889 gfc_init_se (&tsse
, NULL
);
4890 tdss
= gfc_walk_expr (tdst
);
4891 tsss
= gfc_walk_expr (tsrc
);
4892 if (tsss
== gfc_ss_terminator
)
4894 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
4895 tsss
->info
->where
= 1;
4897 gfc_add_ss_to_loop (&loop
, tdss
);
4898 gfc_add_ss_to_loop (&loop
, tsss
);
4902 /* Handle the else clause. */
4903 gfc_init_se (&edse
, NULL
);
4904 gfc_init_se (&esse
, NULL
);
4905 edss
= gfc_walk_expr (edst
);
4906 esss
= gfc_walk_expr (esrc
);
4907 if (esss
== gfc_ss_terminator
)
4909 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
4910 esss
->info
->where
= 1;
4912 gfc_add_ss_to_loop (&loop
, edss
);
4913 gfc_add_ss_to_loop (&loop
, esss
);
4916 gfc_conv_ss_startstride (&loop
);
4917 gfc_conv_loop_setup (&loop
, &tdst
->where
);
4919 gfc_mark_ss_chain_used (css
, 1);
4920 gfc_mark_ss_chain_used (tdss
, 1);
4921 gfc_mark_ss_chain_used (tsss
, 1);
4924 gfc_mark_ss_chain_used (edss
, 1);
4925 gfc_mark_ss_chain_used (esss
, 1);
4928 gfc_start_scalarized_body (&loop
, &body
);
4930 gfc_copy_loopinfo_to_se (&cse
, &loop
);
4931 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
4932 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
4938 gfc_copy_loopinfo_to_se (&edse
, &loop
);
4939 gfc_copy_loopinfo_to_se (&esse
, &loop
);
4944 gfc_conv_expr (&cse
, cond
);
4945 gfc_add_block_to_block (&body
, &cse
.pre
);
4948 gfc_conv_expr (&tsse
, tsrc
);
4949 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4950 gfc_conv_tmp_array_ref (&tdse
);
4952 gfc_conv_expr (&tdse
, tdst
);
4956 gfc_conv_expr (&esse
, esrc
);
4957 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4958 gfc_conv_tmp_array_ref (&edse
);
4960 gfc_conv_expr (&edse
, edst
);
4963 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, false, true);
4964 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
, false,
4966 : build_empty_stmt (input_location
);
4967 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
4968 gfc_add_expr_to_block (&body
, tmp
);
4969 gfc_add_block_to_block (&body
, &cse
.post
);
4971 gfc_trans_scalarizing_loops (&loop
, &body
);
4972 gfc_add_block_to_block (&block
, &loop
.pre
);
4973 gfc_add_block_to_block (&block
, &loop
.post
);
4974 gfc_cleanup_loop (&loop
);
4976 return gfc_finish_block (&block
);
4979 /* As the WHERE or WHERE construct statement can be nested, we call
4980 gfc_trans_where_2 to do the translation, and pass the initial
4981 NULL values for both the control mask and the pending control mask. */
4984 gfc_trans_where (gfc_code
* code
)
4990 cblock
= code
->block
;
4992 && cblock
->next
->op
== EXEC_ASSIGN
4993 && !cblock
->next
->next
)
4995 eblock
= cblock
->block
;
4998 /* A simple "WHERE (cond) x = y" statement or block is
4999 dependence free if cond is not dependent upon writing x,
5000 and the source y is unaffected by the destination x. */
5001 if (!gfc_check_dependency (cblock
->next
->expr1
,
5003 && !gfc_check_dependency (cblock
->next
->expr1
,
5004 cblock
->next
->expr2
, 0))
5005 return gfc_trans_where_3 (cblock
, NULL
);
5007 else if (!eblock
->expr1
5010 && eblock
->next
->op
== EXEC_ASSIGN
5011 && !eblock
->next
->next
)
5013 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5014 block is dependence free if cond is not dependent on writes
5015 to x1 and x2, y1 is not dependent on writes to x2, and y2
5016 is not dependent on writes to x1, and both y's are not
5017 dependent upon their own x's. In addition to this, the
5018 final two dependency checks below exclude all but the same
5019 array reference if the where and elswhere destinations
5020 are the same. In short, this is VERY conservative and this
5021 is needed because the two loops, required by the standard
5022 are coalesced in gfc_trans_where_3. */
5023 if (!gfc_check_dependency (cblock
->next
->expr1
,
5025 && !gfc_check_dependency (eblock
->next
->expr1
,
5027 && !gfc_check_dependency (cblock
->next
->expr1
,
5028 eblock
->next
->expr2
, 1)
5029 && !gfc_check_dependency (eblock
->next
->expr1
,
5030 cblock
->next
->expr2
, 1)
5031 && !gfc_check_dependency (cblock
->next
->expr1
,
5032 cblock
->next
->expr2
, 1)
5033 && !gfc_check_dependency (eblock
->next
->expr1
,
5034 eblock
->next
->expr2
, 1)
5035 && !gfc_check_dependency (cblock
->next
->expr1
,
5036 eblock
->next
->expr1
, 0)
5037 && !gfc_check_dependency (eblock
->next
->expr1
,
5038 cblock
->next
->expr1
, 0))
5039 return gfc_trans_where_3 (cblock
, eblock
);
5043 gfc_start_block (&block
);
5045 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5047 return gfc_finish_block (&block
);
5051 /* CYCLE a DO loop. The label decl has already been created by
5052 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5053 node at the head of the loop. We must mark the label as used. */
5056 gfc_trans_cycle (gfc_code
* code
)
5060 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5061 gcc_assert (cycle_label
);
5063 TREE_USED (cycle_label
) = 1;
5064 return build1_v (GOTO_EXPR
, cycle_label
);
5068 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5069 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5073 gfc_trans_exit (gfc_code
* code
)
5077 exit_label
= code
->ext
.which_construct
->exit_label
;
5078 gcc_assert (exit_label
);
5080 TREE_USED (exit_label
) = 1;
5081 return build1_v (GOTO_EXPR
, exit_label
);
5085 /* Translate the ALLOCATE statement. */
5088 gfc_trans_allocate (gfc_code
* code
)
5091 gfc_expr
*expr
, *e3rhs
= NULL
;
5101 tree al_vptr
, al_len
;
5102 /* If an expr3 is present, then store the tree for accessing its
5103 _vptr, and _len components in the variables, respectively. The
5104 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5105 the trees may be the NULL_TREE indicating that this is not
5106 available for expr3's type. */
5107 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5111 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
;
5112 gfc_symtree
*newsym
= NULL
;
5114 if (!code
->ext
.alloc
.list
)
5117 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5118 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5119 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5121 gfc_init_block (&block
);
5122 gfc_init_block (&post
);
5124 /* STAT= (and maybe ERRMSG=) is present. */
5128 tree gfc_int4_type_node
= gfc_get_int_type (4);
5129 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5131 /* ERRMSG= only makes sense with STAT=. */
5134 gfc_init_se (&se
, NULL
);
5135 se
.want_pointer
= 1;
5136 gfc_conv_expr_lhs (&se
, code
->expr2
);
5138 errlen
= se
.string_length
;
5142 errmsg
= null_pointer_node
;
5143 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5146 /* GOTO destinations. */
5147 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5148 label_finish
= gfc_build_label_decl (NULL_TREE
);
5149 TREE_USED (label_finish
) = 0;
5152 /* When an expr3 is present evaluate it only once. The standards prevent a
5153 dependency of expr3 on the objects in the allocate list. An expr3 can
5154 be pre-evaluated in all cases. One just has to make sure, to use the
5155 correct way, i.e., to get the descriptor or to get a reference
5159 bool vtab_needed
= false;
5160 /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
5161 the expression is only needed to get the _vptr, _len a.s.o. */
5162 tree expr3_tmp
= NULL_TREE
;
5164 /* Figure whether we need the vtab from expr3. */
5165 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5167 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5169 /* When expr3 is a variable, i.e., a very simple expression,
5170 then convert it once here. */
5171 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5172 || code
->expr3
->expr_type
== EXPR_ARRAY
5173 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5175 if (!code
->expr3
->mold
5176 || code
->expr3
->ts
.type
== BT_CHARACTER
5179 /* Convert expr3 to a tree. */
5180 gfc_init_se (&se
, NULL
);
5181 /* For all "simple" expression just get the descriptor or the
5182 reference, respectively, depending on the rank of the expr. */
5183 if (code
->expr3
->rank
!= 0)
5184 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5186 gfc_conv_expr_reference (&se
, code
->expr3
);
5187 if (!code
->expr3
->mold
)
5190 expr3_tmp
= se
.expr
;
5191 expr3_len
= se
.string_length
;
5192 gfc_add_block_to_block (&block
, &se
.pre
);
5193 gfc_add_block_to_block (&post
, &se
.post
);
5195 /* else expr3 = NULL_TREE set above. */
5199 /* In all other cases evaluate the expr3 and create a
5201 gfc_init_se (&se
, NULL
);
5202 symbol_attribute attr
;
5203 /* Get the descriptor for all arrays, that are not allocatable or
5204 pointer, because the latter are descriptors already. */
5205 attr
= gfc_expr_attr (code
->expr3
);
5206 if (code
->expr3
->rank
!= 0 && !attr
.allocatable
&& !attr
.pointer
)
5207 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5209 gfc_conv_expr_reference (&se
, code
->expr3
);
5210 if (code
->expr3
->ts
.type
== BT_CLASS
)
5211 gfc_conv_class_to_class (&se
, code
->expr3
,
5215 gfc_add_block_to_block (&block
, &se
.pre
);
5216 gfc_add_block_to_block (&post
, &se
.post
);
5217 /* Prevent aliasing, i.e., se.expr may be already a
5218 variable declaration. */
5219 if (!VAR_P (se
.expr
))
5222 tmp
= build_fold_indirect_ref_loc (input_location
,
5224 /* We need a regular (non-UID) symbol here, therefore give a
5226 var
= gfc_create_var (TREE_TYPE (tmp
), "atmp");
5227 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5232 if (!code
->expr3
->mold
)
5236 /* When he length of a char array is easily available
5237 here, fix it for future use. */
5238 if (se
.string_length
)
5239 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5242 /* Figure how to get the _vtab entry. This also obtains the tree
5243 expression for accessing the _len component, because only
5244 unlimited polymorphic objects, which are a subcategory of class
5245 types, have a _len component. */
5246 if (code
->expr3
->ts
.type
== BT_CLASS
)
5249 /* Polymorphic SOURCE: VPTR must be determined at run time.
5250 expr3 may be a temporary array declaration, therefore check for
5251 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5252 if (expr3
!= NULL_TREE
&& GFC_CLASS_TYPE_P (TREE_TYPE (expr3
))
5253 && (VAR_P (expr3
) || !code
->expr3
->ref
))
5254 tmp
= gfc_class_vptr_get (expr3
);
5255 else if (expr3_tmp
!= NULL_TREE
5256 && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp
))
5257 && (VAR_P (expr3_tmp
) || !code
->expr3
->ref
))
5258 tmp
= gfc_class_vptr_get (expr3_tmp
);
5261 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5262 gfc_add_vptr_component (rhs
);
5263 gfc_init_se (&se
, NULL
);
5264 se
.want_pointer
= 1;
5265 gfc_conv_expr (&se
, rhs
);
5267 gfc_free_expr (rhs
);
5269 /* Set the element size. */
5270 expr3_esize
= gfc_vptr_size_get (tmp
);
5273 /* Initialize the ref to the _len component. */
5274 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5276 /* Same like for retrieving the _vptr. */
5277 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5278 expr3_len
= gfc_class_len_get (expr3
);
5279 else if (expr3_tmp
!= NULL_TREE
&& !code
->expr3
->ref
)
5280 expr3_len
= gfc_class_len_get (expr3_tmp
);
5283 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5284 gfc_add_len_component (rhs
);
5285 gfc_init_se (&se
, NULL
);
5286 gfc_conv_expr (&se
, rhs
);
5287 expr3_len
= se
.expr
;
5288 gfc_free_expr (rhs
);
5294 /* When the object to allocate is polymorphic type, then it
5295 needs its vtab set correctly, so deduce the required _vtab
5296 and _len from the source expression. */
5299 /* VPTR is fixed at compile time. */
5302 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5304 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5305 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5308 /* _len component needs to be set, when ts is a character
5310 if (expr3_len
== NULL_TREE
5311 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5313 if (code
->expr3
->ts
.u
.cl
5314 && code
->expr3
->ts
.u
.cl
->length
)
5316 gfc_init_se (&se
, NULL
);
5317 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5318 gfc_add_block_to_block (&block
, &se
.pre
);
5319 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5321 gcc_assert (expr3_len
);
5323 /* For character arrays only the kind's size is needed, because
5324 the array mem_size is _len * (elem_size = kind_size).
5325 For all other get the element size in the normal way. */
5326 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5327 expr3_esize
= TYPE_SIZE_UNIT (
5328 gfc_get_char_type (code
->expr3
->ts
.kind
));
5330 expr3_esize
= TYPE_SIZE_UNIT (
5331 gfc_typenode_for_spec (&code
->expr3
->ts
));
5333 /* The routine gfc_trans_assignment () already implements all
5334 techniques needed. Unfortunately we may have a temporary
5335 variable for the source= expression here. When that is the
5336 case convert this variable into a temporary gfc_expr of type
5337 EXPR_VARIABLE and used it as rhs for the assignment. The
5338 advantage is, that we get scalarizer support for free,
5339 don't have to take care about scalar to array treatment and
5340 will benefit of every enhancements gfc_trans_assignment ()
5342 if (expr3
!= NULL_TREE
&& DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5344 /* Build a temporary symtree and symbol. Do not add it to
5345 the current namespace to prevent accidently modifying
5346 a colliding symbol's as. */
5347 newsym
= XCNEW (gfc_symtree
);
5348 /* The name of the symtree should be unique, because
5349 gfc_create_var () took care about generating the
5351 newsym
->name
= gfc_get_string (IDENTIFIER_POINTER (
5352 DECL_NAME (expr3
)));
5353 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5354 /* The backend_decl is known. It is expr3, which is inserted
5356 newsym
->n
.sym
->backend_decl
= expr3
;
5357 e3rhs
= gfc_get_expr ();
5358 e3rhs
->ts
= code
->expr3
->ts
;
5359 e3rhs
->rank
= code
->expr3
->rank
;
5360 e3rhs
->symtree
= newsym
;
5361 /* Mark the symbol referenced or gfc_trans_assignment will
5363 newsym
->n
.sym
->attr
.referenced
= 1;
5364 e3rhs
->expr_type
= EXPR_VARIABLE
;
5365 /* Set the symbols type, upto it was BT_UNKNOWN. */
5366 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5367 /* Check whether the expr3 is array valued. */
5370 gfc_array_spec
*arr
;
5371 arr
= gfc_get_array_spec ();
5372 arr
->rank
= e3rhs
->rank
;
5373 arr
->type
= AS_DEFERRED
;
5374 /* Set the dimension and pointer attribute for arrays
5375 to be on the safe side. */
5376 newsym
->n
.sym
->attr
.dimension
= 1;
5377 newsym
->n
.sym
->attr
.pointer
= 1;
5378 newsym
->n
.sym
->as
= arr
;
5379 gfc_add_full_array_ref (e3rhs
, arr
);
5381 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5382 newsym
->n
.sym
->attr
.pointer
= 1;
5383 /* The string length is known to. Set it for char arrays. */
5384 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5385 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5386 gfc_commit_symbol (newsym
->n
.sym
);
5389 e3rhs
= gfc_copy_expr (code
->expr3
);
5391 gcc_assert (expr3_esize
);
5392 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5394 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5396 /* Compute the explicit typespec given only once for all objects
5398 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5399 expr3_esize
= TYPE_SIZE_UNIT (
5400 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5404 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5405 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5406 gfc_init_se (&se_sz
, NULL
);
5407 gfc_conv_expr (&se_sz
, sz
);
5409 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5410 tmp
= TYPE_SIZE_UNIT (tmp
);
5411 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5412 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5413 TREE_TYPE (se_sz
.expr
),
5418 /* Loop over all objects to allocate. */
5419 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5421 expr
= gfc_copy_expr (al
->expr
);
5422 /* UNLIMITED_POLY () needs the _data component to be set, when
5423 expr is a unlimited polymorphic object. But the _data component
5424 has not been set yet, so check the derived type's attr for the
5425 unlimited polymorphic flag to be safe. */
5426 upoly_expr
= UNLIMITED_POLY (expr
)
5427 || (expr
->ts
.type
== BT_DERIVED
5428 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5429 gfc_init_se (&se
, NULL
);
5431 /* For class types prepare the expressions to ref the _vptr
5432 and the _len component. The latter for unlimited polymorphic
5434 if (expr
->ts
.type
== BT_CLASS
)
5436 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
5437 gfc_add_data_component (expr
);
5438 /* Prep the vptr handle. */
5439 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
5440 gfc_add_vptr_component (expr_ref_vptr
);
5441 se
.want_pointer
= 1;
5442 gfc_conv_expr (&se
, expr_ref_vptr
);
5444 se
.want_pointer
= 0;
5445 gfc_free_expr (expr_ref_vptr
);
5446 /* Allocated unlimited polymorphic objects always have a _len
5450 expr_ref_len
= gfc_copy_expr (al
->expr
);
5451 gfc_add_len_component (expr_ref_len
);
5452 gfc_conv_expr (&se
, expr_ref_len
);
5454 gfc_free_expr (expr_ref_len
);
5457 /* In a loop ensure that all loop variable dependent variables
5458 are initialized at the same spot in all execution paths. */
5462 al_vptr
= al_len
= NULL_TREE
;
5464 se
.want_pointer
= 1;
5465 se
.descriptor_only
= 1;
5466 gfc_conv_expr (&se
, expr
);
5467 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5468 /* se.string_length now stores the .string_length variable of expr
5469 needed to allocate character(len=:) arrays. */
5470 al_len
= se
.string_length
;
5472 al_len_needs_set
= al_len
!= NULL_TREE
;
5473 /* When allocating an array one can not use much of the
5474 pre-evaluated expr3 expressions, because for most of them the
5475 scalarizer is needed which is not available in the pre-evaluation
5476 step. Therefore gfc_array_allocate () is responsible (and able)
5477 to handle the complete array allocation. Only the element size
5478 needs to be provided, which is done most of the time by the
5479 pre-evaluation step. */
5481 if (expr3_len
&& code
->expr3
->ts
.type
== BT_CHARACTER
)
5482 /* When al is an array, then the element size for each element
5483 in the array is needed, which is the product of the len and
5484 esize for char arrays. */
5485 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5486 TREE_TYPE (expr3_esize
), expr3_esize
,
5487 fold_convert (TREE_TYPE (expr3_esize
),
5491 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
5492 label_finish
, tmp
, &nelems
, code
->expr3
))
5494 /* A scalar or derived type. First compute the size to
5497 expr3_len is set when expr3 is an unlimited polymorphic
5498 object or a deferred length string. */
5499 if (expr3_len
!= NULL_TREE
)
5501 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
5502 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5503 TREE_TYPE (expr3_esize
),
5505 if (code
->expr3
->ts
.type
!= BT_CLASS
)
5506 /* expr3 is a deferred length string, i.e., we are
5511 /* For unlimited polymorphic enties build
5512 (len > 0) ? element_size * len : element_size
5513 to compute the number of bytes to allocate.
5514 This allows the allocation of unlimited polymorphic
5515 objects from an expr3 that is also unlimited
5516 polymorphic and stores a _len dependent object,
5518 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
5519 boolean_type_node
, expr3_len
,
5521 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
5522 TREE_TYPE (expr3_esize
),
5523 memsz
, tmp
, expr3_esize
);
5526 else if (expr3_esize
!= NULL_TREE
)
5527 /* Any other object in expr3 just needs element size in
5529 memsz
= expr3_esize
;
5530 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5532 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
5534 /* Allocating deferred length char arrays need the length
5535 to allocate in the alloc_type_spec. But also unlimited
5536 polymorphic objects may be allocated as char arrays.
5537 Both are handled here. */
5538 gfc_init_se (&se_sz
, NULL
);
5539 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5540 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5541 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5542 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5543 expr3_len
= se_sz
.expr
;
5544 tmp_expr3_len_flag
= true;
5545 tmp
= TYPE_SIZE_UNIT (
5546 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
5547 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5549 fold_convert (TREE_TYPE (tmp
),
5553 else if (expr
->ts
.type
== BT_CHARACTER
)
5555 /* Compute the number of bytes needed to allocate a fixed
5556 length char array. */
5557 gcc_assert (se
.string_length
!= NULL_TREE
);
5558 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
5559 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5560 TREE_TYPE (tmp
), tmp
,
5561 fold_convert (TREE_TYPE (tmp
),
5564 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5565 /* Handle all types, where the alloc_type_spec is set. */
5566 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5568 /* Handle size computation of the type declared to alloc. */
5569 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
5571 /* Allocate - for non-pointers with re-alloc checking. */
5572 if (gfc_expr_attr (expr
).allocatable
)
5573 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
, NULL_TREE
,
5574 stat
, errmsg
, errlen
, label_finish
,
5577 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
5579 if (al
->expr
->ts
.type
== BT_DERIVED
5580 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5582 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5583 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
5584 gfc_add_expr_to_block (&se
.pre
, tmp
);
5589 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5590 && expr3_len
!= NULL_TREE
)
5592 /* Arrays need to have a _len set before the array
5593 descriptor is filled. */
5594 gfc_add_modify (&block
, al_len
,
5595 fold_convert (TREE_TYPE (al_len
), expr3_len
));
5596 /* Prevent setting the length twice. */
5597 al_len_needs_set
= false;
5601 gfc_add_block_to_block (&block
, &se
.pre
);
5603 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5606 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
5607 parm
= fold_build2_loc (input_location
, NE_EXPR
,
5608 boolean_type_node
, stat
,
5609 build_int_cst (TREE_TYPE (stat
), 0));
5610 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5611 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
5612 tmp
, build_empty_stmt (input_location
));
5613 gfc_add_expr_to_block (&block
, tmp
);
5617 if (al_vptr
!= NULL_TREE
)
5619 if (expr3_vptr
!= NULL_TREE
)
5620 /* The vtab is already known, so just assign it. */
5621 gfc_add_modify (&block
, al_vptr
,
5622 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
5625 /* VPTR is fixed at compile time. */
5630 /* Although expr3 is pre-evaluated above, it may happen,
5631 that for arrays or in mold= cases the pre-evaluation
5632 was not successful. In these rare cases take the vtab
5633 from the typespec of expr3 here. */
5634 ts
= &code
->expr3
->ts
;
5635 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
5636 /* The alloc_type_spec gives the type to allocate or the
5637 al is unlimited polymorphic, which enforces the use of
5638 an alloc_type_spec that is not necessarily a BT_DERIVED. */
5639 ts
= &code
->ext
.alloc
.ts
;
5641 /* Prepare for setting the vtab as declared. */
5644 vtab
= gfc_find_vtab (ts
);
5646 tmp
= gfc_build_addr_expr (NULL_TREE
,
5647 gfc_get_symbol_decl (vtab
));
5648 gfc_add_modify (&block
, al_vptr
,
5649 fold_convert (TREE_TYPE (al_vptr
), tmp
));
5653 /* Add assignment for string length. */
5654 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
5656 if (expr3_len
!= NULL_TREE
)
5658 gfc_add_modify (&block
, al_len
,
5659 fold_convert (TREE_TYPE (al_len
),
5661 /* When tmp_expr3_len_flag is set, then expr3_len is
5662 abused to carry the length information from the
5663 alloc_type. Clear it to prevent setting incorrect len
5664 information in future loop iterations. */
5665 if (tmp_expr3_len_flag
)
5666 /* No need to reset tmp_expr3_len_flag, because the
5667 presence of an expr3 can not change within in the
5669 expr3_len
= NULL_TREE
;
5671 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
5672 && code
->ext
.alloc
.ts
.u
.cl
->length
)
5674 /* Cover the cases where a string length is explicitly
5675 specified by a type spec for deferred length character
5676 arrays or unlimited polymorphic objects without a
5677 source= or mold= expression. */
5678 gfc_init_se (&se_sz
, NULL
);
5679 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5680 gfc_add_modify (&block
, al_len
,
5681 fold_convert (TREE_TYPE (al_len
),
5685 /* No length information needed, because type to allocate
5686 has no length. Set _len to 0. */
5687 gfc_add_modify (&block
, al_len
,
5688 fold_convert (TREE_TYPE (al_len
),
5689 integer_zero_node
));
5691 if (code
->expr3
&& !code
->expr3
->mold
)
5693 /* Initialization via SOURCE block (or static default initializer).
5694 Classes need some special handling, so catch them first. */
5695 if (expr3
!= NULL_TREE
5696 && ((POINTER_TYPE_P (TREE_TYPE (expr3
))
5697 && TREE_CODE (expr3
) != POINTER_PLUS_EXPR
)
5698 || (VAR_P (expr3
) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3
))))
5699 && code
->expr3
->ts
.type
== BT_CLASS
5700 && (expr
->ts
.type
== BT_CLASS
5701 || expr
->ts
.type
== BT_DERIVED
))
5704 to
= VAR_P (se
.expr
) ? se
.expr
: TREE_OPERAND (se
.expr
, 0);
5705 tmp
= gfc_copy_class_to_class (expr3
, to
,
5706 nelems
, upoly_expr
);
5708 else if (al
->expr
->ts
.type
== BT_CLASS
)
5710 gfc_actual_arglist
*actual
, *last_arg
;
5713 gfc_ref
*ref
, *dataref
;
5714 gfc_expr
*rhs
= gfc_copy_expr (code
->expr3
);
5716 /* Do a polymorphic deep copy. */
5717 actual
= gfc_get_actual_arglist ();
5718 actual
->expr
= gfc_copy_expr (rhs
);
5719 if (rhs
->ts
.type
== BT_CLASS
)
5720 gfc_add_data_component (actual
->expr
);
5721 last_arg
= actual
->next
= gfc_get_actual_arglist ();
5722 last_arg
->expr
= gfc_copy_expr (al
->expr
);
5723 last_arg
->expr
->ts
.type
= BT_CLASS
;
5724 gfc_add_data_component (last_arg
->expr
);
5727 /* Make sure we go up through the reference chain to
5728 the _data reference, where the arrayspec is found. */
5729 for (ref
= last_arg
->expr
->ref
; ref
; ref
= ref
->next
)
5730 if (ref
->type
== REF_COMPONENT
5731 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
5734 if (dataref
&& dataref
->u
.c
.component
->as
)
5738 gfc_ref
*ref
= dataref
->next
;
5739 ref
->u
.ar
.type
= AR_SECTION
;
5740 /* We have to set up the array reference to give ranges
5741 in all dimensions and ensure that the end and stride
5742 are set so that the copy can be scalarized. */
5744 for (; dim
< dataref
->u
.c
.component
->as
->rank
; dim
++)
5746 ref
->u
.ar
.dimen_type
[dim
] = DIMEN_RANGE
;
5747 if (ref
->u
.ar
.end
[dim
] == NULL
)
5749 ref
->u
.ar
.end
[dim
] = ref
->u
.ar
.start
[dim
];
5750 temp
= gfc_get_int_expr (gfc_default_integer_kind
,
5751 &al
->expr
->where
, 1);
5752 ref
->u
.ar
.start
[dim
] = temp
;
5754 temp
= gfc_subtract (gfc_copy_expr (ref
->u
.ar
.end
[dim
]),
5755 gfc_copy_expr (ref
->u
.ar
.start
[dim
]));
5756 temp
= gfc_add (gfc_get_int_expr (gfc_default_integer_kind
,
5757 &al
->expr
->where
, 1),
5761 if (rhs
->ts
.type
== BT_CLASS
)
5764 ppc
= gfc_find_and_cut_at_last_class_ref (rhs
);
5766 ppc
= gfc_copy_expr (rhs
);
5767 gfc_add_vptr_component (ppc
);
5770 ppc
= gfc_lval_expr_from_sym (gfc_find_vtab (&rhs
->ts
));
5771 gfc_add_component_ref (ppc
, "_copy");
5773 ppc_code
= gfc_get_code (EXEC_CALL
);
5774 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
5775 ppc_code
->loc
= al
->expr
->where
;
5776 /* Although '_copy' is set to be elemental in class.c, it is
5777 not staying that way. Find out why, sometime.... */
5778 ppc_code
->resolved_sym
->attr
.elemental
= 1;
5779 ppc_code
->ext
.actual
= actual
;
5780 ppc_code
->expr1
= ppc
;
5781 /* Since '_copy' is elemental, the scalarizer will take care
5782 of arrays in gfc_trans_call. */
5783 tmp
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
5784 /* We need to add the
5786 al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
5788 al_vptr->copy (expr3_data, al_data);
5789 block, because al is unlimited polymorphic or a deferred
5790 length char array, whose copy routine needs the array lengths
5791 as third and fourth arguments. */
5792 if (al_len
&& UNLIMITED_POLY (code
->expr3
))
5794 tree stdcopy
, extcopy
;
5796 last_arg
->next
= gfc_get_actual_arglist ();
5797 last_arg
= last_arg
->next
;
5798 last_arg
->expr
= gfc_find_and_cut_at_last_class_ref (
5800 gfc_add_len_component (last_arg
->expr
);
5801 /* Add expr3's length. */
5802 last_arg
->next
= gfc_get_actual_arglist ();
5803 last_arg
= last_arg
->next
;
5804 if (code
->expr3
->ts
.type
== BT_CLASS
)
5807 gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5808 gfc_add_len_component (last_arg
->expr
);
5810 else if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5812 gfc_copy_expr (code
->expr3
->ts
.u
.cl
->length
);
5817 extcopy
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
5819 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
5820 boolean_type_node
, expr3_len
,
5822 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
5823 void_type_node
, tmp
, extcopy
, stdcopy
);
5825 gfc_free_statements (ppc_code
);
5826 gfc_free_expr (rhs
);
5830 /* Switch off automatic reallocation since we have just
5831 done the ALLOCATE. */
5832 int realloc_lhs
= flag_realloc_lhs
;
5833 flag_realloc_lhs
= 0;
5834 tmp
= gfc_trans_assignment (gfc_expr_to_initialize (expr
),
5835 e3rhs
, false, false);
5836 flag_realloc_lhs
= realloc_lhs
;
5838 gfc_add_expr_to_block (&block
, tmp
);
5840 else if (code
->expr3
&& code
->expr3
->mold
5841 && code
->expr3
->ts
.type
== BT_CLASS
)
5843 /* Since the _vptr has already been assigned to the allocate
5844 object, we can use gfc_copy_class_to_class in its
5845 initialization mode. */
5846 tmp
= TREE_OPERAND (se
.expr
, 0);
5847 tmp
= gfc_copy_class_to_class (NULL_TREE
, tmp
, nelems
,
5849 gfc_add_expr_to_block (&block
, tmp
);
5852 gfc_free_expr (expr
);
5859 gfc_free_symbol (newsym
->n
.sym
);
5862 gfc_free_expr (e3rhs
);
5867 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
5868 gfc_add_expr_to_block (&block
, tmp
);
5871 /* ERRMSG - only useful if STAT is present. */
5872 if (code
->expr1
&& code
->expr2
)
5874 const char *msg
= "Attempt to allocate an allocated object";
5875 tree slen
, dlen
, errmsg_str
;
5876 stmtblock_t errmsg_block
;
5878 gfc_init_block (&errmsg_block
);
5880 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
5881 gfc_add_modify (&errmsg_block
, errmsg_str
,
5882 gfc_build_addr_expr (pchar_type_node
,
5883 gfc_build_localized_cstring_const (msg
)));
5885 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
5886 dlen
= gfc_get_expr_charlen (code
->expr2
);
5887 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
5888 TREE_TYPE (slen
), dlen
, slen
);
5890 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
5891 code
->expr2
->ts
.kind
,
5893 gfc_default_character_kind
);
5894 dlen
= gfc_finish_block (&errmsg_block
);
5896 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
5897 stat
, build_int_cst (TREE_TYPE (stat
), 0));
5899 tmp
= build3_v (COND_EXPR
, tmp
,
5900 dlen
, build_empty_stmt (input_location
));
5902 gfc_add_expr_to_block (&block
, tmp
);
5908 if (TREE_USED (label_finish
))
5910 tmp
= build1_v (LABEL_EXPR
, label_finish
);
5911 gfc_add_expr_to_block (&block
, tmp
);
5914 gfc_init_se (&se
, NULL
);
5915 gfc_conv_expr_lhs (&se
, code
->expr1
);
5916 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
5917 gfc_add_modify (&block
, se
.expr
, tmp
);
5920 gfc_add_block_to_block (&block
, &se
.post
);
5921 gfc_add_block_to_block (&block
, &post
);
5923 return gfc_finish_block (&block
);
5927 /* Translate a DEALLOCATE statement. */
5930 gfc_trans_deallocate (gfc_code
*code
)
5934 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
5935 tree label_finish
, label_errmsg
;
5938 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
5939 label_finish
= label_errmsg
= NULL_TREE
;
5941 gfc_start_block (&block
);
5943 /* Count the number of failed deallocations. If deallocate() was
5944 called with STAT= , then set STAT to the count. If deallocate
5945 was called with ERRMSG, then set ERRMG to a string. */
5948 tree gfc_int4_type_node
= gfc_get_int_type (4);
5950 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5951 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
5953 /* GOTO destinations. */
5954 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5955 label_finish
= gfc_build_label_decl (NULL_TREE
);
5956 TREE_USED (label_finish
) = 0;
5959 /* Set ERRMSG - only needed if STAT is available. */
5960 if (code
->expr1
&& code
->expr2
)
5962 gfc_init_se (&se
, NULL
);
5963 se
.want_pointer
= 1;
5964 gfc_conv_expr_lhs (&se
, code
->expr2
);
5966 errlen
= se
.string_length
;
5969 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5971 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
5972 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
5974 if (expr
->ts
.type
== BT_CLASS
)
5975 gfc_add_data_component (expr
);
5977 gfc_init_se (&se
, NULL
);
5978 gfc_start_block (&se
.pre
);
5980 se
.want_pointer
= 1;
5981 se
.descriptor_only
= 1;
5982 gfc_conv_expr (&se
, expr
);
5984 if (expr
->rank
|| gfc_is_coarray (expr
))
5988 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->attr
.alloc_comp
5989 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
5991 gfc_ref
*last
= NULL
;
5993 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5994 if (ref
->type
== REF_COMPONENT
)
5997 /* Do not deallocate the components of a derived type
5998 ultimate pointer component. */
5999 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6000 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6002 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
6004 gfc_add_expr_to_block (&se
.pre
, tmp
);
6008 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6010 tmp
= gfc_array_deallocate (se
.expr
, pstat
, errmsg
, errlen
,
6011 label_finish
, expr
);
6012 gfc_add_expr_to_block (&se
.pre
, tmp
);
6014 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6015 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6016 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6019 /* class.c(finalize_component) generates these, when a
6020 finalizable entity has a non-allocatable derived type array
6021 component, which has allocatable components. Obtain the
6022 derived type of the array and deallocate the allocatable
6024 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6026 if (ref
->u
.c
.component
->attr
.dimension
6027 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6031 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6032 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6035 tmp
= gfc_deallocate_alloc_comp
6036 (ref
->u
.c
.component
->ts
.u
.derived
,
6037 se
.expr
, expr
->rank
);
6038 gfc_add_expr_to_block (&se
.pre
, tmp
);
6042 if (al
->expr
->ts
.type
== BT_CLASS
)
6044 gfc_reset_vptr (&se
.pre
, al
->expr
);
6045 if (UNLIMITED_POLY (al
->expr
)
6046 || (al
->expr
->ts
.type
== BT_DERIVED
6047 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6048 /* Clear _len, too. */
6049 gfc_reset_len (&se
.pre
, al
->expr
);
6054 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, false,
6055 al
->expr
, al
->expr
->ts
);
6056 gfc_add_expr_to_block (&se
.pre
, tmp
);
6058 /* Set to zero after deallocation. */
6059 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6061 build_int_cst (TREE_TYPE (se
.expr
), 0));
6062 gfc_add_expr_to_block (&se
.pre
, tmp
);
6064 if (al
->expr
->ts
.type
== BT_CLASS
)
6066 gfc_reset_vptr (&se
.pre
, al
->expr
);
6067 if (UNLIMITED_POLY (al
->expr
)
6068 || (al
->expr
->ts
.type
== BT_DERIVED
6069 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6070 /* Clear _len, too. */
6071 gfc_reset_len (&se
.pre
, al
->expr
);
6079 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6080 build_int_cst (TREE_TYPE (stat
), 0));
6081 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6082 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6083 build1_v (GOTO_EXPR
, label_errmsg
),
6084 build_empty_stmt (input_location
));
6085 gfc_add_expr_to_block (&se
.pre
, tmp
);
6088 tmp
= gfc_finish_block (&se
.pre
);
6089 gfc_add_expr_to_block (&block
, tmp
);
6090 gfc_free_expr (expr
);
6095 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6096 gfc_add_expr_to_block (&block
, tmp
);
6099 /* Set ERRMSG - only needed if STAT is available. */
6100 if (code
->expr1
&& code
->expr2
)
6102 const char *msg
= "Attempt to deallocate an unallocated object";
6103 stmtblock_t errmsg_block
;
6104 tree errmsg_str
, slen
, dlen
, cond
;
6106 gfc_init_block (&errmsg_block
);
6108 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6109 gfc_add_modify (&errmsg_block
, errmsg_str
,
6110 gfc_build_addr_expr (pchar_type_node
,
6111 gfc_build_localized_cstring_const (msg
)));
6112 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6113 dlen
= gfc_get_expr_charlen (code
->expr2
);
6115 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6116 slen
, errmsg_str
, gfc_default_character_kind
);
6117 tmp
= gfc_finish_block (&errmsg_block
);
6119 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6120 build_int_cst (TREE_TYPE (stat
), 0));
6121 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6122 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6123 build_empty_stmt (input_location
));
6125 gfc_add_expr_to_block (&block
, tmp
);
6128 if (code
->expr1
&& TREE_USED (label_finish
))
6130 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6131 gfc_add_expr_to_block (&block
, tmp
);
6137 gfc_init_se (&se
, NULL
);
6138 gfc_conv_expr_lhs (&se
, code
->expr1
);
6139 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6140 gfc_add_modify (&block
, se
.expr
, tmp
);
6143 return gfc_finish_block (&block
);
6146 #include "gt-fortran-trans-stmt.h"