OSDN Git Service

2010-09-03 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans.c
1 /* Code translation -- generate GCC trees from gfc_code.
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Paul Brook
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22 #include "config.h"
23 #include "system.h"
24 #include "coretypes.h"
25 #include "tree.h"
26 #include "gimple.h"     /* For create_tmp_var_raw.  */
27 #include "tree-iterator.h"
28 #include "diagnostic-core.h"  /* For internal_error.  */
29 #include "defaults.h"
30 #include "flags.h"
31 #include "gfortran.h"
32 #include "trans.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
37
38 /* Naming convention for backend interface code:
39
40    gfc_trans_*  translate gfc_code into STMT trees.
41
42    gfc_conv_*   expression conversion
43
44    gfc_get_*    get a backend tree representation of a decl or type  */
45
46 static gfc_file *gfc_current_backend_file;
47
48 const char gfc_msg_fault[] = N_("Array reference out of bounds");
49 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
50
51
52 /* Advance along TREE_CHAIN n times.  */
53
54 tree
55 gfc_advance_chain (tree t, int n)
56 {
57   for (; n > 0; n--)
58     {
59       gcc_assert (t != NULL_TREE);
60       t = DECL_CHAIN (t);
61     }
62   return t;
63 }
64
65
66 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
67
68 tree
69 gfc_chainon_list (tree list, tree add)
70 {
71   tree l;
72
73   l = tree_cons (NULL_TREE, add, NULL_TREE);
74
75   return chainon (list, l);
76 }
77
78
79 /* Strip off a legitimate source ending from the input
80    string NAME of length LEN.  */
81
82 static inline void
83 remove_suffix (char *name, int len)
84 {
85   int i;
86
87   for (i = 2; i < 8 && len > i; i++)
88     {
89       if (name[len - i] == '.')
90         {
91           name[len - i] = '\0';
92           break;
93         }
94     }
95 }
96
97
98 /* Creates a variable declaration with a given TYPE.  */
99
100 tree
101 gfc_create_var_np (tree type, const char *prefix)
102 {
103   tree t;
104   
105   t = create_tmp_var_raw (type, prefix);
106
107   /* No warnings for anonymous variables.  */
108   if (prefix == NULL)
109     TREE_NO_WARNING (t) = 1;
110
111   return t;
112 }
113
114
115 /* Like above, but also adds it to the current scope.  */
116
117 tree
118 gfc_create_var (tree type, const char *prefix)
119 {
120   tree tmp;
121
122   tmp = gfc_create_var_np (type, prefix);
123
124   pushdecl (tmp);
125
126   return tmp;
127 }
128
129
130 /* If the expression is not constant, evaluate it now.  We assign the
131    result of the expression to an artificially created variable VAR, and
132    return a pointer to the VAR_DECL node for this variable.  */
133
134 tree
135 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
136 {
137   tree var;
138
139   if (CONSTANT_CLASS_P (expr))
140     return expr;
141
142   var = gfc_create_var (TREE_TYPE (expr), NULL);
143   gfc_add_modify (pblock, var, expr);
144
145   return var;
146 }
147
148
149 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.  
150    A MODIFY_EXPR is an assignment:
151    LHS <- RHS.  */
152
153 void
154 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
155 {
156   tree tmp;
157
158 #ifdef ENABLE_CHECKING
159   tree t1, t2;
160   t1 = TREE_TYPE (rhs);
161   t2 = TREE_TYPE (lhs);
162   /* Make sure that the types of the rhs and the lhs are the same
163      for scalar assignments.  We should probably have something
164      similar for aggregates, but right now removing that check just
165      breaks everything.  */
166   gcc_assert (t1 == t2
167               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
168 #endif
169
170   tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, lhs,
171                          rhs);
172   gfc_add_expr_to_block (pblock, tmp);
173 }
174
175
176 /* Create a new scope/binding level and initialize a block.  Care must be
177    taken when translating expressions as any temporaries will be placed in
178    the innermost scope.  */
179
180 void
181 gfc_start_block (stmtblock_t * block)
182 {
183   /* Start a new binding level.  */
184   pushlevel (0);
185   block->has_scope = 1;
186
187   /* The block is empty.  */
188   block->head = NULL_TREE;
189 }
190
191
192 /* Initialize a block without creating a new scope.  */
193
194 void
195 gfc_init_block (stmtblock_t * block)
196 {
197   block->head = NULL_TREE;
198   block->has_scope = 0;
199 }
200
201
202 /* Sometimes we create a scope but it turns out that we don't actually
203    need it.  This function merges the scope of BLOCK with its parent.
204    Only variable decls will be merged, you still need to add the code.  */
205
206 void
207 gfc_merge_block_scope (stmtblock_t * block)
208 {
209   tree decl;
210   tree next;
211
212   gcc_assert (block->has_scope);
213   block->has_scope = 0;
214
215   /* Remember the decls in this scope.  */
216   decl = getdecls ();
217   poplevel (0, 0, 0);
218
219   /* Add them to the parent scope.  */
220   while (decl != NULL_TREE)
221     {
222       next = DECL_CHAIN (decl);
223       DECL_CHAIN (decl) = NULL_TREE;
224
225       pushdecl (decl);
226       decl = next;
227     }
228 }
229
230
231 /* Finish a scope containing a block of statements.  */
232
233 tree
234 gfc_finish_block (stmtblock_t * stmtblock)
235 {
236   tree decl;
237   tree expr;
238   tree block;
239
240   expr = stmtblock->head;
241   if (!expr)
242     expr = build_empty_stmt (input_location);
243
244   stmtblock->head = NULL_TREE;
245
246   if (stmtblock->has_scope)
247     {
248       decl = getdecls ();
249
250       if (decl)
251         {
252           block = poplevel (1, 0, 0);
253           expr = build3_v (BIND_EXPR, decl, expr, block);
254         }
255       else
256         poplevel (0, 0, 0);
257     }
258
259   return expr;
260 }
261
262
263 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
264    natural type is used.  */
265
266 tree
267 gfc_build_addr_expr (tree type, tree t)
268 {
269   tree base_type = TREE_TYPE (t);
270   tree natural_type;
271
272   if (type && POINTER_TYPE_P (type)
273       && TREE_CODE (base_type) == ARRAY_TYPE
274       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
275          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
276     {
277       tree min_val = size_zero_node;
278       tree type_domain = TYPE_DOMAIN (base_type);
279       if (type_domain && TYPE_MIN_VALUE (type_domain))
280         min_val = TYPE_MIN_VALUE (type_domain);
281       t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
282                         t, min_val, NULL_TREE, NULL_TREE));
283       natural_type = type;
284     }
285   else
286     natural_type = build_pointer_type (base_type);
287
288   if (TREE_CODE (t) == INDIRECT_REF)
289     {
290       if (!type)
291         type = natural_type;
292       t = TREE_OPERAND (t, 0);
293       natural_type = TREE_TYPE (t);
294     }
295   else
296     {
297       tree base = get_base_address (t);
298       if (base && DECL_P (base))
299         TREE_ADDRESSABLE (base) = 1;
300       t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
301     }
302
303   if (type && natural_type != type)
304     t = convert (type, t);
305
306   return t;
307 }
308
309
310 /* Build an ARRAY_REF with its natural type.  */
311
312 tree
313 gfc_build_array_ref (tree base, tree offset, tree decl)
314 {
315   tree type = TREE_TYPE (base);
316   tree tmp;
317
318   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
319   type = TREE_TYPE (type);
320
321   if (DECL_P (base))
322     TREE_ADDRESSABLE (base) = 1;
323
324   /* Strip NON_LVALUE_EXPR nodes.  */
325   STRIP_TYPE_NOPS (offset);
326
327   /* If the array reference is to a pointer, whose target contains a
328      subreference, use the span that is stored with the backend decl
329      and reference the element with pointer arithmetic.  */
330   if (decl && (TREE_CODE (decl) == FIELD_DECL
331                  || TREE_CODE (decl) == VAR_DECL
332                  || TREE_CODE (decl) == PARM_DECL)
333         && GFC_DECL_SUBREF_ARRAY_P (decl)
334         && !integer_zerop (GFC_DECL_SPAN(decl)))
335     {
336       offset = fold_build2_loc (input_location, MULT_EXPR,
337                                 gfc_array_index_type,
338                                 offset, GFC_DECL_SPAN(decl));
339       tmp = gfc_build_addr_expr (pvoid_type_node, base);
340       tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
341                              pvoid_type_node, tmp,
342                              fold_convert (sizetype, offset));
343       tmp = fold_convert (build_pointer_type (type), tmp);
344       if (!TYPE_STRING_FLAG (type))
345         tmp = build_fold_indirect_ref_loc (input_location, tmp);
346       return tmp;
347     }
348   else
349     /* Otherwise use a straightforward array reference.  */
350     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
351 }
352
353
354 /* Generate a call to print a runtime error possibly including multiple
355    arguments and a locus.  */
356
357 tree
358 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
359 {
360   va_list ap;
361
362   va_start (ap, msgid);
363   return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
364 }
365
366 tree
367 gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
368                                 va_list ap)
369 {
370   stmtblock_t block;
371   tree tmp;
372   tree arg, arg2;
373   tree *argarray;
374   tree fntype;
375   char *message;
376   const char *p;
377   int line, nargs, i;
378
379   /* Compute the number of extra arguments from the format string.  */
380   for (p = msgid, nargs = 0; *p; p++)
381     if (*p == '%')
382       {
383         p++;
384         if (*p != '%')
385           nargs++;
386       }
387
388   /* The code to generate the error.  */
389   gfc_start_block (&block);
390
391   if (where)
392     {
393       line = LOCATION_LINE (where->lb->location);
394       asprintf (&message, "At line %d of file %s",  line,
395                 where->lb->file->filename);
396     }
397   else
398     asprintf (&message, "In file '%s', around line %d",
399               gfc_source_file, input_line + 1);
400
401   arg = gfc_build_addr_expr (pchar_type_node,
402                              gfc_build_localized_cstring_const (message));
403   gfc_free(message);
404   
405   asprintf (&message, "%s", _(msgid));
406   arg2 = gfc_build_addr_expr (pchar_type_node,
407                               gfc_build_localized_cstring_const (message));
408   gfc_free(message);
409
410   /* Build the argument array.  */
411   argarray = XALLOCAVEC (tree, nargs + 2);
412   argarray[0] = arg;
413   argarray[1] = arg2;
414   for (i = 0; i < nargs; i++)
415     argarray[2 + i] = va_arg (ap, tree);
416   va_end (ap);
417   
418   /* Build the function call to runtime_(warning,error)_at; because of the
419      variable number of arguments, we can't use build_call_expr_loc dinput_location,
420      irectly.  */
421   if (error)
422     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
423   else
424     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
425
426   tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
427                                  fold_build1_loc (input_location, ADDR_EXPR,
428                                              build_pointer_type (fntype),
429                                              error
430                                              ? gfor_fndecl_runtime_error_at
431                                              : gfor_fndecl_runtime_warning_at),
432                                  nargs + 2, argarray);
433   gfc_add_expr_to_block (&block, tmp);
434
435   return gfc_finish_block (&block);
436 }
437
438
439 /* Generate a runtime error if COND is true.  */
440
441 void
442 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
443                          locus * where, const char * msgid, ...)
444 {
445   va_list ap;
446   stmtblock_t block;
447   tree body;
448   tree tmp;
449   tree tmpvar = NULL;
450
451   if (integer_zerop (cond))
452     return;
453
454   if (once)
455     {
456        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
457        TREE_STATIC (tmpvar) = 1;
458        DECL_INITIAL (tmpvar) = boolean_true_node;
459        gfc_add_expr_to_block (pblock, tmpvar);
460     }
461
462   gfc_start_block (&block);
463
464   /* The code to generate the error.  */
465   va_start (ap, msgid);
466   gfc_add_expr_to_block (&block,
467                          gfc_trans_runtime_error_vararg (error, where,
468                                                          msgid, ap));
469
470   if (once)
471     gfc_add_modify (&block, tmpvar, boolean_false_node);
472
473   body = gfc_finish_block (&block);
474
475   if (integer_onep (cond))
476     {
477       gfc_add_expr_to_block (pblock, body);
478     }
479   else
480     {
481       /* Tell the compiler that this isn't likely.  */
482       if (once)
483         cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
484                                 long_integer_type_node, tmpvar, cond);
485       else
486         cond = fold_convert (long_integer_type_node, cond);
487
488       tmp = build_int_cst (long_integer_type_node, 0);
489       cond = build_call_expr_loc (input_location,
490                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
491       cond = fold_convert (boolean_type_node, cond);
492
493       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
494       gfc_add_expr_to_block (pblock, tmp);
495     }
496 }
497
498
499 /* Call malloc to allocate size bytes of memory, with special conditions:
500       + if size <= 0, return a malloced area of size 1,
501       + if malloc returns NULL, issue a runtime error.  */
502 tree
503 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
504 {
505   tree tmp, msg, malloc_result, null_result, res;
506   stmtblock_t block2;
507
508   size = gfc_evaluate_now (size, block);
509
510   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
511     size = fold_convert (size_type_node, size);
512
513   /* Create a variable to hold the result.  */
514   res = gfc_create_var (prvoid_type_node, NULL);
515
516   /* Call malloc.  */
517   gfc_start_block (&block2);
518
519   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
520                           build_int_cst (size_type_node, 1));
521
522   gfc_add_modify (&block2, res,
523                   fold_convert (prvoid_type_node,
524                                 build_call_expr_loc (input_location,
525                                    built_in_decls[BUILT_IN_MALLOC], 1, size)));
526
527   /* Optionally check whether malloc was successful.  */
528   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
529     {
530       null_result = fold_build2_loc (input_location, EQ_EXPR,
531                                      boolean_type_node, res,
532                                      build_int_cst (pvoid_type_node, 0));
533       msg = gfc_build_addr_expr (pchar_type_node,
534               gfc_build_localized_cstring_const ("Memory allocation failed"));
535       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
536                              null_result,
537               build_call_expr_loc (input_location,
538                                    gfor_fndecl_os_error, 1, msg),
539                                    build_empty_stmt (input_location));
540       gfc_add_expr_to_block (&block2, tmp);
541     }
542
543   malloc_result = gfc_finish_block (&block2);
544
545   gfc_add_expr_to_block (block, malloc_result);
546
547   if (type != NULL)
548     res = fold_convert (type, res);
549   return res;
550 }
551
552
553 /* Allocate memory, using an optional status argument.
554  
555    This function follows the following pseudo-code:
556
557     void *
558     allocate (size_t size, integer_type* stat)
559     {
560       void *newmem;
561     
562       if (stat)
563         *stat = 0;
564
565       // The only time this can happen is the size wraps around.
566       if (size < 0)
567       {
568         if (stat)
569         {
570           *stat = LIBERROR_ALLOCATION;
571           newmem = NULL;
572         }
573         else
574           runtime_error ("Attempt to allocate negative amount of memory. "
575                          "Possible integer overflow");
576       }
577       else
578       {
579         newmem = malloc (MAX (size, 1));
580         if (newmem == NULL)
581         {
582           if (stat)
583             *stat = LIBERROR_ALLOCATION;
584           else
585             runtime_error ("Out of memory");
586         }
587       }
588
589       return newmem;
590     }  */
591 tree
592 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
593 {
594   stmtblock_t alloc_block;
595   tree res, tmp, error, msg, cond;
596   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
597
598   /* Evaluate size only once, and make sure it has the right type.  */
599   size = gfc_evaluate_now (size, block);
600   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
601     size = fold_convert (size_type_node, size);
602
603   /* Create a variable to hold the result.  */
604   res = gfc_create_var (prvoid_type_node, NULL);
605
606   /* Set the optional status variable to zero.  */
607   if (status != NULL_TREE && !integer_zerop (status))
608     {
609       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
610                              fold_build1_loc (input_location, INDIRECT_REF,
611                                               status_type, status),
612                              build_int_cst (status_type, 0));
613       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
614                              fold_build2_loc (input_location, NE_EXPR,
615                                         boolean_type_node, status,
616                                         build_int_cst (TREE_TYPE (status), 0)),
617                              tmp, build_empty_stmt (input_location));
618       gfc_add_expr_to_block (block, tmp);
619     }
620
621   /* Generate the block of code handling (size < 0).  */
622   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
623                         ("Attempt to allocate negative amount of memory. "
624                          "Possible integer overflow"));
625   error = build_call_expr_loc (input_location,
626                            gfor_fndecl_runtime_error, 1, msg);
627
628   if (status != NULL_TREE && !integer_zerop (status))
629     {
630       /* Set the status variable if it's present.  */
631       stmtblock_t set_status_block;
632
633       gfc_start_block (&set_status_block);
634       gfc_add_modify (&set_status_block,
635                       fold_build1_loc (input_location, INDIRECT_REF,
636                                        status_type, status),
637                            build_int_cst (status_type, LIBERROR_ALLOCATION));
638       gfc_add_modify (&set_status_block, res,
639                            build_int_cst (prvoid_type_node, 0));
640
641       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
642                              status, build_int_cst (TREE_TYPE (status), 0));
643       error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
644                                error, gfc_finish_block (&set_status_block));
645     }
646
647   /* The allocation itself.  */
648   gfc_start_block (&alloc_block);
649   gfc_add_modify (&alloc_block, res,
650                   fold_convert (prvoid_type_node,
651                                 build_call_expr_loc (input_location,
652                                    built_in_decls[BUILT_IN_MALLOC], 1,
653                                         fold_build2_loc (input_location,
654                                             MAX_EXPR, size_type_node, size,
655                                             build_int_cst (size_type_node,
656                                                            1)))));
657
658   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
659                                                 ("Out of memory"));
660   tmp = build_call_expr_loc (input_location,
661                          gfor_fndecl_os_error, 1, msg);
662
663   if (status != NULL_TREE && !integer_zerop (status))
664     {
665       /* Set the status variable if it's present.  */
666       tree tmp2;
667
668       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
669                               status, build_int_cst (TREE_TYPE (status), 0));
670       tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
671                               fold_build1_loc (input_location, INDIRECT_REF,
672                                                status_type, status),
673                               build_int_cst (status_type, LIBERROR_ALLOCATION));
674       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
675                              tmp, tmp2);
676     }
677
678   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
679                          fold_build2_loc (input_location, EQ_EXPR,
680                                           boolean_type_node, res,
681                                           build_int_cst (prvoid_type_node, 0)),
682                          tmp, build_empty_stmt (input_location));
683   gfc_add_expr_to_block (&alloc_block, tmp);
684
685   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size,
686                           build_int_cst (TREE_TYPE (size), 0));
687   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, error,
688                          gfc_finish_block (&alloc_block));
689   gfc_add_expr_to_block (block, tmp);
690
691   return res;
692 }
693
694
695 /* Generate code for an ALLOCATE statement when the argument is an
696    allocatable array.  If the array is currently allocated, it is an
697    error to allocate it again.
698  
699    This function follows the following pseudo-code:
700   
701     void *
702     allocate_array (void *mem, size_t size, integer_type *stat)
703     {
704       if (mem == NULL)
705         return allocate (size, stat);
706       else
707       {
708         if (stat)
709         {
710           free (mem);
711           mem = allocate (size, stat);
712           *stat = LIBERROR_ALLOCATION;
713           return mem;
714         }
715         else
716           runtime_error ("Attempting to allocate already allocated variable");
717       }
718     }
719     
720     expr must be set to the original expression being allocated for its locus
721     and variable name in case a runtime error has to be printed.  */
722 tree
723 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
724                                 tree status, gfc_expr* expr)
725 {
726   stmtblock_t alloc_block;
727   tree res, tmp, null_mem, alloc, error;
728   tree type = TREE_TYPE (mem);
729
730   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
731     size = fold_convert (size_type_node, size);
732
733   /* Create a variable to hold the result.  */
734   res = gfc_create_var (type, NULL);
735   null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
736                               build_int_cst (type, 0));
737
738   /* If mem is NULL, we call gfc_allocate_with_status.  */
739   gfc_start_block (&alloc_block);
740   tmp = gfc_allocate_with_status (&alloc_block, size, status);
741   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
742   alloc = gfc_finish_block (&alloc_block);
743
744   /* Otherwise, we issue a runtime error or set the status variable.  */
745   if (expr)
746     {
747       tree varname;
748
749       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
750       varname = gfc_build_cstring_const (expr->symtree->name);
751       varname = gfc_build_addr_expr (pchar_type_node, varname);
752
753       error = gfc_trans_runtime_error (true, &expr->where,
754                                        "Attempting to allocate already"
755                                        " allocated variable '%s'",
756                                        varname);
757     }
758   else
759     error = gfc_trans_runtime_error (true, NULL,
760                                      "Attempting to allocate already allocated"
761                                      "variable");
762
763   if (status != NULL_TREE && !integer_zerop (status))
764     {
765       tree status_type = TREE_TYPE (TREE_TYPE (status));
766       stmtblock_t set_status_block;
767
768       gfc_start_block (&set_status_block);
769       tmp = build_call_expr_loc (input_location,
770                              built_in_decls[BUILT_IN_FREE], 1,
771                              fold_convert (pvoid_type_node, mem));
772       gfc_add_expr_to_block (&set_status_block, tmp);
773
774       tmp = gfc_allocate_with_status (&set_status_block, size, status);
775       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
776
777       gfc_add_modify (&set_status_block,
778                            fold_build1_loc (input_location, INDIRECT_REF,
779                                             status_type, status),
780                            build_int_cst (status_type, LIBERROR_ALLOCATION));
781
782       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
783                              status, build_int_cst (status_type, 0));
784       error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
785                                error, gfc_finish_block (&set_status_block));
786     }
787
788   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
789                          alloc, error);
790   gfc_add_expr_to_block (block, tmp);
791
792   return res;
793 }
794
795
796 /* Free a given variable, if it's not NULL.  */
797 tree
798 gfc_call_free (tree var)
799 {
800   stmtblock_t block;
801   tree tmp, cond, call;
802
803   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
804     var = fold_convert (pvoid_type_node, var);
805
806   gfc_start_block (&block);
807   var = gfc_evaluate_now (var, &block);
808   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
809                           build_int_cst (pvoid_type_node, 0));
810   call = build_call_expr_loc (input_location,
811                               built_in_decls[BUILT_IN_FREE], 1, var);
812   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
813                          build_empty_stmt (input_location));
814   gfc_add_expr_to_block (&block, tmp);
815
816   return gfc_finish_block (&block);
817 }
818
819
820
821 /* User-deallocate; we emit the code directly from the front-end, and the
822    logic is the same as the previous library function:
823
824     void
825     deallocate (void *pointer, GFC_INTEGER_4 * stat)
826     {
827       if (!pointer)
828         {
829           if (stat)
830             *stat = 1;
831           else
832             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
833         }
834       else
835         {
836           free (pointer);
837           if (stat)
838             *stat = 0;
839         }
840     }
841
842    In this front-end version, status doesn't have to be GFC_INTEGER_4.
843    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
844    even when no status variable is passed to us (this is used for
845    unconditional deallocation generated by the front-end at end of
846    each procedure).
847    
848    If a runtime-message is possible, `expr' must point to the original
849    expression being deallocated for its locus and variable name.  */
850 tree
851 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
852                             gfc_expr* expr)
853 {
854   stmtblock_t null, non_null;
855   tree cond, tmp, error;
856
857   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
858                           build_int_cst (TREE_TYPE (pointer), 0));
859
860   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
861      we emit a runtime error.  */
862   gfc_start_block (&null);
863   if (!can_fail)
864     {
865       tree varname;
866
867       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
868
869       varname = gfc_build_cstring_const (expr->symtree->name);
870       varname = gfc_build_addr_expr (pchar_type_node, varname);
871
872       error = gfc_trans_runtime_error (true, &expr->where,
873                                        "Attempt to DEALLOCATE unallocated '%s'",
874                                        varname);
875     }
876   else
877     error = build_empty_stmt (input_location);
878
879   if (status != NULL_TREE && !integer_zerop (status))
880     {
881       tree status_type = TREE_TYPE (TREE_TYPE (status));
882       tree cond2;
883
884       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
885                                status, build_int_cst (TREE_TYPE (status), 0));
886       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
887                              fold_build1_loc (input_location, INDIRECT_REF,
888                                               status_type, status),
889                              build_int_cst (status_type, 1));
890       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
891                                cond2, tmp, error);
892     }
893
894   gfc_add_expr_to_block (&null, error);
895
896   /* When POINTER is not NULL, we free it.  */
897   gfc_start_block (&non_null);
898   tmp = build_call_expr_loc (input_location,
899                          built_in_decls[BUILT_IN_FREE], 1,
900                          fold_convert (pvoid_type_node, pointer));
901   gfc_add_expr_to_block (&non_null, tmp);
902
903   if (status != NULL_TREE && !integer_zerop (status))
904     {
905       /* We set STATUS to zero if it is present.  */
906       tree status_type = TREE_TYPE (TREE_TYPE (status));
907       tree cond2;
908
909       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
910                                status, build_int_cst (TREE_TYPE (status), 0));
911       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
912                              fold_build1_loc (input_location, INDIRECT_REF,
913                                               status_type, status),
914                              build_int_cst (status_type, 0));
915       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
916                              tmp, build_empty_stmt (input_location));
917       gfc_add_expr_to_block (&non_null, tmp);
918     }
919
920   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
921                           gfc_finish_block (&null),
922                           gfc_finish_block (&non_null));
923 }
924
925
926 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
927    following pseudo-code:
928
929 void *
930 internal_realloc (void *mem, size_t size)
931 {
932   if (size < 0)
933     runtime_error ("Attempt to allocate a negative amount of memory.");
934   res = realloc (mem, size);
935   if (!res && size != 0)
936     _gfortran_os_error ("Out of memory");
937
938   if (size == 0)
939     return NULL;
940
941   return res;
942 }  */
943 tree
944 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
945 {
946   tree msg, res, negative, nonzero, zero, null_result, tmp;
947   tree type = TREE_TYPE (mem);
948
949   size = gfc_evaluate_now (size, block);
950
951   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
952     size = fold_convert (size_type_node, size);
953
954   /* Create a variable to hold the result.  */
955   res = gfc_create_var (type, NULL);
956
957   /* size < 0 ?  */
958   negative = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size,
959                               build_int_cst (size_type_node, 0));
960   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
961       ("Attempt to allocate a negative amount of memory."));
962   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, negative,
963                          build_call_expr_loc (input_location,
964                                             gfor_fndecl_runtime_error, 1, msg),
965                          build_empty_stmt (input_location));
966   gfc_add_expr_to_block (block, tmp);
967
968   /* Call realloc and check the result.  */
969   tmp = build_call_expr_loc (input_location,
970                          built_in_decls[BUILT_IN_REALLOC], 2,
971                          fold_convert (pvoid_type_node, mem), size);
972   gfc_add_modify (block, res, fold_convert (type, tmp));
973   null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
974                                  res, build_int_cst (pvoid_type_node, 0));
975   nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
976                              build_int_cst (size_type_node, 0));
977   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
978                                  null_result, nonzero);
979   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
980                                                 ("Out of memory"));
981   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
982                          null_result,
983                          build_call_expr_loc (input_location,
984                                               gfor_fndecl_os_error, 1, msg),
985                          build_empty_stmt (input_location));
986   gfc_add_expr_to_block (block, tmp);
987
988   /* if (size == 0) then the result is NULL.  */
989   tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
990                          build_int_cst (type, 0));
991   zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
992                           nonzero);
993   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
994                          build_empty_stmt (input_location));
995   gfc_add_expr_to_block (block, tmp);
996
997   return res;
998 }
999
1000
1001 /* Add an expression to another one, either at the front or the back.  */
1002
1003 static void
1004 add_expr_to_chain (tree* chain, tree expr, bool front)
1005 {
1006   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1007     return;
1008
1009   if (*chain)
1010     {
1011       if (TREE_CODE (*chain) != STATEMENT_LIST)
1012         {
1013           tree tmp;
1014
1015           tmp = *chain;
1016           *chain = NULL_TREE;
1017           append_to_statement_list (tmp, chain);
1018         }
1019
1020       if (front)
1021         {
1022           tree_stmt_iterator i;
1023
1024           i = tsi_start (*chain);
1025           tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1026         }
1027       else
1028         append_to_statement_list (expr, chain);
1029     }
1030   else
1031     *chain = expr;
1032 }
1033
1034 /* Add a statement to a block.  */
1035
1036 void
1037 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1038 {
1039   gcc_assert (block);
1040   add_expr_to_chain (&block->head, expr, false);
1041 }
1042
1043
1044 /* Add a block the end of a block.  */
1045
1046 void
1047 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1048 {
1049   gcc_assert (append);
1050   gcc_assert (!append->has_scope);
1051
1052   gfc_add_expr_to_block (block, append->head);
1053   append->head = NULL_TREE;
1054 }
1055
1056
1057 /* Get the current locus.  The structure may not be complete, and should
1058    only be used with gfc_set_backend_locus.  */
1059
1060 void
1061 gfc_get_backend_locus (locus * loc)
1062 {
1063   loc->lb = XCNEW (gfc_linebuf);
1064   loc->lb->location = input_location;
1065   loc->lb->file = gfc_current_backend_file;
1066 }
1067
1068
1069 /* Set the current locus.  */
1070
1071 void
1072 gfc_set_backend_locus (locus * loc)
1073 {
1074   gfc_current_backend_file = loc->lb->file;
1075   input_location = loc->lb->location;
1076 }
1077
1078
1079 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1080    This static function is wrapped by gfc_trans_code_cond and
1081    gfc_trans_code.  */
1082
1083 static tree
1084 trans_code (gfc_code * code, tree cond)
1085 {
1086   stmtblock_t block;
1087   tree res;
1088
1089   if (!code)
1090     return build_empty_stmt (input_location);
1091
1092   gfc_start_block (&block);
1093
1094   /* Translate statements one by one into GENERIC trees until we reach
1095      the end of this gfc_code branch.  */
1096   for (; code; code = code->next)
1097     {
1098       if (code->here != 0)
1099         {
1100           res = gfc_trans_label_here (code);
1101           gfc_add_expr_to_block (&block, res);
1102         }
1103
1104       gfc_set_backend_locus (&code->loc);
1105
1106       switch (code->op)
1107         {
1108         case EXEC_NOP:
1109         case EXEC_END_BLOCK:
1110         case EXEC_END_PROCEDURE:
1111           res = NULL_TREE;
1112           break;
1113
1114         case EXEC_ASSIGN:
1115           if (code->expr1->ts.type == BT_CLASS)
1116             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1117           else
1118             res = gfc_trans_assign (code);
1119           break;
1120
1121         case EXEC_LABEL_ASSIGN:
1122           res = gfc_trans_label_assign (code);
1123           break;
1124
1125         case EXEC_POINTER_ASSIGN:
1126           if (code->expr1->ts.type == BT_CLASS)
1127             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1128           else
1129             res = gfc_trans_pointer_assign (code);
1130           break;
1131
1132         case EXEC_INIT_ASSIGN:
1133           if (code->expr1->ts.type == BT_CLASS)
1134             res = gfc_trans_class_init_assign (code);
1135           else
1136             res = gfc_trans_init_assign (code);
1137           break;
1138
1139         case EXEC_CONTINUE:
1140           res = NULL_TREE;
1141           break;
1142
1143         case EXEC_CRITICAL:
1144           res = gfc_trans_critical (code);
1145           break;
1146
1147         case EXEC_CYCLE:
1148           res = gfc_trans_cycle (code);
1149           break;
1150
1151         case EXEC_EXIT:
1152           res = gfc_trans_exit (code);
1153           break;
1154
1155         case EXEC_GOTO:
1156           res = gfc_trans_goto (code);
1157           break;
1158
1159         case EXEC_ENTRY:
1160           res = gfc_trans_entry (code);
1161           break;
1162
1163         case EXEC_PAUSE:
1164           res = gfc_trans_pause (code);
1165           break;
1166
1167         case EXEC_STOP:
1168         case EXEC_ERROR_STOP:
1169           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1170           break;
1171
1172         case EXEC_CALL:
1173           /* For MVBITS we've got the special exception that we need a
1174              dependency check, too.  */
1175           {
1176             bool is_mvbits = false;
1177             if (code->resolved_isym
1178                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1179               is_mvbits = true;
1180             if (code->resolved_isym
1181                 && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
1182               res = gfc_conv_intrinsic_move_alloc (code);
1183             else
1184               res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1185                                     NULL_TREE, false);
1186           }
1187           break;
1188
1189         case EXEC_CALL_PPC:
1190           res = gfc_trans_call (code, false, NULL_TREE,
1191                                 NULL_TREE, false);
1192           break;
1193
1194         case EXEC_ASSIGN_CALL:
1195           res = gfc_trans_call (code, true, NULL_TREE,
1196                                 NULL_TREE, false);
1197           break;
1198
1199         case EXEC_RETURN:
1200           res = gfc_trans_return (code);
1201           break;
1202
1203         case EXEC_IF:
1204           res = gfc_trans_if (code);
1205           break;
1206
1207         case EXEC_ARITHMETIC_IF:
1208           res = gfc_trans_arithmetic_if (code);
1209           break;
1210
1211         case EXEC_BLOCK:
1212           res = gfc_trans_block_construct (code);
1213           break;
1214
1215         case EXEC_DO:
1216           res = gfc_trans_do (code, cond);
1217           break;
1218
1219         case EXEC_DO_WHILE:
1220           res = gfc_trans_do_while (code);
1221           break;
1222
1223         case EXEC_SELECT:
1224           res = gfc_trans_select (code);
1225           break;
1226
1227         case EXEC_SELECT_TYPE:
1228           /* Do nothing. SELECT TYPE statements should be transformed into
1229           an ordinary SELECT CASE at resolution stage.
1230           TODO: Add an error message here once this is done.  */
1231           res = NULL_TREE;
1232           break;
1233
1234         case EXEC_FLUSH:
1235           res = gfc_trans_flush (code);
1236           break;
1237
1238         case EXEC_SYNC_ALL:
1239         case EXEC_SYNC_IMAGES:
1240         case EXEC_SYNC_MEMORY:
1241           res = gfc_trans_sync (code, code->op);
1242           break;
1243
1244         case EXEC_FORALL:
1245           res = gfc_trans_forall (code);
1246           break;
1247
1248         case EXEC_WHERE:
1249           res = gfc_trans_where (code);
1250           break;
1251
1252         case EXEC_ALLOCATE:
1253           res = gfc_trans_allocate (code);
1254           break;
1255
1256         case EXEC_DEALLOCATE:
1257           res = gfc_trans_deallocate (code);
1258           break;
1259
1260         case EXEC_OPEN:
1261           res = gfc_trans_open (code);
1262           break;
1263
1264         case EXEC_CLOSE:
1265           res = gfc_trans_close (code);
1266           break;
1267
1268         case EXEC_READ:
1269           res = gfc_trans_read (code);
1270           break;
1271
1272         case EXEC_WRITE:
1273           res = gfc_trans_write (code);
1274           break;
1275
1276         case EXEC_IOLENGTH:
1277           res = gfc_trans_iolength (code);
1278           break;
1279
1280         case EXEC_BACKSPACE:
1281           res = gfc_trans_backspace (code);
1282           break;
1283
1284         case EXEC_ENDFILE:
1285           res = gfc_trans_endfile (code);
1286           break;
1287
1288         case EXEC_INQUIRE:
1289           res = gfc_trans_inquire (code);
1290           break;
1291
1292         case EXEC_WAIT:
1293           res = gfc_trans_wait (code);
1294           break;
1295
1296         case EXEC_REWIND:
1297           res = gfc_trans_rewind (code);
1298           break;
1299
1300         case EXEC_TRANSFER:
1301           res = gfc_trans_transfer (code);
1302           break;
1303
1304         case EXEC_DT_END:
1305           res = gfc_trans_dt_end (code);
1306           break;
1307
1308         case EXEC_OMP_ATOMIC:
1309         case EXEC_OMP_BARRIER:
1310         case EXEC_OMP_CRITICAL:
1311         case EXEC_OMP_DO:
1312         case EXEC_OMP_FLUSH:
1313         case EXEC_OMP_MASTER:
1314         case EXEC_OMP_ORDERED:
1315         case EXEC_OMP_PARALLEL:
1316         case EXEC_OMP_PARALLEL_DO:
1317         case EXEC_OMP_PARALLEL_SECTIONS:
1318         case EXEC_OMP_PARALLEL_WORKSHARE:
1319         case EXEC_OMP_SECTIONS:
1320         case EXEC_OMP_SINGLE:
1321         case EXEC_OMP_TASK:
1322         case EXEC_OMP_TASKWAIT:
1323         case EXEC_OMP_WORKSHARE:
1324           res = gfc_trans_omp_directive (code);
1325           break;
1326
1327         default:
1328           internal_error ("gfc_trans_code(): Bad statement code");
1329         }
1330
1331       gfc_set_backend_locus (&code->loc);
1332
1333       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1334         {
1335           if (TREE_CODE (res) != STATEMENT_LIST)
1336             SET_EXPR_LOCATION (res, input_location);
1337             
1338           /* Add the new statement to the block.  */
1339           gfc_add_expr_to_block (&block, res);
1340         }
1341     }
1342
1343   /* Return the finished block.  */
1344   return gfc_finish_block (&block);
1345 }
1346
1347
1348 /* Translate an executable statement with condition, cond.  The condition is
1349    used by gfc_trans_do to test for IO result conditions inside implied
1350    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1351
1352 tree
1353 gfc_trans_code_cond (gfc_code * code, tree cond)
1354 {
1355   return trans_code (code, cond);
1356 }
1357
1358 /* Translate an executable statement without condition.  */
1359
1360 tree
1361 gfc_trans_code (gfc_code * code)
1362 {
1363   return trans_code (code, NULL_TREE);
1364 }
1365
1366
1367 /* This function is called after a complete program unit has been parsed
1368    and resolved.  */
1369
1370 void
1371 gfc_generate_code (gfc_namespace * ns)
1372 {
1373   ompws_flags = 0;
1374   if (ns->is_block_data)
1375     {
1376       gfc_generate_block_data (ns);
1377       return;
1378     }
1379
1380   gfc_generate_function_code (ns);
1381 }
1382
1383
1384 /* This function is called after a complete module has been parsed
1385    and resolved.  */
1386
1387 void
1388 gfc_generate_module_code (gfc_namespace * ns)
1389 {
1390   gfc_namespace *n;
1391   struct module_htab_entry *entry;
1392
1393   gcc_assert (ns->proc_name->backend_decl == NULL);
1394   ns->proc_name->backend_decl
1395     = build_decl (ns->proc_name->declared_at.lb->location,
1396                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1397                   void_type_node);
1398   entry = gfc_find_module (ns->proc_name->name);
1399   if (entry->namespace_decl)
1400     /* Buggy sourcecode, using a module before defining it?  */
1401     htab_empty (entry->decls);
1402   entry->namespace_decl = ns->proc_name->backend_decl;
1403
1404   gfc_generate_module_vars (ns);
1405
1406   /* We need to generate all module function prototypes first, to allow
1407      sibling calls.  */
1408   for (n = ns->contained; n; n = n->sibling)
1409     {
1410       gfc_entry_list *el;
1411
1412       if (!n->proc_name)
1413         continue;
1414
1415       gfc_create_function_decl (n, false);
1416       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1417       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1418       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1419       for (el = ns->entries; el; el = el->next)
1420         {
1421           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1422           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1423           gfc_module_add_decl (entry, el->sym->backend_decl);
1424         }
1425     }
1426
1427   for (n = ns->contained; n; n = n->sibling)
1428     {
1429       if (!n->proc_name)
1430         continue;
1431
1432       gfc_generate_function_code (n);
1433     }
1434 }
1435
1436
1437 /* Initialize an init/cleanup block with existing code.  */
1438
1439 void
1440 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
1441 {
1442   gcc_assert (block);
1443
1444   block->init = NULL_TREE;
1445   block->code = code;
1446   block->cleanup = NULL_TREE;
1447 }
1448
1449
1450 /* Add a new pair of initializers/clean-up code.  */
1451
1452 void
1453 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
1454 {
1455   gcc_assert (block);
1456
1457   /* The new pair of init/cleanup should be "wrapped around" the existing
1458      block of code, thus the initialization is added to the front and the
1459      cleanup to the back.  */
1460   add_expr_to_chain (&block->init, init, true);
1461   add_expr_to_chain (&block->cleanup, cleanup, false);
1462 }
1463
1464
1465 /* Finish up a wrapped block by building a corresponding try-finally expr.  */
1466
1467 tree
1468 gfc_finish_wrapped_block (gfc_wrapped_block* block)
1469 {
1470   tree result;
1471
1472   gcc_assert (block);
1473
1474   /* Build the final expression.  For this, just add init and body together,
1475      and put clean-up with that into a TRY_FINALLY_EXPR.  */
1476   result = block->init;
1477   add_expr_to_chain (&result, block->code, false);
1478   if (block->cleanup)
1479     result = build2 (TRY_FINALLY_EXPR, void_type_node, result, block->cleanup);
1480   
1481   /* Clear the block.  */
1482   block->init = NULL_TREE;
1483   block->code = NULL_TREE;
1484   block->cleanup = NULL_TREE;
1485
1486   return result;
1487 }