OSDN Git Service

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