OSDN Git Service

gcc/fortran/
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-stmt.c
1 /* Statement translation -- generate GCC trees from gfc_code.
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3    2011
4    Free Software Foundation, Inc.
5    Contributed by Paul Brook <paul@nowt.org>
6    and Steven Bosscher <s.bosscher@student.tudelft.nl>
7
8 This file is part of GCC.
9
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
13 version.
14
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
18 for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3.  If not see
22 <http://www.gnu.org/licenses/>.  */
23
24
25 #include "config.h"
26 #include "system.h"
27 #include "coretypes.h"
28 #include "tree.h"
29 #include "gfortran.h"
30 #include "flags.h"
31 #include "trans.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "arith.h"
37 #include "dependency.h"
38 #include "ggc.h"
39
40 typedef struct iter_info
41 {
42   tree var;
43   tree start;
44   tree end;
45   tree step;
46   struct iter_info *next;
47 }
48 iter_info;
49
50 typedef struct forall_info
51 {
52   iter_info *this_loop;
53   tree mask;
54   tree maskindex;
55   int nvar;
56   tree size;
57   struct forall_info  *prev_nest;
58 }
59 forall_info;
60
61 static void gfc_trans_where_2 (gfc_code *, tree, bool,
62                                forall_info *, stmtblock_t *);
63
64 /* Translate a F95 label number to a LABEL_EXPR.  */
65
66 tree
67 gfc_trans_label_here (gfc_code * code)
68 {
69   return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
70 }
71
72
73 /* Given a variable expression which has been ASSIGNed to, find the decl
74    containing the auxiliary variables.  For variables in common blocks this
75    is a field_decl.  */
76
77 void
78 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
79 {
80   gcc_assert (expr->symtree->n.sym->attr.assign == 1);
81   gfc_conv_expr (se, expr);
82   /* Deals with variable in common block. Get the field declaration.  */
83   if (TREE_CODE (se->expr) == COMPONENT_REF)
84     se->expr = TREE_OPERAND (se->expr, 1);
85   /* Deals with dummy argument. Get the parameter declaration.  */
86   else if (TREE_CODE (se->expr) == INDIRECT_REF)
87     se->expr = TREE_OPERAND (se->expr, 0);
88 }
89
90 /* Translate a label assignment statement.  */
91
92 tree
93 gfc_trans_label_assign (gfc_code * code)
94 {
95   tree label_tree;
96   gfc_se se;
97   tree len;
98   tree addr;
99   tree len_tree;
100   int label_len;
101
102   /* Start a new block.  */
103   gfc_init_se (&se, NULL);
104   gfc_start_block (&se.pre);
105   gfc_conv_label_variable (&se, code->expr1);
106
107   len = GFC_DECL_STRING_LEN (se.expr);
108   addr = GFC_DECL_ASSIGN_ADDR (se.expr);
109
110   label_tree = gfc_get_label_decl (code->label1);
111
112   if (code->label1->defined == ST_LABEL_TARGET)
113     {
114       label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
115       len_tree = integer_minus_one_node;
116     }
117   else
118     {
119       gfc_expr *format = code->label1->format;
120
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);
126     }
127
128   gfc_add_modify (&se.pre, len, len_tree);
129   gfc_add_modify (&se.pre, addr, label_tree);
130
131   return gfc_finish_block (&se.pre);
132 }
133
134 /* Translate a GOTO statement.  */
135
136 tree
137 gfc_trans_goto (gfc_code * code)
138 {
139   locus loc = code->loc;
140   tree assigned_goto;
141   tree target;
142   tree tmp;
143   gfc_se se;
144
145   if (code->label1 != NULL)
146     return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
147
148   /* ASSIGNED GOTO.  */
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");
157
158   assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
159
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
164      just ignore it.  */
165
166   target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
167                             assigned_goto);
168   gfc_add_expr_to_block (&se.pre, target);
169   return gfc_finish_block (&se.pre);
170 }
171
172
173 /* Translate an ENTRY statement.  Just adds a label for this entry point.  */
174 tree
175 gfc_trans_entry (gfc_code * code)
176 {
177   return build1_v (LABEL_EXPR, code->ext.entry->label);
178 }
179
180
181 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
182    elemental subroutines.  Make temporaries for output arguments if any such
183    dependencies are found.  Output arguments are chosen because internal_unpack
184    can be used, as is, to copy the result back to the variable.  */
185 static void
186 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
187                                  gfc_symbol * sym, gfc_actual_arglist * arg,
188                                  gfc_dep_check check_variable)
189 {
190   gfc_actual_arglist *arg0;
191   gfc_expr *e;
192   gfc_formal_arglist *formal;
193   gfc_loopinfo tmp_loop;
194   gfc_se parmse;
195   gfc_ss *ss;
196   gfc_ss_info *info;
197   gfc_symbol *fsym;
198   gfc_ref *ref;
199   int n;
200   tree data;
201   tree offset;
202   tree size;
203   tree tmp;
204
205   if (loopse->ss == NULL)
206     return;
207
208   ss = loopse->ss;
209   arg0 = arg;
210   formal = sym->formal;
211
212   /* Loop over all the arguments testing for dependencies.  */
213   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
214     {
215       e = arg->expr;
216       if (e == NULL)
217         continue;
218
219       /* Obtain the info structure for the current argument.  */ 
220       info = NULL;
221       for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
222         {
223           if (ss->expr != e)
224             continue;
225           info = &ss->data.info;
226           break;
227         }
228
229       /* If there is a dependency, create a temporary and use it
230          instead of the variable.  */
231       fsym = formal ? formal->sym : NULL;
232       if (e->expr_type == EXPR_VARIABLE
233             && e->rank && fsym
234             && fsym->attr.intent != INTENT_IN
235             && gfc_check_fncall_dependency (e, fsym->attr.intent,
236                                             sym, arg0, check_variable))
237         {
238           tree initial, temptype;
239           stmtblock_t temp_post;
240
241           /* Make a local loopinfo for the temporary creation, so that
242              none of the other ss->info's have to be renormalized.  */
243           gfc_init_loopinfo (&tmp_loop);
244           tmp_loop.dimen = info->dimen;
245           for (n = 0; n < info->dimen; n++)
246             {
247               tmp_loop.to[n] = loopse->loop->to[n];
248               tmp_loop.from[n] = loopse->loop->from[n];
249               tmp_loop.order[n] = loopse->loop->order[n];
250             }
251
252           /* Obtain the argument descriptor for unpacking.  */
253           gfc_init_se (&parmse, NULL);
254           parmse.want_pointer = 1;
255
256           /* The scalarizer introduces some specific peculiarities when
257              handling elemental subroutines; the stride can be needed up to
258              the dim_array - 1, rather than dim_loop - 1 to calculate
259              offsets outside the loop.  For this reason, we make sure that
260              the descriptor has the dimensionality of the array by converting
261              trailing elements into ranges with end = start.  */
262           for (ref = e->ref; ref; ref = ref->next)
263             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
264               break;
265
266           if (ref)
267             {
268               bool seen_range = false;
269               for (n = 0; n < ref->u.ar.dimen; n++)
270                 {
271                   if (ref->u.ar.dimen_type[n] == DIMEN_RANGE)
272                     seen_range = true;
273
274                   if (!seen_range
275                         || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
276                     continue;
277
278                   ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]);
279                   ref->u.ar.dimen_type[n] = DIMEN_RANGE;
280                 }
281             }
282
283           gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
284           gfc_add_block_to_block (&se->pre, &parmse.pre);
285
286           /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
287              initialize the array temporary with a copy of the values.  */
288           if (fsym->attr.intent == INTENT_INOUT
289                 || (fsym->ts.type ==BT_DERIVED
290                       && fsym->attr.intent == INTENT_OUT))
291             initial = parmse.expr;
292           else
293             initial = NULL_TREE;
294
295           /* Find the type of the temporary to create; we don't use the type
296              of e itself as this breaks for subcomponent-references in e (where
297              the type of e is that of the final reference, but parmse.expr's
298              type corresponds to the full derived-type).  */
299           /* TODO: Fix this somehow so we don't need a temporary of the whole
300              array but instead only the components referenced.  */
301           temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor.  */
302           gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
303           temptype = TREE_TYPE (temptype);
304           temptype = gfc_get_element_type (temptype);
305
306           /* Generate the temporary.  Cleaning up the temporary should be the
307              very last thing done, so we add the code to a new block and add it
308              to se->post as last instructions.  */
309           size = gfc_create_var (gfc_array_index_type, NULL);
310           data = gfc_create_var (pvoid_type_node, NULL);
311           gfc_init_block (&temp_post);
312           tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
313                                              &tmp_loop, info, temptype,
314                                              initial,
315                                              false, true, false,
316                                              &arg->expr->where);
317           gfc_add_modify (&se->pre, size, tmp);
318           tmp = fold_convert (pvoid_type_node, info->data);
319           gfc_add_modify (&se->pre, data, tmp);
320
321           /* Calculate the offset for the temporary.  */
322           offset = gfc_index_zero_node;
323           for (n = 0; n < info->dimen; n++)
324             {
325               tmp = gfc_conv_descriptor_stride_get (info->descriptor,
326                                                     gfc_rank_cst[n]);
327               tmp = fold_build2_loc (input_location, MULT_EXPR,
328                                      gfc_array_index_type,
329                                      loopse->loop->from[n], tmp);
330               offset = fold_build2_loc (input_location, MINUS_EXPR,
331                                         gfc_array_index_type, offset, tmp);
332             }
333           info->offset = gfc_create_var (gfc_array_index_type, NULL);     
334           gfc_add_modify (&se->pre, info->offset, offset);
335
336           /* Copy the result back using unpack.  */
337           tmp = build_call_expr_loc (input_location,
338                                  gfor_fndecl_in_unpack, 2, parmse.expr, data);
339           gfc_add_expr_to_block (&se->post, tmp);
340
341           /* parmse.pre is already added above.  */
342           gfc_add_block_to_block (&se->post, &parmse.post);
343           gfc_add_block_to_block (&se->post, &temp_post);
344         }
345     }
346 }
347
348
349 /* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
350
351 tree
352 gfc_trans_call (gfc_code * code, bool dependency_check,
353                 tree mask, tree count1, bool invert)
354 {
355   gfc_se se;
356   gfc_ss * ss;
357   int has_alternate_specifier;
358   gfc_dep_check check_variable;
359   tree index = NULL_TREE;
360   tree maskexpr = NULL_TREE;
361   tree tmp;
362
363   /* A CALL starts a new block because the actual arguments may have to
364      be evaluated first.  */
365   gfc_init_se (&se, NULL);
366   gfc_start_block (&se.pre);
367
368   gcc_assert (code->resolved_sym);
369
370   ss = gfc_ss_terminator;
371   if (code->resolved_sym->attr.elemental)
372     ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
373
374   /* Is not an elemental subroutine call with array valued arguments.  */
375   if (ss == gfc_ss_terminator)
376     {
377
378       /* Translate the call.  */
379       has_alternate_specifier
380         = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
381                                   code->expr1, NULL);
382
383       /* A subroutine without side-effect, by definition, does nothing!  */
384       TREE_SIDE_EFFECTS (se.expr) = 1;
385
386       /* Chain the pieces together and return the block.  */
387       if (has_alternate_specifier)
388         {
389           gfc_code *select_code;
390           gfc_symbol *sym;
391           select_code = code->next;
392           gcc_assert(select_code->op == EXEC_SELECT);
393           sym = select_code->expr1->symtree->n.sym;
394           se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
395           if (sym->backend_decl == NULL)
396             sym->backend_decl = gfc_get_symbol_decl (sym);
397           gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
398         }
399       else
400         gfc_add_expr_to_block (&se.pre, se.expr);
401
402       gfc_add_block_to_block (&se.pre, &se.post);
403     }
404
405   else
406     {
407       /* An elemental subroutine call with array valued arguments has
408          to be scalarized.  */
409       gfc_loopinfo loop;
410       stmtblock_t body;
411       stmtblock_t block;
412       gfc_se loopse;
413       gfc_se depse;
414
415       /* gfc_walk_elemental_function_args renders the ss chain in the
416          reverse order to the actual argument order.  */
417       ss = gfc_reverse_ss (ss);
418
419       /* Initialize the loop.  */
420       gfc_init_se (&loopse, NULL);
421       gfc_init_loopinfo (&loop);
422       gfc_add_ss_to_loop (&loop, ss);
423
424       gfc_conv_ss_startstride (&loop);
425       /* TODO: gfc_conv_loop_setup generates a temporary for vector 
426          subscripts.  This could be prevented in the elemental case  
427          as temporaries are handled separatedly 
428          (below in gfc_conv_elemental_dependencies).  */
429       gfc_conv_loop_setup (&loop, &code->expr1->where);
430       gfc_mark_ss_chain_used (ss, 1);
431
432       /* Convert the arguments, checking for dependencies.  */
433       gfc_copy_loopinfo_to_se (&loopse, &loop);
434       loopse.ss = ss;
435
436       /* For operator assignment, do dependency checking.  */
437       if (dependency_check)
438         check_variable = ELEM_CHECK_VARIABLE;
439       else
440         check_variable = ELEM_DONT_CHECK_VARIABLE;
441
442       gfc_init_se (&depse, NULL);
443       gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
444                                        code->ext.actual, check_variable);
445
446       gfc_add_block_to_block (&loop.pre,  &depse.pre);
447       gfc_add_block_to_block (&loop.post, &depse.post);
448
449       /* Generate the loop body.  */
450       gfc_start_scalarized_body (&loop, &body);
451       gfc_init_block (&block);
452
453       if (mask && count1)
454         {
455           /* Form the mask expression according to the mask.  */
456           index = count1;
457           maskexpr = gfc_build_array_ref (mask, index, NULL);
458           if (invert)
459             maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
460                                         TREE_TYPE (maskexpr), maskexpr);
461         }
462
463       /* Add the subroutine call to the block.  */
464       gfc_conv_procedure_call (&loopse, code->resolved_sym,
465                                code->ext.actual, code->expr1, NULL);
466
467       if (mask && count1)
468         {
469           tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
470                           build_empty_stmt (input_location));
471           gfc_add_expr_to_block (&loopse.pre, tmp);
472           tmp = fold_build2_loc (input_location, PLUS_EXPR,
473                                  gfc_array_index_type,
474                                  count1, gfc_index_one_node);
475           gfc_add_modify (&loopse.pre, count1, tmp);
476         }
477       else
478         gfc_add_expr_to_block (&loopse.pre, loopse.expr);
479
480       gfc_add_block_to_block (&block, &loopse.pre);
481       gfc_add_block_to_block (&block, &loopse.post);
482
483       /* Finish up the loop block and the loop.  */
484       gfc_add_expr_to_block (&body, gfc_finish_block (&block));
485       gfc_trans_scalarizing_loops (&loop, &body);
486       gfc_add_block_to_block (&se.pre, &loop.pre);
487       gfc_add_block_to_block (&se.pre, &loop.post);
488       gfc_add_block_to_block (&se.pre, &se.post);
489       gfc_cleanup_loop (&loop);
490     }
491
492   return gfc_finish_block (&se.pre);
493 }
494
495
496 /* Translate the RETURN statement.  */
497
498 tree
499 gfc_trans_return (gfc_code * code)
500 {
501   if (code->expr1)
502     {
503       gfc_se se;
504       tree tmp;
505       tree result;
506
507       /* If code->expr is not NULL, this return statement must appear
508          in a subroutine and current_fake_result_decl has already
509          been generated.  */
510
511       result = gfc_get_fake_result_decl (NULL, 0);
512       if (!result)
513         {
514           gfc_warning ("An alternate return at %L without a * dummy argument",
515                         &code->expr1->where);
516           return gfc_generate_return ();
517         }
518
519       /* Start a new block for this statement.  */
520       gfc_init_se (&se, NULL);
521       gfc_start_block (&se.pre);
522
523       gfc_conv_expr (&se, code->expr1);
524
525       /* Note that the actually returned expression is a simple value and
526          does not depend on any pointers or such; thus we can clean-up with
527          se.post before returning.  */
528       tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
529                              result, fold_convert (TREE_TYPE (result),
530                              se.expr));
531       gfc_add_expr_to_block (&se.pre, tmp);
532       gfc_add_block_to_block (&se.pre, &se.post);
533
534       tmp = gfc_generate_return ();
535       gfc_add_expr_to_block (&se.pre, tmp);
536       return gfc_finish_block (&se.pre);
537     }
538
539   return gfc_generate_return ();
540 }
541
542
543 /* Translate the PAUSE statement.  We have to translate this statement
544    to a runtime library call.  */
545
546 tree
547 gfc_trans_pause (gfc_code * code)
548 {
549   tree gfc_int4_type_node = gfc_get_int_type (4);
550   gfc_se se;
551   tree tmp;
552
553   /* Start a new block for this statement.  */
554   gfc_init_se (&se, NULL);
555   gfc_start_block (&se.pre);
556
557
558   if (code->expr1 == NULL)
559     {
560       tmp = build_int_cst (gfc_int4_type_node, 0);
561       tmp = build_call_expr_loc (input_location,
562                                  gfor_fndecl_pause_string, 2,
563                                  build_int_cst (pchar_type_node, 0), tmp);
564     }
565   else if (code->expr1->ts.type == BT_INTEGER)
566     {
567       gfc_conv_expr (&se, code->expr1);
568       tmp = build_call_expr_loc (input_location,
569                                  gfor_fndecl_pause_numeric, 1,
570                                  fold_convert (gfc_int4_type_node, se.expr));
571     }
572   else
573     {
574       gfc_conv_expr_reference (&se, code->expr1);
575       tmp = build_call_expr_loc (input_location,
576                              gfor_fndecl_pause_string, 2,
577                              se.expr, se.string_length);
578     }
579
580   gfc_add_expr_to_block (&se.pre, tmp);
581
582   gfc_add_block_to_block (&se.pre, &se.post);
583
584   return gfc_finish_block (&se.pre);
585 }
586
587
588 /* Translate the STOP statement.  We have to translate this statement
589    to a runtime library call.  */
590
591 tree
592 gfc_trans_stop (gfc_code *code, bool error_stop)
593 {
594   tree gfc_int4_type_node = gfc_get_int_type (4);
595   gfc_se se;
596   tree tmp;
597
598   /* Start a new block for this statement.  */
599   gfc_init_se (&se, NULL);
600   gfc_start_block (&se.pre);
601
602   if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
603     {
604       /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY.  */
605       tmp = built_in_decls [BUILT_IN_SYNCHRONIZE];
606       tmp = build_call_expr_loc (input_location, tmp, 0);
607       gfc_add_expr_to_block (&se.pre, tmp);
608
609       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
610       gfc_add_expr_to_block (&se.pre, tmp);
611     }
612
613   if (code->expr1 == NULL)
614     {
615       tmp = build_int_cst (gfc_int4_type_node, 0);
616       tmp = build_call_expr_loc (input_location,
617                                  error_stop
618                                  ? (gfc_option.coarray == GFC_FCOARRAY_LIB
619                                     ? gfor_fndecl_caf_error_stop_str
620                                     : gfor_fndecl_error_stop_string)
621                                  : gfor_fndecl_stop_string,
622                                  2, build_int_cst (pchar_type_node, 0), tmp);
623     }
624   else if (code->expr1->ts.type == BT_INTEGER)
625     {
626       gfc_conv_expr (&se, code->expr1);
627       tmp = build_call_expr_loc (input_location,
628                                  error_stop
629                                  ? (gfc_option.coarray == GFC_FCOARRAY_LIB
630                                     ? gfor_fndecl_caf_error_stop
631                                     : gfor_fndecl_error_stop_numeric)
632                                  : gfor_fndecl_stop_numeric_f08, 1, 
633                                  fold_convert (gfc_int4_type_node, se.expr));
634     }
635   else
636     {
637       gfc_conv_expr_reference (&se, code->expr1);
638       tmp = build_call_expr_loc (input_location,
639                                  error_stop
640                                  ? (gfc_option.coarray == GFC_FCOARRAY_LIB
641                                     ? gfor_fndecl_caf_error_stop_str
642                                     : gfor_fndecl_error_stop_string)
643                                  : gfor_fndecl_stop_string,
644                                  2, se.expr, se.string_length);
645     }
646
647   gfc_add_expr_to_block (&se.pre, tmp);
648
649   gfc_add_block_to_block (&se.pre, &se.post);
650
651   return gfc_finish_block (&se.pre);
652 }
653
654
655 tree
656 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
657 {
658   gfc_se se, argse;
659   tree tmp;
660   tree images = NULL_TREE, stat = NULL_TREE,
661        errmsg = NULL_TREE, errmsglen = NULL_TREE;
662
663   /* Short cut: For single images without bound checking or without STAT=,
664      return early. (ERRMSG= is always untouched for -fcoarray=single.)  */
665   if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
666       && gfc_option.coarray != GFC_FCOARRAY_LIB)
667     return NULL_TREE; 
668
669   gfc_init_se (&se, NULL);
670   gfc_start_block (&se.pre);
671
672   if (code->expr1 && code->expr1->rank == 0)
673     {
674       gfc_init_se (&argse, NULL);
675       gfc_conv_expr_val (&argse, code->expr1);
676       images = argse.expr;
677     }
678
679   if (code->expr2)
680     {
681       gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
682       gfc_init_se (&argse, NULL);
683       gfc_conv_expr_val (&argse, code->expr2);
684       stat = argse.expr;
685     }
686   else
687     stat = null_pointer_node;
688
689   if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
690       && type != EXEC_SYNC_MEMORY)
691     {
692       gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
693       gfc_init_se (&argse, NULL);
694       gfc_conv_expr (&argse, code->expr3);
695       gfc_conv_string_parameter (&argse);
696       errmsg = gfc_build_addr_expr (NULL, argse.expr);
697       errmsglen = argse.string_length;
698     }
699   else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
700     {
701       errmsg = null_pointer_node;
702       errmsglen = build_int_cst (integer_type_node, 0);
703     }
704
705   /* Check SYNC IMAGES(imageset) for valid image index.
706      FIXME: Add a check for image-set arrays. */
707   if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
708       && code->expr1->rank == 0)
709     {
710       tree cond;
711       if (gfc_option.coarray != GFC_FCOARRAY_LIB)
712         cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
713                                 images, build_int_cst (TREE_TYPE (images), 1));
714       else
715         {
716           tree cond2;
717           cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
718                                   images, gfort_gvar_caf_num_images);
719           cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
720                                    images,
721                                    build_int_cst (TREE_TYPE (images), 1));
722           cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
723                                   boolean_type_node, cond, cond2);
724         }
725       gfc_trans_runtime_check (true, false, cond, &se.pre,
726                                &code->expr1->where, "Invalid image number "
727                                "%d in SYNC IMAGES",
728                                fold_convert (integer_type_node, se.expr));
729     }
730
731    /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
732       image control statements SYNC IMAGES and SYNC ALL.  */
733    if (gfc_option.coarray == GFC_FCOARRAY_LIB)
734      {
735         tmp = built_in_decls [BUILT_IN_SYNCHRONIZE];
736         tmp = build_call_expr_loc (input_location, tmp, 0);
737         gfc_add_expr_to_block (&se.pre, tmp);
738      }
739
740   if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
741     {
742       /* Set STAT to zero.  */
743       if (code->expr2)
744         gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
745     }
746   else if (type == EXEC_SYNC_ALL)
747     {
748       /* SYNC ALL           =>   stat == null_pointer_node
749          SYNC ALL(stat=s)   =>   stat has an integer type
750
751          If "stat" has the wrong integer type, use a temp variable of
752          the right type and later cast the result back into "stat".  */
753       if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
754         {
755           if (TREE_TYPE (stat) == integer_type_node)
756             stat = gfc_build_addr_expr (NULL, stat);
757           
758           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
759                                      3, stat, errmsg, errmsglen);
760           gfc_add_expr_to_block (&se.pre, tmp);
761         }
762       else
763         {
764           tree tmp_stat = gfc_create_var (integer_type_node, "stat");
765
766           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
767                                      3, gfc_build_addr_expr (NULL, tmp_stat),
768                                      errmsg, errmsglen);
769           gfc_add_expr_to_block (&se.pre, tmp);
770           
771           gfc_add_modify (&se.pre, stat,
772                           fold_convert (TREE_TYPE (stat), tmp_stat));
773         }
774     }
775   else
776     {
777       tree len;
778
779       gcc_assert (type == EXEC_SYNC_IMAGES);
780
781       if (!code->expr1)
782         {
783           len = build_int_cst (integer_type_node, -1);
784           images = null_pointer_node;
785         }
786       else if (code->expr1->rank == 0)
787         {
788           len = build_int_cst (integer_type_node, 1);
789           images = gfc_build_addr_expr (NULL_TREE, images);
790         }
791       else
792         {
793           /* FIXME.  */
794           if (code->expr1->ts.kind != gfc_c_int_kind)
795             gfc_fatal_error ("Sorry, only support for integer kind %d "
796                              "implemented for image-set at %L",
797                              gfc_c_int_kind, &code->expr1->where);
798
799           gfc_conv_array_parameter (&se, code->expr1,
800                                     gfc_walk_expr (code->expr1), true, NULL,
801                                     NULL, &len);
802           images = se.expr;
803
804           tmp = gfc_typenode_for_spec (&code->expr1->ts);
805           if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
806             tmp = gfc_get_element_type (tmp);
807
808           len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
809                                  TREE_TYPE (len), len,
810                                  fold_convert (TREE_TYPE (len),
811                                                TYPE_SIZE_UNIT (tmp)));
812           len = fold_convert (integer_type_node, len);
813         }
814
815       /* SYNC IMAGES(imgs)        => stat == null_pointer_node
816          SYNC IMAGES(imgs,stat=s) => stat has an integer type
817
818          If "stat" has the wrong integer type, use a temp variable of
819          the right type and later cast the result back into "stat".  */
820       if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
821         {
822           if (TREE_TYPE (stat) == integer_type_node)
823             stat = gfc_build_addr_expr (NULL, stat);
824
825           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 
826                                      5, fold_convert (integer_type_node, len),
827                                      images, stat, errmsg, errmsglen);
828           gfc_add_expr_to_block (&se.pre, tmp);
829         }
830       else
831         {
832           tree tmp_stat = gfc_create_var (integer_type_node, "stat");
833
834           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 
835                                      5, fold_convert (integer_type_node, len),
836                                      images, gfc_build_addr_expr (NULL, tmp_stat),
837                                      errmsg, errmsglen);
838           gfc_add_expr_to_block (&se.pre, tmp);
839
840           gfc_add_modify (&se.pre, stat, 
841                           fold_convert (TREE_TYPE (stat), tmp_stat));
842         }
843     }
844
845   return gfc_finish_block (&se.pre);
846 }
847
848
849 /* Generate GENERIC for the IF construct. This function also deals with
850    the simple IF statement, because the front end translates the IF
851    statement into an IF construct.
852
853    We translate:
854
855         IF (cond) THEN
856            then_clause
857         ELSEIF (cond2)
858            elseif_clause
859         ELSE
860            else_clause
861         ENDIF
862
863    into:
864
865         pre_cond_s;
866         if (cond_s)
867           {
868             then_clause;
869           }
870         else
871           {
872             pre_cond_s
873             if (cond_s)
874               {
875                 elseif_clause
876               }
877             else
878               {
879                 else_clause;
880               }
881           }
882
883    where COND_S is the simplified version of the predicate. PRE_COND_S
884    are the pre side-effects produced by the translation of the
885    conditional.
886    We need to build the chain recursively otherwise we run into
887    problems with folding incomplete statements.  */
888
889 static tree
890 gfc_trans_if_1 (gfc_code * code)
891 {
892   gfc_se if_se;
893   tree stmt, elsestmt;
894   locus saved_loc;
895   location_t loc;
896
897   /* Check for an unconditional ELSE clause.  */
898   if (!code->expr1)
899     return gfc_trans_code (code->next);
900
901   /* Initialize a statement builder for each block. Puts in NULL_TREEs.  */
902   gfc_init_se (&if_se, NULL);
903   gfc_start_block (&if_se.pre);
904
905   /* Calculate the IF condition expression.  */
906   if (code->expr1->where.lb)
907     {
908       gfc_save_backend_locus (&saved_loc);
909       gfc_set_backend_locus (&code->expr1->where);
910     }
911
912   gfc_conv_expr_val (&if_se, code->expr1);
913
914   if (code->expr1->where.lb)
915     gfc_restore_backend_locus (&saved_loc);
916
917   /* Translate the THEN clause.  */
918   stmt = gfc_trans_code (code->next);
919
920   /* Translate the ELSE clause.  */
921   if (code->block)
922     elsestmt = gfc_trans_if_1 (code->block);
923   else
924     elsestmt = build_empty_stmt (input_location);
925
926   /* Build the condition expression and add it to the condition block.  */
927   loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
928   stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
929                           elsestmt);
930   
931   gfc_add_expr_to_block (&if_se.pre, stmt);
932
933   /* Finish off this statement.  */
934   return gfc_finish_block (&if_se.pre);
935 }
936
937 tree
938 gfc_trans_if (gfc_code * code)
939 {
940   stmtblock_t body;
941   tree exit_label;
942
943   /* Create exit label so it is available for trans'ing the body code.  */
944   exit_label = gfc_build_label_decl (NULL_TREE);
945   code->exit_label = exit_label;
946
947   /* Translate the actual code in code->block.  */
948   gfc_init_block (&body);
949   gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
950
951   /* Add exit label.  */
952   gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
953
954   return gfc_finish_block (&body);
955 }
956
957
958 /* Translate an arithmetic IF expression.
959
960    IF (cond) label1, label2, label3 translates to
961
962     if (cond <= 0)
963       {
964         if (cond < 0)
965           goto label1;
966         else // cond == 0
967           goto label2;
968       }
969     else // cond > 0
970       goto label3;
971
972    An optimized version can be generated in case of equal labels.
973    E.g., if label1 is equal to label2, we can translate it to
974
975     if (cond <= 0)
976       goto label1;
977     else
978       goto label3;
979 */
980
981 tree
982 gfc_trans_arithmetic_if (gfc_code * code)
983 {
984   gfc_se se;
985   tree tmp;
986   tree branch1;
987   tree branch2;
988   tree zero;
989
990   /* Start a new block.  */
991   gfc_init_se (&se, NULL);
992   gfc_start_block (&se.pre);
993
994   /* Pre-evaluate COND.  */
995   gfc_conv_expr_val (&se, code->expr1);
996   se.expr = gfc_evaluate_now (se.expr, &se.pre);
997
998   /* Build something to compare with.  */
999   zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1000
1001   if (code->label1->value != code->label2->value)
1002     {
1003       /* If (cond < 0) take branch1 else take branch2.
1004          First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases.  */
1005       branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1006       branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1007
1008       if (code->label1->value != code->label3->value)
1009         tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1010                                se.expr, zero);
1011       else
1012         tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1013                                se.expr, zero);
1014
1015       branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1016                                  tmp, branch1, branch2);
1017     }
1018   else
1019     branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1020
1021   if (code->label1->value != code->label3->value
1022       && code->label2->value != code->label3->value)
1023     {
1024       /* if (cond <= 0) take branch1 else take branch2.  */
1025       branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1026       tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1027                              se.expr, zero);
1028       branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1029                                  tmp, branch1, branch2);
1030     }
1031
1032   /* Append the COND_EXPR to the evaluation of COND, and return.  */
1033   gfc_add_expr_to_block (&se.pre, branch1);
1034   return gfc_finish_block (&se.pre);
1035 }
1036
1037
1038 /* Translate a CRITICAL block. */
1039 tree
1040 gfc_trans_critical (gfc_code *code)
1041 {
1042   stmtblock_t block;
1043   tree tmp;
1044
1045   gfc_start_block (&block);
1046
1047   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1048     {
1049       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
1050       gfc_add_expr_to_block (&block, tmp);
1051     }
1052
1053   tmp = gfc_trans_code (code->block->next);
1054   gfc_add_expr_to_block (&block, tmp);
1055
1056   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1057     {
1058       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
1059                                  0);
1060       gfc_add_expr_to_block (&block, tmp);
1061     }
1062
1063
1064   return gfc_finish_block (&block);
1065 }
1066
1067
1068 /* Do proper initialization for ASSOCIATE names.  */
1069
1070 static void
1071 trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1072 {
1073   gfc_expr *e;
1074   tree tmp;
1075
1076   gcc_assert (sym->assoc);
1077   e = sym->assoc->target;
1078
1079   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1080      to array temporary) for arrays with either unknown shape or if associating
1081      to a variable.  */
1082   if (sym->attr.dimension
1083       && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
1084     {
1085       gfc_se se;
1086       gfc_ss *ss;
1087       tree desc;
1088
1089       desc = sym->backend_decl;
1090
1091       /* If association is to an expression, evaluate it and create temporary.
1092          Otherwise, get descriptor of target for pointer assignment.  */
1093       gfc_init_se (&se, NULL);
1094       ss = gfc_walk_expr (e);
1095       if (sym->assoc->variable)
1096         {
1097           se.direct_byref = 1;
1098           se.expr = desc;
1099         }
1100       gfc_conv_expr_descriptor (&se, e, ss);
1101
1102       /* If we didn't already do the pointer assignment, set associate-name
1103          descriptor to the one generated for the temporary.  */
1104       if (!sym->assoc->variable)
1105         {
1106           int dim;
1107
1108           gfc_add_modify (&se.pre, desc, se.expr);
1109
1110           /* The generated descriptor has lower bound zero (as array
1111              temporary), shift bounds so we get lower bounds of 1.  */
1112           for (dim = 0; dim < e->rank; ++dim)
1113             gfc_conv_shift_descriptor_lbound (&se.pre, desc,
1114                                               dim, gfc_index_one_node);
1115         }
1116
1117       /* Done, register stuff as init / cleanup code.  */
1118       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
1119                             gfc_finish_block (&se.post));
1120     }
1121
1122   /* Do a scalar pointer assignment; this is for scalar variable targets.  */
1123   else if (gfc_is_associate_pointer (sym))
1124     {
1125       gfc_se se;
1126
1127       gcc_assert (!sym->attr.dimension);
1128
1129       gfc_init_se (&se, NULL);
1130       gfc_conv_expr (&se, e);
1131
1132       tmp = TREE_TYPE (sym->backend_decl);
1133       tmp = gfc_build_addr_expr (tmp, se.expr);
1134       gfc_add_modify (&se.pre, sym->backend_decl, tmp);
1135       
1136       gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1137                             gfc_finish_block (&se.post));
1138     }
1139
1140   /* Do a simple assignment.  This is for scalar expressions, where we
1141      can simply use expression assignment.  */
1142   else
1143     {
1144       gfc_expr *lhs;
1145
1146       lhs = gfc_lval_expr_from_sym (sym);
1147       tmp = gfc_trans_assignment (lhs, e, false, true);
1148       gfc_add_init_cleanup (block, tmp, NULL_TREE);
1149     }
1150 }
1151
1152
1153 /* Translate a BLOCK construct.  This is basically what we would do for a
1154    procedure body.  */
1155
1156 tree
1157 gfc_trans_block_construct (gfc_code* code)
1158 {
1159   gfc_namespace* ns;
1160   gfc_symbol* sym;
1161   gfc_wrapped_block block;
1162   tree exit_label;
1163   stmtblock_t body;
1164   gfc_association_list *ass;
1165
1166   ns = code->ext.block.ns;
1167   gcc_assert (ns);
1168   sym = ns->proc_name;
1169   gcc_assert (sym);
1170
1171   /* Process local variables.  */
1172   gcc_assert (!sym->tlink);
1173   sym->tlink = sym;
1174   gfc_process_block_locals (ns);
1175
1176   /* Generate code including exit-label.  */
1177   gfc_init_block (&body);
1178   exit_label = gfc_build_label_decl (NULL_TREE);
1179   code->exit_label = exit_label;
1180   gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
1181   gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1182
1183   /* Finish everything.  */
1184   gfc_start_wrapped_block (&block, gfc_finish_block (&body));
1185   gfc_trans_deferred_vars (sym, &block);
1186   for (ass = code->ext.block.assoc; ass; ass = ass->next)
1187     trans_associate_var (ass->st->n.sym, &block);
1188     
1189   return gfc_finish_wrapped_block (&block);
1190 }
1191
1192
1193 /* Translate the simple DO construct.  This is where the loop variable has
1194    integer type and step +-1.  We can't use this in the general case
1195    because integer overflow and floating point errors could give incorrect
1196    results.
1197    We translate a do loop from:
1198
1199    DO dovar = from, to, step
1200       body
1201    END DO
1202
1203    to:
1204
1205    [Evaluate loop bounds and step]
1206    dovar = from;
1207    if ((step > 0) ? (dovar <= to) : (dovar => to))
1208     {
1209       for (;;)
1210         {
1211           body;
1212    cycle_label:
1213           cond = (dovar == to);
1214           dovar += step;
1215           if (cond) goto end_label;
1216         }
1217       }
1218    end_label:
1219
1220    This helps the optimizers by avoiding the extra induction variable
1221    used in the general case.  */
1222
1223 static tree
1224 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
1225                      tree from, tree to, tree step, tree exit_cond)
1226 {
1227   stmtblock_t body;
1228   tree type;
1229   tree cond;
1230   tree tmp;
1231   tree saved_dovar = NULL;
1232   tree cycle_label;
1233   tree exit_label;
1234   location_t loc;
1235   
1236   type = TREE_TYPE (dovar);
1237
1238   loc = code->ext.iterator->start->where.lb->location;
1239
1240   /* Initialize the DO variable: dovar = from.  */
1241   gfc_add_modify_loc (loc, pblock, dovar, from);
1242   
1243   /* Save value for do-tinkering checking. */
1244   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1245     {
1246       saved_dovar = gfc_create_var (type, ".saved_dovar");
1247       gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
1248     }
1249
1250   /* Cycle and exit statements are implemented with gotos.  */
1251   cycle_label = gfc_build_label_decl (NULL_TREE);
1252   exit_label = gfc_build_label_decl (NULL_TREE);
1253
1254   /* Put the labels where they can be found later. See gfc_trans_do().  */
1255   code->cycle_label = cycle_label;
1256   code->exit_label = exit_label;
1257
1258   /* Loop body.  */
1259   gfc_start_block (&body);
1260
1261   /* Main loop body.  */
1262   tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1263   gfc_add_expr_to_block (&body, tmp);
1264
1265   /* Label for cycle statements (if needed).  */
1266   if (TREE_USED (cycle_label))
1267     {
1268       tmp = build1_v (LABEL_EXPR, cycle_label);
1269       gfc_add_expr_to_block (&body, tmp);
1270     }
1271
1272   /* Check whether someone has modified the loop variable. */
1273   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1274     {
1275       tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
1276                              dovar, saved_dovar);
1277       gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1278                                "Loop variable has been modified");
1279     }
1280
1281   /* Exit the loop if there is an I/O result condition or error.  */
1282   if (exit_cond)
1283     {
1284       tmp = build1_v (GOTO_EXPR, exit_label);
1285       tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1286                              exit_cond, tmp,
1287                              build_empty_stmt (loc));
1288       gfc_add_expr_to_block (&body, tmp);
1289     }
1290
1291   /* Evaluate the loop condition.  */
1292   cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
1293                           to);
1294   cond = gfc_evaluate_now_loc (loc, cond, &body);
1295
1296   /* Increment the loop variable.  */
1297   tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1298   gfc_add_modify_loc (loc, &body, dovar, tmp);
1299
1300   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1301     gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1302
1303   /* The loop exit.  */
1304   tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1305   TREE_USED (exit_label) = 1;
1306   tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1307                          cond, tmp, build_empty_stmt (loc));
1308   gfc_add_expr_to_block (&body, tmp);
1309
1310   /* Finish the loop body.  */
1311   tmp = gfc_finish_block (&body);
1312   tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1313
1314   /* Only execute the loop if the number of iterations is positive.  */
1315   if (tree_int_cst_sgn (step) > 0)
1316     cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
1317                             to);
1318   else
1319     cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
1320                             to);
1321   tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
1322                          build_empty_stmt (loc));
1323   gfc_add_expr_to_block (pblock, tmp);
1324
1325   /* Add the exit label.  */
1326   tmp = build1_v (LABEL_EXPR, exit_label);
1327   gfc_add_expr_to_block (pblock, tmp);
1328
1329   return gfc_finish_block (pblock);
1330 }
1331
1332 /* Translate the DO construct.  This obviously is one of the most
1333    important ones to get right with any compiler, but especially
1334    so for Fortran.
1335
1336    We special case some loop forms as described in gfc_trans_simple_do.
1337    For other cases we implement them with a separate loop count,
1338    as described in the standard.
1339
1340    We translate a do loop from:
1341
1342    DO dovar = from, to, step
1343       body
1344    END DO
1345
1346    to:
1347
1348    [evaluate loop bounds and step]
1349    empty = (step > 0 ? to < from : to > from);
1350    countm1 = (to - from) / step;
1351    dovar = from;
1352    if (empty) goto exit_label;
1353    for (;;)
1354      {
1355        body;
1356 cycle_label:
1357        dovar += step
1358        if (countm1 ==0) goto exit_label;
1359        countm1--;
1360      }
1361 exit_label:
1362
1363    countm1 is an unsigned integer.  It is equal to the loop count minus one,
1364    because the loop count itself can overflow.  */
1365
1366 tree
1367 gfc_trans_do (gfc_code * code, tree exit_cond)
1368 {
1369   gfc_se se;
1370   tree dovar;
1371   tree saved_dovar = NULL;
1372   tree from;
1373   tree to;
1374   tree step;
1375   tree countm1;
1376   tree type;
1377   tree utype;
1378   tree cond;
1379   tree cycle_label;
1380   tree exit_label;
1381   tree tmp;
1382   tree pos_step;
1383   stmtblock_t block;
1384   stmtblock_t body;
1385   location_t loc;
1386
1387   gfc_start_block (&block);
1388
1389   loc = code->ext.iterator->start->where.lb->location;
1390
1391   /* Evaluate all the expressions in the iterator.  */
1392   gfc_init_se (&se, NULL);
1393   gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1394   gfc_add_block_to_block (&block, &se.pre);
1395   dovar = se.expr;
1396   type = TREE_TYPE (dovar);
1397
1398   gfc_init_se (&se, NULL);
1399   gfc_conv_expr_val (&se, code->ext.iterator->start);
1400   gfc_add_block_to_block (&block, &se.pre);
1401   from = gfc_evaluate_now (se.expr, &block);
1402
1403   gfc_init_se (&se, NULL);
1404   gfc_conv_expr_val (&se, code->ext.iterator->end);
1405   gfc_add_block_to_block (&block, &se.pre);
1406   to = gfc_evaluate_now (se.expr, &block);
1407
1408   gfc_init_se (&se, NULL);
1409   gfc_conv_expr_val (&se, code->ext.iterator->step);
1410   gfc_add_block_to_block (&block, &se.pre);
1411   step = gfc_evaluate_now (se.expr, &block);
1412
1413   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1414     {
1415       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
1416                              build_zero_cst (type));
1417       gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
1418                                "DO step value is zero");
1419     }
1420
1421   /* Special case simple loops.  */
1422   if (TREE_CODE (type) == INTEGER_TYPE
1423       && (integer_onep (step)
1424         || tree_int_cst_equal (step, integer_minus_one_node)))
1425     return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
1426
1427   pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
1428                               build_zero_cst (type));
1429
1430   if (TREE_CODE (type) == INTEGER_TYPE)
1431     utype = unsigned_type_for (type);
1432   else
1433     utype = unsigned_type_for (gfc_array_index_type);
1434   countm1 = gfc_create_var (utype, "countm1");
1435
1436   /* Cycle and exit statements are implemented with gotos.  */
1437   cycle_label = gfc_build_label_decl (NULL_TREE);
1438   exit_label = gfc_build_label_decl (NULL_TREE);
1439   TREE_USED (exit_label) = 1;
1440
1441   /* Put these labels where they can be found later.  */
1442   code->cycle_label = cycle_label;
1443   code->exit_label = exit_label;
1444
1445   /* Initialize the DO variable: dovar = from.  */
1446   gfc_add_modify (&block, dovar, from);
1447
1448   /* Save value for do-tinkering checking. */
1449   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1450     {
1451       saved_dovar = gfc_create_var (type, ".saved_dovar");
1452       gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
1453     }
1454
1455   /* Initialize loop count and jump to exit label if the loop is empty.
1456      This code is executed before we enter the loop body. We generate:
1457      step_sign = sign(1,step);
1458      if (step > 0)
1459        {
1460          if (to < from)
1461            goto exit_label;
1462        }
1463      else
1464        {
1465          if (to > from)
1466            goto exit_label;
1467        }
1468        countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
1469
1470   */
1471
1472   if (TREE_CODE (type) == INTEGER_TYPE)
1473     {
1474       tree pos, neg, step_sign, to2, from2, step2;
1475
1476       /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1)  */
1477
1478       tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
1479                              build_int_cst (TREE_TYPE (step), 0));
1480       step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, 
1481                                    build_int_cst (type, -1), 
1482                                    build_int_cst (type, 1));
1483
1484       tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
1485       pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1486                              fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1487                                               exit_label),
1488                              build_empty_stmt (loc));
1489
1490       tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
1491                              from);
1492       neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1493                              fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1494                                               exit_label),
1495                              build_empty_stmt (loc));
1496       tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1497                              pos_step, pos, neg);
1498
1499       gfc_add_expr_to_block (&block, tmp);
1500
1501       /* Calculate the loop count.  to-from can overflow, so
1502          we cast to unsigned.  */
1503
1504       to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
1505       from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
1506       step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
1507       step2 = fold_convert (utype, step2);
1508       tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
1509       tmp = fold_convert (utype, tmp);
1510       tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
1511       tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
1512       gfc_add_expr_to_block (&block, tmp);
1513     }
1514   else
1515     {
1516       /* TODO: We could use the same width as the real type.
1517          This would probably cause more problems that it solves
1518          when we implement "long double" types.  */
1519
1520       tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
1521       tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
1522       tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
1523       gfc_add_modify (&block, countm1, tmp);
1524
1525       /* We need a special check for empty loops:
1526          empty = (step > 0 ? to < from : to > from);  */
1527       tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
1528                              fold_build2_loc (loc, LT_EXPR,
1529                                               boolean_type_node, to, from),
1530                              fold_build2_loc (loc, GT_EXPR,
1531                                               boolean_type_node, to, from));
1532       /* If the loop is empty, go directly to the exit label.  */
1533       tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1534                          build1_v (GOTO_EXPR, exit_label),
1535                          build_empty_stmt (input_location));
1536       gfc_add_expr_to_block (&block, tmp);
1537     }
1538
1539   /* Loop body.  */
1540   gfc_start_block (&body);
1541
1542   /* Main loop body.  */
1543   tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1544   gfc_add_expr_to_block (&body, tmp);
1545
1546   /* Label for cycle statements (if needed).  */
1547   if (TREE_USED (cycle_label))
1548     {
1549       tmp = build1_v (LABEL_EXPR, cycle_label);
1550       gfc_add_expr_to_block (&body, tmp);
1551     }
1552
1553   /* Check whether someone has modified the loop variable. */
1554   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1555     {
1556       tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
1557                              saved_dovar);
1558       gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1559                                "Loop variable has been modified");
1560     }
1561
1562   /* Exit the loop if there is an I/O result condition or error.  */
1563   if (exit_cond)
1564     {
1565       tmp = build1_v (GOTO_EXPR, exit_label);
1566       tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1567                              exit_cond, tmp,
1568                              build_empty_stmt (input_location));
1569       gfc_add_expr_to_block (&body, tmp);
1570     }
1571
1572   /* Increment the loop variable.  */
1573   tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1574   gfc_add_modify_loc (loc, &body, dovar, tmp);
1575
1576   if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1577     gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1578
1579   /* End with the loop condition.  Loop until countm1 == 0.  */
1580   cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
1581                           build_int_cst (utype, 0));
1582   tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1583   tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1584                          cond, tmp, build_empty_stmt (loc));
1585   gfc_add_expr_to_block (&body, tmp);
1586
1587   /* Decrement the loop count.  */
1588   tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
1589                          build_int_cst (utype, 1));
1590   gfc_add_modify_loc (loc, &body, countm1, tmp);
1591
1592   /* End of loop body.  */
1593   tmp = gfc_finish_block (&body);
1594
1595   /* The for loop itself.  */
1596   tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1597   gfc_add_expr_to_block (&block, tmp);
1598
1599   /* Add the exit label.  */
1600   tmp = build1_v (LABEL_EXPR, exit_label);
1601   gfc_add_expr_to_block (&block, tmp);
1602
1603   return gfc_finish_block (&block);
1604 }
1605
1606
1607 /* Translate the DO WHILE construct.
1608
1609    We translate
1610
1611    DO WHILE (cond)
1612       body
1613    END DO
1614
1615    to:
1616
1617    for ( ; ; )
1618      {
1619        pre_cond;
1620        if (! cond) goto exit_label;
1621        body;
1622 cycle_label:
1623      }
1624 exit_label:
1625
1626    Because the evaluation of the exit condition `cond' may have side
1627    effects, we can't do much for empty loop bodies.  The backend optimizers
1628    should be smart enough to eliminate any dead loops.  */
1629
1630 tree
1631 gfc_trans_do_while (gfc_code * code)
1632 {
1633   gfc_se cond;
1634   tree tmp;
1635   tree cycle_label;
1636   tree exit_label;
1637   stmtblock_t block;
1638
1639   /* Everything we build here is part of the loop body.  */
1640   gfc_start_block (&block);
1641
1642   /* Cycle and exit statements are implemented with gotos.  */
1643   cycle_label = gfc_build_label_decl (NULL_TREE);
1644   exit_label = gfc_build_label_decl (NULL_TREE);
1645
1646   /* Put the labels where they can be found later. See gfc_trans_do().  */
1647   code->cycle_label = cycle_label;
1648   code->exit_label = exit_label;
1649
1650   /* Create a GIMPLE version of the exit condition.  */
1651   gfc_init_se (&cond, NULL);
1652   gfc_conv_expr_val (&cond, code->expr1);
1653   gfc_add_block_to_block (&block, &cond.pre);
1654   cond.expr = fold_build1_loc (code->expr1->where.lb->location,
1655                                TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1656
1657   /* Build "IF (! cond) GOTO exit_label".  */
1658   tmp = build1_v (GOTO_EXPR, exit_label);
1659   TREE_USED (exit_label) = 1;
1660   tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
1661                          void_type_node, cond.expr, tmp,
1662                          build_empty_stmt (code->expr1->where.lb->location));
1663   gfc_add_expr_to_block (&block, tmp);
1664
1665   /* The main body of the loop.  */
1666   tmp = gfc_trans_code (code->block->next);
1667   gfc_add_expr_to_block (&block, tmp);
1668
1669   /* Label for cycle statements (if needed).  */
1670   if (TREE_USED (cycle_label))
1671     {
1672       tmp = build1_v (LABEL_EXPR, cycle_label);
1673       gfc_add_expr_to_block (&block, tmp);
1674     }
1675
1676   /* End of loop body.  */
1677   tmp = gfc_finish_block (&block);
1678
1679   gfc_init_block (&block);
1680   /* Build the loop.  */
1681   tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
1682                          void_type_node, tmp);
1683   gfc_add_expr_to_block (&block, tmp);
1684
1685   /* Add the exit label.  */
1686   tmp = build1_v (LABEL_EXPR, exit_label);
1687   gfc_add_expr_to_block (&block, tmp);
1688
1689   return gfc_finish_block (&block);
1690 }
1691
1692
1693 /* Translate the SELECT CASE construct for INTEGER case expressions,
1694    without killing all potential optimizations.  The problem is that
1695    Fortran allows unbounded cases, but the back-end does not, so we
1696    need to intercept those before we enter the equivalent SWITCH_EXPR
1697    we can build.
1698
1699    For example, we translate this,
1700
1701    SELECT CASE (expr)
1702       CASE (:100,101,105:115)
1703          block_1
1704       CASE (190:199,200:)
1705          block_2
1706       CASE (300)
1707          block_3
1708       CASE DEFAULT
1709          block_4
1710    END SELECT
1711
1712    to the GENERIC equivalent,
1713
1714      switch (expr)
1715        {
1716          case (minimum value for typeof(expr) ... 100:
1717          case 101:
1718          case 105 ... 114:
1719            block1:
1720            goto end_label;
1721
1722          case 200 ... (maximum value for typeof(expr):
1723          case 190 ... 199:
1724            block2;
1725            goto end_label;
1726
1727          case 300:
1728            block_3;
1729            goto end_label;
1730
1731          default:
1732            block_4;
1733            goto end_label;
1734        }
1735
1736      end_label:  */
1737
1738 static tree
1739 gfc_trans_integer_select (gfc_code * code)
1740 {
1741   gfc_code *c;
1742   gfc_case *cp;
1743   tree end_label;
1744   tree tmp;
1745   gfc_se se;
1746   stmtblock_t block;
1747   stmtblock_t body;
1748
1749   gfc_start_block (&block);
1750
1751   /* Calculate the switch expression.  */
1752   gfc_init_se (&se, NULL);
1753   gfc_conv_expr_val (&se, code->expr1);
1754   gfc_add_block_to_block (&block, &se.pre);
1755
1756   end_label = gfc_build_label_decl (NULL_TREE);
1757
1758   gfc_init_block (&body);
1759
1760   for (c = code->block; c; c = c->block)
1761     {
1762       for (cp = c->ext.block.case_list; cp; cp = cp->next)
1763         {
1764           tree low, high;
1765           tree label;
1766
1767           /* Assume it's the default case.  */
1768           low = high = NULL_TREE;
1769
1770           if (cp->low)
1771             {
1772               low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1773                                           cp->low->ts.kind);
1774
1775               /* If there's only a lower bound, set the high bound to the
1776                  maximum value of the case expression.  */
1777               if (!cp->high)
1778                 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1779             }
1780
1781           if (cp->high)
1782             {
1783               /* Three cases are possible here:
1784
1785                  1) There is no lower bound, e.g. CASE (:N).
1786                  2) There is a lower bound .NE. high bound, that is
1787                     a case range, e.g. CASE (N:M) where M>N (we make
1788                     sure that M>N during type resolution).
1789                  3) There is a lower bound, and it has the same value
1790                     as the high bound, e.g. CASE (N:N).  This is our
1791                     internal representation of CASE(N).
1792
1793                  In the first and second case, we need to set a value for
1794                  high.  In the third case, we don't because the GCC middle
1795                  end represents a single case value by just letting high be
1796                  a NULL_TREE.  We can't do that because we need to be able
1797                  to represent unbounded cases.  */
1798
1799               if (!cp->low
1800                   || (cp->low
1801                       && mpz_cmp (cp->low->value.integer,
1802                                   cp->high->value.integer) != 0))
1803                 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1804                                              cp->high->ts.kind);
1805
1806               /* Unbounded case.  */
1807               if (!cp->low)
1808                 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1809             }
1810
1811           /* Build a label.  */
1812           label = gfc_build_label_decl (NULL_TREE);
1813
1814           /* Add this case label.
1815              Add parameter 'label', make it match GCC backend.  */
1816           tmp = build_case_label (low, high, label);
1817           gfc_add_expr_to_block (&body, tmp);
1818         }
1819
1820       /* Add the statements for this case.  */
1821       tmp = gfc_trans_code (c->next);
1822       gfc_add_expr_to_block (&body, tmp);
1823
1824       /* Break to the end of the construct.  */
1825       tmp = build1_v (GOTO_EXPR, end_label);
1826       gfc_add_expr_to_block (&body, tmp);
1827     }
1828
1829   tmp = gfc_finish_block (&body);
1830   tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1831   gfc_add_expr_to_block (&block, tmp);
1832
1833   tmp = build1_v (LABEL_EXPR, end_label);
1834   gfc_add_expr_to_block (&block, tmp);
1835
1836   return gfc_finish_block (&block);
1837 }
1838
1839
1840 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1841
1842    There are only two cases possible here, even though the standard
1843    does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1844    .FALSE., and DEFAULT.
1845
1846    We never generate more than two blocks here.  Instead, we always
1847    try to eliminate the DEFAULT case.  This way, we can translate this
1848    kind of SELECT construct to a simple
1849
1850    if {} else {};
1851
1852    expression in GENERIC.  */
1853
1854 static tree
1855 gfc_trans_logical_select (gfc_code * code)
1856 {
1857   gfc_code *c;
1858   gfc_code *t, *f, *d;
1859   gfc_case *cp;
1860   gfc_se se;
1861   stmtblock_t block;
1862
1863   /* Assume we don't have any cases at all.  */
1864   t = f = d = NULL;
1865
1866   /* Now see which ones we actually do have.  We can have at most two
1867      cases in a single case list: one for .TRUE. and one for .FALSE.
1868      The default case is always separate.  If the cases for .TRUE. and
1869      .FALSE. are in the same case list, the block for that case list
1870      always executed, and we don't generate code a COND_EXPR.  */
1871   for (c = code->block; c; c = c->block)
1872     {
1873       for (cp = c->ext.block.case_list; cp; cp = cp->next)
1874         {
1875           if (cp->low)
1876             {
1877               if (cp->low->value.logical == 0) /* .FALSE.  */
1878                 f = c;
1879               else /* if (cp->value.logical != 0), thus .TRUE.  */
1880                 t = c;
1881             }
1882           else
1883             d = c;
1884         }
1885     }
1886
1887   /* Start a new block.  */
1888   gfc_start_block (&block);
1889
1890   /* Calculate the switch expression.  We always need to do this
1891      because it may have side effects.  */
1892   gfc_init_se (&se, NULL);
1893   gfc_conv_expr_val (&se, code->expr1);
1894   gfc_add_block_to_block (&block, &se.pre);
1895
1896   if (t == f && t != NULL)
1897     {
1898       /* Cases for .TRUE. and .FALSE. are in the same block.  Just
1899          translate the code for these cases, append it to the current
1900          block.  */
1901       gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1902     }
1903   else
1904     {
1905       tree true_tree, false_tree, stmt;
1906
1907       true_tree = build_empty_stmt (input_location);
1908       false_tree = build_empty_stmt (input_location);
1909
1910       /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1911           Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1912           make the missing case the default case.  */
1913       if (t != NULL && f != NULL)
1914         d = NULL;
1915       else if (d != NULL)
1916         {
1917           if (t == NULL)
1918             t = d;
1919           else
1920             f = d;
1921         }
1922
1923       /* Translate the code for each of these blocks, and append it to
1924          the current block.  */
1925       if (t != NULL)
1926         true_tree = gfc_trans_code (t->next);
1927
1928       if (f != NULL)
1929         false_tree = gfc_trans_code (f->next);
1930
1931       stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1932                               se.expr, true_tree, false_tree);
1933       gfc_add_expr_to_block (&block, stmt);
1934     }
1935
1936   return gfc_finish_block (&block);
1937 }
1938
1939
1940 /* The jump table types are stored in static variables to avoid
1941    constructing them from scratch every single time.  */
1942 static GTY(()) tree select_struct[2];
1943
1944 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1945    Instead of generating compares and jumps, it is far simpler to
1946    generate a data structure describing the cases in order and call a
1947    library subroutine that locates the right case.
1948    This is particularly true because this is the only case where we
1949    might have to dispose of a temporary.
1950    The library subroutine returns a pointer to jump to or NULL if no
1951    branches are to be taken.  */
1952
1953 static tree
1954 gfc_trans_character_select (gfc_code *code)
1955 {
1956   tree init, end_label, tmp, type, case_num, label, fndecl;
1957   stmtblock_t block, body;
1958   gfc_case *cp, *d;
1959   gfc_code *c;
1960   gfc_se se, expr1se;
1961   int n, k;
1962   VEC(constructor_elt,gc) *inits = NULL;
1963
1964   tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
1965
1966   /* The jump table types are stored in static variables to avoid
1967      constructing them from scratch every single time.  */
1968   static tree ss_string1[2], ss_string1_len[2];
1969   static tree ss_string2[2], ss_string2_len[2];
1970   static tree ss_target[2];
1971
1972   cp = code->block->ext.block.case_list;
1973   while (cp->left != NULL)
1974     cp = cp->left;
1975
1976   /* Generate the body */
1977   gfc_start_block (&block);
1978   gfc_init_se (&expr1se, NULL);
1979   gfc_conv_expr_reference (&expr1se, code->expr1);
1980
1981   gfc_add_block_to_block (&block, &expr1se.pre);
1982
1983   end_label = gfc_build_label_decl (NULL_TREE);
1984
1985   gfc_init_block (&body);
1986
1987   /* Attempt to optimize length 1 selects.  */
1988   if (integer_onep (expr1se.string_length))
1989     {
1990       for (d = cp; d; d = d->right)
1991         {
1992           int i;
1993           if (d->low)
1994             {
1995               gcc_assert (d->low->expr_type == EXPR_CONSTANT
1996                           && d->low->ts.type == BT_CHARACTER);
1997               if (d->low->value.character.length > 1)
1998                 {
1999                   for (i = 1; i < d->low->value.character.length; i++)
2000                     if (d->low->value.character.string[i] != ' ')
2001                       break;
2002                   if (i != d->low->value.character.length)
2003                     {
2004                       if (optimize && d->high && i == 1)
2005                         {
2006                           gcc_assert (d->high->expr_type == EXPR_CONSTANT
2007                                       && d->high->ts.type == BT_CHARACTER);
2008                           if (d->high->value.character.length > 1
2009                               && (d->low->value.character.string[0]
2010                                   == d->high->value.character.string[0])
2011                               && d->high->value.character.string[1] != ' '
2012                               && ((d->low->value.character.string[1] < ' ')
2013                                   == (d->high->value.character.string[1]
2014                                       < ' ')))
2015                             continue;
2016                         }
2017                       break;
2018                     }
2019                 }
2020             }
2021           if (d->high)
2022             {
2023               gcc_assert (d->high->expr_type == EXPR_CONSTANT
2024                           && d->high->ts.type == BT_CHARACTER);
2025               if (d->high->value.character.length > 1)
2026                 {
2027                   for (i = 1; i < d->high->value.character.length; i++)
2028                     if (d->high->value.character.string[i] != ' ')
2029                       break;
2030                   if (i != d->high->value.character.length)
2031                     break;
2032                 }
2033             }
2034         }
2035       if (d == NULL)
2036         {
2037           tree ctype = gfc_get_char_type (code->expr1->ts.kind);
2038
2039           for (c = code->block; c; c = c->block)
2040             {
2041               for (cp = c->ext.block.case_list; cp; cp = cp->next)
2042                 {
2043                   tree low, high;
2044                   tree label;
2045                   gfc_char_t r;
2046
2047                   /* Assume it's the default case.  */
2048                   low = high = NULL_TREE;
2049
2050                   if (cp->low)
2051                     {
2052                       /* CASE ('ab') or CASE ('ab':'az') will never match
2053                          any length 1 character.  */
2054                       if (cp->low->value.character.length > 1
2055                           && cp->low->value.character.string[1] != ' ')
2056                         continue;
2057
2058                       if (cp->low->value.character.length > 0)
2059                         r = cp->low->value.character.string[0];
2060                       else
2061                         r = ' ';
2062                       low = build_int_cst (ctype, r);
2063
2064                       /* If there's only a lower bound, set the high bound
2065                          to the maximum value of the case expression.  */
2066                       if (!cp->high)
2067                         high = TYPE_MAX_VALUE (ctype);
2068                     }
2069
2070                   if (cp->high)
2071                     {
2072                       if (!cp->low
2073                           || (cp->low->value.character.string[0]
2074                               != cp->high->value.character.string[0]))
2075                         {
2076                           if (cp->high->value.character.length > 0)
2077                             r = cp->high->value.character.string[0];
2078                           else
2079                             r = ' ';
2080                           high = build_int_cst (ctype, r);
2081                         }
2082
2083                       /* Unbounded case.  */
2084                       if (!cp->low)
2085                         low = TYPE_MIN_VALUE (ctype);
2086                     }
2087
2088                   /* Build a label.  */
2089                   label = gfc_build_label_decl (NULL_TREE);
2090
2091                   /* Add this case label.
2092                      Add parameter 'label', make it match GCC backend.  */
2093                   tmp = build_case_label (low, high, label);
2094                   gfc_add_expr_to_block (&body, tmp);
2095                 }
2096
2097               /* Add the statements for this case.  */
2098               tmp = gfc_trans_code (c->next);
2099               gfc_add_expr_to_block (&body, tmp);
2100
2101               /* Break to the end of the construct.  */
2102               tmp = build1_v (GOTO_EXPR, end_label);
2103               gfc_add_expr_to_block (&body, tmp);
2104             }
2105
2106           tmp = gfc_string_to_single_character (expr1se.string_length,
2107                                                 expr1se.expr,
2108                                                 code->expr1->ts.kind);
2109           case_num = gfc_create_var (ctype, "case_num");
2110           gfc_add_modify (&block, case_num, tmp);
2111
2112           gfc_add_block_to_block (&block, &expr1se.post);
2113
2114           tmp = gfc_finish_block (&body);
2115           tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2116           gfc_add_expr_to_block (&block, tmp);
2117
2118           tmp = build1_v (LABEL_EXPR, end_label);
2119           gfc_add_expr_to_block (&block, tmp);
2120
2121           return gfc_finish_block (&block);
2122         }
2123     }
2124
2125   if (code->expr1->ts.kind == 1)
2126     k = 0;
2127   else if (code->expr1->ts.kind == 4)
2128     k = 1;
2129   else
2130     gcc_unreachable ();
2131
2132   if (select_struct[k] == NULL)
2133     {
2134       tree *chain = NULL;
2135       select_struct[k] = make_node (RECORD_TYPE);
2136
2137       if (code->expr1->ts.kind == 1)
2138         TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
2139       else if (code->expr1->ts.kind == 4)
2140         TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
2141       else
2142         gcc_unreachable ();
2143
2144 #undef ADD_FIELD
2145 #define ADD_FIELD(NAME, TYPE)                                               \
2146   ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k],                 \
2147                                           get_identifier (stringize(NAME)), \
2148                                           TYPE,                             \
2149                                           &chain)
2150
2151       ADD_FIELD (string1, pchartype);
2152       ADD_FIELD (string1_len, gfc_charlen_type_node);
2153
2154       ADD_FIELD (string2, pchartype);
2155       ADD_FIELD (string2_len, gfc_charlen_type_node);
2156
2157       ADD_FIELD (target, integer_type_node);
2158 #undef ADD_FIELD
2159
2160       gfc_finish_type (select_struct[k]);
2161     }
2162
2163   n = 0;
2164   for (d = cp; d; d = d->right)
2165     d->n = n++;
2166
2167   for (c = code->block; c; c = c->block)
2168     {
2169       for (d = c->ext.block.case_list; d; d = d->next)
2170         {
2171           label = gfc_build_label_decl (NULL_TREE);
2172           tmp = build_case_label ((d->low == NULL && d->high == NULL)
2173                                   ? NULL
2174                                   : build_int_cst (integer_type_node, d->n),
2175                                   NULL, label);
2176           gfc_add_expr_to_block (&body, tmp);
2177         }
2178
2179       tmp = gfc_trans_code (c->next);
2180       gfc_add_expr_to_block (&body, tmp);
2181
2182       tmp = build1_v (GOTO_EXPR, end_label);
2183       gfc_add_expr_to_block (&body, tmp);
2184     }
2185
2186   /* Generate the structure describing the branches */
2187   for (d = cp; d; d = d->right)
2188     {
2189       VEC(constructor_elt,gc) *node = NULL;
2190
2191       gfc_init_se (&se, NULL);
2192
2193       if (d->low == NULL)
2194         {
2195           CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
2196           CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
2197         }
2198       else
2199         {
2200           gfc_conv_expr_reference (&se, d->low);
2201
2202           CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
2203           CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
2204         }
2205
2206       if (d->high == NULL)
2207         {
2208           CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
2209           CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
2210         }
2211       else
2212         {
2213           gfc_init_se (&se, NULL);
2214           gfc_conv_expr_reference (&se, d->high);
2215
2216           CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
2217           CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
2218         }
2219
2220       CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
2221                               build_int_cst (integer_type_node, d->n));
2222
2223       tmp = build_constructor (select_struct[k], node);
2224       CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
2225     }
2226
2227   type = build_array_type (select_struct[k],
2228                            build_index_type (size_int (n-1)));
2229
2230   init = build_constructor (type, inits);
2231   TREE_CONSTANT (init) = 1;
2232   TREE_STATIC (init) = 1;
2233   /* Create a static variable to hold the jump table.  */
2234   tmp = gfc_create_var (type, "jumptable");
2235   TREE_CONSTANT (tmp) = 1;
2236   TREE_STATIC (tmp) = 1;
2237   TREE_READONLY (tmp) = 1;
2238   DECL_INITIAL (tmp) = init;
2239   init = tmp;
2240
2241   /* Build the library call */
2242   init = gfc_build_addr_expr (pvoid_type_node, init);
2243
2244   if (code->expr1->ts.kind == 1)
2245     fndecl = gfor_fndecl_select_string;
2246   else if (code->expr1->ts.kind == 4)
2247     fndecl = gfor_fndecl_select_string_char4;
2248   else
2249     gcc_unreachable ();
2250
2251   tmp = build_call_expr_loc (input_location,
2252                          fndecl, 4, init,
2253                          build_int_cst (gfc_charlen_type_node, n),
2254                          expr1se.expr, expr1se.string_length);
2255   case_num = gfc_create_var (integer_type_node, "case_num");
2256   gfc_add_modify (&block, case_num, tmp);
2257
2258   gfc_add_block_to_block (&block, &expr1se.post);
2259
2260   tmp = gfc_finish_block (&body);
2261   tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
2262   gfc_add_expr_to_block (&block, tmp);
2263
2264   tmp = build1_v (LABEL_EXPR, end_label);
2265   gfc_add_expr_to_block (&block, tmp);
2266
2267   return gfc_finish_block (&block);
2268 }
2269
2270
2271 /* Translate the three variants of the SELECT CASE construct.
2272
2273    SELECT CASEs with INTEGER case expressions can be translated to an
2274    equivalent GENERIC switch statement, and for LOGICAL case
2275    expressions we build one or two if-else compares.
2276
2277    SELECT CASEs with CHARACTER case expressions are a whole different
2278    story, because they don't exist in GENERIC.  So we sort them and
2279    do a binary search at runtime.
2280
2281    Fortran has no BREAK statement, and it does not allow jumps from
2282    one case block to another.  That makes things a lot easier for
2283    the optimizers.  */
2284
2285 tree
2286 gfc_trans_select (gfc_code * code)
2287 {
2288   stmtblock_t block;
2289   tree body;
2290   tree exit_label;
2291
2292   gcc_assert (code && code->expr1);
2293   gfc_init_block (&block);
2294
2295   /* Build the exit label and hang it in.  */
2296   exit_label = gfc_build_label_decl (NULL_TREE);
2297   code->exit_label = exit_label;
2298
2299   /* Empty SELECT constructs are legal.  */
2300   if (code->block == NULL)
2301     body = build_empty_stmt (input_location);
2302
2303   /* Select the correct translation function.  */
2304   else
2305     switch (code->expr1->ts.type)
2306       {
2307       case BT_LOGICAL:
2308         body = gfc_trans_logical_select (code);
2309         break;
2310
2311       case BT_INTEGER:
2312         body = gfc_trans_integer_select (code);
2313         break;
2314
2315       case BT_CHARACTER:
2316         body = gfc_trans_character_select (code);
2317         break;
2318
2319       default:
2320         gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2321         /* Not reached */
2322       }
2323
2324   /* Build everything together.  */
2325   gfc_add_expr_to_block (&block, body);
2326   gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
2327
2328   return gfc_finish_block (&block);
2329 }
2330
2331
2332 /* Traversal function to substitute a replacement symtree if the symbol
2333    in the expression is the same as that passed.  f == 2 signals that
2334    that variable itself is not to be checked - only the references.
2335    This group of functions is used when the variable expression in a
2336    FORALL assignment has internal references.  For example:
2337                 FORALL (i = 1:4) p(p(i)) = i
2338    The only recourse here is to store a copy of 'p' for the index
2339    expression.  */
2340
2341 static gfc_symtree *new_symtree;
2342 static gfc_symtree *old_symtree;
2343
2344 static bool
2345 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
2346 {
2347   if (expr->expr_type != EXPR_VARIABLE)
2348     return false;
2349
2350   if (*f == 2)
2351     *f = 1;
2352   else if (expr->symtree->n.sym == sym)
2353     expr->symtree = new_symtree;
2354
2355   return false;
2356 }
2357
2358 static void
2359 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
2360 {
2361   gfc_traverse_expr (e, sym, forall_replace, f);
2362 }
2363
2364 static bool
2365 forall_restore (gfc_expr *expr,
2366                 gfc_symbol *sym ATTRIBUTE_UNUSED,
2367                 int *f ATTRIBUTE_UNUSED)
2368 {
2369   if (expr->expr_type != EXPR_VARIABLE)
2370     return false;
2371
2372   if (expr->symtree == new_symtree)
2373     expr->symtree = old_symtree;
2374
2375   return false;
2376 }
2377
2378 static void
2379 forall_restore_symtree (gfc_expr *e)
2380 {
2381   gfc_traverse_expr (e, NULL, forall_restore, 0);
2382 }
2383
2384 static void
2385 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2386 {
2387   gfc_se tse;
2388   gfc_se rse;
2389   gfc_expr *e;
2390   gfc_symbol *new_sym;
2391   gfc_symbol *old_sym;
2392   gfc_symtree *root;
2393   tree tmp;
2394
2395   /* Build a copy of the lvalue.  */
2396   old_symtree = c->expr1->symtree;
2397   old_sym = old_symtree->n.sym;
2398   e = gfc_lval_expr_from_sym (old_sym);
2399   if (old_sym->attr.dimension)
2400     {
2401       gfc_init_se (&tse, NULL);
2402       gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
2403       gfc_add_block_to_block (pre, &tse.pre);
2404       gfc_add_block_to_block (post, &tse.post);
2405       tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
2406
2407       if (e->ts.type != BT_CHARACTER)
2408         {
2409           /* Use the variable offset for the temporary.  */
2410           tmp = gfc_conv_array_offset (old_sym->backend_decl);
2411           gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
2412         }
2413     }
2414   else
2415     {
2416       gfc_init_se (&tse, NULL);
2417       gfc_init_se (&rse, NULL);
2418       gfc_conv_expr (&rse, e);
2419       if (e->ts.type == BT_CHARACTER)
2420         {
2421           tse.string_length = rse.string_length;
2422           tmp = gfc_get_character_type_len (gfc_default_character_kind,
2423                                             tse.string_length);
2424           tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
2425                                           rse.string_length);
2426           gfc_add_block_to_block (pre, &tse.pre);
2427           gfc_add_block_to_block (post, &tse.post);
2428         }
2429       else
2430         {
2431           tmp = gfc_typenode_for_spec (&e->ts);
2432           tse.expr = gfc_create_var (tmp, "temp");
2433         }
2434
2435       tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
2436                                      e->expr_type == EXPR_VARIABLE, true);
2437       gfc_add_expr_to_block (pre, tmp);
2438     }
2439   gfc_free_expr (e);
2440
2441   /* Create a new symbol to represent the lvalue.  */
2442   new_sym = gfc_new_symbol (old_sym->name, NULL);
2443   new_sym->ts = old_sym->ts;
2444   new_sym->attr.referenced = 1;
2445   new_sym->attr.temporary = 1;
2446   new_sym->attr.dimension = old_sym->attr.dimension;
2447   new_sym->attr.flavor = old_sym->attr.flavor;
2448
2449   /* Use the temporary as the backend_decl.  */
2450   new_sym->backend_decl = tse.expr;
2451
2452   /* Create a fake symtree for it.  */
2453   root = NULL;
2454   new_symtree = gfc_new_symtree (&root, old_sym->name);
2455   new_symtree->n.sym = new_sym;
2456   gcc_assert (new_symtree == root);
2457
2458   /* Go through the expression reference replacing the old_symtree
2459      with the new.  */
2460   forall_replace_symtree (c->expr1, old_sym, 2);
2461
2462   /* Now we have made this temporary, we might as well use it for
2463   the right hand side.  */
2464   forall_replace_symtree (c->expr2, old_sym, 1);
2465 }
2466
2467
2468 /* Handles dependencies in forall assignments.  */
2469 static int
2470 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2471 {
2472   gfc_ref *lref;
2473   gfc_ref *rref;
2474   int need_temp;
2475   gfc_symbol *lsym;
2476
2477   lsym = c->expr1->symtree->n.sym;
2478   need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
2479
2480   /* Now check for dependencies within the 'variable'
2481      expression itself.  These are treated by making a complete
2482      copy of variable and changing all the references to it
2483      point to the copy instead.  Note that the shallow copy of
2484      the variable will not suffice for derived types with
2485      pointer components.  We therefore leave these to their
2486      own devices.  */
2487   if (lsym->ts.type == BT_DERIVED
2488         && lsym->ts.u.derived->attr.pointer_comp)
2489     return need_temp;
2490
2491   new_symtree = NULL;
2492   if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
2493     {
2494       forall_make_variable_temp (c, pre, post);
2495       need_temp = 0;
2496     }
2497
2498   /* Substrings with dependencies are treated in the same
2499      way.  */
2500   if (c->expr1->ts.type == BT_CHARACTER
2501         && c->expr1->ref
2502         && c->expr2->expr_type == EXPR_VARIABLE
2503         && lsym == c->expr2->symtree->n.sym)
2504     {
2505       for (lref = c->expr1->ref; lref; lref = lref->next)
2506         if (lref->type == REF_SUBSTRING)
2507           break;
2508       for (rref = c->expr2->ref; rref; rref = rref->next)
2509         if (rref->type == REF_SUBSTRING)
2510           break;
2511
2512       if (rref && lref
2513             && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
2514         {
2515           forall_make_variable_temp (c, pre, post);
2516           need_temp = 0;
2517         }
2518     }
2519   return need_temp;
2520 }
2521
2522
2523 static void
2524 cleanup_forall_symtrees (gfc_code *c)
2525 {
2526   forall_restore_symtree (c->expr1);
2527   forall_restore_symtree (c->expr2);
2528   free (new_symtree->n.sym);
2529   free (new_symtree);
2530 }
2531
2532
2533 /* Generate the loops for a FORALL block, specified by FORALL_TMP.  BODY
2534    is the contents of the FORALL block/stmt to be iterated.  MASK_FLAG
2535    indicates whether we should generate code to test the FORALLs mask
2536    array.  OUTER is the loop header to be used for initializing mask
2537    indices.
2538
2539    The generated loop format is:
2540     count = (end - start + step) / step
2541     loopvar = start
2542     while (1)
2543       {
2544         if (count <=0 )
2545           goto end_of_loop
2546         <body>
2547         loopvar += step
2548         count --
2549       }
2550     end_of_loop:  */
2551
2552 static tree
2553 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
2554                        int mask_flag, stmtblock_t *outer)
2555 {
2556   int n, nvar;
2557   tree tmp;
2558   tree cond;
2559   stmtblock_t block;
2560   tree exit_label;
2561   tree count;
2562   tree var, start, end, step;
2563   iter_info *iter;
2564
2565   /* Initialize the mask index outside the FORALL nest.  */
2566   if (mask_flag && forall_tmp->mask)
2567     gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
2568
2569   iter = forall_tmp->this_loop;
2570   nvar = forall_tmp->nvar;
2571   for (n = 0; n < nvar; n++)
2572     {
2573       var = iter->var;
2574       start = iter->start;
2575       end = iter->end;
2576       step = iter->step;
2577
2578       exit_label = gfc_build_label_decl (NULL_TREE);
2579       TREE_USED (exit_label) = 1;
2580
2581       /* The loop counter.  */
2582       count = gfc_create_var (TREE_TYPE (var), "count");
2583
2584       /* The body of the loop.  */
2585       gfc_init_block (&block);
2586
2587       /* The exit condition.  */
2588       cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2589                               count, build_int_cst (TREE_TYPE (count), 0));
2590       tmp = build1_v (GOTO_EXPR, exit_label);
2591       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2592                              cond, tmp, build_empty_stmt (input_location));
2593       gfc_add_expr_to_block (&block, tmp);
2594
2595       /* The main loop body.  */
2596       gfc_add_expr_to_block (&block, body);
2597
2598       /* Increment the loop variable.  */
2599       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
2600                              step);
2601       gfc_add_modify (&block, var, tmp);
2602
2603       /* Advance to the next mask element.  Only do this for the
2604          innermost loop.  */
2605       if (n == 0 && mask_flag && forall_tmp->mask)
2606         {
2607           tree maskindex = forall_tmp->maskindex;
2608           tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2609                                  maskindex, gfc_index_one_node);
2610           gfc_add_modify (&block, maskindex, tmp);
2611         }
2612
2613       /* Decrement the loop counter.  */
2614       tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
2615                              build_int_cst (TREE_TYPE (var), 1));
2616       gfc_add_modify (&block, count, tmp);
2617
2618       body = gfc_finish_block (&block);
2619
2620       /* Loop var initialization.  */
2621       gfc_init_block (&block);
2622       gfc_add_modify (&block, var, start);
2623
2624
2625       /* Initialize the loop counter.  */
2626       tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
2627                              start);
2628       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
2629                              tmp);
2630       tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
2631                              tmp, step);
2632       gfc_add_modify (&block, count, tmp);
2633
2634       /* The loop expression.  */
2635       tmp = build1_v (LOOP_EXPR, body);
2636       gfc_add_expr_to_block (&block, tmp);
2637
2638       /* The exit label.  */
2639       tmp = build1_v (LABEL_EXPR, exit_label);
2640       gfc_add_expr_to_block (&block, tmp);
2641
2642       body = gfc_finish_block (&block);
2643       iter = iter->next;
2644     }
2645   return body;
2646 }
2647
2648
2649 /* Generate the body and loops according to MASK_FLAG.  If MASK_FLAG
2650    is nonzero, the body is controlled by all masks in the forall nest.
2651    Otherwise, the innermost loop is not controlled by it's mask.  This
2652    is used for initializing that mask.  */
2653
2654 static tree
2655 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
2656                               int mask_flag)
2657 {
2658   tree tmp;
2659   stmtblock_t header;
2660   forall_info *forall_tmp;
2661   tree mask, maskindex;
2662
2663   gfc_start_block (&header);
2664
2665   forall_tmp = nested_forall_info;
2666   while (forall_tmp != NULL)
2667     {
2668       /* Generate body with masks' control.  */
2669       if (mask_flag)
2670         {
2671           mask = forall_tmp->mask;
2672           maskindex = forall_tmp->maskindex;
2673
2674           /* If a mask was specified make the assignment conditional.  */
2675           if (mask)
2676             {
2677               tmp = gfc_build_array_ref (mask, maskindex, NULL);
2678               body = build3_v (COND_EXPR, tmp, body,
2679                                build_empty_stmt (input_location));
2680             }
2681         }
2682       body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2683       forall_tmp = forall_tmp->prev_nest;
2684       mask_flag = 1;
2685     }
2686
2687   gfc_add_expr_to_block (&header, body);
2688   return gfc_finish_block (&header);
2689 }
2690
2691
2692 /* Allocate data for holding a temporary array.  Returns either a local
2693    temporary array or a pointer variable.  */
2694
2695 static tree
2696 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2697                  tree elem_type)
2698 {
2699   tree tmpvar;
2700   tree type;
2701   tree tmp;
2702
2703   if (INTEGER_CST_P (size))
2704     tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2705                            size, gfc_index_one_node);
2706   else
2707     tmp = NULL_TREE;
2708
2709   type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2710   type = build_array_type (elem_type, type);
2711   if (gfc_can_put_var_on_stack (bytesize))
2712     {
2713       gcc_assert (INTEGER_CST_P (size));
2714       tmpvar = gfc_create_var (type, "temp");
2715       *pdata = NULL_TREE;
2716     }
2717   else
2718     {
2719       tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2720       *pdata = convert (pvoid_type_node, tmpvar);
2721
2722       tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2723       gfc_add_modify (pblock, tmpvar, tmp);
2724     }
2725   return tmpvar;
2726 }
2727
2728
2729 /* Generate codes to copy the temporary to the actual lhs.  */
2730
2731 static tree
2732 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2733                                tree count1, tree wheremask, bool invert)
2734 {
2735   gfc_ss *lss;
2736   gfc_se lse, rse;
2737   stmtblock_t block, body;
2738   gfc_loopinfo loop1;
2739   tree tmp;
2740   tree wheremaskexpr;
2741
2742   /* Walk the lhs.  */
2743   lss = gfc_walk_expr (expr);
2744
2745   if (lss == gfc_ss_terminator)
2746     {
2747       gfc_start_block (&block);
2748
2749       gfc_init_se (&lse, NULL);
2750
2751       /* Translate the expression.  */
2752       gfc_conv_expr (&lse, expr);
2753
2754       /* Form the expression for the temporary.  */
2755       tmp = gfc_build_array_ref (tmp1, count1, NULL);
2756
2757       /* Use the scalar assignment as is.  */
2758       gfc_add_block_to_block (&block, &lse.pre);
2759       gfc_add_modify (&block, lse.expr, tmp);
2760       gfc_add_block_to_block (&block, &lse.post);
2761
2762       /* Increment the count1.  */
2763       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2764                              count1, gfc_index_one_node);
2765       gfc_add_modify (&block, count1, tmp);
2766
2767       tmp = gfc_finish_block (&block);
2768     }
2769   else
2770     {
2771       gfc_start_block (&block);
2772
2773       gfc_init_loopinfo (&loop1);
2774       gfc_init_se (&rse, NULL);
2775       gfc_init_se (&lse, NULL);
2776
2777       /* Associate the lss with the loop.  */
2778       gfc_add_ss_to_loop (&loop1, lss);
2779
2780       /* Calculate the bounds of the scalarization.  */
2781       gfc_conv_ss_startstride (&loop1);
2782       /* Setup the scalarizing loops.  */
2783       gfc_conv_loop_setup (&loop1, &expr->where);
2784
2785       gfc_mark_ss_chain_used (lss, 1);
2786
2787       /* Start the scalarized loop body.  */
2788       gfc_start_scalarized_body (&loop1, &body);
2789
2790       /* Setup the gfc_se structures.  */
2791       gfc_copy_loopinfo_to_se (&lse, &loop1);
2792       lse.ss = lss;
2793
2794       /* Form the expression of the temporary.  */
2795       if (lss != gfc_ss_terminator)
2796         rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2797       /* Translate expr.  */
2798       gfc_conv_expr (&lse, expr);
2799
2800       /* Use the scalar assignment.  */
2801       rse.string_length = lse.string_length;
2802       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
2803
2804       /* Form the mask expression according to the mask tree list.  */
2805       if (wheremask)
2806         {
2807           wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2808           if (invert)
2809             wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2810                                              TREE_TYPE (wheremaskexpr),
2811                                              wheremaskexpr);
2812           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2813                                  wheremaskexpr, tmp,
2814                                  build_empty_stmt (input_location));
2815        }
2816
2817       gfc_add_expr_to_block (&body, tmp);
2818
2819       /* Increment count1.  */
2820       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2821                              count1, gfc_index_one_node);
2822       gfc_add_modify (&body, count1, tmp);
2823
2824       /* Increment count3.  */
2825       if (count3)
2826         {
2827           tmp = fold_build2_loc (input_location, PLUS_EXPR,
2828                                  gfc_array_index_type, count3,
2829                                  gfc_index_one_node);
2830           gfc_add_modify (&body, count3, tmp);
2831         }
2832
2833       /* Generate the copying loops.  */
2834       gfc_trans_scalarizing_loops (&loop1, &body);
2835       gfc_add_block_to_block (&block, &loop1.pre);
2836       gfc_add_block_to_block (&block, &loop1.post);
2837       gfc_cleanup_loop (&loop1);
2838
2839       tmp = gfc_finish_block (&block);
2840     }
2841   return tmp;
2842 }
2843
2844
2845 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2846    temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2847    and should not be freed.  WHEREMASK is the conditional execution mask
2848    whose sense may be inverted by INVERT.  */
2849
2850 static tree
2851 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2852                                tree count1, gfc_ss *lss, gfc_ss *rss,
2853                                tree wheremask, bool invert)
2854 {
2855   stmtblock_t block, body1;
2856   gfc_loopinfo loop;
2857   gfc_se lse;
2858   gfc_se rse;
2859   tree tmp;
2860   tree wheremaskexpr;
2861
2862   gfc_start_block (&block);
2863
2864   gfc_init_se (&rse, NULL);
2865   gfc_init_se (&lse, NULL);
2866
2867   if (lss == gfc_ss_terminator)
2868     {
2869       gfc_init_block (&body1);
2870       gfc_conv_expr (&rse, expr2);
2871       lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2872     }
2873   else
2874     {
2875       /* Initialize the loop.  */
2876       gfc_init_loopinfo (&loop);
2877
2878       /* We may need LSS to determine the shape of the expression.  */
2879       gfc_add_ss_to_loop (&loop, lss);
2880       gfc_add_ss_to_loop (&loop, rss);
2881
2882       gfc_conv_ss_startstride (&loop);
2883       gfc_conv_loop_setup (&loop, &expr2->where);
2884
2885       gfc_mark_ss_chain_used (rss, 1);
2886       /* Start the loop body.  */
2887       gfc_start_scalarized_body (&loop, &body1);
2888
2889       /* Translate the expression.  */
2890       gfc_copy_loopinfo_to_se (&rse, &loop);
2891       rse.ss = rss;
2892       gfc_conv_expr (&rse, expr2);
2893
2894       /* Form the expression of the temporary.  */
2895       lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2896     }
2897
2898   /* Use the scalar assignment.  */
2899   lse.string_length = rse.string_length;
2900   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2901                                  expr2->expr_type == EXPR_VARIABLE, true);
2902
2903   /* Form the mask expression according to the mask tree list.  */
2904   if (wheremask)
2905     {
2906       wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2907       if (invert)
2908         wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
2909                                          TREE_TYPE (wheremaskexpr),
2910                                          wheremaskexpr);
2911       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2912                              wheremaskexpr, tmp,
2913                              build_empty_stmt (input_location));
2914     }
2915
2916   gfc_add_expr_to_block (&body1, tmp);
2917
2918   if (lss == gfc_ss_terminator)
2919     {
2920       gfc_add_block_to_block (&block, &body1);
2921
2922       /* Increment count1.  */
2923       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2924                              count1, gfc_index_one_node);
2925       gfc_add_modify (&block, count1, tmp);
2926     }
2927   else
2928     {
2929       /* Increment count1.  */
2930       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2931                              count1, gfc_index_one_node);
2932       gfc_add_modify (&body1, count1, tmp);
2933
2934       /* Increment count3.  */
2935       if (count3)
2936         {
2937           tmp = fold_build2_loc (input_location, PLUS_EXPR,
2938                                  gfc_array_index_type,
2939                                  count3, gfc_index_one_node);
2940           gfc_add_modify (&body1, count3, tmp);
2941         }
2942
2943       /* Generate the copying loops.  */
2944       gfc_trans_scalarizing_loops (&loop, &body1);
2945
2946       gfc_add_block_to_block (&block, &loop.pre);
2947       gfc_add_block_to_block (&block, &loop.post);
2948
2949       gfc_cleanup_loop (&loop);
2950       /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
2951          as tree nodes in SS may not be valid in different scope.  */
2952     }
2953
2954   tmp = gfc_finish_block (&block);
2955   return tmp;
2956 }
2957
2958
2959 /* Calculate the size of temporary needed in the assignment inside forall.
2960    LSS and RSS are filled in this function.  */
2961
2962 static tree
2963 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
2964                          stmtblock_t * pblock,
2965                          gfc_ss **lss, gfc_ss **rss)
2966 {
2967   gfc_loopinfo loop;
2968   tree size;
2969   int i;
2970   int save_flag;
2971   tree tmp;
2972
2973   *lss = gfc_walk_expr (expr1);
2974   *rss = NULL;
2975
2976   size = gfc_index_one_node;
2977   if (*lss != gfc_ss_terminator)
2978     {
2979       gfc_init_loopinfo (&loop);
2980
2981       /* Walk the RHS of the expression.  */
2982       *rss = gfc_walk_expr (expr2);
2983       if (*rss == gfc_ss_terminator)
2984         {
2985           /* The rhs is scalar.  Add a ss for the expression.  */
2986           *rss = gfc_get_ss ();
2987           (*rss)->next = gfc_ss_terminator;
2988           (*rss)->type = GFC_SS_SCALAR;
2989           (*rss)->expr = expr2;
2990         }
2991
2992       /* Associate the SS with the loop.  */
2993       gfc_add_ss_to_loop (&loop, *lss);
2994       /* We don't actually need to add the rhs at this point, but it might
2995          make guessing the loop bounds a bit easier.  */
2996       gfc_add_ss_to_loop (&loop, *rss);
2997
2998       /* We only want the shape of the expression, not rest of the junk
2999          generated by the scalarizer.  */
3000       loop.array_parameter = 1;
3001
3002       /* Calculate the bounds of the scalarization.  */
3003       save_flag = gfc_option.rtcheck;
3004       gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
3005       gfc_conv_ss_startstride (&loop);
3006       gfc_option.rtcheck = save_flag;
3007       gfc_conv_loop_setup (&loop, &expr2->where);
3008
3009       /* Figure out how many elements we need.  */
3010       for (i = 0; i < loop.dimen; i++)
3011         {
3012           tmp = fold_build2_loc (input_location, MINUS_EXPR,
3013                                  gfc_array_index_type,
3014                                  gfc_index_one_node, loop.from[i]);
3015           tmp = fold_build2_loc (input_location, PLUS_EXPR,
3016                                  gfc_array_index_type, tmp, loop.to[i]);
3017           size = fold_build2_loc (input_location, MULT_EXPR,
3018                                   gfc_array_index_type, size, tmp);
3019         }
3020       gfc_add_block_to_block (pblock, &loop.pre);
3021       size = gfc_evaluate_now (size, pblock);
3022       gfc_add_block_to_block (pblock, &loop.post);
3023
3024       /* TODO: write a function that cleans up a loopinfo without freeing
3025          the SS chains.  Currently a NOP.  */
3026     }
3027
3028   return size;
3029 }
3030
3031
3032 /* Calculate the overall iterator number of the nested forall construct.
3033    This routine actually calculates the number of times the body of the
3034    nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3035    that by the expression INNER_SIZE.  The BLOCK argument specifies the
3036    block in which to calculate the result, and the optional INNER_SIZE_BODY
3037    argument contains any statements that need to executed (inside the loop)
3038    to initialize or calculate INNER_SIZE.  */
3039
3040 static tree
3041 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
3042                              stmtblock_t *inner_size_body, stmtblock_t *block)
3043 {
3044   forall_info *forall_tmp = nested_forall_info;
3045   tree tmp, number;
3046   stmtblock_t body;
3047
3048   /* We can eliminate the innermost unconditional loops with constant
3049      array bounds.  */
3050   if (INTEGER_CST_P (inner_size))
3051     {
3052       while (forall_tmp
3053              && !forall_tmp->mask 
3054              && INTEGER_CST_P (forall_tmp->size))
3055         {
3056           inner_size = fold_build2_loc (input_location, MULT_EXPR,
3057                                         gfc_array_index_type,
3058                                         inner_size, forall_tmp->size);
3059           forall_tmp = forall_tmp->prev_nest;
3060         }
3061
3062       /* If there are no loops left, we have our constant result.  */
3063       if (!forall_tmp)
3064         return inner_size;
3065     }
3066
3067   /* Otherwise, create a temporary variable to compute the result.  */
3068   number = gfc_create_var (gfc_array_index_type, "num");
3069   gfc_add_modify (block, number, gfc_index_zero_node);
3070
3071   gfc_start_block (&body);
3072   if (inner_size_body)
3073     gfc_add_block_to_block (&body, inner_size_body);
3074   if (forall_tmp)
3075     tmp = fold_build2_loc (input_location, PLUS_EXPR,
3076                            gfc_array_index_type, number, inner_size);
3077   else
3078     tmp = inner_size;
3079   gfc_add_modify (&body, number, tmp);
3080   tmp = gfc_finish_block (&body);
3081
3082   /* Generate loops.  */
3083   if (forall_tmp != NULL)
3084     tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
3085
3086   gfc_add_expr_to_block (block, tmp);
3087
3088   return number;
3089 }
3090
3091
3092 /* Allocate temporary for forall construct.  SIZE is the size of temporary
3093    needed.  PTEMP1 is returned for space free.  */
3094
3095 static tree
3096 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
3097                                  tree * ptemp1)
3098 {
3099   tree bytesize;
3100   tree unit;
3101   tree tmp;
3102
3103   unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
3104   if (!integer_onep (unit))
3105     bytesize = fold_build2_loc (input_location, MULT_EXPR,
3106                                 gfc_array_index_type, size, unit);
3107   else
3108     bytesize = size;
3109
3110   *ptemp1 = NULL;
3111   tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
3112
3113   if (*ptemp1)
3114     tmp = build_fold_indirect_ref_loc (input_location, tmp);
3115   return tmp;
3116 }
3117
3118
3119 /* Allocate temporary for forall construct according to the information in
3120    nested_forall_info.  INNER_SIZE is the size of temporary needed in the
3121    assignment inside forall.  PTEMP1 is returned for space free.  */
3122
3123 static tree
3124 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
3125                                tree inner_size, stmtblock_t * inner_size_body,
3126                                stmtblock_t * block, tree * ptemp1)
3127 {
3128   tree size;
3129
3130   /* Calculate the total size of temporary needed in forall construct.  */
3131   size = compute_overall_iter_number (nested_forall_info, inner_size,
3132                                       inner_size_body, block);
3133
3134   return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
3135 }
3136
3137
3138 /* Handle assignments inside forall which need temporary.
3139
3140     forall (i=start:end:stride; maskexpr)
3141       e<i> = f<i>
3142     end forall
3143    (where e,f<i> are arbitrary expressions possibly involving i
3144     and there is a dependency between e<i> and f<i>)
3145    Translates to:
3146     masktmp(:) = maskexpr(:)
3147
3148     maskindex = 0;
3149     count1 = 0;
3150     num = 0;
3151     for (i = start; i <= end; i += stride)
3152       num += SIZE (f<i>)
3153     count1 = 0;
3154     ALLOCATE (tmp(num))
3155     for (i = start; i <= end; i += stride)
3156       {
3157         if (masktmp[maskindex++])
3158           tmp[count1++] = f<i>
3159       }
3160     maskindex = 0;
3161     count1 = 0;
3162     for (i = start; i <= end; i += stride)
3163       {
3164         if (masktmp[maskindex++])
3165           e<i> = tmp[count1++]
3166       }
3167     DEALLOCATE (tmp)
3168   */
3169 static void
3170 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3171                             tree wheremask, bool invert,
3172                             forall_info * nested_forall_info,
3173                             stmtblock_t * block)
3174 {
3175   tree type;
3176   tree inner_size;
3177   gfc_ss *lss, *rss;
3178   tree count, count1;
3179   tree tmp, tmp1;
3180   tree ptemp1;
3181   stmtblock_t inner_size_body;
3182
3183   /* Create vars. count1 is the current iterator number of the nested
3184      forall.  */
3185   count1 = gfc_create_var (gfc_array_index_type, "count1");
3186
3187   /* Count is the wheremask index.  */
3188   if (wheremask)
3189     {
3190       count = gfc_create_var (gfc_array_index_type, "count");
3191       gfc_add_modify (block, count, gfc_index_zero_node);
3192     }
3193   else
3194     count = NULL;
3195
3196   /* Initialize count1.  */
3197   gfc_add_modify (block, count1, gfc_index_zero_node);
3198
3199   /* Calculate the size of temporary needed in the assignment. Return loop, lss
3200      and rss which are used in function generate_loop_for_rhs_to_temp().  */
3201   gfc_init_block (&inner_size_body);
3202   inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
3203                                         &lss, &rss);
3204
3205   /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3206   if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
3207     {
3208       if (!expr1->ts.u.cl->backend_decl)
3209         {
3210           gfc_se tse;
3211           gfc_init_se (&tse, NULL);
3212           gfc_conv_expr (&tse, expr1->ts.u.cl->length);
3213           expr1->ts.u.cl->backend_decl = tse.expr;
3214         }
3215       type = gfc_get_character_type_len (gfc_default_character_kind,
3216                                          expr1->ts.u.cl->backend_decl);
3217     }
3218   else
3219     type = gfc_typenode_for_spec (&expr1->ts);
3220
3221   /* Allocate temporary for nested forall construct according to the
3222      information in nested_forall_info and inner_size.  */
3223   tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
3224                                         &inner_size_body, block, &ptemp1);
3225
3226   /* Generate codes to copy rhs to the temporary .  */
3227   tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
3228                                        wheremask, invert);
3229
3230   /* Generate body and loops according to the information in
3231      nested_forall_info.  */
3232   tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3233   gfc_add_expr_to_block (block, tmp);
3234
3235   /* Reset count1.  */
3236   gfc_add_modify (block, count1, gfc_index_zero_node);
3237
3238   /* Reset count.  */
3239   if (wheremask)
3240     gfc_add_modify (block, count, gfc_index_zero_node);
3241
3242   /* Generate codes to copy the temporary to lhs.  */
3243   tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
3244                                        wheremask, invert);
3245
3246   /* Generate body and loops according to the information in
3247      nested_forall_info.  */
3248   tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3249   gfc_add_expr_to_block (block, tmp);
3250
3251   if (ptemp1)
3252     {
3253       /* Free the temporary.  */
3254       tmp = gfc_call_free (ptemp1);
3255       gfc_add_expr_to_block (block, tmp);
3256     }
3257 }
3258
3259
3260 /* Translate pointer assignment inside FORALL which need temporary.  */
3261
3262 static void
3263 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3264                                     forall_info * nested_forall_info,
3265                                     stmtblock_t * block)
3266 {
3267   tree type;
3268   tree inner_size;
3269   gfc_ss *lss, *rss;
3270   gfc_se lse;
3271   gfc_se rse;
3272   gfc_ss_info *info;
3273   gfc_loopinfo loop;
3274   tree desc;
3275   tree parm;
3276   tree parmtype;
3277   stmtblock_t body;
3278   tree count;
3279   tree tmp, tmp1, ptemp1;
3280
3281   count = gfc_create_var (gfc_array_index_type, "count");
3282   gfc_add_modify (block, count, gfc_index_zero_node);
3283
3284   inner_size = integer_one_node;
3285   lss = gfc_walk_expr (expr1);
3286   rss = gfc_walk_expr (expr2);
3287   if (lss == gfc_ss_terminator)
3288     {
3289       type = gfc_typenode_for_spec (&expr1->ts);
3290       type = build_pointer_type (type);
3291
3292       /* Allocate temporary for nested forall construct according to the
3293          information in nested_forall_info and inner_size.  */
3294       tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
3295                                             inner_size, NULL, block, &ptemp1);
3296       gfc_start_block (&body);
3297       gfc_init_se (&lse, NULL);
3298       lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3299       gfc_init_se (&rse, NULL);
3300       rse.want_pointer = 1;
3301       gfc_conv_expr (&rse, expr2);
3302       gfc_add_block_to_block (&body, &rse.pre);
3303       gfc_add_modify (&body, lse.expr,
3304                            fold_convert (TREE_TYPE (lse.expr), rse.expr));
3305       gfc_add_block_to_block (&body, &rse.post);
3306
3307       /* Increment count.  */
3308       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3309                              count, gfc_index_one_node);
3310       gfc_add_modify (&body, count, tmp);
3311
3312       tmp = gfc_finish_block (&body);
3313
3314       /* Generate body and loops according to the information in
3315          nested_forall_info.  */
3316       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3317       gfc_add_expr_to_block (block, tmp);
3318
3319       /* Reset count.  */
3320       gfc_add_modify (block, count, gfc_index_zero_node);
3321
3322       gfc_start_block (&body);
3323       gfc_init_se (&lse, NULL);
3324       gfc_init_se (&rse, NULL);
3325       rse.expr = gfc_build_array_ref (tmp1, count, NULL);
3326       lse.want_pointer = 1;
3327       gfc_conv_expr (&lse, expr1);
3328       gfc_add_block_to_block (&body, &lse.pre);
3329       gfc_add_modify (&body, lse.expr, rse.expr);
3330       gfc_add_block_to_block (&body, &lse.post);
3331       /* Increment count.  */
3332       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3333                              count, gfc_index_one_node);
3334       gfc_add_modify (&body, count, tmp);
3335       tmp = gfc_finish_block (&body);
3336
3337       /* Generate body and loops according to the information in
3338          nested_forall_info.  */
3339       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3340       gfc_add_expr_to_block (block, tmp);
3341     }
3342   else
3343     {
3344       gfc_init_loopinfo (&loop);
3345
3346       /* Associate the SS with the loop.  */
3347       gfc_add_ss_to_loop (&loop, rss);
3348
3349       /* Setup the scalarizing loops and bounds.  */
3350       gfc_conv_ss_startstride (&loop);
3351
3352       gfc_conv_loop_setup (&loop, &expr2->where);
3353
3354       info = &rss->data.info;
3355       desc = info->descriptor;
3356
3357       /* Make a new descriptor.  */
3358       parmtype = gfc_get_element_type (TREE_TYPE (desc));
3359       parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
3360                                             loop.from, loop.to, 1,
3361                                             GFC_ARRAY_UNKNOWN, true);
3362
3363       /* Allocate temporary for nested forall construct.  */
3364       tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
3365                                             inner_size, NULL, block, &ptemp1);
3366       gfc_start_block (&body);
3367       gfc_init_se (&lse, NULL);
3368       lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3369       lse.direct_byref = 1;
3370       rss = gfc_walk_expr (expr2);
3371       gfc_conv_expr_descriptor (&lse, expr2, rss);
3372
3373       gfc_add_block_to_block (&body, &lse.pre);
3374       gfc_add_block_to_block (&body, &lse.post);
3375
3376       /* Increment count.  */
3377       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3378                              count, gfc_index_one_node);
3379       gfc_add_modify (&body, count, tmp);
3380
3381       tmp = gfc_finish_block (&body);
3382
3383       /* Generate body and loops according to the information in
3384          nested_forall_info.  */
3385       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3386       gfc_add_expr_to_block (block, tmp);
3387
3388       /* Reset count.  */
3389       gfc_add_modify (block, count, gfc_index_zero_node);
3390
3391       parm = gfc_build_array_ref (tmp1, count, NULL);
3392       lss = gfc_walk_expr (expr1);
3393       gfc_init_se (&lse, NULL);
3394       gfc_conv_expr_descriptor (&lse, expr1, lss);
3395       gfc_add_modify (&lse.pre, lse.expr, parm);
3396       gfc_start_block (&body);
3397       gfc_add_block_to_block (&body, &lse.pre);
3398       gfc_add_block_to_block (&body, &lse.post);
3399
3400       /* Increment count.  */
3401       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3402                              count, gfc_index_one_node);
3403       gfc_add_modify (&body, count, tmp);
3404
3405       tmp = gfc_finish_block (&body);
3406
3407       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3408       gfc_add_expr_to_block (block, tmp);
3409     }
3410   /* Free the temporary.  */
3411   if (ptemp1)
3412     {
3413       tmp = gfc_call_free (ptemp1);
3414       gfc_add_expr_to_block (block, tmp);
3415     }