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);
553 gfc_warning ("An alternate return at %L without a * dummy argument",
554 &code
->expr1
->where
);
555 return gfc_generate_return ();
558 /* Start a new block for this statement. */
559 gfc_init_se (&se
, NULL
);
560 gfc_start_block (&se
.pre
);
562 gfc_conv_expr (&se
, code
->expr1
);
564 /* Note that the actually returned expression is a simple value and
565 does not depend on any pointers or such; thus we can clean-up with
566 se.post before returning. */
567 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
568 result
, fold_convert (TREE_TYPE (result
),
570 gfc_add_expr_to_block (&se
.pre
, tmp
);
571 gfc_add_block_to_block (&se
.pre
, &se
.post
);
573 tmp
= gfc_generate_return ();
574 gfc_add_expr_to_block (&se
.pre
, tmp
);
575 return gfc_finish_block (&se
.pre
);
578 return gfc_generate_return ();
582 /* Translate the PAUSE statement. We have to translate this statement
583 to a runtime library call. */
586 gfc_trans_pause (gfc_code
* code
)
588 tree gfc_int4_type_node
= gfc_get_int_type (4);
592 /* Start a new block for this statement. */
593 gfc_init_se (&se
, NULL
);
594 gfc_start_block (&se
.pre
);
597 if (code
->expr1
== NULL
)
599 tmp
= build_int_cst (gfc_int4_type_node
, 0);
600 tmp
= build_call_expr_loc (input_location
,
601 gfor_fndecl_pause_string
, 2,
602 build_int_cst (pchar_type_node
, 0), tmp
);
604 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
606 gfc_conv_expr (&se
, code
->expr1
);
607 tmp
= build_call_expr_loc (input_location
,
608 gfor_fndecl_pause_numeric
, 1,
609 fold_convert (gfc_int4_type_node
, se
.expr
));
613 gfc_conv_expr_reference (&se
, code
->expr1
);
614 tmp
= build_call_expr_loc (input_location
,
615 gfor_fndecl_pause_string
, 2,
616 se
.expr
, se
.string_length
);
619 gfc_add_expr_to_block (&se
.pre
, tmp
);
621 gfc_add_block_to_block (&se
.pre
, &se
.post
);
623 return gfc_finish_block (&se
.pre
);
627 /* Translate the STOP statement. We have to translate this statement
628 to a runtime library call. */
631 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
633 tree gfc_int4_type_node
= gfc_get_int_type (4);
637 /* Start a new block for this statement. */
638 gfc_init_se (&se
, NULL
);
639 gfc_start_block (&se
.pre
);
641 if (flag_coarray
== GFC_FCOARRAY_LIB
&& !error_stop
)
643 /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
644 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
645 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
646 gfc_add_expr_to_block (&se
.pre
, tmp
);
648 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_finalize
, 0);
649 gfc_add_expr_to_block (&se
.pre
, tmp
);
652 if (code
->expr1
== NULL
)
654 tmp
= build_int_cst (gfc_int4_type_node
, 0);
655 tmp
= build_call_expr_loc (input_location
,
657 ? (flag_coarray
== GFC_FCOARRAY_LIB
658 ? gfor_fndecl_caf_error_stop_str
659 : gfor_fndecl_error_stop_string
)
660 : gfor_fndecl_stop_string
,
661 2, build_int_cst (pchar_type_node
, 0), tmp
);
663 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
665 gfc_conv_expr (&se
, code
->expr1
);
666 tmp
= build_call_expr_loc (input_location
,
668 ? (flag_coarray
== GFC_FCOARRAY_LIB
669 ? gfor_fndecl_caf_error_stop
670 : gfor_fndecl_error_stop_numeric
)
671 : gfor_fndecl_stop_numeric_f08
, 1,
672 fold_convert (gfc_int4_type_node
, se
.expr
));
676 gfc_conv_expr_reference (&se
, code
->expr1
);
677 tmp
= build_call_expr_loc (input_location
,
679 ? (flag_coarray
== GFC_FCOARRAY_LIB
680 ? gfor_fndecl_caf_error_stop_str
681 : gfor_fndecl_error_stop_string
)
682 : gfor_fndecl_stop_string
,
683 2, se
.expr
, se
.string_length
);
686 gfc_add_expr_to_block (&se
.pre
, tmp
);
688 gfc_add_block_to_block (&se
.pre
, &se
.post
);
690 return gfc_finish_block (&se
.pre
);
695 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op type ATTRIBUTE_UNUSED
)
698 tree stat
= NULL_TREE
, lock_acquired
= NULL_TREE
;
700 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
701 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
702 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
705 gfc_init_se (&se
, NULL
);
706 gfc_start_block (&se
.pre
);
710 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
711 gfc_init_se (&argse
, NULL
);
712 gfc_conv_expr_val (&argse
, code
->expr2
);
718 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
719 gfc_init_se (&argse
, NULL
);
720 gfc_conv_expr_val (&argse
, code
->expr4
);
721 lock_acquired
= argse
.expr
;
724 if (stat
!= NULL_TREE
)
725 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
727 if (lock_acquired
!= NULL_TREE
)
728 gfc_add_modify (&se
.pre
, lock_acquired
,
729 fold_convert (TREE_TYPE (lock_acquired
),
732 return gfc_finish_block (&se
.pre
);
737 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
741 tree images
= NULL_TREE
, stat
= NULL_TREE
,
742 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
744 /* Short cut: For single images without bound checking or without STAT=,
745 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
746 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
747 && flag_coarray
!= GFC_FCOARRAY_LIB
)
750 gfc_init_se (&se
, NULL
);
751 gfc_start_block (&se
.pre
);
753 if (code
->expr1
&& code
->expr1
->rank
== 0)
755 gfc_init_se (&argse
, NULL
);
756 gfc_conv_expr_val (&argse
, code
->expr1
);
762 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
763 gfc_init_se (&argse
, NULL
);
764 gfc_conv_expr_val (&argse
, code
->expr2
);
768 stat
= null_pointer_node
;
770 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
771 && type
!= EXEC_SYNC_MEMORY
)
773 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
774 gfc_init_se (&argse
, NULL
);
775 gfc_conv_expr (&argse
, code
->expr3
);
776 gfc_conv_string_parameter (&argse
);
777 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
778 errmsglen
= argse
.string_length
;
780 else if (flag_coarray
== GFC_FCOARRAY_LIB
&& type
!= EXEC_SYNC_MEMORY
)
782 errmsg
= null_pointer_node
;
783 errmsglen
= build_int_cst (integer_type_node
, 0);
786 /* Check SYNC IMAGES(imageset) for valid image index.
787 FIXME: Add a check for image-set arrays. */
788 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
789 && code
->expr1
->rank
== 0)
792 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
793 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
794 images
, build_int_cst (TREE_TYPE (images
), 1));
798 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
799 2, integer_zero_node
,
800 build_int_cst (integer_type_node
, -1));
801 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
803 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
805 build_int_cst (TREE_TYPE (images
), 1));
806 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
807 boolean_type_node
, cond
, cond2
);
809 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
810 &code
->expr1
->where
, "Invalid image number "
812 fold_convert (integer_type_node
, images
));
815 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
816 image control statements SYNC IMAGES and SYNC ALL. */
817 if (flag_coarray
== GFC_FCOARRAY_LIB
)
819 tmp
= builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE
);
820 tmp
= build_call_expr_loc (input_location
, tmp
, 0);
821 gfc_add_expr_to_block (&se
.pre
, tmp
);
824 if (flag_coarray
!= GFC_FCOARRAY_LIB
|| type
== EXEC_SYNC_MEMORY
)
826 /* Set STAT to zero. */
828 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
830 else if (type
== EXEC_SYNC_ALL
)
832 /* SYNC ALL => stat == null_pointer_node
833 SYNC ALL(stat=s) => stat has an integer type
835 If "stat" has the wrong integer type, use a temp variable of
836 the right type and later cast the result back into "stat". */
837 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
839 if (TREE_TYPE (stat
) == integer_type_node
)
840 stat
= gfc_build_addr_expr (NULL
, stat
);
842 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
843 3, stat
, errmsg
, errmsglen
);
844 gfc_add_expr_to_block (&se
.pre
, tmp
);
848 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
850 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
851 3, gfc_build_addr_expr (NULL
, tmp_stat
),
853 gfc_add_expr_to_block (&se
.pre
, tmp
);
855 gfc_add_modify (&se
.pre
, stat
,
856 fold_convert (TREE_TYPE (stat
), tmp_stat
));
863 gcc_assert (type
== EXEC_SYNC_IMAGES
);
867 len
= build_int_cst (integer_type_node
, -1);
868 images
= null_pointer_node
;
870 else if (code
->expr1
->rank
== 0)
872 len
= build_int_cst (integer_type_node
, 1);
873 images
= gfc_build_addr_expr (NULL_TREE
, images
);
878 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
879 gfc_fatal_error ("Sorry, only support for integer kind %d "
880 "implemented for image-set at %L",
881 gfc_c_int_kind
, &code
->expr1
->where
);
883 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
886 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
887 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
888 tmp
= gfc_get_element_type (tmp
);
890 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
891 TREE_TYPE (len
), len
,
892 fold_convert (TREE_TYPE (len
),
893 TYPE_SIZE_UNIT (tmp
)));
894 len
= fold_convert (integer_type_node
, len
);
897 /* SYNC IMAGES(imgs) => stat == null_pointer_node
898 SYNC IMAGES(imgs,stat=s) => stat has an integer type
900 If "stat" has the wrong integer type, use a temp variable of
901 the right type and later cast the result back into "stat". */
902 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
904 if (TREE_TYPE (stat
) == integer_type_node
)
905 stat
= gfc_build_addr_expr (NULL
, stat
);
907 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
908 5, fold_convert (integer_type_node
, len
),
909 images
, stat
, errmsg
, errmsglen
);
910 gfc_add_expr_to_block (&se
.pre
, tmp
);
914 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
916 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
917 5, fold_convert (integer_type_node
, len
),
918 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
920 gfc_add_expr_to_block (&se
.pre
, tmp
);
922 gfc_add_modify (&se
.pre
, stat
,
923 fold_convert (TREE_TYPE (stat
), tmp_stat
));
927 return gfc_finish_block (&se
.pre
);
931 /* Generate GENERIC for the IF construct. This function also deals with
932 the simple IF statement, because the front end translates the IF
933 statement into an IF construct.
965 where COND_S is the simplified version of the predicate. PRE_COND_S
966 are the pre side-effects produced by the translation of the
968 We need to build the chain recursively otherwise we run into
969 problems with folding incomplete statements. */
972 gfc_trans_if_1 (gfc_code
* code
)
979 /* Check for an unconditional ELSE clause. */
981 return gfc_trans_code (code
->next
);
983 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
984 gfc_init_se (&if_se
, NULL
);
985 gfc_start_block (&if_se
.pre
);
987 /* Calculate the IF condition expression. */
988 if (code
->expr1
->where
.lb
)
990 gfc_save_backend_locus (&saved_loc
);
991 gfc_set_backend_locus (&code
->expr1
->where
);
994 gfc_conv_expr_val (&if_se
, code
->expr1
);
996 if (code
->expr1
->where
.lb
)
997 gfc_restore_backend_locus (&saved_loc
);
999 /* Translate the THEN clause. */
1000 stmt
= gfc_trans_code (code
->next
);
1002 /* Translate the ELSE clause. */
1004 elsestmt
= gfc_trans_if_1 (code
->block
);
1006 elsestmt
= build_empty_stmt (input_location
);
1008 /* Build the condition expression and add it to the condition block. */
1009 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1010 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1013 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1015 /* Finish off this statement. */
1016 return gfc_finish_block (&if_se
.pre
);
1020 gfc_trans_if (gfc_code
* code
)
1025 /* Create exit label so it is available for trans'ing the body code. */
1026 exit_label
= gfc_build_label_decl (NULL_TREE
);
1027 code
->exit_label
= exit_label
;
1029 /* Translate the actual code in code->block. */
1030 gfc_init_block (&body
);
1031 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1033 /* Add exit label. */
1034 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1036 return gfc_finish_block (&body
);
1040 /* Translate an arithmetic IF expression.
1042 IF (cond) label1, label2, label3 translates to
1054 An optimized version can be generated in case of equal labels.
1055 E.g., if label1 is equal to label2, we can translate it to
1064 gfc_trans_arithmetic_if (gfc_code
* code
)
1072 /* Start a new block. */
1073 gfc_init_se (&se
, NULL
);
1074 gfc_start_block (&se
.pre
);
1076 /* Pre-evaluate COND. */
1077 gfc_conv_expr_val (&se
, code
->expr1
);
1078 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1080 /* Build something to compare with. */
1081 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1083 if (code
->label1
->value
!= code
->label2
->value
)
1085 /* If (cond < 0) take branch1 else take branch2.
1086 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1087 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1088 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1090 if (code
->label1
->value
!= code
->label3
->value
)
1091 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1094 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1097 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1098 tmp
, branch1
, branch2
);
1101 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1103 if (code
->label1
->value
!= code
->label3
->value
1104 && code
->label2
->value
!= code
->label3
->value
)
1106 /* if (cond <= 0) take branch1 else take branch2. */
1107 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1108 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1110 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1111 tmp
, branch1
, branch2
);
1114 /* Append the COND_EXPR to the evaluation of COND, and return. */
1115 gfc_add_expr_to_block (&se
.pre
, branch1
);
1116 return gfc_finish_block (&se
.pre
);
1120 /* Translate a CRITICAL block. */
1122 gfc_trans_critical (gfc_code
*code
)
1125 tree tmp
, token
= NULL_TREE
;
1127 gfc_start_block (&block
);
1129 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1131 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1132 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1133 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1134 token
, integer_zero_node
, integer_one_node
,
1135 null_pointer_node
, null_pointer_node
,
1136 null_pointer_node
, integer_zero_node
);
1137 gfc_add_expr_to_block (&block
, tmp
);
1140 tmp
= gfc_trans_code (code
->block
->next
);
1141 gfc_add_expr_to_block (&block
, tmp
);
1143 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1145 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1146 token
, integer_zero_node
, integer_one_node
,
1147 null_pointer_node
, null_pointer_node
,
1149 gfc_add_expr_to_block (&block
, tmp
);
1153 return gfc_finish_block (&block
);
1157 /* Return true, when the class has a _len component. */
1160 class_has_len_component (gfc_symbol
*sym
)
1162 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1165 if (strcmp (comp
->name
, "_len") == 0)
1173 /* Do proper initialization for ASSOCIATE names. */
1176 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1187 bool need_len_assign
;
1189 gcc_assert (sym
->assoc
);
1190 e
= sym
->assoc
->target
;
1192 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1193 && (gfc_is_class_scalar_expr (e
)
1194 || gfc_is_class_array_ref (e
, NULL
));
1196 unlimited
= UNLIMITED_POLY (e
);
1198 /* Assignments to the string length need to be generated, when
1199 ( sym is a char array or
1200 sym has a _len component)
1201 and the associated expression is unlimited polymorphic, which is
1202 not (yet) correctly in 'unlimited', because for an already associated
1203 BT_DERIVED the u-poly flag is not set, i.e.,
1204 __tmp_CHARACTER_0_1 => w => arg
1205 ^ generated temp ^ from code, the w does not have the u-poly
1206 flag set, where UNLIMITED_POLY(e) expects it. */
1207 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1208 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1209 && (sym
->ts
.type
== BT_CHARACTER
1210 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1211 && class_has_len_component (sym
))));
1212 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1213 to array temporary) for arrays with either unknown shape or if associating
1215 if (sym
->attr
.dimension
&& !class_target
1216 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1220 bool cst_array_ctor
;
1222 desc
= sym
->backend_decl
;
1223 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1224 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1226 /* If association is to an expression, evaluate it and create temporary.
1227 Otherwise, get descriptor of target for pointer assignment. */
1228 gfc_init_se (&se
, NULL
);
1229 if (sym
->assoc
->variable
|| cst_array_ctor
)
1231 se
.direct_byref
= 1;
1236 gfc_conv_expr_descriptor (&se
, e
);
1238 /* If we didn't already do the pointer assignment, set associate-name
1239 descriptor to the one generated for the temporary. */
1240 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1244 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1246 /* The generated descriptor has lower bound zero (as array
1247 temporary), shift bounds so we get lower bounds of 1. */
1248 for (dim
= 0; dim
< e
->rank
; ++dim
)
1249 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1250 dim
, gfc_index_one_node
);
1253 /* If this is a subreference array pointer associate name use the
1254 associate variable element size for the value of 'span'. */
1255 if (sym
->attr
.subref_array_pointer
)
1257 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1258 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1259 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1260 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1261 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1264 /* Done, register stuff as init / cleanup code. */
1265 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1266 gfc_finish_block (&se
.post
));
1269 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1270 arrays to be assigned directly. */
1271 else if (class_target
&& sym
->attr
.dimension
1272 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1276 gfc_init_se (&se
, NULL
);
1277 se
.descriptor_only
= 1;
1278 gfc_conv_expr (&se
, e
);
1280 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)));
1281 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1283 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1287 /* Recover the dtype, which has been overwritten by the
1288 assignment from an unlimited polymorphic object. */
1289 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1290 gfc_add_modify (&se
.pre
, tmp
,
1291 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1294 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1295 gfc_finish_block (&se
.post
));
1298 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1299 else if (gfc_is_associate_pointer (sym
))
1303 gcc_assert (!sym
->attr
.dimension
);
1305 gfc_init_se (&se
, NULL
);
1307 /* Class associate-names come this way because they are
1308 unconditionally associate pointers and the symbol is scalar. */
1309 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1312 /* For a class array we need a descriptor for the selector. */
1313 gfc_conv_expr_descriptor (&se
, e
);
1314 /* Needed to get/set the _len component below. */
1315 target_expr
= se
.expr
;
1317 /* Obtain a temporary class container for the result. */
1318 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1319 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1321 /* Set the offset. */
1322 desc
= gfc_class_data_get (se
.expr
);
1323 offset
= gfc_index_zero_node
;
1324 for (n
= 0; n
< e
->rank
; n
++)
1326 dim
= gfc_rank_cst
[n
];
1327 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1328 gfc_array_index_type
,
1329 gfc_conv_descriptor_stride_get (desc
, dim
),
1330 gfc_conv_descriptor_lbound_get (desc
, dim
));
1331 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1332 gfc_array_index_type
,
1335 if (need_len_assign
)
1337 /* Get the _len comp from the target expr by stripping _data
1338 from it and adding component-ref to _len. */
1339 tmp
= gfc_class_len_get (TREE_OPERAND (target_expr
, 0));
1340 /* Get the component-ref for the temp structure's _len comp. */
1341 charlen
= gfc_class_len_get (se
.expr
);
1342 /* Add the assign to the beginning of the the block... */
1343 gfc_add_modify (&se
.pre
, charlen
,
1344 fold_convert (TREE_TYPE (charlen
), tmp
));
1345 /* and the oposite way at the end of the block, to hand changes
1346 on the string length back. */
1347 gfc_add_modify (&se
.post
, tmp
,
1348 fold_convert (TREE_TYPE (tmp
), charlen
));
1349 /* Length assignment done, prevent adding it again below. */
1350 need_len_assign
= false;
1352 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1354 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1355 && CLASS_DATA (e
)->attr
.dimension
)
1357 /* This is bound to be a class array element. */
1358 gfc_conv_expr_reference (&se
, e
);
1359 /* Get the _vptr component of the class object. */
1360 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1361 /* Obtain a temporary class container for the result. */
1362 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1363 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1367 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1368 which has the string length included. For CHARACTERS it is still
1369 needed and will be done at the end of this routine. */
1370 gfc_conv_expr (&se
, e
);
1371 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1374 tmp
= TREE_TYPE (sym
->backend_decl
);
1375 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1376 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1378 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1379 gfc_finish_block (&se
.post
));
1382 /* Do a simple assignment. This is for scalar expressions, where we
1383 can simply use expression assignment. */
1388 lhs
= gfc_lval_expr_from_sym (sym
);
1389 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1390 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1393 /* Set the stringlength, when needed. */
1394 if (need_len_assign
)
1397 gfc_init_se (&se
, NULL
);
1398 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1400 /* What about deferred strings? */
1401 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1402 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1405 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1406 gfc_get_symbol_decl (sym
);
1407 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1408 : gfc_class_len_get (sym
->backend_decl
);
1409 /* Prevent adding a noop len= len. */
1412 gfc_add_modify (&se
.pre
, charlen
,
1413 fold_convert (TREE_TYPE (charlen
), tmp
));
1414 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1415 gfc_finish_block (&se
.post
));
1421 /* Translate a BLOCK construct. This is basically what we would do for a
1425 gfc_trans_block_construct (gfc_code
* code
)
1429 gfc_wrapped_block block
;
1432 gfc_association_list
*ass
;
1434 ns
= code
->ext
.block
.ns
;
1436 sym
= ns
->proc_name
;
1439 /* Process local variables. */
1440 gcc_assert (!sym
->tlink
);
1442 gfc_process_block_locals (ns
);
1444 /* Generate code including exit-label. */
1445 gfc_init_block (&body
);
1446 exit_label
= gfc_build_label_decl (NULL_TREE
);
1447 code
->exit_label
= exit_label
;
1449 /* Generate !$ACC DECLARE directive. */
1450 if (ns
->oacc_declare_clauses
)
1452 tree tmp
= gfc_trans_oacc_declare (&body
, ns
);
1453 gfc_add_expr_to_block (&body
, tmp
);
1456 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1457 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1459 /* Finish everything. */
1460 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1461 gfc_trans_deferred_vars (sym
, &block
);
1462 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1463 trans_associate_var (ass
->st
->n
.sym
, &block
);
1465 return gfc_finish_wrapped_block (&block
);
1469 /* Translate the simple DO construct. This is where the loop variable has
1470 integer type and step +-1. We can't use this in the general case
1471 because integer overflow and floating point errors could give incorrect
1473 We translate a do loop from:
1475 DO dovar = from, to, step
1481 [Evaluate loop bounds and step]
1483 if ((step > 0) ? (dovar <= to) : (dovar => to))
1489 cond = (dovar == to);
1491 if (cond) goto end_label;
1496 This helps the optimizers by avoiding the extra induction variable
1497 used in the general case. */
1500 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1501 tree from
, tree to
, tree step
, tree exit_cond
)
1507 tree saved_dovar
= NULL
;
1512 type
= TREE_TYPE (dovar
);
1514 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1516 /* Initialize the DO variable: dovar = from. */
1517 gfc_add_modify_loc (loc
, pblock
, dovar
,
1518 fold_convert (TREE_TYPE(dovar
), from
));
1520 /* Save value for do-tinkering checking. */
1521 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1523 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1524 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1527 /* Cycle and exit statements are implemented with gotos. */
1528 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1529 exit_label
= gfc_build_label_decl (NULL_TREE
);
1531 /* Put the labels where they can be found later. See gfc_trans_do(). */
1532 code
->cycle_label
= cycle_label
;
1533 code
->exit_label
= exit_label
;
1536 gfc_start_block (&body
);
1538 /* Main loop body. */
1539 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1540 gfc_add_expr_to_block (&body
, tmp
);
1542 /* Label for cycle statements (if needed). */
1543 if (TREE_USED (cycle_label
))
1545 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1546 gfc_add_expr_to_block (&body
, tmp
);
1549 /* Check whether someone has modified the loop variable. */
1550 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1552 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1553 dovar
, saved_dovar
);
1554 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1555 "Loop variable has been modified");
1558 /* Exit the loop if there is an I/O result condition or error. */
1561 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1562 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1564 build_empty_stmt (loc
));
1565 gfc_add_expr_to_block (&body
, tmp
);
1568 /* Evaluate the loop condition. */
1569 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, dovar
,
1571 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1573 /* Increment the loop variable. */
1574 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1575 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1577 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1578 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1580 /* The loop exit. */
1581 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1582 TREE_USED (exit_label
) = 1;
1583 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1584 cond
, tmp
, build_empty_stmt (loc
));
1585 gfc_add_expr_to_block (&body
, tmp
);
1587 /* Finish the loop body. */
1588 tmp
= gfc_finish_block (&body
);
1589 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1591 /* Only execute the loop if the number of iterations is positive. */
1592 if (tree_int_cst_sgn (step
) > 0)
1593 cond
= fold_build2_loc (loc
, LE_EXPR
, boolean_type_node
, dovar
,
1596 cond
= fold_build2_loc (loc
, GE_EXPR
, boolean_type_node
, dovar
,
1598 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, cond
, tmp
,
1599 build_empty_stmt (loc
));
1600 gfc_add_expr_to_block (pblock
, tmp
);
1602 /* Add the exit label. */
1603 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1604 gfc_add_expr_to_block (pblock
, tmp
);
1606 return gfc_finish_block (pblock
);
1609 /* Translate the DO construct. This obviously is one of the most
1610 important ones to get right with any compiler, but especially
1613 We special case some loop forms as described in gfc_trans_simple_do.
1614 For other cases we implement them with a separate loop count,
1615 as described in the standard.
1617 We translate a do loop from:
1619 DO dovar = from, to, step
1625 [evaluate loop bounds and step]
1626 empty = (step > 0 ? to < from : to > from);
1627 countm1 = (to - from) / step;
1629 if (empty) goto exit_label;
1637 if (countm1t == 0) goto exit_label;
1641 countm1 is an unsigned integer. It is equal to the loop count minus one,
1642 because the loop count itself can overflow. */
1645 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
1649 tree saved_dovar
= NULL
;
1664 gfc_start_block (&block
);
1666 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1668 /* Evaluate all the expressions in the iterator. */
1669 gfc_init_se (&se
, NULL
);
1670 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
1671 gfc_add_block_to_block (&block
, &se
.pre
);
1673 type
= TREE_TYPE (dovar
);
1675 gfc_init_se (&se
, NULL
);
1676 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
1677 gfc_add_block_to_block (&block
, &se
.pre
);
1678 from
= gfc_evaluate_now (se
.expr
, &block
);
1680 gfc_init_se (&se
, NULL
);
1681 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
1682 gfc_add_block_to_block (&block
, &se
.pre
);
1683 to
= gfc_evaluate_now (se
.expr
, &block
);
1685 gfc_init_se (&se
, NULL
);
1686 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
1687 gfc_add_block_to_block (&block
, &se
.pre
);
1688 step
= gfc_evaluate_now (se
.expr
, &block
);
1690 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1692 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
1693 build_zero_cst (type
));
1694 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
1695 "DO step value is zero");
1698 /* Special case simple loops. */
1699 if (TREE_CODE (type
) == INTEGER_TYPE
1700 && (integer_onep (step
)
1701 || tree_int_cst_equal (step
, integer_minus_one_node
)))
1702 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
, exit_cond
);
1705 if (TREE_CODE (type
) == INTEGER_TYPE
)
1706 utype
= unsigned_type_for (type
);
1708 utype
= unsigned_type_for (gfc_array_index_type
);
1709 countm1
= gfc_create_var (utype
, "countm1");
1711 /* Cycle and exit statements are implemented with gotos. */
1712 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1713 exit_label
= gfc_build_label_decl (NULL_TREE
);
1714 TREE_USED (exit_label
) = 1;
1716 /* Put these labels where they can be found later. */
1717 code
->cycle_label
= cycle_label
;
1718 code
->exit_label
= exit_label
;
1720 /* Initialize the DO variable: dovar = from. */
1721 gfc_add_modify (&block
, dovar
, from
);
1723 /* Save value for do-tinkering checking. */
1724 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1726 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1727 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
1730 /* Initialize loop count and jump to exit label if the loop is empty.
1731 This code is executed before we enter the loop body. We generate:
1734 countm1 = (to - from) / step;
1740 countm1 = (from - to) / -step;
1746 if (TREE_CODE (type
) == INTEGER_TYPE
)
1748 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
1750 /* The distance from FROM to TO cannot always be represented in a signed
1751 type, thus use unsigned arithmetic, also to avoid any undefined
1753 tou
= fold_convert (utype
, to
);
1754 fromu
= fold_convert (utype
, from
);
1755 stepu
= fold_convert (utype
, step
);
1757 /* For a positive step, when to < from, exit, otherwise compute
1758 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
1759 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
1760 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
1761 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
1764 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
1765 fold_build2 (MODIFY_EXPR
, void_type_node
,
1767 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1768 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1769 exit_label
), NULL_TREE
));
1771 /* For a negative step, when to > from, exit, otherwise compute
1772 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
1773 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
1774 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
1775 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
1777 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
1778 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
1779 fold_build2 (MODIFY_EXPR
, void_type_node
,
1781 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1782 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1783 exit_label
), NULL_TREE
));
1785 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
1786 build_int_cst (TREE_TYPE (step
), 0));
1787 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
1789 gfc_add_expr_to_block (&block
, tmp
);
1795 /* TODO: We could use the same width as the real type.
1796 This would probably cause more problems that it solves
1797 when we implement "long double" types. */
1799 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
1800 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
1801 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
1802 gfc_add_modify (&block
, countm1
, tmp
);
1804 /* We need a special check for empty loops:
1805 empty = (step > 0 ? to < from : to > from); */
1806 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
1807 build_zero_cst (type
));
1808 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
1809 fold_build2_loc (loc
, LT_EXPR
,
1810 boolean_type_node
, to
, from
),
1811 fold_build2_loc (loc
, GT_EXPR
,
1812 boolean_type_node
, to
, from
));
1813 /* If the loop is empty, go directly to the exit label. */
1814 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1815 build1_v (GOTO_EXPR
, exit_label
),
1816 build_empty_stmt (input_location
));
1817 gfc_add_expr_to_block (&block
, tmp
);
1821 gfc_start_block (&body
);
1823 /* Main loop body. */
1824 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1825 gfc_add_expr_to_block (&body
, tmp
);
1827 /* Label for cycle statements (if needed). */
1828 if (TREE_USED (cycle_label
))
1830 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1831 gfc_add_expr_to_block (&body
, tmp
);
1834 /* Check whether someone has modified the loop variable. */
1835 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1837 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
1839 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1840 "Loop variable has been modified");
1843 /* Exit the loop if there is an I/O result condition or error. */
1846 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1847 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1849 build_empty_stmt (input_location
));
1850 gfc_add_expr_to_block (&body
, tmp
);
1853 /* Increment the loop variable. */
1854 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1855 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1857 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1858 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1860 /* Initialize countm1t. */
1861 tree countm1t
= gfc_create_var (utype
, "countm1t");
1862 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
1864 /* Decrement the loop count. */
1865 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
1866 build_int_cst (utype
, 1));
1867 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
1869 /* End with the loop condition. Loop until countm1t == 0. */
1870 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
1871 build_int_cst (utype
, 0));
1872 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1873 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1874 cond
, tmp
, build_empty_stmt (loc
));
1875 gfc_add_expr_to_block (&body
, tmp
);
1877 /* End of loop body. */
1878 tmp
= gfc_finish_block (&body
);
1880 /* The for loop itself. */
1881 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1882 gfc_add_expr_to_block (&block
, tmp
);
1884 /* Add the exit label. */
1885 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1886 gfc_add_expr_to_block (&block
, tmp
);
1888 return gfc_finish_block (&block
);
1892 /* Translate the DO WHILE construct.
1905 if (! cond) goto exit_label;
1911 Because the evaluation of the exit condition `cond' may have side
1912 effects, we can't do much for empty loop bodies. The backend optimizers
1913 should be smart enough to eliminate any dead loops. */
1916 gfc_trans_do_while (gfc_code
* code
)
1924 /* Everything we build here is part of the loop body. */
1925 gfc_start_block (&block
);
1927 /* Cycle and exit statements are implemented with gotos. */
1928 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1929 exit_label
= gfc_build_label_decl (NULL_TREE
);
1931 /* Put the labels where they can be found later. See gfc_trans_do(). */
1932 code
->cycle_label
= cycle_label
;
1933 code
->exit_label
= exit_label
;
1935 /* Create a GIMPLE version of the exit condition. */
1936 gfc_init_se (&cond
, NULL
);
1937 gfc_conv_expr_val (&cond
, code
->expr1
);
1938 gfc_add_block_to_block (&block
, &cond
.pre
);
1939 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
1940 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
1942 /* Build "IF (! cond) GOTO exit_label". */
1943 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1944 TREE_USED (exit_label
) = 1;
1945 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
1946 void_type_node
, cond
.expr
, tmp
,
1947 build_empty_stmt (code
->expr1
->where
.lb
->location
));
1948 gfc_add_expr_to_block (&block
, tmp
);
1950 /* The main body of the loop. */
1951 tmp
= gfc_trans_code (code
->block
->next
);
1952 gfc_add_expr_to_block (&block
, tmp
);
1954 /* Label for cycle statements (if needed). */
1955 if (TREE_USED (cycle_label
))
1957 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1958 gfc_add_expr_to_block (&block
, tmp
);
1961 /* End of loop body. */
1962 tmp
= gfc_finish_block (&block
);
1964 gfc_init_block (&block
);
1965 /* Build the loop. */
1966 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
1967 void_type_node
, tmp
);
1968 gfc_add_expr_to_block (&block
, tmp
);
1970 /* Add the exit label. */
1971 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1972 gfc_add_expr_to_block (&block
, tmp
);
1974 return gfc_finish_block (&block
);
1978 /* Translate the SELECT CASE construct for INTEGER case expressions,
1979 without killing all potential optimizations. The problem is that
1980 Fortran allows unbounded cases, but the back-end does not, so we
1981 need to intercept those before we enter the equivalent SWITCH_EXPR
1984 For example, we translate this,
1987 CASE (:100,101,105:115)
1997 to the GENERIC equivalent,
2001 case (minimum value for typeof(expr) ... 100:
2007 case 200 ... (maximum value for typeof(expr):
2024 gfc_trans_integer_select (gfc_code
* code
)
2034 gfc_start_block (&block
);
2036 /* Calculate the switch expression. */
2037 gfc_init_se (&se
, NULL
);
2038 gfc_conv_expr_val (&se
, code
->expr1
);
2039 gfc_add_block_to_block (&block
, &se
.pre
);
2041 end_label
= gfc_build_label_decl (NULL_TREE
);
2043 gfc_init_block (&body
);
2045 for (c
= code
->block
; c
; c
= c
->block
)
2047 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2052 /* Assume it's the default case. */
2053 low
= high
= NULL_TREE
;
2057 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2060 /* If there's only a lower bound, set the high bound to the
2061 maximum value of the case expression. */
2063 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2068 /* Three cases are possible here:
2070 1) There is no lower bound, e.g. CASE (:N).
2071 2) There is a lower bound .NE. high bound, that is
2072 a case range, e.g. CASE (N:M) where M>N (we make
2073 sure that M>N during type resolution).
2074 3) There is a lower bound, and it has the same value
2075 as the high bound, e.g. CASE (N:N). This is our
2076 internal representation of CASE(N).
2078 In the first and second case, we need to set a value for
2079 high. In the third case, we don't because the GCC middle
2080 end represents a single case value by just letting high be
2081 a NULL_TREE. We can't do that because we need to be able
2082 to represent unbounded cases. */
2086 && mpz_cmp (cp
->low
->value
.integer
,
2087 cp
->high
->value
.integer
) != 0))
2088 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2091 /* Unbounded case. */
2093 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2096 /* Build a label. */
2097 label
= gfc_build_label_decl (NULL_TREE
);
2099 /* Add this case label.
2100 Add parameter 'label', make it match GCC backend. */
2101 tmp
= build_case_label (low
, high
, label
);
2102 gfc_add_expr_to_block (&body
, tmp
);
2105 /* Add the statements for this case. */
2106 tmp
= gfc_trans_code (c
->next
);
2107 gfc_add_expr_to_block (&body
, tmp
);
2109 /* Break to the end of the construct. */
2110 tmp
= build1_v (GOTO_EXPR
, end_label
);
2111 gfc_add_expr_to_block (&body
, tmp
);
2114 tmp
= gfc_finish_block (&body
);
2115 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2116 se
.expr
, tmp
, NULL_TREE
);
2117 gfc_add_expr_to_block (&block
, tmp
);
2119 tmp
= build1_v (LABEL_EXPR
, end_label
);
2120 gfc_add_expr_to_block (&block
, tmp
);
2122 return gfc_finish_block (&block
);
2126 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2128 There are only two cases possible here, even though the standard
2129 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2130 .FALSE., and DEFAULT.
2132 We never generate more than two blocks here. Instead, we always
2133 try to eliminate the DEFAULT case. This way, we can translate this
2134 kind of SELECT construct to a simple
2138 expression in GENERIC. */
2141 gfc_trans_logical_select (gfc_code
* code
)
2144 gfc_code
*t
, *f
, *d
;
2149 /* Assume we don't have any cases at all. */
2152 /* Now see which ones we actually do have. We can have at most two
2153 cases in a single case list: one for .TRUE. and one for .FALSE.
2154 The default case is always separate. If the cases for .TRUE. and
2155 .FALSE. are in the same case list, the block for that case list
2156 always executed, and we don't generate code a COND_EXPR. */
2157 for (c
= code
->block
; c
; c
= c
->block
)
2159 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2163 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2165 else /* if (cp->value.logical != 0), thus .TRUE. */
2173 /* Start a new block. */
2174 gfc_start_block (&block
);
2176 /* Calculate the switch expression. We always need to do this
2177 because it may have side effects. */
2178 gfc_init_se (&se
, NULL
);
2179 gfc_conv_expr_val (&se
, code
->expr1
);
2180 gfc_add_block_to_block (&block
, &se
.pre
);
2182 if (t
== f
&& t
!= NULL
)
2184 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2185 translate the code for these cases, append it to the current
2187 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2191 tree true_tree
, false_tree
, stmt
;
2193 true_tree
= build_empty_stmt (input_location
);
2194 false_tree
= build_empty_stmt (input_location
);
2196 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2197 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2198 make the missing case the default case. */
2199 if (t
!= NULL
&& f
!= NULL
)
2209 /* Translate the code for each of these blocks, and append it to
2210 the current block. */
2212 true_tree
= gfc_trans_code (t
->next
);
2215 false_tree
= gfc_trans_code (f
->next
);
2217 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2218 se
.expr
, true_tree
, false_tree
);
2219 gfc_add_expr_to_block (&block
, stmt
);
2222 return gfc_finish_block (&block
);
2226 /* The jump table types are stored in static variables to avoid
2227 constructing them from scratch every single time. */
2228 static GTY(()) tree select_struct
[2];
2230 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2231 Instead of generating compares and jumps, it is far simpler to
2232 generate a data structure describing the cases in order and call a
2233 library subroutine that locates the right case.
2234 This is particularly true because this is the only case where we
2235 might have to dispose of a temporary.
2236 The library subroutine returns a pointer to jump to or NULL if no
2237 branches are to be taken. */
2240 gfc_trans_character_select (gfc_code
*code
)
2242 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2243 stmtblock_t block
, body
;
2248 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2250 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2252 /* The jump table types are stored in static variables to avoid
2253 constructing them from scratch every single time. */
2254 static tree ss_string1
[2], ss_string1_len
[2];
2255 static tree ss_string2
[2], ss_string2_len
[2];
2256 static tree ss_target
[2];
2258 cp
= code
->block
->ext
.block
.case_list
;
2259 while (cp
->left
!= NULL
)
2262 /* Generate the body */
2263 gfc_start_block (&block
);
2264 gfc_init_se (&expr1se
, NULL
);
2265 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2267 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2269 end_label
= gfc_build_label_decl (NULL_TREE
);
2271 gfc_init_block (&body
);
2273 /* Attempt to optimize length 1 selects. */
2274 if (integer_onep (expr1se
.string_length
))
2276 for (d
= cp
; d
; d
= d
->right
)
2281 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2282 && d
->low
->ts
.type
== BT_CHARACTER
);
2283 if (d
->low
->value
.character
.length
> 1)
2285 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2286 if (d
->low
->value
.character
.string
[i
] != ' ')
2288 if (i
!= d
->low
->value
.character
.length
)
2290 if (optimize
&& d
->high
&& i
== 1)
2292 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2293 && d
->high
->ts
.type
== BT_CHARACTER
);
2294 if (d
->high
->value
.character
.length
> 1
2295 && (d
->low
->value
.character
.string
[0]
2296 == d
->high
->value
.character
.string
[0])
2297 && d
->high
->value
.character
.string
[1] != ' '
2298 && ((d
->low
->value
.character
.string
[1] < ' ')
2299 == (d
->high
->value
.character
.string
[1]
2309 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2310 && d
->high
->ts
.type
== BT_CHARACTER
);
2311 if (d
->high
->value
.character
.length
> 1)
2313 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2314 if (d
->high
->value
.character
.string
[i
] != ' ')
2316 if (i
!= d
->high
->value
.character
.length
)
2323 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2325 for (c
= code
->block
; c
; c
= c
->block
)
2327 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2333 /* Assume it's the default case. */
2334 low
= high
= NULL_TREE
;
2338 /* CASE ('ab') or CASE ('ab':'az') will never match
2339 any length 1 character. */
2340 if (cp
->low
->value
.character
.length
> 1
2341 && cp
->low
->value
.character
.string
[1] != ' ')
2344 if (cp
->low
->value
.character
.length
> 0)
2345 r
= cp
->low
->value
.character
.string
[0];
2348 low
= build_int_cst (ctype
, r
);
2350 /* If there's only a lower bound, set the high bound
2351 to the maximum value of the case expression. */
2353 high
= TYPE_MAX_VALUE (ctype
);
2359 || (cp
->low
->value
.character
.string
[0]
2360 != cp
->high
->value
.character
.string
[0]))
2362 if (cp
->high
->value
.character
.length
> 0)
2363 r
= cp
->high
->value
.character
.string
[0];
2366 high
= build_int_cst (ctype
, r
);
2369 /* Unbounded case. */
2371 low
= TYPE_MIN_VALUE (ctype
);
2374 /* Build a label. */
2375 label
= gfc_build_label_decl (NULL_TREE
);
2377 /* Add this case label.
2378 Add parameter 'label', make it match GCC backend. */
2379 tmp
= build_case_label (low
, high
, label
);
2380 gfc_add_expr_to_block (&body
, tmp
);
2383 /* Add the statements for this case. */
2384 tmp
= gfc_trans_code (c
->next
);
2385 gfc_add_expr_to_block (&body
, tmp
);
2387 /* Break to the end of the construct. */
2388 tmp
= build1_v (GOTO_EXPR
, end_label
);
2389 gfc_add_expr_to_block (&body
, tmp
);
2392 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2394 code
->expr1
->ts
.kind
);
2395 case_num
= gfc_create_var (ctype
, "case_num");
2396 gfc_add_modify (&block
, case_num
, tmp
);
2398 gfc_add_block_to_block (&block
, &expr1se
.post
);
2400 tmp
= gfc_finish_block (&body
);
2401 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2402 case_num
, tmp
, NULL_TREE
);
2403 gfc_add_expr_to_block (&block
, tmp
);
2405 tmp
= build1_v (LABEL_EXPR
, end_label
);
2406 gfc_add_expr_to_block (&block
, tmp
);
2408 return gfc_finish_block (&block
);
2412 if (code
->expr1
->ts
.kind
== 1)
2414 else if (code
->expr1
->ts
.kind
== 4)
2419 if (select_struct
[k
] == NULL
)
2422 select_struct
[k
] = make_node (RECORD_TYPE
);
2424 if (code
->expr1
->ts
.kind
== 1)
2425 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2426 else if (code
->expr1
->ts
.kind
== 4)
2427 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2432 #define ADD_FIELD(NAME, TYPE) \
2433 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2434 get_identifier (stringize(NAME)), \
2438 ADD_FIELD (string1
, pchartype
);
2439 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2441 ADD_FIELD (string2
, pchartype
);
2442 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2444 ADD_FIELD (target
, integer_type_node
);
2447 gfc_finish_type (select_struct
[k
]);
2451 for (d
= cp
; d
; d
= d
->right
)
2454 for (c
= code
->block
; c
; c
= c
->block
)
2456 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2458 label
= gfc_build_label_decl (NULL_TREE
);
2459 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2461 : build_int_cst (integer_type_node
, d
->n
),
2463 gfc_add_expr_to_block (&body
, tmp
);
2466 tmp
= gfc_trans_code (c
->next
);
2467 gfc_add_expr_to_block (&body
, tmp
);
2469 tmp
= build1_v (GOTO_EXPR
, end_label
);
2470 gfc_add_expr_to_block (&body
, tmp
);
2473 /* Generate the structure describing the branches */
2474 for (d
= cp
; d
; d
= d
->right
)
2476 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2478 gfc_init_se (&se
, NULL
);
2482 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2483 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2487 gfc_conv_expr_reference (&se
, d
->low
);
2489 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2490 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2493 if (d
->high
== NULL
)
2495 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2496 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2500 gfc_init_se (&se
, NULL
);
2501 gfc_conv_expr_reference (&se
, d
->high
);
2503 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2504 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2507 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2508 build_int_cst (integer_type_node
, d
->n
));
2510 tmp
= build_constructor (select_struct
[k
], node
);
2511 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2514 type
= build_array_type (select_struct
[k
],
2515 build_index_type (size_int (n
-1)));
2517 init
= build_constructor (type
, inits
);
2518 TREE_CONSTANT (init
) = 1;
2519 TREE_STATIC (init
) = 1;
2520 /* Create a static variable to hold the jump table. */
2521 tmp
= gfc_create_var (type
, "jumptable");
2522 TREE_CONSTANT (tmp
) = 1;
2523 TREE_STATIC (tmp
) = 1;
2524 TREE_READONLY (tmp
) = 1;
2525 DECL_INITIAL (tmp
) = init
;
2528 /* Build the library call */
2529 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
2531 if (code
->expr1
->ts
.kind
== 1)
2532 fndecl
= gfor_fndecl_select_string
;
2533 else if (code
->expr1
->ts
.kind
== 4)
2534 fndecl
= gfor_fndecl_select_string_char4
;
2538 tmp
= build_call_expr_loc (input_location
,
2540 build_int_cst (gfc_charlen_type_node
, n
),
2541 expr1se
.expr
, expr1se
.string_length
);
2542 case_num
= gfc_create_var (integer_type_node
, "case_num");
2543 gfc_add_modify (&block
, case_num
, tmp
);
2545 gfc_add_block_to_block (&block
, &expr1se
.post
);
2547 tmp
= gfc_finish_block (&body
);
2548 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2549 case_num
, tmp
, NULL_TREE
);
2550 gfc_add_expr_to_block (&block
, tmp
);
2552 tmp
= build1_v (LABEL_EXPR
, end_label
);
2553 gfc_add_expr_to_block (&block
, tmp
);
2555 return gfc_finish_block (&block
);
2559 /* Translate the three variants of the SELECT CASE construct.
2561 SELECT CASEs with INTEGER case expressions can be translated to an
2562 equivalent GENERIC switch statement, and for LOGICAL case
2563 expressions we build one or two if-else compares.
2565 SELECT CASEs with CHARACTER case expressions are a whole different
2566 story, because they don't exist in GENERIC. So we sort them and
2567 do a binary search at runtime.
2569 Fortran has no BREAK statement, and it does not allow jumps from
2570 one case block to another. That makes things a lot easier for
2574 gfc_trans_select (gfc_code
* code
)
2580 gcc_assert (code
&& code
->expr1
);
2581 gfc_init_block (&block
);
2583 /* Build the exit label and hang it in. */
2584 exit_label
= gfc_build_label_decl (NULL_TREE
);
2585 code
->exit_label
= exit_label
;
2587 /* Empty SELECT constructs are legal. */
2588 if (code
->block
== NULL
)
2589 body
= build_empty_stmt (input_location
);
2591 /* Select the correct translation function. */
2593 switch (code
->expr1
->ts
.type
)
2596 body
= gfc_trans_logical_select (code
);
2600 body
= gfc_trans_integer_select (code
);
2604 body
= gfc_trans_character_select (code
);
2608 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2612 /* Build everything together. */
2613 gfc_add_expr_to_block (&block
, body
);
2614 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2616 return gfc_finish_block (&block
);
2620 /* Traversal function to substitute a replacement symtree if the symbol
2621 in the expression is the same as that passed. f == 2 signals that
2622 that variable itself is not to be checked - only the references.
2623 This group of functions is used when the variable expression in a
2624 FORALL assignment has internal references. For example:
2625 FORALL (i = 1:4) p(p(i)) = i
2626 The only recourse here is to store a copy of 'p' for the index
2629 static gfc_symtree
*new_symtree
;
2630 static gfc_symtree
*old_symtree
;
2633 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2635 if (expr
->expr_type
!= EXPR_VARIABLE
)
2640 else if (expr
->symtree
->n
.sym
== sym
)
2641 expr
->symtree
= new_symtree
;
2647 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
2649 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
2653 forall_restore (gfc_expr
*expr
,
2654 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
2655 int *f ATTRIBUTE_UNUSED
)
2657 if (expr
->expr_type
!= EXPR_VARIABLE
)
2660 if (expr
->symtree
== new_symtree
)
2661 expr
->symtree
= old_symtree
;
2667 forall_restore_symtree (gfc_expr
*e
)
2669 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
2673 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2678 gfc_symbol
*new_sym
;
2679 gfc_symbol
*old_sym
;
2683 /* Build a copy of the lvalue. */
2684 old_symtree
= c
->expr1
->symtree
;
2685 old_sym
= old_symtree
->n
.sym
;
2686 e
= gfc_lval_expr_from_sym (old_sym
);
2687 if (old_sym
->attr
.dimension
)
2689 gfc_init_se (&tse
, NULL
);
2690 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
2691 gfc_add_block_to_block (pre
, &tse
.pre
);
2692 gfc_add_block_to_block (post
, &tse
.post
);
2693 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
2695 if (e
->ts
.type
!= BT_CHARACTER
)
2697 /* Use the variable offset for the temporary. */
2698 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
2699 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
2704 gfc_init_se (&tse
, NULL
);
2705 gfc_init_se (&rse
, NULL
);
2706 gfc_conv_expr (&rse
, e
);
2707 if (e
->ts
.type
== BT_CHARACTER
)
2709 tse
.string_length
= rse
.string_length
;
2710 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
2712 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
2714 gfc_add_block_to_block (pre
, &tse
.pre
);
2715 gfc_add_block_to_block (post
, &tse
.post
);
2719 tmp
= gfc_typenode_for_spec (&e
->ts
);
2720 tse
.expr
= gfc_create_var (tmp
, "temp");
2723 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
, true,
2724 e
->expr_type
== EXPR_VARIABLE
, true);
2725 gfc_add_expr_to_block (pre
, tmp
);
2729 /* Create a new symbol to represent the lvalue. */
2730 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
2731 new_sym
->ts
= old_sym
->ts
;
2732 new_sym
->attr
.referenced
= 1;
2733 new_sym
->attr
.temporary
= 1;
2734 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
2735 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
2737 /* Use the temporary as the backend_decl. */
2738 new_sym
->backend_decl
= tse
.expr
;
2740 /* Create a fake symtree for it. */
2742 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
2743 new_symtree
->n
.sym
= new_sym
;
2744 gcc_assert (new_symtree
== root
);
2746 /* Go through the expression reference replacing the old_symtree
2748 forall_replace_symtree (c
->expr1
, old_sym
, 2);
2750 /* Now we have made this temporary, we might as well use it for
2751 the right hand side. */
2752 forall_replace_symtree (c
->expr2
, old_sym
, 1);
2756 /* Handles dependencies in forall assignments. */
2758 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2765 lsym
= c
->expr1
->symtree
->n
.sym
;
2766 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
2768 /* Now check for dependencies within the 'variable'
2769 expression itself. These are treated by making a complete
2770 copy of variable and changing all the references to it
2771 point to the copy instead. Note that the shallow copy of
2772 the variable will not suffice for derived types with
2773 pointer components. We therefore leave these to their
2775 if (lsym
->ts
.type
== BT_DERIVED
2776 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
2780 if (find_forall_index (c
->expr1
, lsym
, 2))
2782 forall_make_variable_temp (c
, pre
, post
);
2786 /* Substrings with dependencies are treated in the same
2788 if (c
->expr1
->ts
.type
== BT_CHARACTER
2790 && c
->expr2
->expr_type
== EXPR_VARIABLE
2791 && lsym
== c
->expr2
->symtree
->n
.sym
)
2793 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
2794 if (lref
->type
== REF_SUBSTRING
)
2796 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
2797 if (rref
->type
== REF_SUBSTRING
)
2801 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
2803 forall_make_variable_temp (c
, pre
, post
);
2812 cleanup_forall_symtrees (gfc_code
*c
)
2814 forall_restore_symtree (c
->expr1
);
2815 forall_restore_symtree (c
->expr2
);
2816 free (new_symtree
->n
.sym
);
2821 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2822 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2823 indicates whether we should generate code to test the FORALLs mask
2824 array. OUTER is the loop header to be used for initializing mask
2827 The generated loop format is:
2828 count = (end - start + step) / step
2841 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
2842 int mask_flag
, stmtblock_t
*outer
)
2850 tree var
, start
, end
, step
;
2853 /* Initialize the mask index outside the FORALL nest. */
2854 if (mask_flag
&& forall_tmp
->mask
)
2855 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
2857 iter
= forall_tmp
->this_loop
;
2858 nvar
= forall_tmp
->nvar
;
2859 for (n
= 0; n
< nvar
; n
++)
2862 start
= iter
->start
;
2866 exit_label
= gfc_build_label_decl (NULL_TREE
);
2867 TREE_USED (exit_label
) = 1;
2869 /* The loop counter. */
2870 count
= gfc_create_var (TREE_TYPE (var
), "count");
2872 /* The body of the loop. */
2873 gfc_init_block (&block
);
2875 /* The exit condition. */
2876 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
2877 count
, build_int_cst (TREE_TYPE (count
), 0));
2878 if (forall_tmp
->do_concurrent
)
2879 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2880 build_int_cst (integer_type_node
,
2881 annot_expr_ivdep_kind
));
2883 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2884 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2885 cond
, tmp
, build_empty_stmt (input_location
));
2886 gfc_add_expr_to_block (&block
, tmp
);
2888 /* The main loop body. */
2889 gfc_add_expr_to_block (&block
, body
);
2891 /* Increment the loop variable. */
2892 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
2894 gfc_add_modify (&block
, var
, tmp
);
2896 /* Advance to the next mask element. Only do this for the
2898 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
2900 tree maskindex
= forall_tmp
->maskindex
;
2901 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2902 maskindex
, gfc_index_one_node
);
2903 gfc_add_modify (&block
, maskindex
, tmp
);
2906 /* Decrement the loop counter. */
2907 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
2908 build_int_cst (TREE_TYPE (var
), 1));
2909 gfc_add_modify (&block
, count
, tmp
);
2911 body
= gfc_finish_block (&block
);
2913 /* Loop var initialization. */
2914 gfc_init_block (&block
);
2915 gfc_add_modify (&block
, var
, start
);
2918 /* Initialize the loop counter. */
2919 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
2921 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
2923 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
2925 gfc_add_modify (&block
, count
, tmp
);
2927 /* The loop expression. */
2928 tmp
= build1_v (LOOP_EXPR
, body
);
2929 gfc_add_expr_to_block (&block
, tmp
);
2931 /* The exit label. */
2932 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2933 gfc_add_expr_to_block (&block
, tmp
);
2935 body
= gfc_finish_block (&block
);
2942 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2943 is nonzero, the body is controlled by all masks in the forall nest.
2944 Otherwise, the innermost loop is not controlled by it's mask. This
2945 is used for initializing that mask. */
2948 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
2953 forall_info
*forall_tmp
;
2954 tree mask
, maskindex
;
2956 gfc_start_block (&header
);
2958 forall_tmp
= nested_forall_info
;
2959 while (forall_tmp
!= NULL
)
2961 /* Generate body with masks' control. */
2964 mask
= forall_tmp
->mask
;
2965 maskindex
= forall_tmp
->maskindex
;
2967 /* If a mask was specified make the assignment conditional. */
2970 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
2971 body
= build3_v (COND_EXPR
, tmp
, body
,
2972 build_empty_stmt (input_location
));
2975 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
2976 forall_tmp
= forall_tmp
->prev_nest
;
2980 gfc_add_expr_to_block (&header
, body
);
2981 return gfc_finish_block (&header
);
2985 /* Allocate data for holding a temporary array. Returns either a local
2986 temporary array or a pointer variable. */
2989 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
2996 if (INTEGER_CST_P (size
))
2997 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2998 size
, gfc_index_one_node
);
3002 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3003 type
= build_array_type (elem_type
, type
);
3004 if (gfc_can_put_var_on_stack (bytesize
))
3006 gcc_assert (INTEGER_CST_P (size
));
3007 tmpvar
= gfc_create_var (type
, "temp");
3012 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3013 *pdata
= convert (pvoid_type_node
, tmpvar
);
3015 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3016 gfc_add_modify (pblock
, tmpvar
, tmp
);
3022 /* Generate codes to copy the temporary to the actual lhs. */
3025 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3026 tree count1
, tree wheremask
, bool invert
)
3030 stmtblock_t block
, body
;
3036 lss
= gfc_walk_expr (expr
);
3038 if (lss
== gfc_ss_terminator
)
3040 gfc_start_block (&block
);
3042 gfc_init_se (&lse
, NULL
);
3044 /* Translate the expression. */
3045 gfc_conv_expr (&lse
, expr
);
3047 /* Form the expression for the temporary. */
3048 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3050 /* Use the scalar assignment as is. */
3051 gfc_add_block_to_block (&block
, &lse
.pre
);
3052 gfc_add_modify (&block
, lse
.expr
, tmp
);
3053 gfc_add_block_to_block (&block
, &lse
.post
);
3055 /* Increment the count1. */
3056 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3057 count1
, gfc_index_one_node
);
3058 gfc_add_modify (&block
, count1
, tmp
);
3060 tmp
= gfc_finish_block (&block
);
3064 gfc_start_block (&block
);
3066 gfc_init_loopinfo (&loop1
);
3067 gfc_init_se (&rse
, NULL
);
3068 gfc_init_se (&lse
, NULL
);
3070 /* Associate the lss with the loop. */
3071 gfc_add_ss_to_loop (&loop1
, lss
);
3073 /* Calculate the bounds of the scalarization. */
3074 gfc_conv_ss_startstride (&loop1
);
3075 /* Setup the scalarizing loops. */
3076 gfc_conv_loop_setup (&loop1
, &expr
->where
);
3078 gfc_mark_ss_chain_used (lss
, 1);
3080 /* Start the scalarized loop body. */
3081 gfc_start_scalarized_body (&loop1
, &body
);
3083 /* Setup the gfc_se structures. */
3084 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
3087 /* Form the expression of the temporary. */
3088 if (lss
!= gfc_ss_terminator
)
3089 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3090 /* Translate expr. */
3091 gfc_conv_expr (&lse
, expr
);
3093 /* Use the scalar assignment. */
3094 rse
.string_length
= lse
.string_length
;
3095 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true, true);
3097 /* Form the mask expression according to the mask tree list. */
3100 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3102 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3103 TREE_TYPE (wheremaskexpr
),
3105 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3107 build_empty_stmt (input_location
));
3110 gfc_add_expr_to_block (&body
, tmp
);
3112 /* Increment count1. */
3113 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3114 count1
, gfc_index_one_node
);
3115 gfc_add_modify (&body
, count1
, tmp
);
3117 /* Increment count3. */
3120 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3121 gfc_array_index_type
, count3
,
3122 gfc_index_one_node
);
3123 gfc_add_modify (&body
, count3
, tmp
);
3126 /* Generate the copying loops. */
3127 gfc_trans_scalarizing_loops (&loop1
, &body
);
3128 gfc_add_block_to_block (&block
, &loop1
.pre
);
3129 gfc_add_block_to_block (&block
, &loop1
.post
);
3130 gfc_cleanup_loop (&loop1
);
3132 tmp
= gfc_finish_block (&block
);
3138 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3139 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3140 and should not be freed. WHEREMASK is the conditional execution mask
3141 whose sense may be inverted by INVERT. */
3144 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3145 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3146 tree wheremask
, bool invert
)
3148 stmtblock_t block
, body1
;
3155 gfc_start_block (&block
);
3157 gfc_init_se (&rse
, NULL
);
3158 gfc_init_se (&lse
, NULL
);
3160 if (lss
== gfc_ss_terminator
)
3162 gfc_init_block (&body1
);
3163 gfc_conv_expr (&rse
, expr2
);
3164 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3168 /* Initialize the loop. */
3169 gfc_init_loopinfo (&loop
);
3171 /* We may need LSS to determine the shape of the expression. */
3172 gfc_add_ss_to_loop (&loop
, lss
);
3173 gfc_add_ss_to_loop (&loop
, rss
);
3175 gfc_conv_ss_startstride (&loop
);
3176 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3178 gfc_mark_ss_chain_used (rss
, 1);
3179 /* Start the loop body. */
3180 gfc_start_scalarized_body (&loop
, &body1
);
3182 /* Translate the expression. */
3183 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3185 gfc_conv_expr (&rse
, expr2
);
3187 /* Form the expression of the temporary. */
3188 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3191 /* Use the scalar assignment. */
3192 lse
.string_length
= rse
.string_length
;
3193 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
, true,
3194 expr2
->expr_type
== EXPR_VARIABLE
, true);
3196 /* Form the mask expression according to the mask tree list. */
3199 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3201 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3202 TREE_TYPE (wheremaskexpr
),
3204 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3206 build_empty_stmt (input_location
));
3209 gfc_add_expr_to_block (&body1
, tmp
);
3211 if (lss
== gfc_ss_terminator
)
3213 gfc_add_block_to_block (&block
, &body1
);
3215 /* Increment count1. */
3216 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3217 count1
, gfc_index_one_node
);
3218 gfc_add_modify (&block
, count1
, tmp
);
3222 /* Increment count1. */
3223 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3224 count1
, gfc_index_one_node
);
3225 gfc_add_modify (&body1
, count1
, tmp
);
3227 /* Increment count3. */
3230 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3231 gfc_array_index_type
,
3232 count3
, gfc_index_one_node
);
3233 gfc_add_modify (&body1
, count3
, tmp
);
3236 /* Generate the copying loops. */
3237 gfc_trans_scalarizing_loops (&loop
, &body1
);
3239 gfc_add_block_to_block (&block
, &loop
.pre
);
3240 gfc_add_block_to_block (&block
, &loop
.post
);
3242 gfc_cleanup_loop (&loop
);
3243 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3244 as tree nodes in SS may not be valid in different scope. */
3247 tmp
= gfc_finish_block (&block
);
3252 /* Calculate the size of temporary needed in the assignment inside forall.
3253 LSS and RSS are filled in this function. */
3256 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3257 stmtblock_t
* pblock
,
3258 gfc_ss
**lss
, gfc_ss
**rss
)
3266 *lss
= gfc_walk_expr (expr1
);
3269 size
= gfc_index_one_node
;
3270 if (*lss
!= gfc_ss_terminator
)
3272 gfc_init_loopinfo (&loop
);
3274 /* Walk the RHS of the expression. */
3275 *rss
= gfc_walk_expr (expr2
);
3276 if (*rss
== gfc_ss_terminator
)
3277 /* The rhs is scalar. Add a ss for the expression. */
3278 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3280 /* Associate the SS with the loop. */
3281 gfc_add_ss_to_loop (&loop
, *lss
);
3282 /* We don't actually need to add the rhs at this point, but it might
3283 make guessing the loop bounds a bit easier. */
3284 gfc_add_ss_to_loop (&loop
, *rss
);
3286 /* We only want the shape of the expression, not rest of the junk
3287 generated by the scalarizer. */
3288 loop
.array_parameter
= 1;
3290 /* Calculate the bounds of the scalarization. */
3291 save_flag
= gfc_option
.rtcheck
;
3292 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3293 gfc_conv_ss_startstride (&loop
);
3294 gfc_option
.rtcheck
= save_flag
;
3295 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3297 /* Figure out how many elements we need. */
3298 for (i
= 0; i
< loop
.dimen
; i
++)
3300 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3301 gfc_array_index_type
,
3302 gfc_index_one_node
, loop
.from
[i
]);
3303 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3304 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3305 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3306 gfc_array_index_type
, size
, tmp
);
3308 gfc_add_block_to_block (pblock
, &loop
.pre
);
3309 size
= gfc_evaluate_now (size
, pblock
);
3310 gfc_add_block_to_block (pblock
, &loop
.post
);
3312 /* TODO: write a function that cleans up a loopinfo without freeing
3313 the SS chains. Currently a NOP. */
3320 /* Calculate the overall iterator number of the nested forall construct.
3321 This routine actually calculates the number of times the body of the
3322 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3323 that by the expression INNER_SIZE. The BLOCK argument specifies the
3324 block in which to calculate the result, and the optional INNER_SIZE_BODY
3325 argument contains any statements that need to executed (inside the loop)
3326 to initialize or calculate INNER_SIZE. */
3329 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3330 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3332 forall_info
*forall_tmp
= nested_forall_info
;
3336 /* We can eliminate the innermost unconditional loops with constant
3338 if (INTEGER_CST_P (inner_size
))
3341 && !forall_tmp
->mask
3342 && INTEGER_CST_P (forall_tmp
->size
))
3344 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3345 gfc_array_index_type
,
3346 inner_size
, forall_tmp
->size
);
3347 forall_tmp
= forall_tmp
->prev_nest
;
3350 /* If there are no loops left, we have our constant result. */
3355 /* Otherwise, create a temporary variable to compute the result. */
3356 number
= gfc_create_var (gfc_array_index_type
, "num");
3357 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3359 gfc_start_block (&body
);
3360 if (inner_size_body
)
3361 gfc_add_block_to_block (&body
, inner_size_body
);
3363 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3364 gfc_array_index_type
, number
, inner_size
);
3367 gfc_add_modify (&body
, number
, tmp
);
3368 tmp
= gfc_finish_block (&body
);
3370 /* Generate loops. */
3371 if (forall_tmp
!= NULL
)
3372 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3374 gfc_add_expr_to_block (block
, tmp
);
3380 /* Allocate temporary for forall construct. SIZE is the size of temporary
3381 needed. PTEMP1 is returned for space free. */
3384 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3391 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3392 if (!integer_onep (unit
))
3393 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3394 gfc_array_index_type
, size
, unit
);
3399 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3402 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3407 /* Allocate temporary for forall construct according to the information in
3408 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3409 assignment inside forall. PTEMP1 is returned for space free. */
3412 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3413 tree inner_size
, stmtblock_t
* inner_size_body
,
3414 stmtblock_t
* block
, tree
* ptemp1
)
3418 /* Calculate the total size of temporary needed in forall construct. */
3419 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3420 inner_size_body
, block
);
3422 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3426 /* Handle assignments inside forall which need temporary.
3428 forall (i=start:end:stride; maskexpr)
3431 (where e,f<i> are arbitrary expressions possibly involving i
3432 and there is a dependency between e<i> and f<i>)
3434 masktmp(:) = maskexpr(:)
3439 for (i = start; i <= end; i += stride)
3443 for (i = start; i <= end; i += stride)
3445 if (masktmp[maskindex++])
3446 tmp[count1++] = f<i>
3450 for (i = start; i <= end; i += stride)
3452 if (masktmp[maskindex++])
3453 e<i> = tmp[count1++]
3458 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3459 tree wheremask
, bool invert
,
3460 forall_info
* nested_forall_info
,
3461 stmtblock_t
* block
)
3469 stmtblock_t inner_size_body
;
3471 /* Create vars. count1 is the current iterator number of the nested
3473 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3475 /* Count is the wheremask index. */
3478 count
= gfc_create_var (gfc_array_index_type
, "count");
3479 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3484 /* Initialize count1. */
3485 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3487 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3488 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3489 gfc_init_block (&inner_size_body
);
3490 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
3493 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3494 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
3496 if (!expr1
->ts
.u
.cl
->backend_decl
)
3499 gfc_init_se (&tse
, NULL
);
3500 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
3501 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
3503 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3504 expr1
->ts
.u
.cl
->backend_decl
);
3507 type
= gfc_typenode_for_spec (&expr1
->ts
);
3509 /* Allocate temporary for nested forall construct according to the
3510 information in nested_forall_info and inner_size. */
3511 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
3512 &inner_size_body
, block
, &ptemp1
);
3514 /* Generate codes to copy rhs to the temporary . */
3515 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
3518 /* Generate body and loops according to the information in
3519 nested_forall_info. */
3520 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3521 gfc_add_expr_to_block (block
, tmp
);
3524 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3528 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3530 /* Generate codes to copy the temporary to lhs. */
3531 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
3534 /* Generate body and loops according to the information in
3535 nested_forall_info. */
3536 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3537 gfc_add_expr_to_block (block
, tmp
);
3541 /* Free the temporary. */
3542 tmp
= gfc_call_free (ptemp1
);
3543 gfc_add_expr_to_block (block
, tmp
);
3548 /* Translate pointer assignment inside FORALL which need temporary. */
3551 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3552 forall_info
* nested_forall_info
,
3553 stmtblock_t
* block
)
3560 gfc_array_info
*info
;
3567 tree tmp
, tmp1
, ptemp1
;
3569 count
= gfc_create_var (gfc_array_index_type
, "count");
3570 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3572 inner_size
= gfc_index_one_node
;
3573 lss
= gfc_walk_expr (expr1
);
3574 rss
= gfc_walk_expr (expr2
);
3575 if (lss
== gfc_ss_terminator
)
3577 type
= gfc_typenode_for_spec (&expr1
->ts
);
3578 type
= build_pointer_type (type
);
3580 /* Allocate temporary for nested forall construct according to the
3581 information in nested_forall_info and inner_size. */
3582 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3583 inner_size
, NULL
, block
, &ptemp1
);
3584 gfc_start_block (&body
);
3585 gfc_init_se (&lse
, NULL
);
3586 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3587 gfc_init_se (&rse
, NULL
);
3588 rse
.want_pointer
= 1;
3589 gfc_conv_expr (&rse
, expr2
);
3590 gfc_add_block_to_block (&body
, &rse
.pre
);
3591 gfc_add_modify (&body
, lse
.expr
,
3592 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3593 gfc_add_block_to_block (&body
, &rse
.post
);
3595 /* Increment count. */
3596 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3597 count
, gfc_index_one_node
);
3598 gfc_add_modify (&body
, count
, tmp
);
3600 tmp
= gfc_finish_block (&body
);
3602 /* Generate body and loops according to the information in
3603 nested_forall_info. */
3604 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3605 gfc_add_expr_to_block (block
, tmp
);
3608 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3610 gfc_start_block (&body
);
3611 gfc_init_se (&lse
, NULL
);
3612 gfc_init_se (&rse
, NULL
);
3613 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3614 lse
.want_pointer
= 1;
3615 gfc_conv_expr (&lse
, expr1
);
3616 gfc_add_block_to_block (&body
, &lse
.pre
);
3617 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3618 gfc_add_block_to_block (&body
, &lse
.post
);
3619 /* Increment count. */
3620 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3621 count
, gfc_index_one_node
);
3622 gfc_add_modify (&body
, count
, tmp
);
3623 tmp
= gfc_finish_block (&body
);
3625 /* Generate body and loops according to the information in
3626 nested_forall_info. */
3627 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3628 gfc_add_expr_to_block (block
, tmp
);
3632 gfc_init_loopinfo (&loop
);
3634 /* Associate the SS with the loop. */
3635 gfc_add_ss_to_loop (&loop
, rss
);
3637 /* Setup the scalarizing loops and bounds. */
3638 gfc_conv_ss_startstride (&loop
);
3640 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3642 info
= &rss
->info
->data
.array
;
3643 desc
= info
->descriptor
;
3645 /* Make a new descriptor. */
3646 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3647 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
3648 loop
.from
, loop
.to
, 1,
3649 GFC_ARRAY_UNKNOWN
, true);
3651 /* Allocate temporary for nested forall construct. */
3652 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
3653 inner_size
, NULL
, block
, &ptemp1
);
3654 gfc_start_block (&body
);
3655 gfc_init_se (&lse
, NULL
);
3656 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3657 lse
.direct_byref
= 1;
3658 gfc_conv_expr_descriptor (&lse
, expr2
);
3660 gfc_add_block_to_block (&body
, &lse
.pre
);
3661 gfc_add_block_to_block (&body
, &lse
.post
);
3663 /* Increment count. */
3664 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3665 count
, gfc_index_one_node
);
3666 gfc_add_modify (&body
, count
, tmp
);
3668 tmp
= gfc_finish_block (&body
);
3670 /* Generate body and loops according to the information in
3671 nested_forall_info. */
3672 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3673 gfc_add_expr_to_block (block
, tmp
);
3676 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3678 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
3679 gfc_init_se (&lse
, NULL
);
3680 gfc_conv_expr_descriptor (&lse
, expr1
);
3681 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
3682 gfc_start_block (&body
);
3683 gfc_add_block_to_block (&body
, &lse
.pre
);
3684 gfc_add_block_to_block (&body
, &lse
.post
);
3686 /* Increment count. */
3687 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3688 count
, gfc_index_one_node
);
3689 gfc_add_modify (&body
, count
, tmp
);
3691 tmp
= gfc_finish_block (&body
);
3693 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3694 gfc_add_expr_to_block (block
, tmp
);
3696 /* Free the temporary. */
3699 tmp
= gfc_call_free (ptemp1
);
3700 gfc_add_expr_to_block (block
, tmp
);
3705 /* FORALL and WHERE statements are really nasty, especially when you nest
3706 them. All the rhs of a forall assignment must be evaluated before the
3707 actual assignments are performed. Presumably this also applies to all the
3708 assignments in an inner where statement. */
3710 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3711 linear array, relying on the fact that we process in the same order in all
3714 forall (i=start:end:stride; maskexpr)
3718 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3720 count = ((end + 1 - start) / stride)
3721 masktmp(:) = maskexpr(:)
3724 for (i = start; i <= end; i += stride)
3726 if (masktmp[maskindex++])
3730 for (i = start; i <= end; i += stride)
3732 if (masktmp[maskindex++])
3736 Note that this code only works when there are no dependencies.
3737 Forall loop with array assignments and data dependencies are a real pain,
3738 because the size of the temporary cannot always be determined before the
3739 loop is executed. This problem is compounded by the presence of nested
3744 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
3761 tree cycle_label
= NULL_TREE
;
3765 gfc_forall_iterator
*fa
;
3768 gfc_saved_var
*saved_vars
;
3769 iter_info
*this_forall
;
3773 /* Do nothing if the mask is false. */
3775 && code
->expr1
->expr_type
== EXPR_CONSTANT
3776 && !code
->expr1
->value
.logical
)
3777 return build_empty_stmt (input_location
);
3780 /* Count the FORALL index number. */
3781 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3785 /* Allocate the space for var, start, end, step, varexpr. */
3786 var
= XCNEWVEC (tree
, nvar
);
3787 start
= XCNEWVEC (tree
, nvar
);
3788 end
= XCNEWVEC (tree
, nvar
);
3789 step
= XCNEWVEC (tree
, nvar
);
3790 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
3791 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
3793 /* Allocate the space for info. */
3794 info
= XCNEW (forall_info
);
3796 gfc_start_block (&pre
);
3797 gfc_init_block (&post
);
3798 gfc_init_block (&block
);
3801 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3803 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
3805 /* Allocate space for this_forall. */
3806 this_forall
= XCNEW (iter_info
);
3808 /* Create a temporary variable for the FORALL index. */
3809 tmp
= gfc_typenode_for_spec (&sym
->ts
);
3810 var
[n
] = gfc_create_var (tmp
, sym
->name
);
3811 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
3813 /* Record it in this_forall. */
3814 this_forall
->var
= var
[n
];
3816 /* Replace the index symbol's backend_decl with the temporary decl. */
3817 sym
->backend_decl
= var
[n
];
3819 /* Work out the start, end and stride for the loop. */
3820 gfc_init_se (&se
, NULL
);
3821 gfc_conv_expr_val (&se
, fa
->start
);
3822 /* Record it in this_forall. */
3823 this_forall
->start
= se
.expr
;
3824 gfc_add_block_to_block (&block
, &se
.pre
);
3827 gfc_init_se (&se
, NULL
);
3828 gfc_conv_expr_val (&se
, fa
->end
);
3829 /* Record it in this_forall. */
3830 this_forall
->end
= se
.expr
;
3831 gfc_make_safe_expr (&se
);
3832 gfc_add_block_to_block (&block
, &se
.pre
);
3835 gfc_init_se (&se
, NULL
);
3836 gfc_conv_expr_val (&se
, fa
->stride
);
3837 /* Record it in this_forall. */
3838 this_forall
->step
= se
.expr
;
3839 gfc_make_safe_expr (&se
);
3840 gfc_add_block_to_block (&block
, &se
.pre
);
3843 /* Set the NEXT field of this_forall to NULL. */
3844 this_forall
->next
= NULL
;
3845 /* Link this_forall to the info construct. */
3846 if (info
->this_loop
)
3848 iter_info
*iter_tmp
= info
->this_loop
;
3849 while (iter_tmp
->next
!= NULL
)
3850 iter_tmp
= iter_tmp
->next
;
3851 iter_tmp
->next
= this_forall
;
3854 info
->this_loop
= this_forall
;
3860 /* Calculate the size needed for the current forall level. */
3861 size
= gfc_index_one_node
;
3862 for (n
= 0; n
< nvar
; n
++)
3864 /* size = (end + step - start) / step. */
3865 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
3867 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
3869 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
3871 tmp
= convert (gfc_array_index_type
, tmp
);
3873 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3877 /* Record the nvar and size of current forall level. */
3883 /* If the mask is .true., consider the FORALL unconditional. */
3884 if (code
->expr1
->expr_type
== EXPR_CONSTANT
3885 && code
->expr1
->value
.logical
)
3893 /* First we need to allocate the mask. */
3896 /* As the mask array can be very big, prefer compact boolean types. */
3897 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
3898 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
3899 size
, NULL
, &block
, &pmask
);
3900 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
3902 /* Record them in the info structure. */
3903 info
->maskindex
= maskindex
;
3908 /* No mask was specified. */
3909 maskindex
= NULL_TREE
;
3910 mask
= pmask
= NULL_TREE
;
3913 /* Link the current forall level to nested_forall_info. */
3914 info
->prev_nest
= nested_forall_info
;
3915 nested_forall_info
= info
;
3917 /* Copy the mask into a temporary variable if required.
3918 For now we assume a mask temporary is needed. */
3921 /* As the mask array can be very big, prefer compact boolean types. */
3922 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
3924 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
3926 /* Start of mask assignment loop body. */
3927 gfc_start_block (&body
);
3929 /* Evaluate the mask expression. */
3930 gfc_init_se (&se
, NULL
);
3931 gfc_conv_expr_val (&se
, code
->expr1
);
3932 gfc_add_block_to_block (&body
, &se
.pre
);
3934 /* Store the mask. */
3935 se
.expr
= convert (mask_type
, se
.expr
);
3937 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3938 gfc_add_modify (&body
, tmp
, se
.expr
);
3940 /* Advance to the next mask element. */
3941 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3942 maskindex
, gfc_index_one_node
);
3943 gfc_add_modify (&body
, maskindex
, tmp
);
3945 /* Generate the loops. */
3946 tmp
= gfc_finish_block (&body
);
3947 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
3948 gfc_add_expr_to_block (&block
, tmp
);
3951 if (code
->op
== EXEC_DO_CONCURRENT
)
3953 gfc_init_block (&body
);
3954 cycle_label
= gfc_build_label_decl (NULL_TREE
);
3955 code
->cycle_label
= cycle_label
;
3956 tmp
= gfc_trans_code (code
->block
->next
);
3957 gfc_add_expr_to_block (&body
, tmp
);
3959 if (TREE_USED (cycle_label
))
3961 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
3962 gfc_add_expr_to_block (&body
, tmp
);
3965 tmp
= gfc_finish_block (&body
);
3966 nested_forall_info
->do_concurrent
= true;
3967 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3968 gfc_add_expr_to_block (&block
, tmp
);
3972 c
= code
->block
->next
;
3974 /* TODO: loop merging in FORALL statements. */
3975 /* Now that we've got a copy of the mask, generate the assignment loops. */
3981 /* A scalar or array assignment. DO the simple check for
3982 lhs to rhs dependencies. These make a temporary for the
3983 rhs and form a second forall block to copy to variable. */
3984 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
3986 /* Temporaries due to array assignment data dependencies introduce
3987 no end of problems. */
3989 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
3990 nested_forall_info
, &block
);
3993 /* Use the normal assignment copying routines. */
3994 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
3996 /* Generate body and loops. */
3997 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3999 gfc_add_expr_to_block (&block
, tmp
);
4002 /* Cleanup any temporary symtrees that have been made to deal
4003 with dependencies. */
4005 cleanup_forall_symtrees (c
);
4010 /* Translate WHERE or WHERE construct nested in FORALL. */
4011 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4014 /* Pointer assignment inside FORALL. */
4015 case EXEC_POINTER_ASSIGN
:
4016 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4018 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4019 nested_forall_info
, &block
);
4022 /* Use the normal assignment copying routines. */
4023 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4025 /* Generate body and loops. */
4026 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4028 gfc_add_expr_to_block (&block
, tmp
);
4033 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4034 gfc_add_expr_to_block (&block
, tmp
);
4037 /* Explicit subroutine calls are prevented by the frontend but interface
4038 assignments can legitimately produce them. */
4039 case EXEC_ASSIGN_CALL
:
4040 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4041 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4042 gfc_add_expr_to_block (&block
, tmp
);
4053 /* Restore the original index variables. */
4054 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4055 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4057 /* Free the space for var, start, end, step, varexpr. */
4065 for (this_forall
= info
->this_loop
; this_forall
;)
4067 iter_info
*next
= this_forall
->next
;
4072 /* Free the space for this forall_info. */
4077 /* Free the temporary for the mask. */
4078 tmp
= gfc_call_free (pmask
);
4079 gfc_add_expr_to_block (&block
, tmp
);
4082 pushdecl (maskindex
);
4084 gfc_add_block_to_block (&pre
, &block
);
4085 gfc_add_block_to_block (&pre
, &post
);
4087 return gfc_finish_block (&pre
);
4091 /* Translate the FORALL statement or construct. */
4093 tree
gfc_trans_forall (gfc_code
* code
)
4095 return gfc_trans_forall_1 (code
, NULL
);
4099 /* Translate the DO CONCURRENT construct. */
4101 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4103 return gfc_trans_forall_1 (code
, NULL
);
4107 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4108 If the WHERE construct is nested in FORALL, compute the overall temporary
4109 needed by the WHERE mask expression multiplied by the iterator number of
4111 ME is the WHERE mask expression.
4112 MASK is the current execution mask upon input, whose sense may or may
4113 not be inverted as specified by the INVERT argument.
4114 CMASK is the updated execution mask on output, or NULL if not required.
4115 PMASK is the pending execution mask on output, or NULL if not required.
4116 BLOCK is the block in which to place the condition evaluation loops. */
4119 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4120 tree mask
, bool invert
, tree cmask
, tree pmask
,
4121 tree mask_type
, stmtblock_t
* block
)
4126 stmtblock_t body
, body1
;
4127 tree count
, cond
, mtmp
;
4130 gfc_init_loopinfo (&loop
);
4132 lss
= gfc_walk_expr (me
);
4133 rss
= gfc_walk_expr (me
);
4135 /* Variable to index the temporary. */
4136 count
= gfc_create_var (gfc_array_index_type
, "count");
4137 /* Initialize count. */
4138 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4140 gfc_start_block (&body
);
4142 gfc_init_se (&rse
, NULL
);
4143 gfc_init_se (&lse
, NULL
);
4145 if (lss
== gfc_ss_terminator
)
4147 gfc_init_block (&body1
);
4151 /* Initialize the loop. */
4152 gfc_init_loopinfo (&loop
);
4154 /* We may need LSS to determine the shape of the expression. */
4155 gfc_add_ss_to_loop (&loop
, lss
);
4156 gfc_add_ss_to_loop (&loop
, rss
);
4158 gfc_conv_ss_startstride (&loop
);
4159 gfc_conv_loop_setup (&loop
, &me
->where
);
4161 gfc_mark_ss_chain_used (rss
, 1);
4162 /* Start the loop body. */
4163 gfc_start_scalarized_body (&loop
, &body1
);
4165 /* Translate the expression. */
4166 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4168 gfc_conv_expr (&rse
, me
);
4171 /* Variable to evaluate mask condition. */
4172 cond
= gfc_create_var (mask_type
, "cond");
4173 if (mask
&& (cmask
|| pmask
))
4174 mtmp
= gfc_create_var (mask_type
, "mask");
4175 else mtmp
= NULL_TREE
;
4177 gfc_add_block_to_block (&body1
, &lse
.pre
);
4178 gfc_add_block_to_block (&body1
, &rse
.pre
);
4180 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4182 if (mask
&& (cmask
|| pmask
))
4184 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4186 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4187 gfc_add_modify (&body1
, mtmp
, tmp
);
4192 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4195 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4197 gfc_add_modify (&body1
, tmp1
, tmp
);
4202 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4203 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4205 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4207 gfc_add_modify (&body1
, tmp1
, tmp
);
4210 gfc_add_block_to_block (&body1
, &lse
.post
);
4211 gfc_add_block_to_block (&body1
, &rse
.post
);
4213 if (lss
== gfc_ss_terminator
)
4215 gfc_add_block_to_block (&body
, &body1
);
4219 /* Increment count. */
4220 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4221 count
, gfc_index_one_node
);
4222 gfc_add_modify (&body1
, count
, tmp1
);
4224 /* Generate the copying loops. */
4225 gfc_trans_scalarizing_loops (&loop
, &body1
);
4227 gfc_add_block_to_block (&body
, &loop
.pre
);
4228 gfc_add_block_to_block (&body
, &loop
.post
);
4230 gfc_cleanup_loop (&loop
);
4231 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4232 as tree nodes in SS may not be valid in different scope. */
4235 tmp1
= gfc_finish_block (&body
);
4236 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4237 if (nested_forall_info
!= NULL
)
4238 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4240 gfc_add_expr_to_block (block
, tmp1
);
4244 /* Translate an assignment statement in a WHERE statement or construct
4245 statement. The MASK expression is used to control which elements
4246 of EXPR1 shall be assigned. The sense of MASK is specified by
4250 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4251 tree mask
, bool invert
,
4252 tree count1
, tree count2
,
4258 gfc_ss
*lss_section
;
4265 tree index
, maskexpr
;
4267 /* A defined assignment. */
4268 if (cnext
&& cnext
->resolved_sym
)
4269 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4272 /* TODO: handle this special case.
4273 Special case a single function returning an array. */
4274 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4276 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4282 /* Assignment of the form lhs = rhs. */
4283 gfc_start_block (&block
);
4285 gfc_init_se (&lse
, NULL
);
4286 gfc_init_se (&rse
, NULL
);
4289 lss
= gfc_walk_expr (expr1
);
4292 /* In each where-assign-stmt, the mask-expr and the variable being
4293 defined shall be arrays of the same shape. */
4294 gcc_assert (lss
!= gfc_ss_terminator
);
4296 /* The assignment needs scalarization. */
4299 /* Find a non-scalar SS from the lhs. */
4300 while (lss_section
!= gfc_ss_terminator
4301 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4302 lss_section
= lss_section
->next
;
4304 gcc_assert (lss_section
!= gfc_ss_terminator
);
4306 /* Initialize the scalarizer. */
4307 gfc_init_loopinfo (&loop
);
4310 rss
= gfc_walk_expr (expr2
);
4311 if (rss
== gfc_ss_terminator
)
4313 /* The rhs is scalar. Add a ss for the expression. */
4314 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4315 rss
->info
->where
= 1;
4318 /* Associate the SS with the loop. */
4319 gfc_add_ss_to_loop (&loop
, lss
);
4320 gfc_add_ss_to_loop (&loop
, rss
);
4322 /* Calculate the bounds of the scalarization. */
4323 gfc_conv_ss_startstride (&loop
);
4325 /* Resolve any data dependencies in the statement. */
4326 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4328 /* Setup the scalarizing loops. */
4329 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4331 /* Setup the gfc_se structures. */
4332 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4333 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4336 gfc_mark_ss_chain_used (rss
, 1);
4337 if (loop
.temp_ss
== NULL
)
4340 gfc_mark_ss_chain_used (lss
, 1);
4344 lse
.ss
= loop
.temp_ss
;
4345 gfc_mark_ss_chain_used (lss
, 3);
4346 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4349 /* Start the scalarized loop body. */
4350 gfc_start_scalarized_body (&loop
, &body
);
4352 /* Translate the expression. */
4353 gfc_conv_expr (&rse
, expr2
);
4354 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4355 gfc_conv_tmp_array_ref (&lse
);
4357 gfc_conv_expr (&lse
, expr1
);
4359 /* Form the mask expression according to the mask. */
4361 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4363 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4364 TREE_TYPE (maskexpr
), maskexpr
);
4366 /* Use the scalar assignment as is. */
4367 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4368 loop
.temp_ss
!= NULL
, false, true);
4370 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4372 gfc_add_expr_to_block (&body
, tmp
);
4374 if (lss
== gfc_ss_terminator
)
4376 /* Increment count1. */
4377 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4378 count1
, gfc_index_one_node
);
4379 gfc_add_modify (&body
, count1
, tmp
);
4381 /* Use the scalar assignment as is. */
4382 gfc_add_block_to_block (&block
, &body
);
4386 gcc_assert (lse
.ss
== gfc_ss_terminator
4387 && rse
.ss
== gfc_ss_terminator
);
4389 if (loop
.temp_ss
!= NULL
)
4391 /* Increment count1 before finish the main body of a scalarized
4393 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4394 gfc_array_index_type
, count1
, gfc_index_one_node
);
4395 gfc_add_modify (&body
, count1
, tmp
);
4396 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4398 /* We need to copy the temporary to the actual lhs. */
4399 gfc_init_se (&lse
, NULL
);
4400 gfc_init_se (&rse
, NULL
);
4401 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4402 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4404 rse
.ss
= loop
.temp_ss
;
4407 gfc_conv_tmp_array_ref (&rse
);
4408 gfc_conv_expr (&lse
, expr1
);
4410 gcc_assert (lse
.ss
== gfc_ss_terminator
4411 && rse
.ss
== gfc_ss_terminator
);
4413 /* Form the mask expression according to the mask tree list. */
4415 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4417 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4418 TREE_TYPE (maskexpr
), maskexpr
);
4420 /* Use the scalar assignment as is. */
4421 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, false,
4423 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4424 build_empty_stmt (input_location
));
4425 gfc_add_expr_to_block (&body
, tmp
);
4427 /* Increment count2. */
4428 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4429 gfc_array_index_type
, count2
,
4430 gfc_index_one_node
);
4431 gfc_add_modify (&body
, count2
, tmp
);
4435 /* Increment count1. */
4436 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4437 gfc_array_index_type
, count1
,
4438 gfc_index_one_node
);
4439 gfc_add_modify (&body
, count1
, tmp
);
4442 /* Generate the copying loops. */
4443 gfc_trans_scalarizing_loops (&loop
, &body
);
4445 /* Wrap the whole thing up. */
4446 gfc_add_block_to_block (&block
, &loop
.pre
);
4447 gfc_add_block_to_block (&block
, &loop
.post
);
4448 gfc_cleanup_loop (&loop
);
4451 return gfc_finish_block (&block
);
4455 /* Translate the WHERE construct or statement.
4456 This function can be called iteratively to translate the nested WHERE
4457 construct or statement.
4458 MASK is the control mask. */
4461 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4462 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4464 stmtblock_t inner_size_body
;
4465 tree inner_size
, size
;
4474 tree count1
, count2
;
4478 tree pcmask
= NULL_TREE
;
4479 tree ppmask
= NULL_TREE
;
4480 tree cmask
= NULL_TREE
;
4481 tree pmask
= NULL_TREE
;
4482 gfc_actual_arglist
*arg
;
4484 /* the WHERE statement or the WHERE construct statement. */
4485 cblock
= code
->block
;
4487 /* As the mask array can be very big, prefer compact boolean types. */
4488 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4490 /* Determine which temporary masks are needed. */
4493 /* One clause: No ELSEWHEREs. */
4494 need_cmask
= (cblock
->next
!= 0);
4497 else if (cblock
->block
->block
)
4499 /* Three or more clauses: Conditional ELSEWHEREs. */
4503 else if (cblock
->next
)
4505 /* Two clauses, the first non-empty. */
4507 need_pmask
= (mask
!= NULL_TREE
4508 && cblock
->block
->next
!= 0);
4510 else if (!cblock
->block
->next
)
4512 /* Two clauses, both empty. */
4516 /* Two clauses, the first empty, the second non-empty. */
4519 need_cmask
= (cblock
->block
->expr1
!= 0);
4528 if (need_cmask
|| need_pmask
)
4530 /* Calculate the size of temporary needed by the mask-expr. */
4531 gfc_init_block (&inner_size_body
);
4532 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
4533 &inner_size_body
, &lss
, &rss
);
4535 gfc_free_ss_chain (lss
);
4536 gfc_free_ss_chain (rss
);
4538 /* Calculate the total size of temporary needed. */
4539 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4540 &inner_size_body
, block
);
4542 /* Check whether the size is negative. */
4543 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
4544 gfc_index_zero_node
);
4545 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4546 cond
, gfc_index_zero_node
, size
);
4547 size
= gfc_evaluate_now (size
, block
);
4549 /* Allocate temporary for WHERE mask if needed. */
4551 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4554 /* Allocate temporary for !mask if needed. */
4556 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4562 /* Each time around this loop, the where clause is conditional
4563 on the value of mask and invert, which are updated at the
4564 bottom of the loop. */
4566 /* Has mask-expr. */
4569 /* Ensure that the WHERE mask will be evaluated exactly once.
4570 If there are no statements in this WHERE/ELSEWHERE clause,
4571 then we don't need to update the control mask (cmask).
4572 If this is the last clause of the WHERE construct, then
4573 we don't need to update the pending control mask (pmask). */
4575 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4577 cblock
->next
? cmask
: NULL_TREE
,
4578 cblock
->block
? pmask
: NULL_TREE
,
4581 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4583 (cblock
->next
|| cblock
->block
)
4584 ? cmask
: NULL_TREE
,
4585 NULL_TREE
, mask_type
, block
);
4589 /* It's a final elsewhere-stmt. No mask-expr is present. */
4593 /* The body of this where clause are controlled by cmask with
4594 sense specified by invert. */
4596 /* Get the assignment statement of a WHERE statement, or the first
4597 statement in where-body-construct of a WHERE construct. */
4598 cnext
= cblock
->next
;
4603 /* WHERE assignment statement. */
4604 case EXEC_ASSIGN_CALL
:
4606 arg
= cnext
->ext
.actual
;
4607 expr1
= expr2
= NULL
;
4608 for (; arg
; arg
= arg
->next
)
4620 expr1
= cnext
->expr1
;
4621 expr2
= cnext
->expr2
;
4623 if (nested_forall_info
!= NULL
)
4625 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4626 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4627 gfc_trans_assign_need_temp (expr1
, expr2
,
4629 nested_forall_info
, block
);
4632 /* Variables to control maskexpr. */
4633 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4634 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4635 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4636 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4638 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4643 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4645 gfc_add_expr_to_block (block
, tmp
);
4650 /* Variables to control maskexpr. */
4651 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4652 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4653 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4654 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4656 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4660 gfc_add_expr_to_block (block
, tmp
);
4665 /* WHERE or WHERE construct is part of a where-body-construct. */
4667 gfc_trans_where_2 (cnext
, cmask
, invert
,
4668 nested_forall_info
, block
);
4675 /* The next statement within the same where-body-construct. */
4676 cnext
= cnext
->next
;
4678 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4679 cblock
= cblock
->block
;
4680 if (mask
== NULL_TREE
)
4682 /* If we're the initial WHERE, we can simply invert the sense
4683 of the current mask to obtain the "mask" for the remaining
4690 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4696 /* If we allocated a pending mask array, deallocate it now. */
4699 tmp
= gfc_call_free (ppmask
);
4700 gfc_add_expr_to_block (block
, tmp
);
4703 /* If we allocated a current mask array, deallocate it now. */
4706 tmp
= gfc_call_free (pcmask
);
4707 gfc_add_expr_to_block (block
, tmp
);
4711 /* Translate a simple WHERE construct or statement without dependencies.
4712 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4713 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4714 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4717 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
4719 stmtblock_t block
, body
;
4720 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
4721 tree tmp
, cexpr
, tstmt
, estmt
;
4722 gfc_ss
*css
, *tdss
, *tsss
;
4723 gfc_se cse
, tdse
, tsse
, edse
, esse
;
4728 /* Allow the scalarizer to workshare simple where loops. */
4729 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
4730 ompws_flags
|= OMPWS_SCALARIZER_WS
;
4732 cond
= cblock
->expr1
;
4733 tdst
= cblock
->next
->expr1
;
4734 tsrc
= cblock
->next
->expr2
;
4735 edst
= eblock
? eblock
->next
->expr1
: NULL
;
4736 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
4738 gfc_start_block (&block
);
4739 gfc_init_loopinfo (&loop
);
4741 /* Handle the condition. */
4742 gfc_init_se (&cse
, NULL
);
4743 css
= gfc_walk_expr (cond
);
4744 gfc_add_ss_to_loop (&loop
, css
);
4746 /* Handle the then-clause. */
4747 gfc_init_se (&tdse
, NULL
);
4748 gfc_init_se (&tsse
, NULL
);
4749 tdss
= gfc_walk_expr (tdst
);
4750 tsss
= gfc_walk_expr (tsrc
);
4751 if (tsss
== gfc_ss_terminator
)
4753 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
4754 tsss
->info
->where
= 1;
4756 gfc_add_ss_to_loop (&loop
, tdss
);
4757 gfc_add_ss_to_loop (&loop
, tsss
);
4761 /* Handle the else clause. */
4762 gfc_init_se (&edse
, NULL
);
4763 gfc_init_se (&esse
, NULL
);
4764 edss
= gfc_walk_expr (edst
);
4765 esss
= gfc_walk_expr (esrc
);
4766 if (esss
== gfc_ss_terminator
)
4768 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
4769 esss
->info
->where
= 1;
4771 gfc_add_ss_to_loop (&loop
, edss
);
4772 gfc_add_ss_to_loop (&loop
, esss
);
4775 gfc_conv_ss_startstride (&loop
);
4776 gfc_conv_loop_setup (&loop
, &tdst
->where
);
4778 gfc_mark_ss_chain_used (css
, 1);
4779 gfc_mark_ss_chain_used (tdss
, 1);
4780 gfc_mark_ss_chain_used (tsss
, 1);
4783 gfc_mark_ss_chain_used (edss
, 1);
4784 gfc_mark_ss_chain_used (esss
, 1);
4787 gfc_start_scalarized_body (&loop
, &body
);
4789 gfc_copy_loopinfo_to_se (&cse
, &loop
);
4790 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
4791 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
4797 gfc_copy_loopinfo_to_se (&edse
, &loop
);
4798 gfc_copy_loopinfo_to_se (&esse
, &loop
);
4803 gfc_conv_expr (&cse
, cond
);
4804 gfc_add_block_to_block (&body
, &cse
.pre
);
4807 gfc_conv_expr (&tsse
, tsrc
);
4808 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4809 gfc_conv_tmp_array_ref (&tdse
);
4811 gfc_conv_expr (&tdse
, tdst
);
4815 gfc_conv_expr (&esse
, esrc
);
4816 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4817 gfc_conv_tmp_array_ref (&edse
);
4819 gfc_conv_expr (&edse
, edst
);
4822 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, false, true);
4823 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
, false,
4825 : build_empty_stmt (input_location
);
4826 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
4827 gfc_add_expr_to_block (&body
, tmp
);
4828 gfc_add_block_to_block (&body
, &cse
.post
);
4830 gfc_trans_scalarizing_loops (&loop
, &body
);
4831 gfc_add_block_to_block (&block
, &loop
.pre
);
4832 gfc_add_block_to_block (&block
, &loop
.post
);
4833 gfc_cleanup_loop (&loop
);
4835 return gfc_finish_block (&block
);
4838 /* As the WHERE or WHERE construct statement can be nested, we call
4839 gfc_trans_where_2 to do the translation, and pass the initial
4840 NULL values for both the control mask and the pending control mask. */
4843 gfc_trans_where (gfc_code
* code
)
4849 cblock
= code
->block
;
4851 && cblock
->next
->op
== EXEC_ASSIGN
4852 && !cblock
->next
->next
)
4854 eblock
= cblock
->block
;
4857 /* A simple "WHERE (cond) x = y" statement or block is
4858 dependence free if cond is not dependent upon writing x,
4859 and the source y is unaffected by the destination x. */
4860 if (!gfc_check_dependency (cblock
->next
->expr1
,
4862 && !gfc_check_dependency (cblock
->next
->expr1
,
4863 cblock
->next
->expr2
, 0))
4864 return gfc_trans_where_3 (cblock
, NULL
);
4866 else if (!eblock
->expr1
4869 && eblock
->next
->op
== EXEC_ASSIGN
4870 && !eblock
->next
->next
)
4872 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4873 block is dependence free if cond is not dependent on writes
4874 to x1 and x2, y1 is not dependent on writes to x2, and y2
4875 is not dependent on writes to x1, and both y's are not
4876 dependent upon their own x's. In addition to this, the
4877 final two dependency checks below exclude all but the same
4878 array reference if the where and elswhere destinations
4879 are the same. In short, this is VERY conservative and this
4880 is needed because the two loops, required by the standard
4881 are coalesced in gfc_trans_where_3. */
4882 if (!gfc_check_dependency (cblock
->next
->expr1
,
4884 && !gfc_check_dependency (eblock
->next
->expr1
,
4886 && !gfc_check_dependency (cblock
->next
->expr1
,
4887 eblock
->next
->expr2
, 1)
4888 && !gfc_check_dependency (eblock
->next
->expr1
,
4889 cblock
->next
->expr2
, 1)
4890 && !gfc_check_dependency (cblock
->next
->expr1
,
4891 cblock
->next
->expr2
, 1)
4892 && !gfc_check_dependency (eblock
->next
->expr1
,
4893 eblock
->next
->expr2
, 1)
4894 && !gfc_check_dependency (cblock
->next
->expr1
,
4895 eblock
->next
->expr1
, 0)
4896 && !gfc_check_dependency (eblock
->next
->expr1
,
4897 cblock
->next
->expr1
, 0))
4898 return gfc_trans_where_3 (cblock
, eblock
);
4902 gfc_start_block (&block
);
4904 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
4906 return gfc_finish_block (&block
);
4910 /* CYCLE a DO loop. The label decl has already been created by
4911 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4912 node at the head of the loop. We must mark the label as used. */
4915 gfc_trans_cycle (gfc_code
* code
)
4919 cycle_label
= code
->ext
.which_construct
->cycle_label
;
4920 gcc_assert (cycle_label
);
4922 TREE_USED (cycle_label
) = 1;
4923 return build1_v (GOTO_EXPR
, cycle_label
);
4927 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4928 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4932 gfc_trans_exit (gfc_code
* code
)
4936 exit_label
= code
->ext
.which_construct
->exit_label
;
4937 gcc_assert (exit_label
);
4939 TREE_USED (exit_label
) = 1;
4940 return build1_v (GOTO_EXPR
, exit_label
);
4944 /* Translate the ALLOCATE statement. */
4947 gfc_trans_allocate (gfc_code
* code
)
4969 tree memsize
= NULL_TREE
;
4970 tree classexpr
= NULL_TREE
;
4972 if (!code
->ext
.alloc
.list
)
4975 stat
= tmp
= memsz
= NULL_TREE
;
4976 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
4978 gfc_init_block (&block
);
4979 gfc_init_block (&post
);
4981 /* STAT= (and maybe ERRMSG=) is present. */
4985 tree gfc_int4_type_node
= gfc_get_int_type (4);
4986 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
4988 /* ERRMSG= only makes sense with STAT=. */
4991 gfc_init_se (&se
, NULL
);
4992 se
.want_pointer
= 1;
4993 gfc_conv_expr_lhs (&se
, code
->expr2
);
4995 errlen
= se
.string_length
;
4999 errmsg
= null_pointer_node
;
5000 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5003 /* GOTO destinations. */
5004 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5005 label_finish
= gfc_build_label_decl (NULL_TREE
);
5006 TREE_USED (label_finish
) = 0;
5012 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5014 expr
= gfc_copy_expr (al
->expr
);
5016 if (expr
->ts
.type
== BT_CLASS
)
5017 gfc_add_data_component (expr
);
5019 gfc_init_se (&se
, NULL
);
5021 se
.want_pointer
= 1;
5022 se
.descriptor_only
= 1;
5023 gfc_conv_expr (&se
, expr
);
5025 /* Evaluate expr3 just once if not a variable. */
5026 if (al
== code
->ext
.alloc
.list
5027 && al
->expr
->ts
.type
== BT_CLASS
5029 && code
->expr3
->ts
.type
== BT_CLASS
5030 && code
->expr3
->expr_type
!= EXPR_VARIABLE
)
5032 gfc_init_se (&se_sz
, NULL
);
5033 gfc_conv_expr_reference (&se_sz
, code
->expr3
);
5034 gfc_conv_class_to_class (&se_sz
, code
->expr3
,
5035 code
->expr3
->ts
, false, true, false, false);
5036 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5037 gfc_add_block_to_block (&se
.post
, &se_sz
.post
);
5038 classexpr
= build_fold_indirect_ref_loc (input_location
,
5040 classexpr
= gfc_evaluate_now (classexpr
, &se
.pre
);
5041 memsize
= gfc_vtable_size_get (classexpr
);
5042 memsize
= fold_convert (sizetype
, memsize
);
5046 class_expr
= classexpr
;
5049 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
, label_finish
,
5050 memsz
, &nelems
, code
->expr3
, &code
->ext
.alloc
.ts
))
5052 bool unlimited_char
;
5054 unlimited_char
= UNLIMITED_POLY (al
->expr
)
5055 && ((code
->expr3
&& code
->expr3
->ts
.type
== BT_CHARACTER
)
5056 || (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
5057 && code
->ext
.alloc
.ts
.u
.cl
5058 && code
->ext
.alloc
.ts
.u
.cl
->length
));
5060 /* A scalar or derived type. */
5062 /* Determine allocate size. */
5063 if (al
->expr
->ts
.type
== BT_CLASS
5066 && memsz
== NULL_TREE
)
5068 if (code
->expr3
->ts
.type
== BT_CLASS
)
5070 sz
= gfc_copy_expr (code
->expr3
);
5071 gfc_add_vptr_component (sz
);
5072 gfc_add_size_component (sz
);
5073 gfc_init_se (&se_sz
, NULL
);
5074 gfc_conv_expr (&se_sz
, sz
);
5079 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr3
->ts
));
5081 else if (((al
->expr
->ts
.type
== BT_CHARACTER
&& al
->expr
->ts
.deferred
)
5082 || unlimited_char
) && code
->expr3
)
5084 if (!code
->expr3
->ts
.u
.cl
->backend_decl
)
5086 /* Convert and use the length expression. */
5087 gfc_init_se (&se_sz
, NULL
);
5088 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5089 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5091 gfc_conv_expr (&se_sz
, code
->expr3
);
5092 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5094 = gfc_evaluate_now (se_sz
.string_length
, &se
.pre
);
5095 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5096 memsz
= se_sz
.string_length
;
5098 else if (code
->expr3
->mold
5099 && code
->expr3
->ts
.u
.cl
5100 && code
->expr3
->ts
.u
.cl
->length
)
5102 gfc_conv_expr (&se_sz
, code
->expr3
->ts
.u
.cl
->length
);
5103 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5104 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5105 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5110 /* This is would be inefficient and possibly could
5111 generate wrong code if the result were not stored
5113 if (slen3
== NULL_TREE
)
5115 gfc_conv_expr (&se_sz
, code
->expr3
);
5116 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5117 expr3
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5118 gfc_add_block_to_block (&post
, &se_sz
.post
);
5119 slen3
= gfc_evaluate_now (se_sz
.string_length
,
5126 /* Otherwise use the stored string length. */
5127 memsz
= code
->expr3
->ts
.u
.cl
->backend_decl
;
5128 tmp
= al
->expr
->ts
.u
.cl
->backend_decl
;
5130 /* Store the string length. */
5131 if (tmp
&& TREE_CODE (tmp
) == VAR_DECL
)
5132 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
5134 else if (al
->expr
->ts
.type
== BT_CHARACTER
5135 && al
->expr
->ts
.deferred
&& se
.string_length
)
5136 gfc_add_modify (&se
.pre
, se
.string_length
,
5137 fold_convert (TREE_TYPE (se
.string_length
),
5139 else if ((al
->expr
->ts
.type
== BT_DERIVED
5140 || al
->expr
->ts
.type
== BT_CLASS
)
5141 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
5143 tmp
= gfc_class_len_get (al
->expr
->symtree
->n
.sym
->backend_decl
);
5144 gfc_add_modify (&se
.pre
, tmp
,
5145 fold_convert (TREE_TYPE (tmp
),
5149 /* Convert to size in bytes, using the character KIND. */
5151 tmp
= TREE_TYPE (gfc_typenode_for_spec (&code
->expr3
->ts
));
5153 tmp
= TREE_TYPE (gfc_typenode_for_spec (&al
->expr
->ts
));
5154 tmp
= TYPE_SIZE_UNIT (tmp
);
5155 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5156 TREE_TYPE (tmp
), tmp
,
5157 fold_convert (TREE_TYPE (tmp
), memsz
));
5159 else if ((al
->expr
->ts
.type
== BT_CHARACTER
&& al
->expr
->ts
.deferred
)
5162 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
&& code
->ext
.alloc
.ts
.u
.cl
->length
);
5163 gfc_init_se (&se_sz
, NULL
);
5164 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5165 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5166 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5167 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5168 /* Store the string length. */
5169 tmp
= al
->expr
->ts
.u
.cl
->backend_decl
;
5170 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
5172 tmp
= TREE_TYPE (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5173 tmp
= TYPE_SIZE_UNIT (tmp
);
5174 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5175 TREE_TYPE (tmp
), tmp
,
5176 fold_convert (TREE_TYPE (se_sz
.expr
),
5179 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5180 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5181 else if (memsz
== NULL_TREE
)
5182 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
5184 if (expr
->ts
.type
== BT_CHARACTER
&& memsz
== NULL_TREE
)
5186 memsz
= se
.string_length
;
5188 /* Convert to size in bytes, using the character KIND. */
5189 tmp
= TREE_TYPE (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5190 tmp
= TYPE_SIZE_UNIT (tmp
);
5191 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5192 TREE_TYPE (tmp
), tmp
,
5193 fold_convert (TREE_TYPE (tmp
), memsz
));
5196 /* Allocate - for non-pointers with re-alloc checking. */
5197 if (gfc_expr_attr (expr
).allocatable
)
5198 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
, NULL_TREE
,
5199 stat
, errmsg
, errlen
, label_finish
, expr
);
5201 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
5203 if (al
->expr
->ts
.type
== BT_DERIVED
5204 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5206 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5207 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
5208 gfc_add_expr_to_block (&se
.pre
, tmp
);
5212 gfc_add_block_to_block (&block
, &se
.pre
);
5214 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5217 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
5218 parm
= fold_build2_loc (input_location
, NE_EXPR
,
5219 boolean_type_node
, stat
,
5220 build_int_cst (TREE_TYPE (stat
), 0));
5221 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5222 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
5223 tmp
, build_empty_stmt (input_location
));
5224 gfc_add_expr_to_block (&block
, tmp
);
5227 /* We need the vptr of CLASS objects to be initialized. */
5228 e
= gfc_copy_expr (al
->expr
);
5229 if (e
->ts
.type
== BT_CLASS
)
5231 gfc_expr
*lhs
, *rhs
;
5233 gfc_ref
*ref
, *class_ref
, *tail
;
5235 /* Find the last class reference. */
5237 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5239 if (ref
->type
== REF_COMPONENT
5240 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
)
5243 if (ref
->next
== NULL
)
5247 /* Remove and store all subsequent references after the
5251 tail
= class_ref
->next
;
5252 class_ref
->next
= NULL
;
5260 lhs
= gfc_expr_to_initialize (e
);
5261 gfc_add_vptr_component (lhs
);
5263 /* Remove the _vptr component and restore the original tail
5267 gfc_free_ref_list (class_ref
->next
);
5268 class_ref
->next
= tail
;
5272 gfc_free_ref_list (e
->ref
);
5276 if (class_expr
!= NULL_TREE
)
5278 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5279 gfc_init_se (&lse
, NULL
);
5280 lse
.want_pointer
= 1;
5281 gfc_conv_expr (&lse
, lhs
);
5282 tmp
= gfc_class_vptr_get (class_expr
);
5283 gfc_add_modify (&block
, lse
.expr
,
5284 fold_convert (TREE_TYPE (lse
.expr
), tmp
));
5286 else if (code
->expr3
&& code
->expr3
->ts
.type
== BT_CLASS
)
5288 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5289 rhs
= gfc_copy_expr (code
->expr3
);
5290 gfc_add_vptr_component (rhs
);
5291 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
5292 gfc_add_expr_to_block (&block
, tmp
);
5293 gfc_free_expr (rhs
);
5294 rhs
= gfc_expr_to_initialize (e
);
5298 /* VPTR is fixed at compile time. */
5302 ts
= &code
->expr3
->ts
;
5303 else if (e
->ts
.type
== BT_DERIVED
)
5305 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| UNLIMITED_POLY (al
->expr
))
5306 ts
= &code
->ext
.alloc
.ts
;
5307 else if (e
->ts
.type
== BT_CLASS
)
5308 ts
= &CLASS_DATA (e
)->ts
;
5312 if (ts
->type
== BT_DERIVED
|| UNLIMITED_POLY (e
))
5314 vtab
= gfc_find_vtab (ts
);
5316 gfc_init_se (&lse
, NULL
);
5317 lse
.want_pointer
= 1;
5318 gfc_conv_expr (&lse
, lhs
);
5319 tmp
= gfc_build_addr_expr (NULL_TREE
,
5320 gfc_get_symbol_decl (vtab
));
5321 gfc_add_modify (&block
, lse
.expr
,
5322 fold_convert (TREE_TYPE (lse
.expr
), tmp
));
5325 gfc_free_expr (lhs
);
5330 if (code
->expr3
&& !code
->expr3
->mold
)
5332 /* Initialization via SOURCE block
5333 (or static default initializer). */
5334 gfc_expr
*rhs
= gfc_copy_expr (code
->expr3
);
5335 if (class_expr
!= NULL_TREE
)
5338 to
= TREE_OPERAND (se
.expr
, 0);
5340 tmp
= gfc_copy_class_to_class (class_expr
, to
, nelems
);
5342 else if (al
->expr
->ts
.type
== BT_CLASS
)
5344 gfc_actual_arglist
*actual
;
5347 gfc_ref
*ref
, *dataref
;
5349 /* Do a polymorphic deep copy. */
5350 actual
= gfc_get_actual_arglist ();
5351 actual
->expr
= gfc_copy_expr (rhs
);
5352 if (rhs
->ts
.type
== BT_CLASS
)
5353 gfc_add_data_component (actual
->expr
);
5354 actual
->next
= gfc_get_actual_arglist ();
5355 actual
->next
->expr
= gfc_copy_expr (al
->expr
);
5356 actual
->next
->expr
->ts
.type
= BT_CLASS
;
5357 gfc_add_data_component (actual
->next
->expr
);
5360 /* Make sure we go up through the reference chain to
5361 the _data reference, where the arrayspec is found. */
5362 for (ref
= actual
->next
->expr
->ref
; ref
; ref
= ref
->next
)
5363 if (ref
->type
== REF_COMPONENT
5364 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
5367 if (dataref
&& dataref
->u
.c
.component
->as
)
5371 gfc_ref
*ref
= dataref
->next
;
5372 ref
->u
.ar
.type
= AR_SECTION
;
5373 /* We have to set up the array reference to give ranges
5374 in all dimensions and ensure that the end and stride
5375 are set so that the copy can be scalarized. */
5377 for (; dim
< dataref
->u
.c
.component
->as
->rank
; dim
++)
5379 ref
->u
.ar
.dimen_type
[dim
] = DIMEN_RANGE
;
5380 if (ref
->u
.ar
.end
[dim
] == NULL
)
5382 ref
->u
.ar
.end
[dim
] = ref
->u
.ar
.start
[dim
];
5383 temp
= gfc_get_int_expr (gfc_default_integer_kind
,
5384 &al
->expr
->where
, 1);
5385 ref
->u
.ar
.start
[dim
] = temp
;
5387 temp
= gfc_subtract (gfc_copy_expr (ref
->u
.ar
.end
[dim
]),
5388 gfc_copy_expr (ref
->u
.ar
.start
[dim
]));
5389 temp
= gfc_add (gfc_get_int_expr (gfc_default_integer_kind
,
5390 &al
->expr
->where
, 1),
5394 if (rhs
->ts
.type
== BT_CLASS
)
5396 ppc
= gfc_copy_expr (rhs
);
5397 gfc_add_vptr_component (ppc
);
5400 ppc
= gfc_lval_expr_from_sym (gfc_find_vtab (&rhs
->ts
));
5401 gfc_add_component_ref (ppc
, "_copy");
5403 ppc_code
= gfc_get_code (EXEC_CALL
);
5404 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
5405 /* Although '_copy' is set to be elemental in class.c, it is
5406 not staying that way. Find out why, sometime.... */
5407 ppc_code
->resolved_sym
->attr
.elemental
= 1;
5408 ppc_code
->ext
.actual
= actual
;
5409 ppc_code
->expr1
= ppc
;
5410 /* Since '_copy' is elemental, the scalarizer will take care
5411 of arrays in gfc_trans_call. */
5412 tmp
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
5413 gfc_free_statements (ppc_code
);
5415 else if (expr3
!= NULL_TREE
)
5417 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5418 gfc_trans_string_copy (&block
, slen3
, tmp
, code
->expr3
->ts
.kind
,
5419 slen3
, expr3
, code
->expr3
->ts
.kind
);
5424 /* Switch off automatic reallocation since we have just done
5426 int realloc_lhs
= flag_realloc_lhs
;
5427 flag_realloc_lhs
= 0;
5428 tmp
= gfc_trans_assignment (gfc_expr_to_initialize (expr
),
5430 flag_realloc_lhs
= realloc_lhs
;
5432 gfc_free_expr (rhs
);
5433 gfc_add_expr_to_block (&block
, tmp
);
5435 else if (code
->expr3
&& code
->expr3
->mold
5436 && code
->expr3
->ts
.type
== BT_CLASS
)
5438 /* Since the _vptr has already been assigned to the allocate
5439 object, we can use gfc_copy_class_to_class in its
5440 initialization mode. */
5441 tmp
= TREE_OPERAND (se
.expr
, 0);
5442 tmp
= gfc_copy_class_to_class (NULL_TREE
, tmp
, nelems
);
5443 gfc_add_expr_to_block (&block
, tmp
);
5446 gfc_free_expr (expr
);
5452 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
5453 gfc_add_expr_to_block (&block
, tmp
);
5456 /* ERRMSG - only useful if STAT is present. */
5457 if (code
->expr1
&& code
->expr2
)
5459 const char *msg
= "Attempt to allocate an allocated object";
5460 tree slen
, dlen
, errmsg_str
;
5461 stmtblock_t errmsg_block
;
5463 gfc_init_block (&errmsg_block
);
5465 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
5466 gfc_add_modify (&errmsg_block
, errmsg_str
,
5467 gfc_build_addr_expr (pchar_type_node
,
5468 gfc_build_localized_cstring_const (msg
)));
5470 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
5471 dlen
= gfc_get_expr_charlen (code
->expr2
);
5472 slen
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (slen
), dlen
,
5475 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
5476 slen
, errmsg_str
, gfc_default_character_kind
);
5477 dlen
= gfc_finish_block (&errmsg_block
);
5479 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
5480 build_int_cst (TREE_TYPE (stat
), 0));
5482 tmp
= build3_v (COND_EXPR
, tmp
, dlen
, build_empty_stmt (input_location
));
5484 gfc_add_expr_to_block (&block
, tmp
);
5490 if (TREE_USED (label_finish
))
5492 tmp
= build1_v (LABEL_EXPR
, label_finish
);
5493 gfc_add_expr_to_block (&block
, tmp
);
5496 gfc_init_se (&se
, NULL
);
5497 gfc_conv_expr_lhs (&se
, code
->expr1
);
5498 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
5499 gfc_add_modify (&block
, se
.expr
, tmp
);
5502 gfc_add_block_to_block (&block
, &se
.post
);
5503 gfc_add_block_to_block (&block
, &post
);
5505 return gfc_finish_block (&block
);
5509 /* Translate a DEALLOCATE statement. */
5512 gfc_trans_deallocate (gfc_code
*code
)
5516 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
5517 tree label_finish
, label_errmsg
;
5520 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
5521 label_finish
= label_errmsg
= NULL_TREE
;
5523 gfc_start_block (&block
);
5525 /* Count the number of failed deallocations. If deallocate() was
5526 called with STAT= , then set STAT to the count. If deallocate
5527 was called with ERRMSG, then set ERRMG to a string. */
5530 tree gfc_int4_type_node
= gfc_get_int_type (4);
5532 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5533 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
5535 /* GOTO destinations. */
5536 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5537 label_finish
= gfc_build_label_decl (NULL_TREE
);
5538 TREE_USED (label_finish
) = 0;
5541 /* Set ERRMSG - only needed if STAT is available. */
5542 if (code
->expr1
&& code
->expr2
)
5544 gfc_init_se (&se
, NULL
);
5545 se
.want_pointer
= 1;
5546 gfc_conv_expr_lhs (&se
, code
->expr2
);
5548 errlen
= se
.string_length
;
5551 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5553 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
5554 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
5556 if (expr
->ts
.type
== BT_CLASS
)
5557 gfc_add_data_component (expr
);
5559 gfc_init_se (&se
, NULL
);
5560 gfc_start_block (&se
.pre
);
5562 se
.want_pointer
= 1;
5563 se
.descriptor_only
= 1;
5564 gfc_conv_expr (&se
, expr
);
5566 if (expr
->rank
|| gfc_is_coarray (expr
))
5568 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->attr
.alloc_comp
5569 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
5572 gfc_ref
*last
= NULL
;
5573 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5574 if (ref
->type
== REF_COMPONENT
)
5577 /* Do not deallocate the components of a derived type
5578 ultimate pointer component. */
5579 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
5580 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
5582 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
5584 gfc_add_expr_to_block (&se
.pre
, tmp
);
5587 tmp
= gfc_array_deallocate (se
.expr
, pstat
, errmsg
, errlen
,
5588 label_finish
, expr
);
5589 gfc_add_expr_to_block (&se
.pre
, tmp
);
5590 if (al
->expr
->ts
.type
== BT_CLASS
)
5591 gfc_reset_vptr (&se
.pre
, al
->expr
);
5595 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, false,
5596 al
->expr
, al
->expr
->ts
);
5597 gfc_add_expr_to_block (&se
.pre
, tmp
);
5599 /* Set to zero after deallocation. */
5600 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
5602 build_int_cst (TREE_TYPE (se
.expr
), 0));
5603 gfc_add_expr_to_block (&se
.pre
, tmp
);
5605 if (al
->expr
->ts
.type
== BT_CLASS
)
5606 gfc_reset_vptr (&se
.pre
, al
->expr
);
5613 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
5614 build_int_cst (TREE_TYPE (stat
), 0));
5615 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5616 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
5617 build1_v (GOTO_EXPR
, label_errmsg
),
5618 build_empty_stmt (input_location
));
5619 gfc_add_expr_to_block (&se
.pre
, tmp
);
5622 tmp
= gfc_finish_block (&se
.pre
);
5623 gfc_add_expr_to_block (&block
, tmp
);
5624 gfc_free_expr (expr
);
5629 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
5630 gfc_add_expr_to_block (&block
, tmp
);
5633 /* Set ERRMSG - only needed if STAT is available. */
5634 if (code
->expr1
&& code
->expr2
)
5636 const char *msg
= "Attempt to deallocate an unallocated object";
5637 stmtblock_t errmsg_block
;
5638 tree errmsg_str
, slen
, dlen
, cond
;
5640 gfc_init_block (&errmsg_block
);
5642 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
5643 gfc_add_modify (&errmsg_block
, errmsg_str
,
5644 gfc_build_addr_expr (pchar_type_node
,
5645 gfc_build_localized_cstring_const (msg
)));
5646 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
5647 dlen
= gfc_get_expr_charlen (code
->expr2
);
5649 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
5650 slen
, errmsg_str
, gfc_default_character_kind
);
5651 tmp
= gfc_finish_block (&errmsg_block
);
5653 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
5654 build_int_cst (TREE_TYPE (stat
), 0));
5655 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5656 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
5657 build_empty_stmt (input_location
));
5659 gfc_add_expr_to_block (&block
, tmp
);
5662 if (code
->expr1
&& TREE_USED (label_finish
))
5664 tmp
= build1_v (LABEL_EXPR
, label_finish
);
5665 gfc_add_expr_to_block (&block
, tmp
);
5671 gfc_init_se (&se
, NULL
);
5672 gfc_conv_expr_lhs (&se
, code
->expr1
);
5673 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
5674 gfc_add_modify (&block
, se
.expr
, tmp
);
5677 return gfc_finish_block (&block
);
5680 #include "gt-fortran-trans-stmt.h"