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"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "dependency.h"
38 typedef struct iter_info
44 struct iter_info
*next
;
48 typedef struct forall_info
55 struct forall_info
*prev_nest
;
60 static void gfc_trans_where_2 (gfc_code
*, tree
, bool,
61 forall_info
*, stmtblock_t
*);
63 /* Translate a F95 label number to a LABEL_EXPR. */
66 gfc_trans_label_here (gfc_code
* code
)
68 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
72 /* Given a variable expression which has been ASSIGNed to, find the decl
73 containing the auxiliary variables. For variables in common blocks this
77 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
79 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
80 gfc_conv_expr (se
, expr
);
81 /* Deals with variable in common block. Get the field declaration. */
82 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
83 se
->expr
= TREE_OPERAND (se
->expr
, 1);
84 /* Deals with dummy argument. Get the parameter declaration. */
85 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
86 se
->expr
= TREE_OPERAND (se
->expr
, 0);
89 /* Translate a label assignment statement. */
92 gfc_trans_label_assign (gfc_code
* code
)
101 /* Start a new block. */
102 gfc_init_se (&se
, NULL
);
103 gfc_start_block (&se
.pre
);
104 gfc_conv_label_variable (&se
, code
->expr1
);
106 len
= GFC_DECL_STRING_LEN (se
.expr
);
107 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
109 label_tree
= gfc_get_label_decl (code
->label1
);
111 if (code
->label1
->defined
== ST_LABEL_TARGET
112 || code
->label1
->defined
== ST_LABEL_DO_TARGET
)
114 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
115 len_tree
= integer_minus_one_node
;
119 gfc_expr
*format
= code
->label1
->format
;
121 label_len
= format
->value
.character
.length
;
122 len_tree
= build_int_cst (gfc_charlen_type_node
, label_len
);
123 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
124 format
->value
.character
.string
);
125 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
128 gfc_add_modify (&se
.pre
, len
, len_tree
);
129 gfc_add_modify (&se
.pre
, addr
, label_tree
);
131 return gfc_finish_block (&se
.pre
);
134 /* Translate a GOTO statement. */
137 gfc_trans_goto (gfc_code
* code
)
139 locus loc
= code
->loc
;
145 if (code
->label1
!= NULL
)
146 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
149 gfc_init_se (&se
, NULL
);
150 gfc_start_block (&se
.pre
);
151 gfc_conv_label_variable (&se
, code
->expr1
);
152 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
154 build_int_cst (TREE_TYPE (tmp
), -1));
155 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
156 "Assigned label is not a target label");
158 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
166 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
168 gfc_add_expr_to_block (&se
.pre
, target
);
169 return gfc_finish_block (&se
.pre
);
173 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 gfc_trans_entry (gfc_code
* code
)
177 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
181 /* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
186 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
188 gfc_ss
**sess
, **loopss
;
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
193 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
196 gcc_assert (*sess
!= gfc_ss_terminator
);
199 new_ss
->next
= old_ss
->next
;
202 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
203 loopss
= &((*loopss
)->loop_chain
))
204 if (*loopss
== old_ss
)
206 gcc_assert (*loopss
!= gfc_ss_terminator
);
209 new_ss
->loop_chain
= old_ss
->loop_chain
;
210 new_ss
->loop
= old_ss
->loop
;
212 gfc_free_ss (old_ss
);
216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
217 elemental subroutines. Make temporaries for output arguments if any such
218 dependencies are found. Output arguments are chosen because internal_unpack
219 can be used, as is, to copy the result back to the variable. */
221 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
222 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
223 gfc_dep_check check_variable
)
225 gfc_actual_arglist
*arg0
;
227 gfc_formal_arglist
*formal
;
235 if (loopse
->ss
== NULL
)
240 formal
= gfc_sym_get_dummy_args (sym
);
242 /* Loop over all the arguments testing for dependencies. */
243 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
249 /* Obtain the info structure for the current argument. */
250 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
251 if (ss
->info
->expr
== e
)
254 /* If there is a dependency, create a temporary and use it
255 instead of the variable. */
256 fsym
= formal
? formal
->sym
: NULL
;
257 if (e
->expr_type
== EXPR_VARIABLE
259 && fsym
->attr
.intent
!= INTENT_IN
260 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
261 sym
, arg0
, check_variable
))
263 tree initial
, temptype
;
264 stmtblock_t temp_post
;
267 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
269 gfc_mark_ss_chain_used (tmp_ss
, 1);
270 tmp_ss
->info
->expr
= ss
->info
->expr
;
271 replace_ss (loopse
, ss
, tmp_ss
);
273 /* Obtain the argument descriptor for unpacking. */
274 gfc_init_se (&parmse
, NULL
);
275 parmse
.want_pointer
= 1;
276 gfc_conv_expr_descriptor (&parmse
, e
);
277 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
280 initialize the array temporary with a copy of the values. */
281 if (fsym
->attr
.intent
== INTENT_INOUT
282 || (fsym
->ts
.type
==BT_DERIVED
283 && fsym
->attr
.intent
== INTENT_OUT
))
284 initial
= parmse
.expr
;
285 /* For class expressions, we always initialize with the copy of
287 else if (e
->ts
.type
== BT_CLASS
)
288 initial
= parmse
.expr
;
292 if (e
->ts
.type
!= BT_CLASS
)
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e
296 (where the type of e is that of the final reference, but
297 parmse.expr's type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
307 /* For class arrays signal that the size of the dynamic type has to
308 be obtained from the vtable, using the 'initial' expression. */
309 temptype
= NULL_TREE
;
311 /* Generate the temporary. Cleaning up the temporary should be the
312 very last thing done, so we add the code to a new block and add it
313 to se->post as last instructions. */
314 size
= gfc_create_var (gfc_array_index_type
, NULL
);
315 data
= gfc_create_var (pvoid_type_node
, NULL
);
316 gfc_init_block (&temp_post
);
317 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
318 temptype
, initial
, false, true,
319 false, &arg
->expr
->where
);
320 gfc_add_modify (&se
->pre
, size
, tmp
);
321 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
322 gfc_add_modify (&se
->pre
, data
, tmp
);
324 /* Update other ss' delta. */
325 gfc_set_delta (loopse
->loop
);
327 /* Copy the result back using unpack..... */
328 if (e
->ts
.type
!= BT_CLASS
)
329 tmp
= build_call_expr_loc (input_location
,
330 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
333 /* ... except for class results where the copy is
335 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
336 tmp
= gfc_conv_descriptor_data_get (tmp
);
337 tmp
= build_call_expr_loc (input_location
,
338 builtin_decl_explicit (BUILT_IN_MEMCPY
),
340 fold_convert (size_type_node
, size
));
342 gfc_add_expr_to_block (&se
->post
, tmp
);
344 /* parmse.pre is already added above. */
345 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
346 gfc_add_block_to_block (&se
->post
, &temp_post
);
352 /* Get the interface symbol for the procedure corresponding to the given call.
353 We can't get the procedure symbol directly as we have to handle the case
354 of (deferred) type-bound procedures. */
357 get_proc_ifc_for_call (gfc_code
*c
)
361 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
363 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
365 /* Fall back/last resort try. */
367 sym
= c
->resolved_sym
;
373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
376 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
377 tree mask
, tree count1
, bool invert
)
381 int has_alternate_specifier
;
382 gfc_dep_check check_variable
;
383 tree index
= NULL_TREE
;
384 tree maskexpr
= NULL_TREE
;
387 /* A CALL starts a new block because the actual arguments may have to
388 be evaluated first. */
389 gfc_init_se (&se
, NULL
);
390 gfc_start_block (&se
.pre
);
392 gcc_assert (code
->resolved_sym
);
394 ss
= gfc_ss_terminator
;
395 if (code
->resolved_sym
->attr
.elemental
)
396 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
397 get_proc_ifc_for_call (code
),
400 /* Is not an elemental subroutine call with array valued arguments. */
401 if (ss
== gfc_ss_terminator
)
404 /* Translate the call. */
405 has_alternate_specifier
406 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
409 /* A subroutine without side-effect, by definition, does nothing! */
410 TREE_SIDE_EFFECTS (se
.expr
) = 1;
412 /* Chain the pieces together and return the block. */
413 if (has_alternate_specifier
)
415 gfc_code
*select_code
;
417 select_code
= code
->next
;
418 gcc_assert(select_code
->op
== EXEC_SELECT
);
419 sym
= select_code
->expr1
->symtree
->n
.sym
;
420 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
421 if (sym
->backend_decl
== NULL
)
422 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
423 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
426 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
433 /* An elemental subroutine call with array valued arguments has
441 /* gfc_walk_elemental_function_args renders the ss chain in the
442 reverse order to the actual argument order. */
443 ss
= gfc_reverse_ss (ss
);
445 /* Initialize the loop. */
446 gfc_init_se (&loopse
, NULL
);
447 gfc_init_loopinfo (&loop
);
448 gfc_add_ss_to_loop (&loop
, ss
);
450 gfc_conv_ss_startstride (&loop
);
451 /* TODO: gfc_conv_loop_setup generates a temporary for vector
452 subscripts. This could be prevented in the elemental case
453 as temporaries are handled separatedly
454 (below in gfc_conv_elemental_dependencies). */
455 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
456 gfc_mark_ss_chain_used (ss
, 1);
458 /* Convert the arguments, checking for dependencies. */
459 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
462 /* For operator assignment, do dependency checking. */
463 if (dependency_check
)
464 check_variable
= ELEM_CHECK_VARIABLE
;
466 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
468 gfc_init_se (&depse
, NULL
);
469 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
470 code
->ext
.actual
, check_variable
);
472 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
473 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
475 /* Generate the loop body. */
476 gfc_start_scalarized_body (&loop
, &body
);
477 gfc_init_block (&block
);
481 /* Form the mask expression according to the mask. */
483 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
485 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
486 TREE_TYPE (maskexpr
), maskexpr
);
489 /* Add the subroutine call to the block. */
490 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
491 code
->ext
.actual
, code
->expr1
,
496 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
497 build_empty_stmt (input_location
));
498 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
499 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
500 gfc_array_index_type
,
501 count1
, gfc_index_one_node
);
502 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
505 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
507 gfc_add_block_to_block (&block
, &loopse
.pre
);
508 gfc_add_block_to_block (&block
, &loopse
.post
);
510 /* Finish up the loop block and the loop. */
511 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
512 gfc_trans_scalarizing_loops (&loop
, &body
);
513 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
514 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
515 gfc_add_block_to_block (&se
.pre
, &se
.post
);
516 gfc_cleanup_loop (&loop
);
519 return gfc_finish_block (&se
.pre
);
523 /* Translate the RETURN statement. */
526 gfc_trans_return (gfc_code
* code
)
534 /* If code->expr is not NULL, this return statement must appear
535 in a subroutine and current_fake_result_decl has already
538 result
= gfc_get_fake_result_decl (NULL
, 0);
542 "An alternate return at %L without a * dummy argument",
543 &code
->expr1
->where
);
544 return gfc_generate_return ();
547 /* Start a new block for this statement. */
548 gfc_init_se (&se
, NULL
);
549 gfc_start_block (&se
.pre
);
551 gfc_conv_expr (&se
, code
->expr1
);
553 /* Note that the actually returned expression is a simple value and
554 does not depend on any pointers or such; thus we can clean-up with
555 se.post before returning. */
556 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
557 result
, fold_convert (TREE_TYPE (result
),
559 gfc_add_expr_to_block (&se
.pre
, tmp
);
560 gfc_add_block_to_block (&se
.pre
, &se
.post
);
562 tmp
= gfc_generate_return ();
563 gfc_add_expr_to_block (&se
.pre
, tmp
);
564 return gfc_finish_block (&se
.pre
);
567 return gfc_generate_return ();
571 /* Translate the PAUSE statement. We have to translate this statement
572 to a runtime library call. */
575 gfc_trans_pause (gfc_code
* code
)
577 tree gfc_int4_type_node
= gfc_get_int_type (4);
581 /* Start a new block for this statement. */
582 gfc_init_se (&se
, NULL
);
583 gfc_start_block (&se
.pre
);
586 if (code
->expr1
== NULL
)
588 tmp
= build_int_cst (gfc_int4_type_node
, 0);
589 tmp
= build_call_expr_loc (input_location
,
590 gfor_fndecl_pause_string
, 2,
591 build_int_cst (pchar_type_node
, 0), tmp
);
593 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
595 gfc_conv_expr (&se
, code
->expr1
);
596 tmp
= build_call_expr_loc (input_location
,
597 gfor_fndecl_pause_numeric
, 1,
598 fold_convert (gfc_int4_type_node
, se
.expr
));
602 gfc_conv_expr_reference (&se
, code
->expr1
);
603 tmp
= build_call_expr_loc (input_location
,
604 gfor_fndecl_pause_string
, 2,
605 se
.expr
, se
.string_length
);
608 gfc_add_expr_to_block (&se
.pre
, tmp
);
610 gfc_add_block_to_block (&se
.pre
, &se
.post
);
612 return gfc_finish_block (&se
.pre
);
616 /* Translate the STOP statement. We have to translate this statement
617 to a runtime library call. */
620 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
622 tree gfc_int4_type_node
= gfc_get_int_type (4);
626 /* Start a new block for this statement. */
627 gfc_init_se (&se
, NULL
);
628 gfc_start_block (&se
.pre
);
630 if (code
->expr1
== NULL
)
632 tmp
= build_int_cst (gfc_int4_type_node
, 0);
633 tmp
= build_call_expr_loc (input_location
,
635 ? (flag_coarray
== GFC_FCOARRAY_LIB
636 ? gfor_fndecl_caf_error_stop_str
637 : gfor_fndecl_error_stop_string
)
638 : gfor_fndecl_stop_string
,
639 2, build_int_cst (pchar_type_node
, 0), tmp
);
641 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
643 gfc_conv_expr (&se
, code
->expr1
);
644 tmp
= build_call_expr_loc (input_location
,
646 ? (flag_coarray
== GFC_FCOARRAY_LIB
647 ? gfor_fndecl_caf_error_stop
648 : gfor_fndecl_error_stop_numeric
)
649 : gfor_fndecl_stop_numeric_f08
, 1,
650 fold_convert (gfc_int4_type_node
, se
.expr
));
654 gfc_conv_expr_reference (&se
, code
->expr1
);
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, se
.expr
, se
.string_length
);
664 gfc_add_expr_to_block (&se
.pre
, tmp
);
666 gfc_add_block_to_block (&se
.pre
, &se
.post
);
668 return gfc_finish_block (&se
.pre
);
673 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
676 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
677 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
679 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
680 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
681 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
686 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
687 gfc_init_se (&argse
, NULL
);
688 gfc_conv_expr_val (&argse
, code
->expr2
);
691 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
692 stat
= null_pointer_node
;
696 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
697 gfc_init_se (&argse
, NULL
);
698 gfc_conv_expr_val (&argse
, code
->expr4
);
699 lock_acquired
= argse
.expr
;
701 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
702 lock_acquired
= null_pointer_node
;
704 gfc_start_block (&se
.pre
);
705 if (flag_coarray
== GFC_FCOARRAY_LIB
)
707 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
708 tree index
= size_zero_node
;
709 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
711 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
712 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
713 != INTMOD_ISO_FORTRAN_ENV
714 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
715 != ISOFORTRAN_LOCK_TYPE
)
717 gfc_error ("Sorry, the lock component of derived type at %L is not "
718 "yet supported", &code
->expr1
->where
);
722 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, code
->expr1
);
724 if (gfc_is_coindexed (code
->expr1
))
725 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
727 image_index
= integer_zero_node
;
729 /* For arrays, obtain the array index. */
730 if (gfc_expr_attr (code
->expr1
).dimension
)
732 tree desc
, tmp
, extent
, lbound
, ubound
;
733 gfc_array_ref
*ar
, ar2
;
736 /* TODO: Extend this, once DT components are supported. */
737 ar
= &code
->expr1
->ref
->u
.ar
;
739 memset (ar
, '\0', sizeof (*ar
));
743 gfc_init_se (&argse
, NULL
);
744 argse
.descriptor_only
= 1;
745 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
746 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
750 extent
= integer_one_node
;
751 for (i
= 0; i
< ar
->dimen
; i
++)
753 gfc_init_se (&argse
, NULL
);
754 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
755 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
756 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
757 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
758 integer_type_node
, argse
.expr
,
759 fold_convert(integer_type_node
, lbound
));
760 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
761 integer_type_node
, extent
, tmp
);
762 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
763 integer_type_node
, index
, tmp
);
764 if (i
< ar
->dimen
- 1)
766 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
767 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
768 tmp
= fold_convert (integer_type_node
, tmp
);
769 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
770 integer_type_node
, extent
, tmp
);
778 gfc_init_se (&argse
, NULL
);
779 argse
.want_pointer
= 1;
780 gfc_conv_expr (&argse
, code
->expr3
);
781 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
783 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
787 errmsg
= null_pointer_node
;
788 errmsg_len
= integer_zero_node
;
791 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
794 stat
= gfc_create_var (integer_type_node
, "stat");
797 if (lock_acquired
!= null_pointer_node
798 && TREE_TYPE (lock_acquired
) != integer_type_node
)
800 lock_acquired2
= lock_acquired
;
801 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
805 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
806 token
, index
, image_index
,
807 lock_acquired
!= null_pointer_node
808 ? gfc_build_addr_expr (NULL
, lock_acquired
)
810 stat
!= null_pointer_node
811 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
814 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
815 token
, index
, image_index
,
816 stat
!= null_pointer_node
817 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
819 gfc_add_expr_to_block (&se
.pre
, tmp
);
821 /* It guarantees memory consistency within the same segment */
822 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
823 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
824 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
825 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
826 ASM_VOLATILE_P (tmp
) = 1;
828 gfc_add_expr_to_block (&se
.pre
, tmp
);
830 if (stat2
!= NULL_TREE
)
831 gfc_add_modify (&se
.pre
, stat2
,
832 fold_convert (TREE_TYPE (stat2
), stat
));
834 if (lock_acquired2
!= NULL_TREE
)
835 gfc_add_modify (&se
.pre
, lock_acquired2
,
836 fold_convert (TREE_TYPE (lock_acquired2
),
839 return gfc_finish_block (&se
.pre
);
842 if (stat
!= NULL_TREE
)
843 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
845 if (lock_acquired
!= NULL_TREE
)
846 gfc_add_modify (&se
.pre
, lock_acquired
,
847 fold_convert (TREE_TYPE (lock_acquired
),
850 return gfc_finish_block (&se
.pre
);
854 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
857 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
858 tree until_count
= NULL_TREE
;
862 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
863 gfc_init_se (&argse
, NULL
);
864 gfc_conv_expr_val (&argse
, code
->expr2
);
867 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
868 stat
= null_pointer_node
;
872 gfc_init_se (&argse
, NULL
);
873 gfc_conv_expr_val (&argse
, code
->expr4
);
874 until_count
= fold_convert (integer_type_node
, argse
.expr
);
877 until_count
= integer_one_node
;
879 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
881 gfc_start_block (&se
.pre
);
882 gfc_init_se (&argse
, NULL
);
883 gfc_conv_expr_val (&argse
, code
->expr1
);
885 if (op
== EXEC_EVENT_POST
)
886 gfc_add_modify (&se
.pre
, argse
.expr
,
887 fold_build2_loc (input_location
, PLUS_EXPR
,
888 TREE_TYPE (argse
.expr
), argse
.expr
,
889 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
891 gfc_add_modify (&se
.pre
, argse
.expr
,
892 fold_build2_loc (input_location
, MINUS_EXPR
,
893 TREE_TYPE (argse
.expr
), argse
.expr
,
894 fold_convert (TREE_TYPE (argse
.expr
),
896 if (stat
!= NULL_TREE
)
897 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
899 return gfc_finish_block (&se
.pre
);
902 gfc_start_block (&se
.pre
);
903 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
904 tree index
= size_zero_node
;
905 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
907 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
908 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
909 != INTMOD_ISO_FORTRAN_ENV
910 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
911 != ISOFORTRAN_EVENT_TYPE
)
913 gfc_error ("Sorry, the event component of derived type at %L is not "
914 "yet supported", &code
->expr1
->where
);
918 gfc_get_caf_token_offset (&token
, NULL
, caf_decl
, NULL_TREE
, code
->expr1
);
920 if (gfc_is_coindexed (code
->expr1
))
921 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
923 image_index
= integer_zero_node
;
925 /* For arrays, obtain the array index. */
926 if (gfc_expr_attr (code
->expr1
).dimension
)
928 tree desc
, tmp
, extent
, lbound
, ubound
;
929 gfc_array_ref
*ar
, ar2
;
932 /* TODO: Extend this, once DT components are supported. */
933 ar
= &code
->expr1
->ref
->u
.ar
;
935 memset (ar
, '\0', sizeof (*ar
));
939 gfc_init_se (&argse
, NULL
);
940 argse
.descriptor_only
= 1;
941 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
942 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
946 extent
= integer_one_node
;
947 for (i
= 0; i
< ar
->dimen
; i
++)
949 gfc_init_se (&argse
, NULL
);
950 gfc_conv_expr_type (&argse
, ar
->start
[i
], integer_type_node
);
951 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
952 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
953 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
954 integer_type_node
, argse
.expr
,
955 fold_convert(integer_type_node
, lbound
));
956 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
957 integer_type_node
, extent
, tmp
);
958 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
959 integer_type_node
, index
, tmp
);
960 if (i
< ar
->dimen
- 1)
962 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
963 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
964 tmp
= fold_convert (integer_type_node
, tmp
);
965 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
966 integer_type_node
, extent
, tmp
);
974 gfc_init_se (&argse
, NULL
);
975 argse
.want_pointer
= 1;
976 gfc_conv_expr (&argse
, code
->expr3
);
977 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
979 errmsg_len
= fold_convert (integer_type_node
, argse
.string_length
);
983 errmsg
= null_pointer_node
;
984 errmsg_len
= integer_zero_node
;
987 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
990 stat
= gfc_create_var (integer_type_node
, "stat");
993 if (op
== EXEC_EVENT_POST
)
994 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
995 token
, index
, image_index
,
996 stat
!= null_pointer_node
997 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1000 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1001 token
, index
, until_count
,
1002 stat
!= null_pointer_node
1003 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1004 errmsg
, errmsg_len
);
1005 gfc_add_expr_to_block (&se
.pre
, tmp
);
1007 /* It guarantees memory consistency within the same segment */
1008 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1009 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1010 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1011 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1012 ASM_VOLATILE_P (tmp
) = 1;
1013 gfc_add_expr_to_block (&se
.pre
, tmp
);
1015 if (stat2
!= NULL_TREE
)
1016 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1018 return gfc_finish_block (&se
.pre
);
1022 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1026 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1027 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1029 /* Short cut: For single images without bound checking or without STAT=,
1030 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1031 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1032 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1035 gfc_init_se (&se
, NULL
);
1036 gfc_start_block (&se
.pre
);
1038 if (code
->expr1
&& code
->expr1
->rank
== 0)
1040 gfc_init_se (&argse
, NULL
);
1041 gfc_conv_expr_val (&argse
, code
->expr1
);
1042 images
= argse
.expr
;
1047 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1048 gfc_init_se (&argse
, NULL
);
1049 gfc_conv_expr_val (&argse
, code
->expr2
);
1053 stat
= null_pointer_node
;
1055 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1057 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1058 gfc_init_se (&argse
, NULL
);
1059 argse
.want_pointer
= 1;
1060 gfc_conv_expr (&argse
, code
->expr3
);
1061 gfc_conv_string_parameter (&argse
);
1062 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1063 errmsglen
= argse
.string_length
;
1065 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1067 errmsg
= null_pointer_node
;
1068 errmsglen
= build_int_cst (integer_type_node
, 0);
1071 /* Check SYNC IMAGES(imageset) for valid image index.
1072 FIXME: Add a check for image-set arrays. */
1073 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1074 && code
->expr1
->rank
== 0)
1077 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1078 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1079 images
, build_int_cst (TREE_TYPE (images
), 1));
1083 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1084 2, integer_zero_node
,
1085 build_int_cst (integer_type_node
, -1));
1086 cond
= fold_build2_loc (input_location
, GT_EXPR
, boolean_type_node
,
1088 cond2
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1090 build_int_cst (TREE_TYPE (images
), 1));
1091 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1092 boolean_type_node
, cond
, cond2
);
1094 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1095 &code
->expr1
->where
, "Invalid image number "
1096 "%d in SYNC IMAGES",
1097 fold_convert (integer_type_node
, images
));
1100 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1101 image control statements SYNC IMAGES and SYNC ALL. */
1102 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1104 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1105 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1106 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1107 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1108 ASM_VOLATILE_P (tmp
) = 1;
1109 gfc_add_expr_to_block (&se
.pre
, tmp
);
1112 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1114 /* Set STAT to zero. */
1116 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1118 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1120 /* SYNC ALL => stat == null_pointer_node
1121 SYNC ALL(stat=s) => stat has an integer type
1123 If "stat" has the wrong integer type, use a temp variable of
1124 the right type and later cast the result back into "stat". */
1125 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1127 if (TREE_TYPE (stat
) == integer_type_node
)
1128 stat
= gfc_build_addr_expr (NULL
, stat
);
1130 if(type
== EXEC_SYNC_MEMORY
)
1131 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1132 3, stat
, errmsg
, errmsglen
);
1134 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1135 3, stat
, errmsg
, errmsglen
);
1137 gfc_add_expr_to_block (&se
.pre
, tmp
);
1141 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1143 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1144 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1146 gfc_add_expr_to_block (&se
.pre
, tmp
);
1148 gfc_add_modify (&se
.pre
, stat
,
1149 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1156 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1160 len
= build_int_cst (integer_type_node
, -1);
1161 images
= null_pointer_node
;
1163 else if (code
->expr1
->rank
== 0)
1165 len
= build_int_cst (integer_type_node
, 1);
1166 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1171 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1172 gfc_fatal_error ("Sorry, only support for integer kind %d "
1173 "implemented for image-set at %L",
1174 gfc_c_int_kind
, &code
->expr1
->where
);
1176 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1179 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1180 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1181 tmp
= gfc_get_element_type (tmp
);
1183 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1184 TREE_TYPE (len
), len
,
1185 fold_convert (TREE_TYPE (len
),
1186 TYPE_SIZE_UNIT (tmp
)));
1187 len
= fold_convert (integer_type_node
, len
);
1190 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1191 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1193 If "stat" has the wrong integer type, use a temp variable of
1194 the right type and later cast the result back into "stat". */
1195 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1197 if (TREE_TYPE (stat
) == integer_type_node
)
1198 stat
= gfc_build_addr_expr (NULL
, stat
);
1200 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1201 5, fold_convert (integer_type_node
, len
),
1202 images
, stat
, errmsg
, errmsglen
);
1203 gfc_add_expr_to_block (&se
.pre
, tmp
);
1207 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1209 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1210 5, fold_convert (integer_type_node
, len
),
1211 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1213 gfc_add_expr_to_block (&se
.pre
, tmp
);
1215 gfc_add_modify (&se
.pre
, stat
,
1216 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1220 return gfc_finish_block (&se
.pre
);
1224 /* Generate GENERIC for the IF construct. This function also deals with
1225 the simple IF statement, because the front end translates the IF
1226 statement into an IF construct.
1258 where COND_S is the simplified version of the predicate. PRE_COND_S
1259 are the pre side-effects produced by the translation of the
1261 We need to build the chain recursively otherwise we run into
1262 problems with folding incomplete statements. */
1265 gfc_trans_if_1 (gfc_code
* code
)
1268 tree stmt
, elsestmt
;
1272 /* Check for an unconditional ELSE clause. */
1274 return gfc_trans_code (code
->next
);
1276 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1277 gfc_init_se (&if_se
, NULL
);
1278 gfc_start_block (&if_se
.pre
);
1280 /* Calculate the IF condition expression. */
1281 if (code
->expr1
->where
.lb
)
1283 gfc_save_backend_locus (&saved_loc
);
1284 gfc_set_backend_locus (&code
->expr1
->where
);
1287 gfc_conv_expr_val (&if_se
, code
->expr1
);
1289 if (code
->expr1
->where
.lb
)
1290 gfc_restore_backend_locus (&saved_loc
);
1292 /* Translate the THEN clause. */
1293 stmt
= gfc_trans_code (code
->next
);
1295 /* Translate the ELSE clause. */
1297 elsestmt
= gfc_trans_if_1 (code
->block
);
1299 elsestmt
= build_empty_stmt (input_location
);
1301 /* Build the condition expression and add it to the condition block. */
1302 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1303 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1306 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1308 /* Finish off this statement. */
1309 return gfc_finish_block (&if_se
.pre
);
1313 gfc_trans_if (gfc_code
* code
)
1318 /* Create exit label so it is available for trans'ing the body code. */
1319 exit_label
= gfc_build_label_decl (NULL_TREE
);
1320 code
->exit_label
= exit_label
;
1322 /* Translate the actual code in code->block. */
1323 gfc_init_block (&body
);
1324 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1326 /* Add exit label. */
1327 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1329 return gfc_finish_block (&body
);
1333 /* Translate an arithmetic IF expression.
1335 IF (cond) label1, label2, label3 translates to
1347 An optimized version can be generated in case of equal labels.
1348 E.g., if label1 is equal to label2, we can translate it to
1357 gfc_trans_arithmetic_if (gfc_code
* code
)
1365 /* Start a new block. */
1366 gfc_init_se (&se
, NULL
);
1367 gfc_start_block (&se
.pre
);
1369 /* Pre-evaluate COND. */
1370 gfc_conv_expr_val (&se
, code
->expr1
);
1371 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1373 /* Build something to compare with. */
1374 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1376 if (code
->label1
->value
!= code
->label2
->value
)
1378 /* If (cond < 0) take branch1 else take branch2.
1379 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1380 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1381 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1383 if (code
->label1
->value
!= code
->label3
->value
)
1384 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
1387 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
1390 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1391 tmp
, branch1
, branch2
);
1394 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1396 if (code
->label1
->value
!= code
->label3
->value
1397 && code
->label2
->value
!= code
->label3
->value
)
1399 /* if (cond <= 0) take branch1 else take branch2. */
1400 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1401 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
1403 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1404 tmp
, branch1
, branch2
);
1407 /* Append the COND_EXPR to the evaluation of COND, and return. */
1408 gfc_add_expr_to_block (&se
.pre
, branch1
);
1409 return gfc_finish_block (&se
.pre
);
1413 /* Translate a CRITICAL block. */
1415 gfc_trans_critical (gfc_code
*code
)
1418 tree tmp
, token
= NULL_TREE
;
1420 gfc_start_block (&block
);
1422 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1424 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1425 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1426 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1427 token
, integer_zero_node
, integer_one_node
,
1428 null_pointer_node
, null_pointer_node
,
1429 null_pointer_node
, integer_zero_node
);
1430 gfc_add_expr_to_block (&block
, tmp
);
1432 /* It guarantees memory consistency within the same segment */
1433 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1434 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1435 gfc_build_string_const (1, ""),
1436 NULL_TREE
, NULL_TREE
,
1437 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1439 ASM_VOLATILE_P (tmp
) = 1;
1441 gfc_add_expr_to_block (&block
, tmp
);
1444 tmp
= gfc_trans_code (code
->block
->next
);
1445 gfc_add_expr_to_block (&block
, tmp
);
1447 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1449 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1450 token
, integer_zero_node
, integer_one_node
,
1451 null_pointer_node
, null_pointer_node
,
1453 gfc_add_expr_to_block (&block
, tmp
);
1455 /* It guarantees memory consistency within the same segment */
1456 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1457 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1458 gfc_build_string_const (1, ""),
1459 NULL_TREE
, NULL_TREE
,
1460 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1462 ASM_VOLATILE_P (tmp
) = 1;
1464 gfc_add_expr_to_block (&block
, tmp
);
1467 return gfc_finish_block (&block
);
1471 /* Return true, when the class has a _len component. */
1474 class_has_len_component (gfc_symbol
*sym
)
1476 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1479 if (strcmp (comp
->name
, "_len") == 0)
1487 /* Do proper initialization for ASSOCIATE names. */
1490 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1501 bool need_len_assign
;
1503 gcc_assert (sym
->assoc
);
1504 e
= sym
->assoc
->target
;
1506 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1507 && (gfc_is_class_scalar_expr (e
)
1508 || gfc_is_class_array_ref (e
, NULL
));
1510 unlimited
= UNLIMITED_POLY (e
);
1512 /* Assignments to the string length need to be generated, when
1513 ( sym is a char array or
1514 sym has a _len component)
1515 and the associated expression is unlimited polymorphic, which is
1516 not (yet) correctly in 'unlimited', because for an already associated
1517 BT_DERIVED the u-poly flag is not set, i.e.,
1518 __tmp_CHARACTER_0_1 => w => arg
1519 ^ generated temp ^ from code, the w does not have the u-poly
1520 flag set, where UNLIMITED_POLY(e) expects it. */
1521 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1522 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1523 && (sym
->ts
.type
== BT_CHARACTER
1524 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1525 && class_has_len_component (sym
))));
1526 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1527 to array temporary) for arrays with either unknown shape or if associating
1529 if (sym
->attr
.dimension
&& !class_target
1530 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1534 bool cst_array_ctor
;
1536 desc
= sym
->backend_decl
;
1537 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1538 && gfc_constant_array_constructor_p (e
->value
.constructor
);
1540 /* If association is to an expression, evaluate it and create temporary.
1541 Otherwise, get descriptor of target for pointer assignment. */
1542 gfc_init_se (&se
, NULL
);
1543 if (sym
->assoc
->variable
|| cst_array_ctor
)
1545 se
.direct_byref
= 1;
1550 gfc_conv_expr_descriptor (&se
, e
);
1552 /* If we didn't already do the pointer assignment, set associate-name
1553 descriptor to the one generated for the temporary. */
1554 if (!sym
->assoc
->variable
&& !cst_array_ctor
)
1558 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1560 /* The generated descriptor has lower bound zero (as array
1561 temporary), shift bounds so we get lower bounds of 1. */
1562 for (dim
= 0; dim
< e
->rank
; ++dim
)
1563 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1564 dim
, gfc_index_one_node
);
1567 /* If this is a subreference array pointer associate name use the
1568 associate variable element size for the value of 'span'. */
1569 if (sym
->attr
.subref_array_pointer
)
1571 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1572 tmp
= e
->symtree
->n
.sym
->backend_decl
;
1573 tmp
= gfc_get_element_type (TREE_TYPE (tmp
));
1574 tmp
= fold_convert (gfc_array_index_type
, size_in_bytes (tmp
));
1575 gfc_add_modify (&se
.pre
, GFC_DECL_SPAN(desc
), tmp
);
1578 /* Done, register stuff as init / cleanup code. */
1579 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1580 gfc_finish_block (&se
.post
));
1583 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1584 arrays to be assigned directly. */
1585 else if (class_target
&& sym
->attr
.dimension
1586 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1590 gfc_init_se (&se
, NULL
);
1591 se
.descriptor_only
= 1;
1592 /* In a select type the (temporary) associate variable shall point to
1593 a standard fortran array (lower bound == 1), but conv_expr ()
1594 just maps to the input array in the class object, whose lbound may
1595 be arbitrary. conv_expr_descriptor solves this by inserting a
1596 temporary array descriptor. */
1597 gfc_conv_expr_descriptor (&se
, e
);
1599 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1600 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1601 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1603 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1605 if (INDIRECT_REF_P (se
.expr
))
1606 tmp
= TREE_OPERAND (se
.expr
, 0);
1610 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1611 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1614 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1618 /* Recover the dtype, which has been overwritten by the
1619 assignment from an unlimited polymorphic object. */
1620 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1621 gfc_add_modify (&se
.pre
, tmp
,
1622 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1625 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1626 gfc_finish_block (&se
.post
));
1629 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1630 else if (gfc_is_associate_pointer (sym
))
1634 gcc_assert (!sym
->attr
.dimension
);
1636 gfc_init_se (&se
, NULL
);
1638 /* Class associate-names come this way because they are
1639 unconditionally associate pointers and the symbol is scalar. */
1640 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1643 /* For a class array we need a descriptor for the selector. */
1644 gfc_conv_expr_descriptor (&se
, e
);
1645 /* Needed to get/set the _len component below. */
1646 target_expr
= se
.expr
;
1648 /* Obtain a temporary class container for the result. */
1649 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1650 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1652 /* Set the offset. */
1653 desc
= gfc_class_data_get (se
.expr
);
1654 offset
= gfc_index_zero_node
;
1655 for (n
= 0; n
< e
->rank
; n
++)
1657 dim
= gfc_rank_cst
[n
];
1658 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1659 gfc_array_index_type
,
1660 gfc_conv_descriptor_stride_get (desc
, dim
),
1661 gfc_conv_descriptor_lbound_get (desc
, dim
));
1662 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1663 gfc_array_index_type
,
1666 if (need_len_assign
)
1669 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1670 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1671 /* Use the original class descriptor stored in the saved
1672 descriptor to get the target_expr. */
1674 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1676 /* Strip the _data component from the target_expr. */
1677 target_expr
= TREE_OPERAND (target_expr
, 0);
1678 /* Add a reference to the _len comp to the target expr. */
1679 tmp
= gfc_class_len_get (target_expr
);
1680 /* Get the component-ref for the temp structure's _len comp. */
1681 charlen
= gfc_class_len_get (se
.expr
);
1682 /* Add the assign to the beginning of the block... */
1683 gfc_add_modify (&se
.pre
, charlen
,
1684 fold_convert (TREE_TYPE (charlen
), tmp
));
1685 /* and the oposite way at the end of the block, to hand changes
1686 on the string length back. */
1687 gfc_add_modify (&se
.post
, tmp
,
1688 fold_convert (TREE_TYPE (tmp
), charlen
));
1689 /* Length assignment done, prevent adding it again below. */
1690 need_len_assign
= false;
1692 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1694 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1695 && CLASS_DATA (e
)->attr
.dimension
)
1697 /* This is bound to be a class array element. */
1698 gfc_conv_expr_reference (&se
, e
);
1699 /* Get the _vptr component of the class object. */
1700 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1701 /* Obtain a temporary class container for the result. */
1702 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1703 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1707 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1708 which has the string length included. For CHARACTERS it is still
1709 needed and will be done at the end of this routine. */
1710 gfc_conv_expr (&se
, e
);
1711 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1714 tmp
= TREE_TYPE (sym
->backend_decl
);
1715 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1716 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1718 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1719 gfc_finish_block (&se
.post
));
1722 /* Do a simple assignment. This is for scalar expressions, where we
1723 can simply use expression assignment. */
1728 lhs
= gfc_lval_expr_from_sym (sym
);
1729 tmp
= gfc_trans_assignment (lhs
, e
, false, true);
1730 gfc_add_init_cleanup (block
, tmp
, NULL_TREE
);
1733 /* Set the stringlength, when needed. */
1734 if (need_len_assign
)
1737 gfc_init_se (&se
, NULL
);
1738 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1740 /* What about deferred strings? */
1741 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1742 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1745 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
1746 gfc_get_symbol_decl (sym
);
1747 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
1748 : gfc_class_len_get (sym
->backend_decl
);
1749 /* Prevent adding a noop len= len. */
1752 gfc_add_modify (&se
.pre
, charlen
,
1753 fold_convert (TREE_TYPE (charlen
), tmp
));
1754 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1755 gfc_finish_block (&se
.post
));
1761 /* Translate a BLOCK construct. This is basically what we would do for a
1765 gfc_trans_block_construct (gfc_code
* code
)
1769 gfc_wrapped_block block
;
1772 gfc_association_list
*ass
;
1774 ns
= code
->ext
.block
.ns
;
1776 sym
= ns
->proc_name
;
1779 /* Process local variables. */
1780 gcc_assert (!sym
->tlink
);
1782 gfc_process_block_locals (ns
);
1784 /* Generate code including exit-label. */
1785 gfc_init_block (&body
);
1786 exit_label
= gfc_build_label_decl (NULL_TREE
);
1787 code
->exit_label
= exit_label
;
1789 finish_oacc_declare (ns
, sym
, true);
1791 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
1792 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1794 /* Finish everything. */
1795 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
1796 gfc_trans_deferred_vars (sym
, &block
);
1797 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
1798 trans_associate_var (ass
->st
->n
.sym
, &block
);
1800 return gfc_finish_wrapped_block (&block
);
1804 /* Translate the simple DO construct. This is where the loop variable has
1805 integer type and step +-1. We can't use this in the general case
1806 because integer overflow and floating point errors could give incorrect
1808 We translate a do loop from:
1810 DO dovar = from, to, step
1816 [Evaluate loop bounds and step]
1818 if ((step > 0) ? (dovar <= to) : (dovar => to))
1824 cond = (dovar == to);
1826 if (cond) goto end_label;
1831 This helps the optimizers by avoiding the extra induction variable
1832 used in the general case. */
1835 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
1836 tree from
, tree to
, tree step
, tree exit_cond
)
1842 tree saved_dovar
= NULL
;
1847 type
= TREE_TYPE (dovar
);
1849 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1851 /* Initialize the DO variable: dovar = from. */
1852 gfc_add_modify_loc (loc
, pblock
, dovar
,
1853 fold_convert (TREE_TYPE(dovar
), from
));
1855 /* Save value for do-tinkering checking. */
1856 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1858 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1859 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
1862 /* Cycle and exit statements are implemented with gotos. */
1863 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1864 exit_label
= gfc_build_label_decl (NULL_TREE
);
1866 /* Put the labels where they can be found later. See gfc_trans_do(). */
1867 code
->cycle_label
= cycle_label
;
1868 code
->exit_label
= exit_label
;
1871 gfc_start_block (&body
);
1873 /* Main loop body. */
1874 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1875 gfc_add_expr_to_block (&body
, tmp
);
1877 /* Label for cycle statements (if needed). */
1878 if (TREE_USED (cycle_label
))
1880 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1881 gfc_add_expr_to_block (&body
, tmp
);
1884 /* Check whether someone has modified the loop variable. */
1885 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1887 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
1888 dovar
, saved_dovar
);
1889 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1890 "Loop variable has been modified");
1893 /* Exit the loop if there is an I/O result condition or error. */
1896 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1897 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1899 build_empty_stmt (loc
));
1900 gfc_add_expr_to_block (&body
, tmp
);
1903 /* Evaluate the loop condition. */
1904 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, dovar
,
1906 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1908 /* Increment the loop variable. */
1909 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1910 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1912 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1913 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1915 /* The loop exit. */
1916 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1917 TREE_USED (exit_label
) = 1;
1918 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1919 cond
, tmp
, build_empty_stmt (loc
));
1920 gfc_add_expr_to_block (&body
, tmp
);
1922 /* Finish the loop body. */
1923 tmp
= gfc_finish_block (&body
);
1924 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1926 /* Only execute the loop if the number of iterations is positive. */
1927 if (tree_int_cst_sgn (step
) > 0)
1928 cond
= fold_build2_loc (loc
, LE_EXPR
, boolean_type_node
, dovar
,
1931 cond
= fold_build2_loc (loc
, GE_EXPR
, boolean_type_node
, dovar
,
1933 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, cond
, tmp
,
1934 build_empty_stmt (loc
));
1935 gfc_add_expr_to_block (pblock
, tmp
);
1937 /* Add the exit label. */
1938 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1939 gfc_add_expr_to_block (pblock
, tmp
);
1941 return gfc_finish_block (pblock
);
1944 /* Translate the DO construct. This obviously is one of the most
1945 important ones to get right with any compiler, but especially
1948 We special case some loop forms as described in gfc_trans_simple_do.
1949 For other cases we implement them with a separate loop count,
1950 as described in the standard.
1952 We translate a do loop from:
1954 DO dovar = from, to, step
1960 [evaluate loop bounds and step]
1961 empty = (step > 0 ? to < from : to > from);
1962 countm1 = (to - from) / step;
1964 if (empty) goto exit_label;
1972 if (countm1t == 0) goto exit_label;
1976 countm1 is an unsigned integer. It is equal to the loop count minus one,
1977 because the loop count itself can overflow. */
1980 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
1984 tree saved_dovar
= NULL
;
1999 gfc_start_block (&block
);
2001 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2003 /* Evaluate all the expressions in the iterator. */
2004 gfc_init_se (&se
, NULL
);
2005 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2006 gfc_add_block_to_block (&block
, &se
.pre
);
2008 type
= TREE_TYPE (dovar
);
2010 gfc_init_se (&se
, NULL
);
2011 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2012 gfc_add_block_to_block (&block
, &se
.pre
);
2013 from
= gfc_evaluate_now (se
.expr
, &block
);
2015 gfc_init_se (&se
, NULL
);
2016 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2017 gfc_add_block_to_block (&block
, &se
.pre
);
2018 to
= gfc_evaluate_now (se
.expr
, &block
);
2020 gfc_init_se (&se
, NULL
);
2021 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2022 gfc_add_block_to_block (&block
, &se
.pre
);
2023 step
= gfc_evaluate_now (se
.expr
, &block
);
2025 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2027 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
2028 build_zero_cst (type
));
2029 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2030 "DO step value is zero");
2033 /* Special case simple loops. */
2034 if (TREE_CODE (type
) == INTEGER_TYPE
2035 && (integer_onep (step
)
2036 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2037 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
, exit_cond
);
2040 if (TREE_CODE (type
) == INTEGER_TYPE
)
2041 utype
= unsigned_type_for (type
);
2043 utype
= unsigned_type_for (gfc_array_index_type
);
2044 countm1
= gfc_create_var (utype
, "countm1");
2046 /* Cycle and exit statements are implemented with gotos. */
2047 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2048 exit_label
= gfc_build_label_decl (NULL_TREE
);
2049 TREE_USED (exit_label
) = 1;
2051 /* Put these labels where they can be found later. */
2052 code
->cycle_label
= cycle_label
;
2053 code
->exit_label
= exit_label
;
2055 /* Initialize the DO variable: dovar = from. */
2056 gfc_add_modify (&block
, dovar
, from
);
2058 /* Save value for do-tinkering checking. */
2059 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2061 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2062 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2065 /* Initialize loop count and jump to exit label if the loop is empty.
2066 This code is executed before we enter the loop body. We generate:
2069 countm1 = (to - from) / step;
2075 countm1 = (from - to) / -step;
2081 if (TREE_CODE (type
) == INTEGER_TYPE
)
2083 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2085 /* The distance from FROM to TO cannot always be represented in a signed
2086 type, thus use unsigned arithmetic, also to avoid any undefined
2088 tou
= fold_convert (utype
, to
);
2089 fromu
= fold_convert (utype
, from
);
2090 stepu
= fold_convert (utype
, step
);
2092 /* For a positive step, when to < from, exit, otherwise compute
2093 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2094 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
2095 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2096 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2099 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2100 fold_build2 (MODIFY_EXPR
, void_type_node
,
2102 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2103 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2104 exit_label
), NULL_TREE
));
2106 /* For a negative step, when to > from, exit, otherwise compute
2107 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2108 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
, from
);
2109 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2110 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2112 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2113 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2114 fold_build2 (MODIFY_EXPR
, void_type_node
,
2116 build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2117 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2118 exit_label
), NULL_TREE
));
2120 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
2121 build_int_cst (TREE_TYPE (step
), 0));
2122 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2124 gfc_add_expr_to_block (&block
, tmp
);
2130 /* TODO: We could use the same width as the real type.
2131 This would probably cause more problems that it solves
2132 when we implement "long double" types. */
2134 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2135 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2136 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2137 gfc_add_modify (&block
, countm1
, tmp
);
2139 /* We need a special check for empty loops:
2140 empty = (step > 0 ? to < from : to > from); */
2141 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
2142 build_zero_cst (type
));
2143 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
2144 fold_build2_loc (loc
, LT_EXPR
,
2145 boolean_type_node
, to
, from
),
2146 fold_build2_loc (loc
, GT_EXPR
,
2147 boolean_type_node
, to
, from
));
2148 /* If the loop is empty, go directly to the exit label. */
2149 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2150 build1_v (GOTO_EXPR
, exit_label
),
2151 build_empty_stmt (input_location
));
2152 gfc_add_expr_to_block (&block
, tmp
);
2156 gfc_start_block (&body
);
2158 /* Main loop body. */
2159 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2160 gfc_add_expr_to_block (&body
, tmp
);
2162 /* Label for cycle statements (if needed). */
2163 if (TREE_USED (cycle_label
))
2165 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2166 gfc_add_expr_to_block (&body
, tmp
);
2169 /* Check whether someone has modified the loop variable. */
2170 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2172 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
2174 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2175 "Loop variable has been modified");
2178 /* Exit the loop if there is an I/O result condition or error. */
2181 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2182 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2184 build_empty_stmt (input_location
));
2185 gfc_add_expr_to_block (&body
, tmp
);
2188 /* Increment the loop variable. */
2189 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2190 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2192 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2193 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2195 /* Initialize countm1t. */
2196 tree countm1t
= gfc_create_var (utype
, "countm1t");
2197 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2199 /* Decrement the loop count. */
2200 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2201 build_int_cst (utype
, 1));
2202 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2204 /* End with the loop condition. Loop until countm1t == 0. */
2205 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1t
,
2206 build_int_cst (utype
, 0));
2207 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2208 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2209 cond
, tmp
, build_empty_stmt (loc
));
2210 gfc_add_expr_to_block (&body
, tmp
);
2212 /* End of loop body. */
2213 tmp
= gfc_finish_block (&body
);
2215 /* The for loop itself. */
2216 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2217 gfc_add_expr_to_block (&block
, tmp
);
2219 /* Add the exit label. */
2220 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2221 gfc_add_expr_to_block (&block
, tmp
);
2223 return gfc_finish_block (&block
);
2227 /* Translate the DO WHILE construct.
2240 if (! cond) goto exit_label;
2246 Because the evaluation of the exit condition `cond' may have side
2247 effects, we can't do much for empty loop bodies. The backend optimizers
2248 should be smart enough to eliminate any dead loops. */
2251 gfc_trans_do_while (gfc_code
* code
)
2259 /* Everything we build here is part of the loop body. */
2260 gfc_start_block (&block
);
2262 /* Cycle and exit statements are implemented with gotos. */
2263 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2264 exit_label
= gfc_build_label_decl (NULL_TREE
);
2266 /* Put the labels where they can be found later. See gfc_trans_do(). */
2267 code
->cycle_label
= cycle_label
;
2268 code
->exit_label
= exit_label
;
2270 /* Create a GIMPLE version of the exit condition. */
2271 gfc_init_se (&cond
, NULL
);
2272 gfc_conv_expr_val (&cond
, code
->expr1
);
2273 gfc_add_block_to_block (&block
, &cond
.pre
);
2274 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2275 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2277 /* Build "IF (! cond) GOTO exit_label". */
2278 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2279 TREE_USED (exit_label
) = 1;
2280 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2281 void_type_node
, cond
.expr
, tmp
,
2282 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2283 gfc_add_expr_to_block (&block
, tmp
);
2285 /* The main body of the loop. */
2286 tmp
= gfc_trans_code (code
->block
->next
);
2287 gfc_add_expr_to_block (&block
, tmp
);
2289 /* Label for cycle statements (if needed). */
2290 if (TREE_USED (cycle_label
))
2292 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2293 gfc_add_expr_to_block (&block
, tmp
);
2296 /* End of loop body. */
2297 tmp
= gfc_finish_block (&block
);
2299 gfc_init_block (&block
);
2300 /* Build the loop. */
2301 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2302 void_type_node
, tmp
);
2303 gfc_add_expr_to_block (&block
, tmp
);
2305 /* Add the exit label. */
2306 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2307 gfc_add_expr_to_block (&block
, tmp
);
2309 return gfc_finish_block (&block
);
2313 /* Translate the SELECT CASE construct for INTEGER case expressions,
2314 without killing all potential optimizations. The problem is that
2315 Fortran allows unbounded cases, but the back-end does not, so we
2316 need to intercept those before we enter the equivalent SWITCH_EXPR
2319 For example, we translate this,
2322 CASE (:100,101,105:115)
2332 to the GENERIC equivalent,
2336 case (minimum value for typeof(expr) ... 100:
2342 case 200 ... (maximum value for typeof(expr):
2359 gfc_trans_integer_select (gfc_code
* code
)
2369 gfc_start_block (&block
);
2371 /* Calculate the switch expression. */
2372 gfc_init_se (&se
, NULL
);
2373 gfc_conv_expr_val (&se
, code
->expr1
);
2374 gfc_add_block_to_block (&block
, &se
.pre
);
2376 end_label
= gfc_build_label_decl (NULL_TREE
);
2378 gfc_init_block (&body
);
2380 for (c
= code
->block
; c
; c
= c
->block
)
2382 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2387 /* Assume it's the default case. */
2388 low
= high
= NULL_TREE
;
2392 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2395 /* If there's only a lower bound, set the high bound to the
2396 maximum value of the case expression. */
2398 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2403 /* Three cases are possible here:
2405 1) There is no lower bound, e.g. CASE (:N).
2406 2) There is a lower bound .NE. high bound, that is
2407 a case range, e.g. CASE (N:M) where M>N (we make
2408 sure that M>N during type resolution).
2409 3) There is a lower bound, and it has the same value
2410 as the high bound, e.g. CASE (N:N). This is our
2411 internal representation of CASE(N).
2413 In the first and second case, we need to set a value for
2414 high. In the third case, we don't because the GCC middle
2415 end represents a single case value by just letting high be
2416 a NULL_TREE. We can't do that because we need to be able
2417 to represent unbounded cases. */
2421 && mpz_cmp (cp
->low
->value
.integer
,
2422 cp
->high
->value
.integer
) != 0))
2423 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2426 /* Unbounded case. */
2428 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2431 /* Build a label. */
2432 label
= gfc_build_label_decl (NULL_TREE
);
2434 /* Add this case label.
2435 Add parameter 'label', make it match GCC backend. */
2436 tmp
= build_case_label (low
, high
, label
);
2437 gfc_add_expr_to_block (&body
, tmp
);
2440 /* Add the statements for this case. */
2441 tmp
= gfc_trans_code (c
->next
);
2442 gfc_add_expr_to_block (&body
, tmp
);
2444 /* Break to the end of the construct. */
2445 tmp
= build1_v (GOTO_EXPR
, end_label
);
2446 gfc_add_expr_to_block (&body
, tmp
);
2449 tmp
= gfc_finish_block (&body
);
2450 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2451 se
.expr
, tmp
, NULL_TREE
);
2452 gfc_add_expr_to_block (&block
, tmp
);
2454 tmp
= build1_v (LABEL_EXPR
, end_label
);
2455 gfc_add_expr_to_block (&block
, tmp
);
2457 return gfc_finish_block (&block
);
2461 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2463 There are only two cases possible here, even though the standard
2464 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2465 .FALSE., and DEFAULT.
2467 We never generate more than two blocks here. Instead, we always
2468 try to eliminate the DEFAULT case. This way, we can translate this
2469 kind of SELECT construct to a simple
2473 expression in GENERIC. */
2476 gfc_trans_logical_select (gfc_code
* code
)
2479 gfc_code
*t
, *f
, *d
;
2484 /* Assume we don't have any cases at all. */
2487 /* Now see which ones we actually do have. We can have at most two
2488 cases in a single case list: one for .TRUE. and one for .FALSE.
2489 The default case is always separate. If the cases for .TRUE. and
2490 .FALSE. are in the same case list, the block for that case list
2491 always executed, and we don't generate code a COND_EXPR. */
2492 for (c
= code
->block
; c
; c
= c
->block
)
2494 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2498 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2500 else /* if (cp->value.logical != 0), thus .TRUE. */
2508 /* Start a new block. */
2509 gfc_start_block (&block
);
2511 /* Calculate the switch expression. We always need to do this
2512 because it may have side effects. */
2513 gfc_init_se (&se
, NULL
);
2514 gfc_conv_expr_val (&se
, code
->expr1
);
2515 gfc_add_block_to_block (&block
, &se
.pre
);
2517 if (t
== f
&& t
!= NULL
)
2519 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2520 translate the code for these cases, append it to the current
2522 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2526 tree true_tree
, false_tree
, stmt
;
2528 true_tree
= build_empty_stmt (input_location
);
2529 false_tree
= build_empty_stmt (input_location
);
2531 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2532 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2533 make the missing case the default case. */
2534 if (t
!= NULL
&& f
!= NULL
)
2544 /* Translate the code for each of these blocks, and append it to
2545 the current block. */
2547 true_tree
= gfc_trans_code (t
->next
);
2550 false_tree
= gfc_trans_code (f
->next
);
2552 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2553 se
.expr
, true_tree
, false_tree
);
2554 gfc_add_expr_to_block (&block
, stmt
);
2557 return gfc_finish_block (&block
);
2561 /* The jump table types are stored in static variables to avoid
2562 constructing them from scratch every single time. */
2563 static GTY(()) tree select_struct
[2];
2565 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2566 Instead of generating compares and jumps, it is far simpler to
2567 generate a data structure describing the cases in order and call a
2568 library subroutine that locates the right case.
2569 This is particularly true because this is the only case where we
2570 might have to dispose of a temporary.
2571 The library subroutine returns a pointer to jump to or NULL if no
2572 branches are to be taken. */
2575 gfc_trans_character_select (gfc_code
*code
)
2577 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2578 stmtblock_t block
, body
;
2583 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2585 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2587 /* The jump table types are stored in static variables to avoid
2588 constructing them from scratch every single time. */
2589 static tree ss_string1
[2], ss_string1_len
[2];
2590 static tree ss_string2
[2], ss_string2_len
[2];
2591 static tree ss_target
[2];
2593 cp
= code
->block
->ext
.block
.case_list
;
2594 while (cp
->left
!= NULL
)
2597 /* Generate the body */
2598 gfc_start_block (&block
);
2599 gfc_init_se (&expr1se
, NULL
);
2600 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2602 gfc_add_block_to_block (&block
, &expr1se
.pre
);
2604 end_label
= gfc_build_label_decl (NULL_TREE
);
2606 gfc_init_block (&body
);
2608 /* Attempt to optimize length 1 selects. */
2609 if (integer_onep (expr1se
.string_length
))
2611 for (d
= cp
; d
; d
= d
->right
)
2616 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
2617 && d
->low
->ts
.type
== BT_CHARACTER
);
2618 if (d
->low
->value
.character
.length
> 1)
2620 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
2621 if (d
->low
->value
.character
.string
[i
] != ' ')
2623 if (i
!= d
->low
->value
.character
.length
)
2625 if (optimize
&& d
->high
&& i
== 1)
2627 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2628 && d
->high
->ts
.type
== BT_CHARACTER
);
2629 if (d
->high
->value
.character
.length
> 1
2630 && (d
->low
->value
.character
.string
[0]
2631 == d
->high
->value
.character
.string
[0])
2632 && d
->high
->value
.character
.string
[1] != ' '
2633 && ((d
->low
->value
.character
.string
[1] < ' ')
2634 == (d
->high
->value
.character
.string
[1]
2644 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
2645 && d
->high
->ts
.type
== BT_CHARACTER
);
2646 if (d
->high
->value
.character
.length
> 1)
2648 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
2649 if (d
->high
->value
.character
.string
[i
] != ' ')
2651 if (i
!= d
->high
->value
.character
.length
)
2658 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
2660 for (c
= code
->block
; c
; c
= c
->block
)
2662 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2668 /* Assume it's the default case. */
2669 low
= high
= NULL_TREE
;
2673 /* CASE ('ab') or CASE ('ab':'az') will never match
2674 any length 1 character. */
2675 if (cp
->low
->value
.character
.length
> 1
2676 && cp
->low
->value
.character
.string
[1] != ' ')
2679 if (cp
->low
->value
.character
.length
> 0)
2680 r
= cp
->low
->value
.character
.string
[0];
2683 low
= build_int_cst (ctype
, r
);
2685 /* If there's only a lower bound, set the high bound
2686 to the maximum value of the case expression. */
2688 high
= TYPE_MAX_VALUE (ctype
);
2694 || (cp
->low
->value
.character
.string
[0]
2695 != cp
->high
->value
.character
.string
[0]))
2697 if (cp
->high
->value
.character
.length
> 0)
2698 r
= cp
->high
->value
.character
.string
[0];
2701 high
= build_int_cst (ctype
, r
);
2704 /* Unbounded case. */
2706 low
= TYPE_MIN_VALUE (ctype
);
2709 /* Build a label. */
2710 label
= gfc_build_label_decl (NULL_TREE
);
2712 /* Add this case label.
2713 Add parameter 'label', make it match GCC backend. */
2714 tmp
= build_case_label (low
, high
, label
);
2715 gfc_add_expr_to_block (&body
, tmp
);
2718 /* Add the statements for this case. */
2719 tmp
= gfc_trans_code (c
->next
);
2720 gfc_add_expr_to_block (&body
, tmp
);
2722 /* Break to the end of the construct. */
2723 tmp
= build1_v (GOTO_EXPR
, end_label
);
2724 gfc_add_expr_to_block (&body
, tmp
);
2727 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
2729 code
->expr1
->ts
.kind
);
2730 case_num
= gfc_create_var (ctype
, "case_num");
2731 gfc_add_modify (&block
, case_num
, tmp
);
2733 gfc_add_block_to_block (&block
, &expr1se
.post
);
2735 tmp
= gfc_finish_block (&body
);
2736 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2737 case_num
, tmp
, NULL_TREE
);
2738 gfc_add_expr_to_block (&block
, tmp
);
2740 tmp
= build1_v (LABEL_EXPR
, end_label
);
2741 gfc_add_expr_to_block (&block
, tmp
);
2743 return gfc_finish_block (&block
);
2747 if (code
->expr1
->ts
.kind
== 1)
2749 else if (code
->expr1
->ts
.kind
== 4)
2754 if (select_struct
[k
] == NULL
)
2757 select_struct
[k
] = make_node (RECORD_TYPE
);
2759 if (code
->expr1
->ts
.kind
== 1)
2760 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
2761 else if (code
->expr1
->ts
.kind
== 4)
2762 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
2767 #define ADD_FIELD(NAME, TYPE) \
2768 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2769 get_identifier (stringize(NAME)), \
2773 ADD_FIELD (string1
, pchartype
);
2774 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
2776 ADD_FIELD (string2
, pchartype
);
2777 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
2779 ADD_FIELD (target
, integer_type_node
);
2782 gfc_finish_type (select_struct
[k
]);
2786 for (d
= cp
; d
; d
= d
->right
)
2789 for (c
= code
->block
; c
; c
= c
->block
)
2791 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
2793 label
= gfc_build_label_decl (NULL_TREE
);
2794 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
2796 : build_int_cst (integer_type_node
, d
->n
),
2798 gfc_add_expr_to_block (&body
, tmp
);
2801 tmp
= gfc_trans_code (c
->next
);
2802 gfc_add_expr_to_block (&body
, tmp
);
2804 tmp
= build1_v (GOTO_EXPR
, end_label
);
2805 gfc_add_expr_to_block (&body
, tmp
);
2808 /* Generate the structure describing the branches */
2809 for (d
= cp
; d
; d
= d
->right
)
2811 vec
<constructor_elt
, va_gc
> *node
= NULL
;
2813 gfc_init_se (&se
, NULL
);
2817 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
2818 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
2822 gfc_conv_expr_reference (&se
, d
->low
);
2824 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
2825 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
2828 if (d
->high
== NULL
)
2830 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
2831 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
2835 gfc_init_se (&se
, NULL
);
2836 gfc_conv_expr_reference (&se
, d
->high
);
2838 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
2839 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
2842 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
2843 build_int_cst (integer_type_node
, d
->n
));
2845 tmp
= build_constructor (select_struct
[k
], node
);
2846 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
2849 type
= build_array_type (select_struct
[k
],
2850 build_index_type (size_int (n
-1)));
2852 init
= build_constructor (type
, inits
);
2853 TREE_CONSTANT (init
) = 1;
2854 TREE_STATIC (init
) = 1;
2855 /* Create a static variable to hold the jump table. */
2856 tmp
= gfc_create_var (type
, "jumptable");
2857 TREE_CONSTANT (tmp
) = 1;
2858 TREE_STATIC (tmp
) = 1;
2859 TREE_READONLY (tmp
) = 1;
2860 DECL_INITIAL (tmp
) = init
;
2863 /* Build the library call */
2864 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
2866 if (code
->expr1
->ts
.kind
== 1)
2867 fndecl
= gfor_fndecl_select_string
;
2868 else if (code
->expr1
->ts
.kind
== 4)
2869 fndecl
= gfor_fndecl_select_string_char4
;
2873 tmp
= build_call_expr_loc (input_location
,
2875 build_int_cst (gfc_charlen_type_node
, n
),
2876 expr1se
.expr
, expr1se
.string_length
);
2877 case_num
= gfc_create_var (integer_type_node
, "case_num");
2878 gfc_add_modify (&block
, case_num
, tmp
);
2880 gfc_add_block_to_block (&block
, &expr1se
.post
);
2882 tmp
= gfc_finish_block (&body
);
2883 tmp
= fold_build3_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
2884 case_num
, tmp
, NULL_TREE
);
2885 gfc_add_expr_to_block (&block
, tmp
);
2887 tmp
= build1_v (LABEL_EXPR
, end_label
);
2888 gfc_add_expr_to_block (&block
, tmp
);
2890 return gfc_finish_block (&block
);
2894 /* Translate the three variants of the SELECT CASE construct.
2896 SELECT CASEs with INTEGER case expressions can be translated to an
2897 equivalent GENERIC switch statement, and for LOGICAL case
2898 expressions we build one or two if-else compares.
2900 SELECT CASEs with CHARACTER case expressions are a whole different
2901 story, because they don't exist in GENERIC. So we sort them and
2902 do a binary search at runtime.
2904 Fortran has no BREAK statement, and it does not allow jumps from
2905 one case block to another. That makes things a lot easier for
2909 gfc_trans_select (gfc_code
* code
)
2915 gcc_assert (code
&& code
->expr1
);
2916 gfc_init_block (&block
);
2918 /* Build the exit label and hang it in. */
2919 exit_label
= gfc_build_label_decl (NULL_TREE
);
2920 code
->exit_label
= exit_label
;
2922 /* Empty SELECT constructs are legal. */
2923 if (code
->block
== NULL
)
2924 body
= build_empty_stmt (input_location
);
2926 /* Select the correct translation function. */
2928 switch (code
->expr1
->ts
.type
)
2931 body
= gfc_trans_logical_select (code
);
2935 body
= gfc_trans_integer_select (code
);
2939 body
= gfc_trans_character_select (code
);
2943 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2947 /* Build everything together. */
2948 gfc_add_expr_to_block (&block
, body
);
2949 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2951 return gfc_finish_block (&block
);
2955 /* Traversal function to substitute a replacement symtree if the symbol
2956 in the expression is the same as that passed. f == 2 signals that
2957 that variable itself is not to be checked - only the references.
2958 This group of functions is used when the variable expression in a
2959 FORALL assignment has internal references. For example:
2960 FORALL (i = 1:4) p(p(i)) = i
2961 The only recourse here is to store a copy of 'p' for the index
2964 static gfc_symtree
*new_symtree
;
2965 static gfc_symtree
*old_symtree
;
2968 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2970 if (expr
->expr_type
!= EXPR_VARIABLE
)
2975 else if (expr
->symtree
->n
.sym
== sym
)
2976 expr
->symtree
= new_symtree
;
2982 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
2984 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
2988 forall_restore (gfc_expr
*expr
,
2989 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
2990 int *f ATTRIBUTE_UNUSED
)
2992 if (expr
->expr_type
!= EXPR_VARIABLE
)
2995 if (expr
->symtree
== new_symtree
)
2996 expr
->symtree
= old_symtree
;
3002 forall_restore_symtree (gfc_expr
*e
)
3004 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3008 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3013 gfc_symbol
*new_sym
;
3014 gfc_symbol
*old_sym
;
3018 /* Build a copy of the lvalue. */
3019 old_symtree
= c
->expr1
->symtree
;
3020 old_sym
= old_symtree
->n
.sym
;
3021 e
= gfc_lval_expr_from_sym (old_sym
);
3022 if (old_sym
->attr
.dimension
)
3024 gfc_init_se (&tse
, NULL
);
3025 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3026 gfc_add_block_to_block (pre
, &tse
.pre
);
3027 gfc_add_block_to_block (post
, &tse
.post
);
3028 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3030 if (e
->ts
.type
!= BT_CHARACTER
)
3032 /* Use the variable offset for the temporary. */
3033 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3034 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3039 gfc_init_se (&tse
, NULL
);
3040 gfc_init_se (&rse
, NULL
);
3041 gfc_conv_expr (&rse
, e
);
3042 if (e
->ts
.type
== BT_CHARACTER
)
3044 tse
.string_length
= rse
.string_length
;
3045 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3047 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3049 gfc_add_block_to_block (pre
, &tse
.pre
);
3050 gfc_add_block_to_block (post
, &tse
.post
);
3054 tmp
= gfc_typenode_for_spec (&e
->ts
);
3055 tse
.expr
= gfc_create_var (tmp
, "temp");
3058 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3059 e
->expr_type
== EXPR_VARIABLE
, false);
3060 gfc_add_expr_to_block (pre
, tmp
);
3064 /* Create a new symbol to represent the lvalue. */
3065 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3066 new_sym
->ts
= old_sym
->ts
;
3067 new_sym
->attr
.referenced
= 1;
3068 new_sym
->attr
.temporary
= 1;
3069 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3070 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3072 /* Use the temporary as the backend_decl. */
3073 new_sym
->backend_decl
= tse
.expr
;
3075 /* Create a fake symtree for it. */
3077 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3078 new_symtree
->n
.sym
= new_sym
;
3079 gcc_assert (new_symtree
== root
);
3081 /* Go through the expression reference replacing the old_symtree
3083 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3085 /* Now we have made this temporary, we might as well use it for
3086 the right hand side. */
3087 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3091 /* Handles dependencies in forall assignments. */
3093 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3100 lsym
= c
->expr1
->symtree
->n
.sym
;
3101 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3103 /* Now check for dependencies within the 'variable'
3104 expression itself. These are treated by making a complete
3105 copy of variable and changing all the references to it
3106 point to the copy instead. Note that the shallow copy of
3107 the variable will not suffice for derived types with
3108 pointer components. We therefore leave these to their
3110 if (lsym
->ts
.type
== BT_DERIVED
3111 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3115 if (find_forall_index (c
->expr1
, lsym
, 2))
3117 forall_make_variable_temp (c
, pre
, post
);
3121 /* Substrings with dependencies are treated in the same
3123 if (c
->expr1
->ts
.type
== BT_CHARACTER
3125 && c
->expr2
->expr_type
== EXPR_VARIABLE
3126 && lsym
== c
->expr2
->symtree
->n
.sym
)
3128 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3129 if (lref
->type
== REF_SUBSTRING
)
3131 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3132 if (rref
->type
== REF_SUBSTRING
)
3136 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3138 forall_make_variable_temp (c
, pre
, post
);
3147 cleanup_forall_symtrees (gfc_code
*c
)
3149 forall_restore_symtree (c
->expr1
);
3150 forall_restore_symtree (c
->expr2
);
3151 free (new_symtree
->n
.sym
);
3156 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3157 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3158 indicates whether we should generate code to test the FORALLs mask
3159 array. OUTER is the loop header to be used for initializing mask
3162 The generated loop format is:
3163 count = (end - start + step) / step
3176 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3177 int mask_flag
, stmtblock_t
*outer
)
3185 tree var
, start
, end
, step
;
3188 /* Initialize the mask index outside the FORALL nest. */
3189 if (mask_flag
&& forall_tmp
->mask
)
3190 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3192 iter
= forall_tmp
->this_loop
;
3193 nvar
= forall_tmp
->nvar
;
3194 for (n
= 0; n
< nvar
; n
++)
3197 start
= iter
->start
;
3201 exit_label
= gfc_build_label_decl (NULL_TREE
);
3202 TREE_USED (exit_label
) = 1;
3204 /* The loop counter. */
3205 count
= gfc_create_var (TREE_TYPE (var
), "count");
3207 /* The body of the loop. */
3208 gfc_init_block (&block
);
3210 /* The exit condition. */
3211 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
3212 count
, build_int_cst (TREE_TYPE (count
), 0));
3213 if (forall_tmp
->do_concurrent
)
3214 cond
= build2 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3215 build_int_cst (integer_type_node
,
3216 annot_expr_ivdep_kind
));
3218 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3219 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3220 cond
, tmp
, build_empty_stmt (input_location
));
3221 gfc_add_expr_to_block (&block
, tmp
);
3223 /* The main loop body. */
3224 gfc_add_expr_to_block (&block
, body
);
3226 /* Increment the loop variable. */
3227 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3229 gfc_add_modify (&block
, var
, tmp
);
3231 /* Advance to the next mask element. Only do this for the
3233 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3235 tree maskindex
= forall_tmp
->maskindex
;
3236 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3237 maskindex
, gfc_index_one_node
);
3238 gfc_add_modify (&block
, maskindex
, tmp
);
3241 /* Decrement the loop counter. */
3242 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3243 build_int_cst (TREE_TYPE (var
), 1));
3244 gfc_add_modify (&block
, count
, tmp
);
3246 body
= gfc_finish_block (&block
);
3248 /* Loop var initialization. */
3249 gfc_init_block (&block
);
3250 gfc_add_modify (&block
, var
, start
);
3253 /* Initialize the loop counter. */
3254 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3256 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3258 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3260 gfc_add_modify (&block
, count
, tmp
);
3262 /* The loop expression. */
3263 tmp
= build1_v (LOOP_EXPR
, body
);
3264 gfc_add_expr_to_block (&block
, tmp
);
3266 /* The exit label. */
3267 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3268 gfc_add_expr_to_block (&block
, tmp
);
3270 body
= gfc_finish_block (&block
);
3277 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3278 is nonzero, the body is controlled by all masks in the forall nest.
3279 Otherwise, the innermost loop is not controlled by it's mask. This
3280 is used for initializing that mask. */
3283 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3288 forall_info
*forall_tmp
;
3289 tree mask
, maskindex
;
3291 gfc_start_block (&header
);
3293 forall_tmp
= nested_forall_info
;
3294 while (forall_tmp
!= NULL
)
3296 /* Generate body with masks' control. */
3299 mask
= forall_tmp
->mask
;
3300 maskindex
= forall_tmp
->maskindex
;
3302 /* If a mask was specified make the assignment conditional. */
3305 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3306 body
= build3_v (COND_EXPR
, tmp
, body
,
3307 build_empty_stmt (input_location
));
3310 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3311 forall_tmp
= forall_tmp
->prev_nest
;
3315 gfc_add_expr_to_block (&header
, body
);
3316 return gfc_finish_block (&header
);
3320 /* Allocate data for holding a temporary array. Returns either a local
3321 temporary array or a pointer variable. */
3324 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3331 if (INTEGER_CST_P (size
))
3332 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3333 size
, gfc_index_one_node
);
3337 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3338 type
= build_array_type (elem_type
, type
);
3339 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3341 tmpvar
= gfc_create_var (type
, "temp");
3346 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3347 *pdata
= convert (pvoid_type_node
, tmpvar
);
3349 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3350 gfc_add_modify (pblock
, tmpvar
, tmp
);
3356 /* Generate codes to copy the temporary to the actual lhs. */
3359 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3360 tree count1
, tree wheremask
, bool invert
)
3364 stmtblock_t block
, body
;
3370 lss
= gfc_walk_expr (expr
);
3372 if (lss
== gfc_ss_terminator
)
3374 gfc_start_block (&block
);
3376 gfc_init_se (&lse
, NULL
);
3378 /* Translate the expression. */
3379 gfc_conv_expr (&lse
, expr
);
3381 /* Form the expression for the temporary. */
3382 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3384 /* Use the scalar assignment as is. */
3385 gfc_add_block_to_block (&block
, &lse
.pre
);
3386 gfc_add_modify (&block
, lse
.expr
, tmp
);
3387 gfc_add_block_to_block (&block
, &lse
.post
);
3389 /* Increment the count1. */
3390 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3391 count1
, gfc_index_one_node
);
3392 gfc_add_modify (&block
, count1
, tmp
);
3394 tmp
= gfc_finish_block (&block
);
3398 gfc_start_block (&block
);
3400 gfc_init_loopinfo (&loop1
);
3401 gfc_init_se (&rse
, NULL
);
3402 gfc_init_se (&lse
, NULL
);
3404 /* Associate the lss with the loop. */
3405 gfc_add_ss_to_loop (&loop1
, lss
);
3407 /* Calculate the bounds of the scalarization. */
3408 gfc_conv_ss_startstride (&loop1
);
3409 /* Setup the scalarizing loops. */
3410 gfc_conv_loop_setup (&loop1
, &expr
->where
);
3412 gfc_mark_ss_chain_used (lss
, 1);
3414 /* Start the scalarized loop body. */
3415 gfc_start_scalarized_body (&loop1
, &body
);
3417 /* Setup the gfc_se structures. */
3418 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
3421 /* Form the expression of the temporary. */
3422 if (lss
!= gfc_ss_terminator
)
3423 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3424 /* Translate expr. */
3425 gfc_conv_expr (&lse
, expr
);
3427 /* Use the scalar assignment. */
3428 rse
.string_length
= lse
.string_length
;
3429 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, true, true);
3431 /* Form the mask expression according to the mask tree list. */
3434 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3436 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3437 TREE_TYPE (wheremaskexpr
),
3439 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3441 build_empty_stmt (input_location
));
3444 gfc_add_expr_to_block (&body
, tmp
);
3446 /* Increment count1. */
3447 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3448 count1
, gfc_index_one_node
);
3449 gfc_add_modify (&body
, count1
, tmp
);
3451 /* Increment count3. */
3454 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3455 gfc_array_index_type
, count3
,
3456 gfc_index_one_node
);
3457 gfc_add_modify (&body
, count3
, tmp
);
3460 /* Generate the copying loops. */
3461 gfc_trans_scalarizing_loops (&loop1
, &body
);
3462 gfc_add_block_to_block (&block
, &loop1
.pre
);
3463 gfc_add_block_to_block (&block
, &loop1
.post
);
3464 gfc_cleanup_loop (&loop1
);
3466 tmp
= gfc_finish_block (&block
);
3472 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3473 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3474 and should not be freed. WHEREMASK is the conditional execution mask
3475 whose sense may be inverted by INVERT. */
3478 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3479 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3480 tree wheremask
, bool invert
)
3482 stmtblock_t block
, body1
;
3489 gfc_start_block (&block
);
3491 gfc_init_se (&rse
, NULL
);
3492 gfc_init_se (&lse
, NULL
);
3494 if (lss
== gfc_ss_terminator
)
3496 gfc_init_block (&body1
);
3497 gfc_conv_expr (&rse
, expr2
);
3498 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3502 /* Initialize the loop. */
3503 gfc_init_loopinfo (&loop
);
3505 /* We may need LSS to determine the shape of the expression. */
3506 gfc_add_ss_to_loop (&loop
, lss
);
3507 gfc_add_ss_to_loop (&loop
, rss
);
3509 gfc_conv_ss_startstride (&loop
);
3510 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3512 gfc_mark_ss_chain_used (rss
, 1);
3513 /* Start the loop body. */
3514 gfc_start_scalarized_body (&loop
, &body1
);
3516 /* Translate the expression. */
3517 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3519 gfc_conv_expr (&rse
, expr2
);
3521 /* Form the expression of the temporary. */
3522 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3525 /* Use the scalar assignment. */
3526 lse
.string_length
= rse
.string_length
;
3527 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3528 expr2
->expr_type
== EXPR_VARIABLE
, false);
3530 /* Form the mask expression according to the mask tree list. */
3533 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3535 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3536 TREE_TYPE (wheremaskexpr
),
3538 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3540 build_empty_stmt (input_location
));
3543 gfc_add_expr_to_block (&body1
, tmp
);
3545 if (lss
== gfc_ss_terminator
)
3547 gfc_add_block_to_block (&block
, &body1
);
3549 /* Increment count1. */
3550 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3551 count1
, gfc_index_one_node
);
3552 gfc_add_modify (&block
, count1
, tmp
);
3556 /* Increment count1. */
3557 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3558 count1
, gfc_index_one_node
);
3559 gfc_add_modify (&body1
, count1
, tmp
);
3561 /* Increment count3. */
3564 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3565 gfc_array_index_type
,
3566 count3
, gfc_index_one_node
);
3567 gfc_add_modify (&body1
, count3
, tmp
);
3570 /* Generate the copying loops. */
3571 gfc_trans_scalarizing_loops (&loop
, &body1
);
3573 gfc_add_block_to_block (&block
, &loop
.pre
);
3574 gfc_add_block_to_block (&block
, &loop
.post
);
3576 gfc_cleanup_loop (&loop
);
3577 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3578 as tree nodes in SS may not be valid in different scope. */
3581 tmp
= gfc_finish_block (&block
);
3586 /* Calculate the size of temporary needed in the assignment inside forall.
3587 LSS and RSS are filled in this function. */
3590 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
3591 stmtblock_t
* pblock
,
3592 gfc_ss
**lss
, gfc_ss
**rss
)
3600 *lss
= gfc_walk_expr (expr1
);
3603 size
= gfc_index_one_node
;
3604 if (*lss
!= gfc_ss_terminator
)
3606 gfc_init_loopinfo (&loop
);
3608 /* Walk the RHS of the expression. */
3609 *rss
= gfc_walk_expr (expr2
);
3610 if (*rss
== gfc_ss_terminator
)
3611 /* The rhs is scalar. Add a ss for the expression. */
3612 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
3614 /* Associate the SS with the loop. */
3615 gfc_add_ss_to_loop (&loop
, *lss
);
3616 /* We don't actually need to add the rhs at this point, but it might
3617 make guessing the loop bounds a bit easier. */
3618 gfc_add_ss_to_loop (&loop
, *rss
);
3620 /* We only want the shape of the expression, not rest of the junk
3621 generated by the scalarizer. */
3622 loop
.array_parameter
= 1;
3624 /* Calculate the bounds of the scalarization. */
3625 save_flag
= gfc_option
.rtcheck
;
3626 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
3627 gfc_conv_ss_startstride (&loop
);
3628 gfc_option
.rtcheck
= save_flag
;
3629 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3631 /* Figure out how many elements we need. */
3632 for (i
= 0; i
< loop
.dimen
; i
++)
3634 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
3635 gfc_array_index_type
,
3636 gfc_index_one_node
, loop
.from
[i
]);
3637 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3638 gfc_array_index_type
, tmp
, loop
.to
[i
]);
3639 size
= fold_build2_loc (input_location
, MULT_EXPR
,
3640 gfc_array_index_type
, size
, tmp
);
3642 gfc_add_block_to_block (pblock
, &loop
.pre
);
3643 size
= gfc_evaluate_now (size
, pblock
);
3644 gfc_add_block_to_block (pblock
, &loop
.post
);
3646 /* TODO: write a function that cleans up a loopinfo without freeing
3647 the SS chains. Currently a NOP. */
3654 /* Calculate the overall iterator number of the nested forall construct.
3655 This routine actually calculates the number of times the body of the
3656 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3657 that by the expression INNER_SIZE. The BLOCK argument specifies the
3658 block in which to calculate the result, and the optional INNER_SIZE_BODY
3659 argument contains any statements that need to executed (inside the loop)
3660 to initialize or calculate INNER_SIZE. */
3663 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
3664 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
3666 forall_info
*forall_tmp
= nested_forall_info
;
3670 /* We can eliminate the innermost unconditional loops with constant
3672 if (INTEGER_CST_P (inner_size
))
3675 && !forall_tmp
->mask
3676 && INTEGER_CST_P (forall_tmp
->size
))
3678 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
3679 gfc_array_index_type
,
3680 inner_size
, forall_tmp
->size
);
3681 forall_tmp
= forall_tmp
->prev_nest
;
3684 /* If there are no loops left, we have our constant result. */
3689 /* Otherwise, create a temporary variable to compute the result. */
3690 number
= gfc_create_var (gfc_array_index_type
, "num");
3691 gfc_add_modify (block
, number
, gfc_index_zero_node
);
3693 gfc_start_block (&body
);
3694 if (inner_size_body
)
3695 gfc_add_block_to_block (&body
, inner_size_body
);
3697 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3698 gfc_array_index_type
, number
, inner_size
);
3701 gfc_add_modify (&body
, number
, tmp
);
3702 tmp
= gfc_finish_block (&body
);
3704 /* Generate loops. */
3705 if (forall_tmp
!= NULL
)
3706 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
3708 gfc_add_expr_to_block (block
, tmp
);
3714 /* Allocate temporary for forall construct. SIZE is the size of temporary
3715 needed. PTEMP1 is returned for space free. */
3718 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
3725 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
3726 if (!integer_onep (unit
))
3727 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
3728 gfc_array_index_type
, size
, unit
);
3733 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
3736 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
3741 /* Allocate temporary for forall construct according to the information in
3742 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3743 assignment inside forall. PTEMP1 is returned for space free. */
3746 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
3747 tree inner_size
, stmtblock_t
* inner_size_body
,
3748 stmtblock_t
* block
, tree
* ptemp1
)
3752 /* Calculate the total size of temporary needed in forall construct. */
3753 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3754 inner_size_body
, block
);
3756 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
3760 /* Handle assignments inside forall which need temporary.
3762 forall (i=start:end:stride; maskexpr)
3765 (where e,f<i> are arbitrary expressions possibly involving i
3766 and there is a dependency between e<i> and f<i>)
3768 masktmp(:) = maskexpr(:)
3773 for (i = start; i <= end; i += stride)
3777 for (i = start; i <= end; i += stride)
3779 if (masktmp[maskindex++])
3780 tmp[count1++] = f<i>
3784 for (i = start; i <= end; i += stride)
3786 if (masktmp[maskindex++])
3787 e<i> = tmp[count1++]
3792 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3793 tree wheremask
, bool invert
,
3794 forall_info
* nested_forall_info
,
3795 stmtblock_t
* block
)
3803 stmtblock_t inner_size_body
;
3805 /* Create vars. count1 is the current iterator number of the nested
3807 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3809 /* Count is the wheremask index. */
3812 count
= gfc_create_var (gfc_array_index_type
, "count");
3813 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3818 /* Initialize count1. */
3819 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3821 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3822 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3823 gfc_init_block (&inner_size_body
);
3824 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
3827 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3828 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
3830 if (!expr1
->ts
.u
.cl
->backend_decl
)
3833 gfc_init_se (&tse
, NULL
);
3834 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
3835 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
3837 type
= gfc_get_character_type_len (gfc_default_character_kind
,
3838 expr1
->ts
.u
.cl
->backend_decl
);
3841 type
= gfc_typenode_for_spec (&expr1
->ts
);
3843 /* Allocate temporary for nested forall construct according to the
3844 information in nested_forall_info and inner_size. */
3845 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
3846 &inner_size_body
, block
, &ptemp1
);
3848 /* Generate codes to copy rhs to the temporary . */
3849 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
3852 /* Generate body and loops according to the information in
3853 nested_forall_info. */
3854 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3855 gfc_add_expr_to_block (block
, tmp
);
3858 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
3862 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3864 /* Generate codes to copy the temporary to lhs. */
3865 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
3868 /* Generate body and loops according to the information in
3869 nested_forall_info. */
3870 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3871 gfc_add_expr_to_block (block
, tmp
);
3875 /* Free the temporary. */
3876 tmp
= gfc_call_free (ptemp1
);
3877 gfc_add_expr_to_block (block
, tmp
);
3882 /* Translate pointer assignment inside FORALL which need temporary. */
3885 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
3886 forall_info
* nested_forall_info
,
3887 stmtblock_t
* block
)
3894 gfc_array_info
*info
;
3901 tree tmp
, tmp1
, ptemp1
;
3903 count
= gfc_create_var (gfc_array_index_type
, "count");
3904 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3906 inner_size
= gfc_index_one_node
;
3907 lss
= gfc_walk_expr (expr1
);
3908 rss
= gfc_walk_expr (expr2
);
3909 if (lss
== gfc_ss_terminator
)
3911 type
= gfc_typenode_for_spec (&expr1
->ts
);
3912 type
= build_pointer_type (type
);
3914 /* Allocate temporary for nested forall construct according to the
3915 information in nested_forall_info and inner_size. */
3916 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3917 inner_size
, NULL
, block
, &ptemp1
);
3918 gfc_start_block (&body
);
3919 gfc_init_se (&lse
, NULL
);
3920 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3921 gfc_init_se (&rse
, NULL
);
3922 rse
.want_pointer
= 1;
3923 gfc_conv_expr (&rse
, expr2
);
3924 gfc_add_block_to_block (&body
, &rse
.pre
);
3925 gfc_add_modify (&body
, lse
.expr
,
3926 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3927 gfc_add_block_to_block (&body
, &rse
.post
);
3929 /* Increment count. */
3930 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3931 count
, gfc_index_one_node
);
3932 gfc_add_modify (&body
, count
, tmp
);
3934 tmp
= gfc_finish_block (&body
);
3936 /* Generate body and loops according to the information in
3937 nested_forall_info. */
3938 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3939 gfc_add_expr_to_block (block
, tmp
);
3942 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3944 gfc_start_block (&body
);
3945 gfc_init_se (&lse
, NULL
);
3946 gfc_init_se (&rse
, NULL
);
3947 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3948 lse
.want_pointer
= 1;
3949 gfc_conv_expr (&lse
, expr1
);
3950 gfc_add_block_to_block (&body
, &lse
.pre
);
3951 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3952 gfc_add_block_to_block (&body
, &lse
.post
);
3953 /* Increment count. */
3954 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3955 count
, gfc_index_one_node
);
3956 gfc_add_modify (&body
, count
, tmp
);
3957 tmp
= gfc_finish_block (&body
);
3959 /* Generate body and loops according to the information in
3960 nested_forall_info. */
3961 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3962 gfc_add_expr_to_block (block
, tmp
);
3966 gfc_init_loopinfo (&loop
);
3968 /* Associate the SS with the loop. */
3969 gfc_add_ss_to_loop (&loop
, rss
);
3971 /* Setup the scalarizing loops and bounds. */
3972 gfc_conv_ss_startstride (&loop
);
3974 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3976 info
= &rss
->info
->data
.array
;
3977 desc
= info
->descriptor
;
3979 /* Make a new descriptor. */
3980 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3981 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
3982 loop
.from
, loop
.to
, 1,
3983 GFC_ARRAY_UNKNOWN
, true);
3985 /* Allocate temporary for nested forall construct. */
3986 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
3987 inner_size
, NULL
, block
, &ptemp1
);
3988 gfc_start_block (&body
);
3989 gfc_init_se (&lse
, NULL
);
3990 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3991 lse
.direct_byref
= 1;
3992 gfc_conv_expr_descriptor (&lse
, expr2
);
3994 gfc_add_block_to_block (&body
, &lse
.pre
);
3995 gfc_add_block_to_block (&body
, &lse
.post
);
3997 /* Increment count. */
3998 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3999 count
, gfc_index_one_node
);
4000 gfc_add_modify (&body
, count
, tmp
);
4002 tmp
= gfc_finish_block (&body
);
4004 /* Generate body and loops according to the information in
4005 nested_forall_info. */
4006 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4007 gfc_add_expr_to_block (block
, tmp
);
4010 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4012 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4013 gfc_init_se (&lse
, NULL
);
4014 gfc_conv_expr_descriptor (&lse
, expr1
);
4015 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4016 gfc_start_block (&body
);
4017 gfc_add_block_to_block (&body
, &lse
.pre
);
4018 gfc_add_block_to_block (&body
, &lse
.post
);
4020 /* Increment count. */
4021 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4022 count
, gfc_index_one_node
);
4023 gfc_add_modify (&body
, count
, tmp
);
4025 tmp
= gfc_finish_block (&body
);
4027 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4028 gfc_add_expr_to_block (block
, tmp
);
4030 /* Free the temporary. */
4033 tmp
= gfc_call_free (ptemp1
);
4034 gfc_add_expr_to_block (block
, tmp
);
4039 /* FORALL and WHERE statements are really nasty, especially when you nest
4040 them. All the rhs of a forall assignment must be evaluated before the
4041 actual assignments are performed. Presumably this also applies to all the
4042 assignments in an inner where statement. */
4044 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4045 linear array, relying on the fact that we process in the same order in all
4048 forall (i=start:end:stride; maskexpr)
4052 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4054 count = ((end + 1 - start) / stride)
4055 masktmp(:) = maskexpr(:)
4058 for (i = start; i <= end; i += stride)
4060 if (masktmp[maskindex++])
4064 for (i = start; i <= end; i += stride)
4066 if (masktmp[maskindex++])
4070 Note that this code only works when there are no dependencies.
4071 Forall loop with array assignments and data dependencies are a real pain,
4072 because the size of the temporary cannot always be determined before the
4073 loop is executed. This problem is compounded by the presence of nested
4078 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4095 tree cycle_label
= NULL_TREE
;
4099 gfc_forall_iterator
*fa
;
4102 gfc_saved_var
*saved_vars
;
4103 iter_info
*this_forall
;
4107 /* Do nothing if the mask is false. */
4109 && code
->expr1
->expr_type
== EXPR_CONSTANT
4110 && !code
->expr1
->value
.logical
)
4111 return build_empty_stmt (input_location
);
4114 /* Count the FORALL index number. */
4115 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4119 /* Allocate the space for var, start, end, step, varexpr. */
4120 var
= XCNEWVEC (tree
, nvar
);
4121 start
= XCNEWVEC (tree
, nvar
);
4122 end
= XCNEWVEC (tree
, nvar
);
4123 step
= XCNEWVEC (tree
, nvar
);
4124 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4125 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4127 /* Allocate the space for info. */
4128 info
= XCNEW (forall_info
);
4130 gfc_start_block (&pre
);
4131 gfc_init_block (&post
);
4132 gfc_init_block (&block
);
4135 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4137 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4139 /* Allocate space for this_forall. */
4140 this_forall
= XCNEW (iter_info
);
4142 /* Create a temporary variable for the FORALL index. */
4143 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4144 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4145 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4147 /* Record it in this_forall. */
4148 this_forall
->var
= var
[n
];
4150 /* Replace the index symbol's backend_decl with the temporary decl. */
4151 sym
->backend_decl
= var
[n
];
4153 /* Work out the start, end and stride for the loop. */
4154 gfc_init_se (&se
, NULL
);
4155 gfc_conv_expr_val (&se
, fa
->start
);
4156 /* Record it in this_forall. */
4157 this_forall
->start
= se
.expr
;
4158 gfc_add_block_to_block (&block
, &se
.pre
);
4161 gfc_init_se (&se
, NULL
);
4162 gfc_conv_expr_val (&se
, fa
->end
);
4163 /* Record it in this_forall. */
4164 this_forall
->end
= se
.expr
;
4165 gfc_make_safe_expr (&se
);
4166 gfc_add_block_to_block (&block
, &se
.pre
);
4169 gfc_init_se (&se
, NULL
);
4170 gfc_conv_expr_val (&se
, fa
->stride
);
4171 /* Record it in this_forall. */
4172 this_forall
->step
= se
.expr
;
4173 gfc_make_safe_expr (&se
);
4174 gfc_add_block_to_block (&block
, &se
.pre
);
4177 /* Set the NEXT field of this_forall to NULL. */
4178 this_forall
->next
= NULL
;
4179 /* Link this_forall to the info construct. */
4180 if (info
->this_loop
)
4182 iter_info
*iter_tmp
= info
->this_loop
;
4183 while (iter_tmp
->next
!= NULL
)
4184 iter_tmp
= iter_tmp
->next
;
4185 iter_tmp
->next
= this_forall
;
4188 info
->this_loop
= this_forall
;
4194 /* Calculate the size needed for the current forall level. */
4195 size
= gfc_index_one_node
;
4196 for (n
= 0; n
< nvar
; n
++)
4198 /* size = (end + step - start) / step. */
4199 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4201 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4203 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4205 tmp
= convert (gfc_array_index_type
, tmp
);
4207 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4211 /* Record the nvar and size of current forall level. */
4217 /* If the mask is .true., consider the FORALL unconditional. */
4218 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4219 && code
->expr1
->value
.logical
)
4227 /* First we need to allocate the mask. */
4230 /* As the mask array can be very big, prefer compact boolean types. */
4231 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4232 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4233 size
, NULL
, &block
, &pmask
);
4234 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4236 /* Record them in the info structure. */
4237 info
->maskindex
= maskindex
;
4242 /* No mask was specified. */
4243 maskindex
= NULL_TREE
;
4244 mask
= pmask
= NULL_TREE
;
4247 /* Link the current forall level to nested_forall_info. */
4248 info
->prev_nest
= nested_forall_info
;
4249 nested_forall_info
= info
;
4251 /* Copy the mask into a temporary variable if required.
4252 For now we assume a mask temporary is needed. */
4255 /* As the mask array can be very big, prefer compact boolean types. */
4256 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4258 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4260 /* Start of mask assignment loop body. */
4261 gfc_start_block (&body
);
4263 /* Evaluate the mask expression. */
4264 gfc_init_se (&se
, NULL
);
4265 gfc_conv_expr_val (&se
, code
->expr1
);
4266 gfc_add_block_to_block (&body
, &se
.pre
);
4268 /* Store the mask. */
4269 se
.expr
= convert (mask_type
, se
.expr
);
4271 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4272 gfc_add_modify (&body
, tmp
, se
.expr
);
4274 /* Advance to the next mask element. */
4275 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4276 maskindex
, gfc_index_one_node
);
4277 gfc_add_modify (&body
, maskindex
, tmp
);
4279 /* Generate the loops. */
4280 tmp
= gfc_finish_block (&body
);
4281 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4282 gfc_add_expr_to_block (&block
, tmp
);
4285 if (code
->op
== EXEC_DO_CONCURRENT
)
4287 gfc_init_block (&body
);
4288 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4289 code
->cycle_label
= cycle_label
;
4290 tmp
= gfc_trans_code (code
->block
->next
);
4291 gfc_add_expr_to_block (&body
, tmp
);
4293 if (TREE_USED (cycle_label
))
4295 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4296 gfc_add_expr_to_block (&body
, tmp
);
4299 tmp
= gfc_finish_block (&body
);
4300 nested_forall_info
->do_concurrent
= true;
4301 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4302 gfc_add_expr_to_block (&block
, tmp
);
4306 c
= code
->block
->next
;
4308 /* TODO: loop merging in FORALL statements. */
4309 /* Now that we've got a copy of the mask, generate the assignment loops. */
4315 /* A scalar or array assignment. DO the simple check for
4316 lhs to rhs dependencies. These make a temporary for the
4317 rhs and form a second forall block to copy to variable. */
4318 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4320 /* Temporaries due to array assignment data dependencies introduce
4321 no end of problems. */
4323 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4324 nested_forall_info
, &block
);
4327 /* Use the normal assignment copying routines. */
4328 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4330 /* Generate body and loops. */
4331 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4333 gfc_add_expr_to_block (&block
, tmp
);
4336 /* Cleanup any temporary symtrees that have been made to deal
4337 with dependencies. */
4339 cleanup_forall_symtrees (c
);
4344 /* Translate WHERE or WHERE construct nested in FORALL. */
4345 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4348 /* Pointer assignment inside FORALL. */
4349 case EXEC_POINTER_ASSIGN
:
4350 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4352 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4353 nested_forall_info
, &block
);
4356 /* Use the normal assignment copying routines. */
4357 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4359 /* Generate body and loops. */
4360 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4362 gfc_add_expr_to_block (&block
, tmp
);
4367 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4368 gfc_add_expr_to_block (&block
, tmp
);
4371 /* Explicit subroutine calls are prevented by the frontend but interface
4372 assignments can legitimately produce them. */
4373 case EXEC_ASSIGN_CALL
:
4374 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4375 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4376 gfc_add_expr_to_block (&block
, tmp
);
4387 /* Restore the original index variables. */
4388 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4389 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4391 /* Free the space for var, start, end, step, varexpr. */
4399 for (this_forall
= info
->this_loop
; this_forall
;)
4401 iter_info
*next
= this_forall
->next
;
4406 /* Free the space for this forall_info. */
4411 /* Free the temporary for the mask. */
4412 tmp
= gfc_call_free (pmask
);
4413 gfc_add_expr_to_block (&block
, tmp
);
4416 pushdecl (maskindex
);
4418 gfc_add_block_to_block (&pre
, &block
);
4419 gfc_add_block_to_block (&pre
, &post
);
4421 return gfc_finish_block (&pre
);
4425 /* Translate the FORALL statement or construct. */
4427 tree
gfc_trans_forall (gfc_code
* code
)
4429 return gfc_trans_forall_1 (code
, NULL
);
4433 /* Translate the DO CONCURRENT construct. */
4435 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4437 return gfc_trans_forall_1 (code
, NULL
);
4441 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4442 If the WHERE construct is nested in FORALL, compute the overall temporary
4443 needed by the WHERE mask expression multiplied by the iterator number of
4445 ME is the WHERE mask expression.
4446 MASK is the current execution mask upon input, whose sense may or may
4447 not be inverted as specified by the INVERT argument.
4448 CMASK is the updated execution mask on output, or NULL if not required.
4449 PMASK is the pending execution mask on output, or NULL if not required.
4450 BLOCK is the block in which to place the condition evaluation loops. */
4453 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4454 tree mask
, bool invert
, tree cmask
, tree pmask
,
4455 tree mask_type
, stmtblock_t
* block
)
4460 stmtblock_t body
, body1
;
4461 tree count
, cond
, mtmp
;
4464 gfc_init_loopinfo (&loop
);
4466 lss
= gfc_walk_expr (me
);
4467 rss
= gfc_walk_expr (me
);
4469 /* Variable to index the temporary. */
4470 count
= gfc_create_var (gfc_array_index_type
, "count");
4471 /* Initialize count. */
4472 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4474 gfc_start_block (&body
);
4476 gfc_init_se (&rse
, NULL
);
4477 gfc_init_se (&lse
, NULL
);
4479 if (lss
== gfc_ss_terminator
)
4481 gfc_init_block (&body1
);
4485 /* Initialize the loop. */
4486 gfc_init_loopinfo (&loop
);
4488 /* We may need LSS to determine the shape of the expression. */
4489 gfc_add_ss_to_loop (&loop
, lss
);
4490 gfc_add_ss_to_loop (&loop
, rss
);
4492 gfc_conv_ss_startstride (&loop
);
4493 gfc_conv_loop_setup (&loop
, &me
->where
);
4495 gfc_mark_ss_chain_used (rss
, 1);
4496 /* Start the loop body. */
4497 gfc_start_scalarized_body (&loop
, &body1
);
4499 /* Translate the expression. */
4500 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4502 gfc_conv_expr (&rse
, me
);
4505 /* Variable to evaluate mask condition. */
4506 cond
= gfc_create_var (mask_type
, "cond");
4507 if (mask
&& (cmask
|| pmask
))
4508 mtmp
= gfc_create_var (mask_type
, "mask");
4509 else mtmp
= NULL_TREE
;
4511 gfc_add_block_to_block (&body1
, &lse
.pre
);
4512 gfc_add_block_to_block (&body1
, &rse
.pre
);
4514 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4516 if (mask
&& (cmask
|| pmask
))
4518 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4520 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4521 gfc_add_modify (&body1
, mtmp
, tmp
);
4526 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4529 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4531 gfc_add_modify (&body1
, tmp1
, tmp
);
4536 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4537 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4539 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4541 gfc_add_modify (&body1
, tmp1
, tmp
);
4544 gfc_add_block_to_block (&body1
, &lse
.post
);
4545 gfc_add_block_to_block (&body1
, &rse
.post
);
4547 if (lss
== gfc_ss_terminator
)
4549 gfc_add_block_to_block (&body
, &body1
);
4553 /* Increment count. */
4554 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4555 count
, gfc_index_one_node
);
4556 gfc_add_modify (&body1
, count
, tmp1
);
4558 /* Generate the copying loops. */
4559 gfc_trans_scalarizing_loops (&loop
, &body1
);
4561 gfc_add_block_to_block (&body
, &loop
.pre
);
4562 gfc_add_block_to_block (&body
, &loop
.post
);
4564 gfc_cleanup_loop (&loop
);
4565 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4566 as tree nodes in SS may not be valid in different scope. */
4569 tmp1
= gfc_finish_block (&body
);
4570 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4571 if (nested_forall_info
!= NULL
)
4572 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
4574 gfc_add_expr_to_block (block
, tmp1
);
4578 /* Translate an assignment statement in a WHERE statement or construct
4579 statement. The MASK expression is used to control which elements
4580 of EXPR1 shall be assigned. The sense of MASK is specified by
4584 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
4585 tree mask
, bool invert
,
4586 tree count1
, tree count2
,
4592 gfc_ss
*lss_section
;
4599 tree index
, maskexpr
;
4601 /* A defined assignment. */
4602 if (cnext
&& cnext
->resolved_sym
)
4603 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
4606 /* TODO: handle this special case.
4607 Special case a single function returning an array. */
4608 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
4610 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
4616 /* Assignment of the form lhs = rhs. */
4617 gfc_start_block (&block
);
4619 gfc_init_se (&lse
, NULL
);
4620 gfc_init_se (&rse
, NULL
);
4623 lss
= gfc_walk_expr (expr1
);
4626 /* In each where-assign-stmt, the mask-expr and the variable being
4627 defined shall be arrays of the same shape. */
4628 gcc_assert (lss
!= gfc_ss_terminator
);
4630 /* The assignment needs scalarization. */
4633 /* Find a non-scalar SS from the lhs. */
4634 while (lss_section
!= gfc_ss_terminator
4635 && lss_section
->info
->type
!= GFC_SS_SECTION
)
4636 lss_section
= lss_section
->next
;
4638 gcc_assert (lss_section
!= gfc_ss_terminator
);
4640 /* Initialize the scalarizer. */
4641 gfc_init_loopinfo (&loop
);
4644 rss
= gfc_walk_expr (expr2
);
4645 if (rss
== gfc_ss_terminator
)
4647 /* The rhs is scalar. Add a ss for the expression. */
4648 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4649 rss
->info
->where
= 1;
4652 /* Associate the SS with the loop. */
4653 gfc_add_ss_to_loop (&loop
, lss
);
4654 gfc_add_ss_to_loop (&loop
, rss
);
4656 /* Calculate the bounds of the scalarization. */
4657 gfc_conv_ss_startstride (&loop
);
4659 /* Resolve any data dependencies in the statement. */
4660 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
4662 /* Setup the scalarizing loops. */
4663 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4665 /* Setup the gfc_se structures. */
4666 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4667 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4670 gfc_mark_ss_chain_used (rss
, 1);
4671 if (loop
.temp_ss
== NULL
)
4674 gfc_mark_ss_chain_used (lss
, 1);
4678 lse
.ss
= loop
.temp_ss
;
4679 gfc_mark_ss_chain_used (lss
, 3);
4680 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
4683 /* Start the scalarized loop body. */
4684 gfc_start_scalarized_body (&loop
, &body
);
4686 /* Translate the expression. */
4687 gfc_conv_expr (&rse
, expr2
);
4688 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4689 gfc_conv_tmp_array_ref (&lse
);
4691 gfc_conv_expr (&lse
, expr1
);
4693 /* Form the mask expression according to the mask. */
4695 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4697 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4698 TREE_TYPE (maskexpr
), maskexpr
);
4700 /* Use the scalar assignment as is. */
4701 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
4702 false, loop
.temp_ss
== NULL
);
4704 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
4706 gfc_add_expr_to_block (&body
, tmp
);
4708 if (lss
== gfc_ss_terminator
)
4710 /* Increment count1. */
4711 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4712 count1
, gfc_index_one_node
);
4713 gfc_add_modify (&body
, count1
, tmp
);
4715 /* Use the scalar assignment as is. */
4716 gfc_add_block_to_block (&block
, &body
);
4720 gcc_assert (lse
.ss
== gfc_ss_terminator
4721 && rse
.ss
== gfc_ss_terminator
);
4723 if (loop
.temp_ss
!= NULL
)
4725 /* Increment count1 before finish the main body of a scalarized
4727 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4728 gfc_array_index_type
, count1
, gfc_index_one_node
);
4729 gfc_add_modify (&body
, count1
, tmp
);
4730 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
4732 /* We need to copy the temporary to the actual lhs. */
4733 gfc_init_se (&lse
, NULL
);
4734 gfc_init_se (&rse
, NULL
);
4735 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4736 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4738 rse
.ss
= loop
.temp_ss
;
4741 gfc_conv_tmp_array_ref (&rse
);
4742 gfc_conv_expr (&lse
, expr1
);
4744 gcc_assert (lse
.ss
== gfc_ss_terminator
4745 && rse
.ss
== gfc_ss_terminator
);
4747 /* Form the mask expression according to the mask tree list. */
4749 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
4751 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4752 TREE_TYPE (maskexpr
), maskexpr
);
4754 /* Use the scalar assignment as is. */
4755 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
4756 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
4757 build_empty_stmt (input_location
));
4758 gfc_add_expr_to_block (&body
, tmp
);
4760 /* Increment count2. */
4761 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4762 gfc_array_index_type
, count2
,
4763 gfc_index_one_node
);
4764 gfc_add_modify (&body
, count2
, tmp
);
4768 /* Increment count1. */
4769 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4770 gfc_array_index_type
, count1
,
4771 gfc_index_one_node
);
4772 gfc_add_modify (&body
, count1
, tmp
);
4775 /* Generate the copying loops. */
4776 gfc_trans_scalarizing_loops (&loop
, &body
);
4778 /* Wrap the whole thing up. */
4779 gfc_add_block_to_block (&block
, &loop
.pre
);
4780 gfc_add_block_to_block (&block
, &loop
.post
);
4781 gfc_cleanup_loop (&loop
);
4784 return gfc_finish_block (&block
);
4788 /* Translate the WHERE construct or statement.
4789 This function can be called iteratively to translate the nested WHERE
4790 construct or statement.
4791 MASK is the control mask. */
4794 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
4795 forall_info
* nested_forall_info
, stmtblock_t
* block
)
4797 stmtblock_t inner_size_body
;
4798 tree inner_size
, size
;
4807 tree count1
, count2
;
4811 tree pcmask
= NULL_TREE
;
4812 tree ppmask
= NULL_TREE
;
4813 tree cmask
= NULL_TREE
;
4814 tree pmask
= NULL_TREE
;
4815 gfc_actual_arglist
*arg
;
4817 /* the WHERE statement or the WHERE construct statement. */
4818 cblock
= code
->block
;
4820 /* As the mask array can be very big, prefer compact boolean types. */
4821 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4823 /* Determine which temporary masks are needed. */
4826 /* One clause: No ELSEWHEREs. */
4827 need_cmask
= (cblock
->next
!= 0);
4830 else if (cblock
->block
->block
)
4832 /* Three or more clauses: Conditional ELSEWHEREs. */
4836 else if (cblock
->next
)
4838 /* Two clauses, the first non-empty. */
4840 need_pmask
= (mask
!= NULL_TREE
4841 && cblock
->block
->next
!= 0);
4843 else if (!cblock
->block
->next
)
4845 /* Two clauses, both empty. */
4849 /* Two clauses, the first empty, the second non-empty. */
4852 need_cmask
= (cblock
->block
->expr1
!= 0);
4861 if (need_cmask
|| need_pmask
)
4863 /* Calculate the size of temporary needed by the mask-expr. */
4864 gfc_init_block (&inner_size_body
);
4865 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
4866 &inner_size_body
, &lss
, &rss
);
4868 gfc_free_ss_chain (lss
);
4869 gfc_free_ss_chain (rss
);
4871 /* Calculate the total size of temporary needed. */
4872 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4873 &inner_size_body
, block
);
4875 /* Check whether the size is negative. */
4876 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
4877 gfc_index_zero_node
);
4878 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
4879 cond
, gfc_index_zero_node
, size
);
4880 size
= gfc_evaluate_now (size
, block
);
4882 /* Allocate temporary for WHERE mask if needed. */
4884 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4887 /* Allocate temporary for !mask if needed. */
4889 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
4895 /* Each time around this loop, the where clause is conditional
4896 on the value of mask and invert, which are updated at the
4897 bottom of the loop. */
4899 /* Has mask-expr. */
4902 /* Ensure that the WHERE mask will be evaluated exactly once.
4903 If there are no statements in this WHERE/ELSEWHERE clause,
4904 then we don't need to update the control mask (cmask).
4905 If this is the last clause of the WHERE construct, then
4906 we don't need to update the pending control mask (pmask). */
4908 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4910 cblock
->next
? cmask
: NULL_TREE
,
4911 cblock
->block
? pmask
: NULL_TREE
,
4914 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
4916 (cblock
->next
|| cblock
->block
)
4917 ? cmask
: NULL_TREE
,
4918 NULL_TREE
, mask_type
, block
);
4922 /* It's a final elsewhere-stmt. No mask-expr is present. */
4926 /* The body of this where clause are controlled by cmask with
4927 sense specified by invert. */
4929 /* Get the assignment statement of a WHERE statement, or the first
4930 statement in where-body-construct of a WHERE construct. */
4931 cnext
= cblock
->next
;
4936 /* WHERE assignment statement. */
4937 case EXEC_ASSIGN_CALL
:
4939 arg
= cnext
->ext
.actual
;
4940 expr1
= expr2
= NULL
;
4941 for (; arg
; arg
= arg
->next
)
4953 expr1
= cnext
->expr1
;
4954 expr2
= cnext
->expr2
;
4956 if (nested_forall_info
!= NULL
)
4958 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4959 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4960 gfc_trans_assign_need_temp (expr1
, expr2
,
4962 nested_forall_info
, block
);
4965 /* Variables to control maskexpr. */
4966 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4967 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4968 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4969 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4971 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4976 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4978 gfc_add_expr_to_block (block
, tmp
);
4983 /* Variables to control maskexpr. */
4984 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4985 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4986 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4987 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4989 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4993 gfc_add_expr_to_block (block
, tmp
);
4998 /* WHERE or WHERE construct is part of a where-body-construct. */
5000 gfc_trans_where_2 (cnext
, cmask
, invert
,
5001 nested_forall_info
, block
);
5008 /* The next statement within the same where-body-construct. */
5009 cnext
= cnext
->next
;
5011 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5012 cblock
= cblock
->block
;
5013 if (mask
== NULL_TREE
)
5015 /* If we're the initial WHERE, we can simply invert the sense
5016 of the current mask to obtain the "mask" for the remaining
5023 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5029 /* If we allocated a pending mask array, deallocate it now. */
5032 tmp
= gfc_call_free (ppmask
);
5033 gfc_add_expr_to_block (block
, tmp
);
5036 /* If we allocated a current mask array, deallocate it now. */
5039 tmp
= gfc_call_free (pcmask
);
5040 gfc_add_expr_to_block (block
, tmp
);
5044 /* Translate a simple WHERE construct or statement without dependencies.
5045 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5046 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5047 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5050 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5052 stmtblock_t block
, body
;
5053 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5054 tree tmp
, cexpr
, tstmt
, estmt
;
5055 gfc_ss
*css
, *tdss
, *tsss
;
5056 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5061 /* Allow the scalarizer to workshare simple where loops. */
5062 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
5063 ompws_flags
|= OMPWS_SCALARIZER_WS
;
5065 cond
= cblock
->expr1
;
5066 tdst
= cblock
->next
->expr1
;
5067 tsrc
= cblock
->next
->expr2
;
5068 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5069 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5071 gfc_start_block (&block
);
5072 gfc_init_loopinfo (&loop
);
5074 /* Handle the condition. */
5075 gfc_init_se (&cse
, NULL
);
5076 css
= gfc_walk_expr (cond
);
5077 gfc_add_ss_to_loop (&loop
, css
);
5079 /* Handle the then-clause. */
5080 gfc_init_se (&tdse
, NULL
);
5081 gfc_init_se (&tsse
, NULL
);
5082 tdss
= gfc_walk_expr (tdst
);
5083 tsss
= gfc_walk_expr (tsrc
);
5084 if (tsss
== gfc_ss_terminator
)
5086 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5087 tsss
->info
->where
= 1;
5089 gfc_add_ss_to_loop (&loop
, tdss
);
5090 gfc_add_ss_to_loop (&loop
, tsss
);
5094 /* Handle the else clause. */
5095 gfc_init_se (&edse
, NULL
);
5096 gfc_init_se (&esse
, NULL
);
5097 edss
= gfc_walk_expr (edst
);
5098 esss
= gfc_walk_expr (esrc
);
5099 if (esss
== gfc_ss_terminator
)
5101 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5102 esss
->info
->where
= 1;
5104 gfc_add_ss_to_loop (&loop
, edss
);
5105 gfc_add_ss_to_loop (&loop
, esss
);
5108 gfc_conv_ss_startstride (&loop
);
5109 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5111 gfc_mark_ss_chain_used (css
, 1);
5112 gfc_mark_ss_chain_used (tdss
, 1);
5113 gfc_mark_ss_chain_used (tsss
, 1);
5116 gfc_mark_ss_chain_used (edss
, 1);
5117 gfc_mark_ss_chain_used (esss
, 1);
5120 gfc_start_scalarized_body (&loop
, &body
);
5122 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5123 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5124 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5130 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5131 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5136 gfc_conv_expr (&cse
, cond
);
5137 gfc_add_block_to_block (&body
, &cse
.pre
);
5140 gfc_conv_expr (&tsse
, tsrc
);
5141 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5142 gfc_conv_tmp_array_ref (&tdse
);
5144 gfc_conv_expr (&tdse
, tdst
);
5148 gfc_conv_expr (&esse
, esrc
);
5149 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5150 gfc_conv_tmp_array_ref (&edse
);
5152 gfc_conv_expr (&edse
, edst
);
5155 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5156 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5158 : build_empty_stmt (input_location
);
5159 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5160 gfc_add_expr_to_block (&body
, tmp
);
5161 gfc_add_block_to_block (&body
, &cse
.post
);
5163 gfc_trans_scalarizing_loops (&loop
, &body
);
5164 gfc_add_block_to_block (&block
, &loop
.pre
);
5165 gfc_add_block_to_block (&block
, &loop
.post
);
5166 gfc_cleanup_loop (&loop
);
5168 return gfc_finish_block (&block
);
5171 /* As the WHERE or WHERE construct statement can be nested, we call
5172 gfc_trans_where_2 to do the translation, and pass the initial
5173 NULL values for both the control mask and the pending control mask. */
5176 gfc_trans_where (gfc_code
* code
)
5182 cblock
= code
->block
;
5184 && cblock
->next
->op
== EXEC_ASSIGN
5185 && !cblock
->next
->next
)
5187 eblock
= cblock
->block
;
5190 /* A simple "WHERE (cond) x = y" statement or block is
5191 dependence free if cond is not dependent upon writing x,
5192 and the source y is unaffected by the destination x. */
5193 if (!gfc_check_dependency (cblock
->next
->expr1
,
5195 && !gfc_check_dependency (cblock
->next
->expr1
,
5196 cblock
->next
->expr2
, 0))
5197 return gfc_trans_where_3 (cblock
, NULL
);
5199 else if (!eblock
->expr1
5202 && eblock
->next
->op
== EXEC_ASSIGN
5203 && !eblock
->next
->next
)
5205 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5206 block is dependence free if cond is not dependent on writes
5207 to x1 and x2, y1 is not dependent on writes to x2, and y2
5208 is not dependent on writes to x1, and both y's are not
5209 dependent upon their own x's. In addition to this, the
5210 final two dependency checks below exclude all but the same
5211 array reference if the where and elswhere destinations
5212 are the same. In short, this is VERY conservative and this
5213 is needed because the two loops, required by the standard
5214 are coalesced in gfc_trans_where_3. */
5215 if (!gfc_check_dependency (cblock
->next
->expr1
,
5217 && !gfc_check_dependency (eblock
->next
->expr1
,
5219 && !gfc_check_dependency (cblock
->next
->expr1
,
5220 eblock
->next
->expr2
, 1)
5221 && !gfc_check_dependency (eblock
->next
->expr1
,
5222 cblock
->next
->expr2
, 1)
5223 && !gfc_check_dependency (cblock
->next
->expr1
,
5224 cblock
->next
->expr2
, 1)
5225 && !gfc_check_dependency (eblock
->next
->expr1
,
5226 eblock
->next
->expr2
, 1)
5227 && !gfc_check_dependency (cblock
->next
->expr1
,
5228 eblock
->next
->expr1
, 0)
5229 && !gfc_check_dependency (eblock
->next
->expr1
,
5230 cblock
->next
->expr1
, 0))
5231 return gfc_trans_where_3 (cblock
, eblock
);
5235 gfc_start_block (&block
);
5237 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5239 return gfc_finish_block (&block
);
5243 /* CYCLE a DO loop. The label decl has already been created by
5244 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5245 node at the head of the loop. We must mark the label as used. */
5248 gfc_trans_cycle (gfc_code
* code
)
5252 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5253 gcc_assert (cycle_label
);
5255 TREE_USED (cycle_label
) = 1;
5256 return build1_v (GOTO_EXPR
, cycle_label
);
5260 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5261 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5265 gfc_trans_exit (gfc_code
* code
)
5269 exit_label
= code
->ext
.which_construct
->exit_label
;
5270 gcc_assert (exit_label
);
5272 TREE_USED (exit_label
) = 1;
5273 return build1_v (GOTO_EXPR
, exit_label
);
5277 /* Translate the ALLOCATE statement. */
5280 gfc_trans_allocate (gfc_code
* code
)
5283 gfc_expr
*expr
, *e3rhs
= NULL
;
5293 tree al_vptr
, al_len
;
5294 tree def_str_len
= NULL_TREE
;
5295 /* If an expr3 is present, then store the tree for accessing its
5296 _vptr, and _len components in the variables, respectively. The
5297 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5298 the trees may be the NULL_TREE indicating that this is not
5299 available for expr3's type. */
5300 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5301 /* Classify what expr3 stores. */
5302 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5306 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
;
5307 gfc_symtree
*newsym
= NULL
;
5309 if (!code
->ext
.alloc
.list
)
5312 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5313 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5314 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5317 gfc_init_block (&block
);
5318 gfc_init_block (&post
);
5320 /* STAT= (and maybe ERRMSG=) is present. */
5324 tree gfc_int4_type_node
= gfc_get_int_type (4);
5325 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5327 /* ERRMSG= only makes sense with STAT=. */
5330 gfc_init_se (&se
, NULL
);
5331 se
.want_pointer
= 1;
5332 gfc_conv_expr_lhs (&se
, code
->expr2
);
5334 errlen
= se
.string_length
;
5338 errmsg
= null_pointer_node
;
5339 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5342 /* GOTO destinations. */
5343 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5344 label_finish
= gfc_build_label_decl (NULL_TREE
);
5345 TREE_USED (label_finish
) = 0;
5348 /* When an expr3 is present evaluate it only once. The standards prevent a
5349 dependency of expr3 on the objects in the allocate list. An expr3 can
5350 be pre-evaluated in all cases. One just has to make sure, to use the
5351 correct way, i.e., to get the descriptor or to get a reference
5355 bool vtab_needed
= false, temp_var_needed
= false;
5357 /* Figure whether we need the vtab from expr3. */
5358 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5360 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5362 gfc_init_se (&se
, NULL
);
5363 /* When expr3 is a variable, i.e., a very simple expression,
5364 then convert it once here. */
5365 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5366 || code
->expr3
->expr_type
== EXPR_ARRAY
5367 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5369 if (!code
->expr3
->mold
5370 || code
->expr3
->ts
.type
== BT_CHARACTER
5372 || code
->ext
.alloc
.arr_spec_from_expr3
)
5374 /* Convert expr3 to a tree. For all "simple" expression just
5375 get the descriptor or the reference, respectively, depending
5376 on the rank of the expr. */
5377 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5378 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5380 gfc_conv_expr_reference (&se
, code
->expr3
);
5381 /* Create a temp variable only for component refs to prevent
5382 having to go through the full deref-chain each time and to
5383 simplfy computation of array properties. */
5384 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5389 /* In all other cases evaluate the expr3. */
5390 symbol_attribute attr
;
5391 /* Get the descriptor for all arrays, that are not allocatable or
5392 pointer, because the latter are descriptors already.
5393 The exception are function calls returning a class object:
5394 The descriptor is stored in their results _data component, which
5395 is easier to access, when first a temporary variable for the
5396 result is created and the descriptor retrieved from there. */
5397 attr
= gfc_expr_attr (code
->expr3
);
5398 if (code
->expr3
->rank
!= 0
5399 && ((!attr
.allocatable
&& !attr
.pointer
)
5400 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5401 && code
->expr3
->ts
.type
!= BT_CLASS
)))
5402 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5404 gfc_conv_expr_reference (&se
, code
->expr3
);
5405 if (code
->expr3
->ts
.type
== BT_CLASS
)
5406 gfc_conv_class_to_class (&se
, code
->expr3
,
5410 temp_var_needed
= !VAR_P (se
.expr
);
5412 gfc_add_block_to_block (&block
, &se
.pre
);
5413 gfc_add_block_to_block (&post
, &se
.post
);
5414 /* Prevent aliasing, i.e., se.expr may be already a
5415 variable declaration. */
5416 if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5419 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) ?
5421 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5423 /* Get the array descriptor and prepare it to be assigned to the
5424 temporary variable var. For classes the array descriptor is
5425 in the _data component and the object goes into the
5426 GFC_DECL_SAVED_DESCRIPTOR. */
5427 if (code
->expr3
->ts
.type
== BT_CLASS
5428 && code
->expr3
->rank
!= 0)
5430 /* When an array_ref was in expr3, then the descriptor is the
5432 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5434 desc
= TREE_OPERAND (tmp
, 0);
5439 tmp
= gfc_class_data_get (tmp
);
5445 /* We need a regular (non-UID) symbol here, therefore give a
5447 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5448 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
5450 gfc_allocate_lang_decl (var
);
5451 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5453 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5455 /* Deallocate any allocatable components after all the allocations
5456 and assignments of expr3 have been completed. */
5457 if (code
->expr3
->ts
.type
== BT_DERIVED
5458 && code
->expr3
->rank
== 0
5459 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
)
5461 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
5463 gfc_add_expr_to_block (&post
, tmp
);
5467 if (se
.string_length
)
5468 /* Evaluate it assuming that it also is complicated like expr3. */
5469 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5474 expr3_len
= se
.string_length
;
5476 /* Store what the expr3 is to be used for. */
5477 if (e3_is
== E3_UNSET
)
5478 e3_is
= expr3
!= NULL_TREE
?
5479 (code
->ext
.alloc
.arr_spec_from_expr3
?
5481 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
5484 /* Figure how to get the _vtab entry. This also obtains the tree
5485 expression for accessing the _len component, because only
5486 unlimited polymorphic objects, which are a subcategory of class
5487 types, have a _len component. */
5488 if (code
->expr3
->ts
.type
== BT_CLASS
)
5491 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
5492 build_fold_indirect_ref (expr3
): expr3
;
5493 /* Polymorphic SOURCE: VPTR must be determined at run time.
5494 expr3 may be a temporary array declaration, therefore check for
5495 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
5496 if (tmp
!= NULL_TREE
5497 && TREE_CODE (tmp
) != POINTER_PLUS_EXPR
5498 && (e3_is
== E3_DESC
5499 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
5500 && (VAR_P (tmp
) || !code
->expr3
->ref
))
5501 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
5502 tmp
= gfc_class_vptr_get (expr3
);
5505 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5506 gfc_add_vptr_component (rhs
);
5507 gfc_init_se (&se
, NULL
);
5508 se
.want_pointer
= 1;
5509 gfc_conv_expr (&se
, rhs
);
5511 gfc_free_expr (rhs
);
5513 /* Set the element size. */
5514 expr3_esize
= gfc_vptr_size_get (tmp
);
5517 /* Initialize the ref to the _len component. */
5518 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
5520 /* Same like for retrieving the _vptr. */
5521 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
5522 expr3_len
= gfc_class_len_get (expr3
);
5525 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
5526 gfc_add_len_component (rhs
);
5527 gfc_init_se (&se
, NULL
);
5528 gfc_conv_expr (&se
, rhs
);
5529 expr3_len
= se
.expr
;
5530 gfc_free_expr (rhs
);
5536 /* When the object to allocate is polymorphic type, then it
5537 needs its vtab set correctly, so deduce the required _vtab
5538 and _len from the source expression. */
5541 /* VPTR is fixed at compile time. */
5544 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
5546 expr3_vptr
= gfc_get_symbol_decl (vtab
);
5547 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
5550 /* _len component needs to be set, when ts is a character
5552 if (expr3_len
== NULL_TREE
5553 && code
->expr3
->ts
.type
== BT_CHARACTER
)
5555 if (code
->expr3
->ts
.u
.cl
5556 && code
->expr3
->ts
.u
.cl
->length
)
5558 gfc_init_se (&se
, NULL
);
5559 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
5560 gfc_add_block_to_block (&block
, &se
.pre
);
5561 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
5563 gcc_assert (expr3_len
);
5565 /* For character arrays only the kind's size is needed, because
5566 the array mem_size is _len * (elem_size = kind_size).
5567 For all other get the element size in the normal way. */
5568 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
5569 expr3_esize
= TYPE_SIZE_UNIT (
5570 gfc_get_char_type (code
->expr3
->ts
.kind
));
5572 expr3_esize
= TYPE_SIZE_UNIT (
5573 gfc_typenode_for_spec (&code
->expr3
->ts
));
5575 /* The routine gfc_trans_assignment () already implements all
5576 techniques needed. Unfortunately we may have a temporary
5577 variable for the source= expression here. When that is the
5578 case convert this variable into a temporary gfc_expr of type
5579 EXPR_VARIABLE and used it as rhs for the assignment. The
5580 advantage is, that we get scalarizer support for free,
5581 don't have to take care about scalar to array treatment and
5582 will benefit of every enhancements gfc_trans_assignment ()
5584 No need to check whether e3_is is E3_UNSET, because that is
5585 done by expr3 != NULL_TREE.
5586 Exclude variables since the following block does not handle
5587 array sections. In any case, there is no harm in sending
5588 variables to gfc_trans_assignment because there is no
5589 evaluation of variables. */
5590 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
5591 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
5592 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
5594 /* Build a temporary symtree and symbol. Do not add it to
5595 the current namespace to prevent accidently modifying
5596 a colliding symbol's as. */
5597 newsym
= XCNEW (gfc_symtree
);
5598 /* The name of the symtree should be unique, because
5599 gfc_create_var () took care about generating the
5601 newsym
->name
= gfc_get_string (IDENTIFIER_POINTER (
5602 DECL_NAME (expr3
)));
5603 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
5604 /* The backend_decl is known. It is expr3, which is inserted
5606 newsym
->n
.sym
->backend_decl
= expr3
;
5607 e3rhs
= gfc_get_expr ();
5608 e3rhs
->ts
= code
->expr3
->ts
;
5609 e3rhs
->rank
= code
->expr3
->rank
;
5610 e3rhs
->symtree
= newsym
;
5611 /* Mark the symbol referenced or gfc_trans_assignment will
5613 newsym
->n
.sym
->attr
.referenced
= 1;
5614 e3rhs
->expr_type
= EXPR_VARIABLE
;
5615 e3rhs
->where
= code
->expr3
->where
;
5616 /* Set the symbols type, upto it was BT_UNKNOWN. */
5617 newsym
->n
.sym
->ts
= e3rhs
->ts
;
5618 /* Check whether the expr3 is array valued. */
5621 gfc_array_spec
*arr
;
5622 arr
= gfc_get_array_spec ();
5623 arr
->rank
= e3rhs
->rank
;
5624 arr
->type
= AS_DEFERRED
;
5625 /* Set the dimension and pointer attribute for arrays
5626 to be on the safe side. */
5627 newsym
->n
.sym
->attr
.dimension
= 1;
5628 newsym
->n
.sym
->attr
.pointer
= 1;
5629 newsym
->n
.sym
->as
= arr
;
5630 gfc_add_full_array_ref (e3rhs
, arr
);
5632 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
5633 newsym
->n
.sym
->attr
.pointer
= 1;
5634 /* The string length is known to. Set it for char arrays. */
5635 if (e3rhs
->ts
.type
== BT_CHARACTER
)
5636 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
5637 gfc_commit_symbol (newsym
->n
.sym
);
5640 e3rhs
= gfc_copy_expr (code
->expr3
);
5642 gcc_assert (expr3_esize
);
5643 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
5644 if (e3_is
== E3_MOLD
)
5646 /* The expr3 is no longer valid after this point. */
5651 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5653 /* Compute the explicit typespec given only once for all objects
5655 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
5656 expr3_esize
= TYPE_SIZE_UNIT (
5657 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5661 gcc_assert (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
);
5662 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
5663 gfc_init_se (&se_sz
, NULL
);
5664 gfc_conv_expr (&se_sz
, sz
);
5666 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
5667 tmp
= TYPE_SIZE_UNIT (tmp
);
5668 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
5669 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
5670 TREE_TYPE (se_sz
.expr
),
5672 def_str_len
= gfc_evaluate_now (se_sz
.expr
, &block
);
5676 /* Loop over all objects to allocate. */
5677 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
5679 expr
= gfc_copy_expr (al
->expr
);
5680 /* UNLIMITED_POLY () needs the _data component to be set, when
5681 expr is a unlimited polymorphic object. But the _data component
5682 has not been set yet, so check the derived type's attr for the
5683 unlimited polymorphic flag to be safe. */
5684 upoly_expr
= UNLIMITED_POLY (expr
)
5685 || (expr
->ts
.type
== BT_DERIVED
5686 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
5687 gfc_init_se (&se
, NULL
);
5689 /* For class types prepare the expressions to ref the _vptr
5690 and the _len component. The latter for unlimited polymorphic
5692 if (expr
->ts
.type
== BT_CLASS
)
5694 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
5695 gfc_add_data_component (expr
);
5696 /* Prep the vptr handle. */
5697 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
5698 gfc_add_vptr_component (expr_ref_vptr
);
5699 se
.want_pointer
= 1;
5700 gfc_conv_expr (&se
, expr_ref_vptr
);
5702 se
.want_pointer
= 0;
5703 gfc_free_expr (expr_ref_vptr
);
5704 /* Allocated unlimited polymorphic objects always have a _len
5708 expr_ref_len
= gfc_copy_expr (al
->expr
);
5709 gfc_add_len_component (expr_ref_len
);
5710 gfc_conv_expr (&se
, expr_ref_len
);
5712 gfc_free_expr (expr_ref_len
);
5715 /* In a loop ensure that all loop variable dependent variables
5716 are initialized at the same spot in all execution paths. */
5720 al_vptr
= al_len
= NULL_TREE
;
5722 se
.want_pointer
= 1;
5723 se
.descriptor_only
= 1;
5725 if (expr
->ts
.type
== BT_CHARACTER
5726 && expr
->ts
.deferred
5727 && TREE_CODE (expr
->ts
.u
.cl
->backend_decl
) == VAR_DECL
5728 && def_str_len
!= NULL_TREE
)
5730 tmp
= expr
->ts
.u
.cl
->backend_decl
;
5731 gfc_add_modify (&block
, tmp
,
5732 fold_convert (TREE_TYPE (tmp
), def_str_len
));
5735 gfc_conv_expr (&se
, expr
);
5736 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5737 /* se.string_length now stores the .string_length variable of expr
5738 needed to allocate character(len=:) arrays. */
5739 al_len
= se
.string_length
;
5741 al_len_needs_set
= al_len
!= NULL_TREE
;
5742 /* When allocating an array one can not use much of the
5743 pre-evaluated expr3 expressions, because for most of them the
5744 scalarizer is needed which is not available in the pre-evaluation
5745 step. Therefore gfc_array_allocate () is responsible (and able)
5746 to handle the complete array allocation. Only the element size
5747 needs to be provided, which is done most of the time by the
5748 pre-evaluation step. */
5750 if (expr3_len
&& code
->expr3
->ts
.type
== BT_CHARACTER
)
5751 /* When al is an array, then the element size for each element
5752 in the array is needed, which is the product of the len and
5753 esize for char arrays. */
5754 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5755 TREE_TYPE (expr3_esize
), expr3_esize
,
5756 fold_convert (TREE_TYPE (expr3_esize
),
5760 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
5761 label_finish
, tmp
, &nelems
,
5762 e3rhs
? e3rhs
: code
->expr3
,
5763 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
5764 code
->expr3
!= NULL
&& e3_is
== E3_DESC
5765 && code
->expr3
->expr_type
== EXPR_ARRAY
))
5767 /* A scalar or derived type. First compute the size to
5770 expr3_len is set when expr3 is an unlimited polymorphic
5771 object or a deferred length string. */
5772 if (expr3_len
!= NULL_TREE
)
5774 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
5775 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
5776 TREE_TYPE (expr3_esize
),
5778 if (code
->expr3
->ts
.type
!= BT_CLASS
)
5779 /* expr3 is a deferred length string, i.e., we are
5784 /* For unlimited polymorphic enties build
5785 (len > 0) ? element_size * len : element_size
5786 to compute the number of bytes to allocate.
5787 This allows the allocation of unlimited polymorphic
5788 objects from an expr3 that is also unlimited
5789 polymorphic and stores a _len dependent object,
5791 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
5792 boolean_type_node
, expr3_len
,
5794 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
5795 TREE_TYPE (expr3_esize
),
5796 memsz
, tmp
, expr3_esize
);
5799 else if (expr3_esize
!= NULL_TREE
)
5800 /* Any other object in expr3 just needs element size in
5802 memsz
= expr3_esize
;
5803 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
5805 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
5807 /* Allocating deferred length char arrays need the length
5808 to allocate in the alloc_type_spec. But also unlimited
5809 polymorphic objects may be allocated as char arrays.
5810 Both are handled here. */
5811 gfc_init_se (&se_sz
, NULL
);
5812 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5813 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
5814 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
5815 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
5816 expr3_len
= se_sz
.expr
;
5817 tmp_expr3_len_flag
= true;
5818 tmp
= TYPE_SIZE_UNIT (
5819 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
5820 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5822 fold_convert (TREE_TYPE (tmp
),
5826 else if (expr
->ts
.type
== BT_CHARACTER
)
5828 /* Compute the number of bytes needed to allocate a fixed
5829 length char array. */
5830 gcc_assert (se
.string_length
!= NULL_TREE
);
5831 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
5832 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
5833 TREE_TYPE (tmp
), tmp
,
5834 fold_convert (TREE_TYPE (tmp
),
5837 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
5838 /* Handle all types, where the alloc_type_spec is set. */
5839 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
5841 /* Handle size computation of the type declared to alloc. */
5842 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
5844 /* Allocate - for non-pointers with re-alloc checking. */
5845 if (gfc_expr_attr (expr
).allocatable
)
5846 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
, NULL_TREE
,
5847 stat
, errmsg
, errlen
, label_finish
,
5850 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
5852 if (al
->expr
->ts
.type
== BT_DERIVED
5853 && expr
->ts
.u
.derived
->attr
.alloc_comp
)
5855 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
5856 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
5857 gfc_add_expr_to_block (&se
.pre
, tmp
);
5862 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
5863 && expr3_len
!= NULL_TREE
)
5865 /* Arrays need to have a _len set before the array
5866 descriptor is filled. */
5867 gfc_add_modify (&block
, al_len
,
5868 fold_convert (TREE_TYPE (al_len
), expr3_len
));
5869 /* Prevent setting the length twice. */
5870 al_len_needs_set
= false;
5874 gfc_add_block_to_block (&block
, &se
.pre
);
5876 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5879 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
5880 parm
= fold_build2_loc (input_location
, NE_EXPR
,
5881 boolean_type_node
, stat
,
5882 build_int_cst (TREE_TYPE (stat
), 0));
5883 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
5884 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
5885 tmp
, build_empty_stmt (input_location
));
5886 gfc_add_expr_to_block (&block
, tmp
);
5890 if (al_vptr
!= NULL_TREE
)
5892 if (expr3_vptr
!= NULL_TREE
)
5893 /* The vtab is already known, so just assign it. */
5894 gfc_add_modify (&block
, al_vptr
,
5895 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
5898 /* VPTR is fixed at compile time. */
5903 /* Although expr3 is pre-evaluated above, it may happen,
5904 that for arrays or in mold= cases the pre-evaluation
5905 was not successful. In these rare cases take the vtab
5906 from the typespec of expr3 here. */
5907 ts
= &code
->expr3
->ts
;
5908 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
5909 /* The alloc_type_spec gives the type to allocate or the
5910 al is unlimited polymorphic, which enforces the use of
5911 an alloc_type_spec that is not necessarily a BT_DERIVED. */
5912 ts
= &code
->ext
.alloc
.ts
;
5914 /* Prepare for setting the vtab as declared. */
5917 vtab
= gfc_find_vtab (ts
);
5919 tmp
= gfc_build_addr_expr (NULL_TREE
,
5920 gfc_get_symbol_decl (vtab
));
5921 gfc_add_modify (&block
, al_vptr
,
5922 fold_convert (TREE_TYPE (al_vptr
), tmp
));
5926 /* Add assignment for string length. */
5927 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
5929 if (expr3_len
!= NULL_TREE
)
5931 gfc_add_modify (&block
, al_len
,
5932 fold_convert (TREE_TYPE (al_len
),
5934 /* When tmp_expr3_len_flag is set, then expr3_len is
5935 abused to carry the length information from the
5936 alloc_type. Clear it to prevent setting incorrect len
5937 information in future loop iterations. */
5938 if (tmp_expr3_len_flag
)
5939 /* No need to reset tmp_expr3_len_flag, because the
5940 presence of an expr3 can not change within in the
5942 expr3_len
= NULL_TREE
;
5944 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
5945 && code
->ext
.alloc
.ts
.u
.cl
->length
)
5947 /* Cover the cases where a string length is explicitly
5948 specified by a type spec for deferred length character
5949 arrays or unlimited polymorphic objects without a
5950 source= or mold= expression. */
5951 gfc_init_se (&se_sz
, NULL
);
5952 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
5953 gfc_add_modify (&block
, al_len
,
5954 fold_convert (TREE_TYPE (al_len
),
5958 /* No length information needed, because type to allocate
5959 has no length. Set _len to 0. */
5960 gfc_add_modify (&block
, al_len
,
5961 fold_convert (TREE_TYPE (al_len
),
5962 integer_zero_node
));
5964 if (code
->expr3
&& !code
->expr3
->mold
)
5966 /* Initialization via SOURCE block (or static default initializer).
5967 Classes need some special handling, so catch them first. */
5968 if (expr3
!= NULL_TREE
5969 && TREE_CODE (expr3
) != POINTER_PLUS_EXPR
5970 && code
->expr3
->ts
.type
== BT_CLASS
5971 && (expr
->ts
.type
== BT_CLASS
5972 || expr
->ts
.type
== BT_DERIVED
))
5974 /* copy_class_to_class can be used for class arrays, too.
5975 It just needs to be ensured, that the decl_saved_descriptor
5976 has a way to get to the vptr. */
5978 to
= VAR_P (se
.expr
) ? se
.expr
: TREE_OPERAND (se
.expr
, 0);
5979 tmp
= gfc_copy_class_to_class (expr3
, to
,
5980 nelems
, upoly_expr
);
5982 else if (al
->expr
->ts
.type
== BT_CLASS
)
5984 gfc_actual_arglist
*actual
, *last_arg
;
5987 gfc_ref
*ref
, *dataref
;
5988 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
5990 /* Do a polymorphic deep copy. */
5991 actual
= gfc_get_actual_arglist ();
5992 actual
->expr
= gfc_copy_expr (rhs
);
5993 if (rhs
->ts
.type
== BT_CLASS
)
5994 gfc_add_data_component (actual
->expr
);
5995 last_arg
= actual
->next
= gfc_get_actual_arglist ();
5996 last_arg
->expr
= gfc_copy_expr (al
->expr
);
5997 last_arg
->expr
->ts
.type
= BT_CLASS
;
5998 gfc_add_data_component (last_arg
->expr
);
6001 /* Make sure we go up through the reference chain to
6002 the _data reference, where the arrayspec is found. */
6003 for (ref
= last_arg
->expr
->ref
; ref
; ref
= ref
->next
)
6004 if (ref
->type
== REF_COMPONENT
6005 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
6008 if (dataref
&& dataref
->u
.c
.component
->as
)
6010 gfc_array_spec
*as
= dataref
->u
.c
.component
->as
;
6011 gfc_free_ref_list (dataref
->next
);
6012 dataref
->next
= NULL
;
6013 gfc_add_full_array_ref (last_arg
->expr
, as
);
6014 gfc_resolve_expr (last_arg
->expr
);
6015 gcc_assert (last_arg
->expr
->ts
.type
== BT_CLASS
6016 || last_arg
->expr
->ts
.type
== BT_DERIVED
);
6017 last_arg
->expr
->ts
.type
= BT_CLASS
;
6019 if (rhs
->ts
.type
== BT_CLASS
)
6022 ppc
= gfc_find_and_cut_at_last_class_ref (rhs
);
6024 ppc
= gfc_copy_expr (rhs
);
6025 gfc_add_vptr_component (ppc
);
6028 ppc
= gfc_lval_expr_from_sym (gfc_find_vtab (&rhs
->ts
));
6029 gfc_add_component_ref (ppc
, "_copy");
6031 ppc_code
= gfc_get_code (EXEC_CALL
);
6032 ppc_code
->resolved_sym
= ppc
->symtree
->n
.sym
;
6033 ppc_code
->loc
= al
->expr
->where
;
6034 /* Although '_copy' is set to be elemental in class.c, it is
6035 not staying that way. Find out why, sometime.... */
6036 ppc_code
->resolved_sym
->attr
.elemental
= 1;
6037 ppc_code
->ext
.actual
= actual
;
6038 ppc_code
->expr1
= ppc
;
6039 /* Since '_copy' is elemental, the scalarizer will take care
6040 of arrays in gfc_trans_call. */
6041 tmp
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6042 /* We need to add the
6044 al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
6046 al_vptr->copy (expr3_data, al_data);
6047 block, because al is unlimited polymorphic or a deferred
6048 length char array, whose copy routine needs the array lengths
6049 as third and fourth arguments. */
6050 if (al_len
&& UNLIMITED_POLY (code
->expr3
))
6052 tree stdcopy
, extcopy
;
6054 last_arg
->next
= gfc_get_actual_arglist ();
6055 last_arg
= last_arg
->next
;
6056 last_arg
->expr
= gfc_find_and_cut_at_last_class_ref (
6058 gfc_add_len_component (last_arg
->expr
);
6059 /* Add expr3's length. */
6060 last_arg
->next
= gfc_get_actual_arglist ();
6061 last_arg
= last_arg
->next
;
6062 if (code
->expr3
->ts
.type
== BT_CLASS
)
6065 gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6066 gfc_add_len_component (last_arg
->expr
);
6068 else if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6070 gfc_copy_expr (code
->expr3
->ts
.u
.cl
->length
);
6075 extcopy
= gfc_trans_call (ppc_code
, true, NULL
, NULL
, false);
6077 tmp
= fold_build2_loc (input_location
, GT_EXPR
,
6078 boolean_type_node
, expr3_len
,
6080 tmp
= fold_build3_loc (input_location
, COND_EXPR
,
6081 void_type_node
, tmp
, extcopy
, stdcopy
);
6083 gfc_free_statements (ppc_code
);
6085 gfc_free_expr (rhs
);
6089 /* Switch off automatic reallocation since we have just
6090 done the ALLOCATE. */
6091 int realloc_lhs
= flag_realloc_lhs
;
6092 flag_realloc_lhs
= 0;
6093 tmp
= gfc_trans_assignment (gfc_expr_to_initialize (expr
),
6094 e3rhs
, false, false);
6095 flag_realloc_lhs
= realloc_lhs
;
6097 gfc_add_expr_to_block (&block
, tmp
);
6099 else if (code
->expr3
&& code
->expr3
->mold
6100 && code
->expr3
->ts
.type
== BT_CLASS
)
6102 /* Since the _vptr has already been assigned to the allocate
6103 object, we can use gfc_copy_class_to_class in its
6104 initialization mode. */
6105 tmp
= TREE_OPERAND (se
.expr
, 0);
6106 tmp
= gfc_copy_class_to_class (NULL_TREE
, tmp
, nelems
,
6108 gfc_add_expr_to_block (&block
, tmp
);
6111 gfc_free_expr (expr
);
6118 gfc_free_symbol (newsym
->n
.sym
);
6121 gfc_free_expr (e3rhs
);
6126 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6127 gfc_add_expr_to_block (&block
, tmp
);
6130 /* ERRMSG - only useful if STAT is present. */
6131 if (code
->expr1
&& code
->expr2
)
6133 const char *msg
= "Attempt to allocate an allocated object";
6134 tree slen
, dlen
, errmsg_str
;
6135 stmtblock_t errmsg_block
;
6137 gfc_init_block (&errmsg_block
);
6139 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6140 gfc_add_modify (&errmsg_block
, errmsg_str
,
6141 gfc_build_addr_expr (pchar_type_node
,
6142 gfc_build_localized_cstring_const (msg
)));
6144 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6145 dlen
= gfc_get_expr_charlen (code
->expr2
);
6146 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6147 TREE_TYPE (slen
), dlen
, slen
);
6149 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6150 code
->expr2
->ts
.kind
,
6152 gfc_default_character_kind
);
6153 dlen
= gfc_finish_block (&errmsg_block
);
6155 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
6156 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6158 tmp
= build3_v (COND_EXPR
, tmp
,
6159 dlen
, build_empty_stmt (input_location
));
6161 gfc_add_expr_to_block (&block
, tmp
);
6167 if (TREE_USED (label_finish
))
6169 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6170 gfc_add_expr_to_block (&block
, tmp
);
6173 gfc_init_se (&se
, NULL
);
6174 gfc_conv_expr_lhs (&se
, code
->expr1
);
6175 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6176 gfc_add_modify (&block
, se
.expr
, tmp
);
6179 gfc_add_block_to_block (&block
, &se
.post
);
6180 gfc_add_block_to_block (&block
, &post
);
6182 return gfc_finish_block (&block
);
6186 /* Translate a DEALLOCATE statement. */
6189 gfc_trans_deallocate (gfc_code
*code
)
6193 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6194 tree label_finish
, label_errmsg
;
6197 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6198 label_finish
= label_errmsg
= NULL_TREE
;
6200 gfc_start_block (&block
);
6202 /* Count the number of failed deallocations. If deallocate() was
6203 called with STAT= , then set STAT to the count. If deallocate
6204 was called with ERRMSG, then set ERRMG to a string. */
6207 tree gfc_int4_type_node
= gfc_get_int_type (4);
6209 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6210 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6212 /* GOTO destinations. */
6213 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6214 label_finish
= gfc_build_label_decl (NULL_TREE
);
6215 TREE_USED (label_finish
) = 0;
6218 /* Set ERRMSG - only needed if STAT is available. */
6219 if (code
->expr1
&& code
->expr2
)
6221 gfc_init_se (&se
, NULL
);
6222 se
.want_pointer
= 1;
6223 gfc_conv_expr_lhs (&se
, code
->expr2
);
6225 errlen
= se
.string_length
;
6228 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6230 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6231 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6233 if (expr
->ts
.type
== BT_CLASS
)
6234 gfc_add_data_component (expr
);
6236 gfc_init_se (&se
, NULL
);
6237 gfc_start_block (&se
.pre
);
6239 se
.want_pointer
= 1;
6240 se
.descriptor_only
= 1;
6241 gfc_conv_expr (&se
, expr
);
6243 if (expr
->rank
|| gfc_is_coarray (expr
))
6247 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->attr
.alloc_comp
6248 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6250 gfc_ref
*last
= NULL
;
6252 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6253 if (ref
->type
== REF_COMPONENT
)
6256 /* Do not deallocate the components of a derived type
6257 ultimate pointer component. */
6258 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6259 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6261 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
6263 gfc_add_expr_to_block (&se
.pre
, tmp
);
6267 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6269 tmp
= gfc_array_deallocate (se
.expr
, pstat
, errmsg
, errlen
,
6270 label_finish
, expr
);
6271 gfc_add_expr_to_block (&se
.pre
, tmp
);
6273 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6274 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6275 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6278 /* class.c(finalize_component) generates these, when a
6279 finalizable entity has a non-allocatable derived type array
6280 component, which has allocatable components. Obtain the
6281 derived type of the array and deallocate the allocatable
6283 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6285 if (ref
->u
.c
.component
->attr
.dimension
6286 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6290 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6291 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6294 tmp
= gfc_deallocate_alloc_comp
6295 (ref
->u
.c
.component
->ts
.u
.derived
,
6296 se
.expr
, expr
->rank
);
6297 gfc_add_expr_to_block (&se
.pre
, tmp
);
6301 if (al
->expr
->ts
.type
== BT_CLASS
)
6303 gfc_reset_vptr (&se
.pre
, al
->expr
);
6304 if (UNLIMITED_POLY (al
->expr
)
6305 || (al
->expr
->ts
.type
== BT_DERIVED
6306 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6307 /* Clear _len, too. */
6308 gfc_reset_len (&se
.pre
, al
->expr
);
6313 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, false,
6314 al
->expr
, al
->expr
->ts
);
6315 gfc_add_expr_to_block (&se
.pre
, tmp
);
6317 /* Set to zero after deallocation. */
6318 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6320 build_int_cst (TREE_TYPE (se
.expr
), 0));
6321 gfc_add_expr_to_block (&se
.pre
, tmp
);
6323 if (al
->expr
->ts
.type
== BT_CLASS
)
6325 gfc_reset_vptr (&se
.pre
, al
->expr
);
6326 if (UNLIMITED_POLY (al
->expr
)
6327 || (al
->expr
->ts
.type
== BT_DERIVED
6328 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6329 /* Clear _len, too. */
6330 gfc_reset_len (&se
.pre
, al
->expr
);
6338 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6339 build_int_cst (TREE_TYPE (stat
), 0));
6340 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6341 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6342 build1_v (GOTO_EXPR
, label_errmsg
),
6343 build_empty_stmt (input_location
));
6344 gfc_add_expr_to_block (&se
.pre
, tmp
);
6347 tmp
= gfc_finish_block (&se
.pre
);
6348 gfc_add_expr_to_block (&block
, tmp
);
6349 gfc_free_expr (expr
);
6354 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6355 gfc_add_expr_to_block (&block
, tmp
);
6358 /* Set ERRMSG - only needed if STAT is available. */
6359 if (code
->expr1
&& code
->expr2
)
6361 const char *msg
= "Attempt to deallocate an unallocated object";
6362 stmtblock_t errmsg_block
;
6363 tree errmsg_str
, slen
, dlen
, cond
;
6365 gfc_init_block (&errmsg_block
);
6367 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6368 gfc_add_modify (&errmsg_block
, errmsg_str
,
6369 gfc_build_addr_expr (pchar_type_node
,
6370 gfc_build_localized_cstring_const (msg
)));
6371 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
6372 dlen
= gfc_get_expr_charlen (code
->expr2
);
6374 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
6375 slen
, errmsg_str
, gfc_default_character_kind
);
6376 tmp
= gfc_finish_block (&errmsg_block
);
6378 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
6379 build_int_cst (TREE_TYPE (stat
), 0));
6380 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6381 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
6382 build_empty_stmt (input_location
));
6384 gfc_add_expr_to_block (&block
, tmp
);
6387 if (code
->expr1
&& TREE_USED (label_finish
))
6389 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6390 gfc_add_expr_to_block (&block
, tmp
);
6396 gfc_init_se (&se
, NULL
);
6397 gfc_conv_expr_lhs (&se
, code
->expr1
);
6398 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6399 gfc_add_modify (&block
, se
.expr
, tmp
);
6402 return gfc_finish_block (&block
);
6405 #include "gt-fortran-trans-stmt.h"