OSDN Git Service

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