OSDN Git Service

* trans-expr.c: Do not include convert.h, ggc.h, real.h, and gimple.h.
[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 "toplev.h"
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 = TREE_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 = TREE_CHAIN (decl);
222       TREE_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 = (tree *) alloca (sizeof (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 /* Add a statement to a block.  */
981
982 void
983 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
984 {
985   gcc_assert (block);
986
987   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
988     return;
989
990   if (block->head)
991     {
992       if (TREE_CODE (block->head) != STATEMENT_LIST)
993         {
994           tree tmp;
995
996           tmp = block->head;
997           block->head = NULL_TREE;
998           append_to_statement_list (tmp, &block->head);
999         }
1000       append_to_statement_list (expr, &block->head);
1001     }
1002   else
1003     /* Don't bother creating a list if we only have a single statement.  */
1004     block->head = expr;
1005 }
1006
1007
1008 /* Add a block the end of a block.  */
1009
1010 void
1011 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1012 {
1013   gcc_assert (append);
1014   gcc_assert (!append->has_scope);
1015
1016   gfc_add_expr_to_block (block, append->head);
1017   append->head = NULL_TREE;
1018 }
1019
1020
1021 /* Get the current locus.  The structure may not be complete, and should
1022    only be used with gfc_set_backend_locus.  */
1023
1024 void
1025 gfc_get_backend_locus (locus * loc)
1026 {
1027   loc->lb = XCNEW (gfc_linebuf);
1028   loc->lb->location = input_location;
1029   loc->lb->file = gfc_current_backend_file;
1030 }
1031
1032
1033 /* Set the current locus.  */
1034
1035 void
1036 gfc_set_backend_locus (locus * loc)
1037 {
1038   gfc_current_backend_file = loc->lb->file;
1039   input_location = loc->lb->location;
1040 }
1041
1042
1043 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1044    This static function is wrapped by gfc_trans_code_cond and
1045    gfc_trans_code.  */
1046
1047 static tree
1048 trans_code (gfc_code * code, tree cond)
1049 {
1050   stmtblock_t block;
1051   tree res;
1052
1053   if (!code)
1054     return build_empty_stmt (input_location);
1055
1056   gfc_start_block (&block);
1057
1058   /* Translate statements one by one into GENERIC trees until we reach
1059      the end of this gfc_code branch.  */
1060   for (; code; code = code->next)
1061     {
1062       if (code->here != 0)
1063         {
1064           res = gfc_trans_label_here (code);
1065           gfc_add_expr_to_block (&block, res);
1066         }
1067
1068       gfc_set_backend_locus (&code->loc);
1069
1070       switch (code->op)
1071         {
1072         case EXEC_NOP:
1073         case EXEC_END_BLOCK:
1074         case EXEC_END_PROCEDURE:
1075           res = NULL_TREE;
1076           break;
1077
1078         case EXEC_ASSIGN:
1079           if (code->expr1->ts.type == BT_CLASS)
1080             res = gfc_trans_class_assign (code);
1081           else
1082             res = gfc_trans_assign (code);
1083           break;
1084
1085         case EXEC_LABEL_ASSIGN:
1086           res = gfc_trans_label_assign (code);
1087           break;
1088
1089         case EXEC_POINTER_ASSIGN:
1090           if (code->expr1->ts.type == BT_CLASS)
1091             res = gfc_trans_class_assign (code);
1092           else
1093             res = gfc_trans_pointer_assign (code);
1094           break;
1095
1096         case EXEC_INIT_ASSIGN:
1097           if (code->expr1->ts.type == BT_CLASS)
1098             res = gfc_trans_class_assign (code);
1099           else
1100             res = gfc_trans_init_assign (code);
1101           break;
1102
1103         case EXEC_CONTINUE:
1104           res = NULL_TREE;
1105           break;
1106
1107         case EXEC_CRITICAL:
1108           res = gfc_trans_critical (code);
1109           break;
1110
1111         case EXEC_CYCLE:
1112           res = gfc_trans_cycle (code);
1113           break;
1114
1115         case EXEC_EXIT:
1116           res = gfc_trans_exit (code);
1117           break;
1118
1119         case EXEC_GOTO:
1120           res = gfc_trans_goto (code);
1121           break;
1122
1123         case EXEC_ENTRY:
1124           res = gfc_trans_entry (code);
1125           break;
1126
1127         case EXEC_PAUSE:
1128           res = gfc_trans_pause (code);
1129           break;
1130
1131         case EXEC_STOP:
1132         case EXEC_ERROR_STOP:
1133           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1134           break;
1135
1136         case EXEC_CALL:
1137           /* For MVBITS we've got the special exception that we need a
1138              dependency check, too.  */
1139           {
1140             bool is_mvbits = false;
1141             if (code->resolved_isym
1142                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1143               is_mvbits = true;
1144             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1145                                   NULL_TREE, false);
1146           }
1147           break;
1148
1149         case EXEC_CALL_PPC:
1150           res = gfc_trans_call (code, false, NULL_TREE,
1151                                 NULL_TREE, false);
1152           break;
1153
1154         case EXEC_ASSIGN_CALL:
1155           res = gfc_trans_call (code, true, NULL_TREE,
1156                                 NULL_TREE, false);
1157           break;
1158
1159         case EXEC_RETURN:
1160           res = gfc_trans_return (code);
1161           break;
1162
1163         case EXEC_IF:
1164           res = gfc_trans_if (code);
1165           break;
1166
1167         case EXEC_ARITHMETIC_IF:
1168           res = gfc_trans_arithmetic_if (code);
1169           break;
1170
1171         case EXEC_BLOCK:
1172           res = gfc_trans_block_construct (code);
1173           break;
1174
1175         case EXEC_DO:
1176           res = gfc_trans_do (code, cond);
1177           break;
1178
1179         case EXEC_DO_WHILE:
1180           res = gfc_trans_do_while (code);
1181           break;
1182
1183         case EXEC_SELECT:
1184           res = gfc_trans_select (code);
1185           break;
1186
1187         case EXEC_SELECT_TYPE:
1188           /* Do nothing. SELECT TYPE statements should be transformed into
1189           an ordinary SELECT CASE at resolution stage.
1190           TODO: Add an error message here once this is done.  */
1191           res = NULL_TREE;
1192           break;
1193
1194         case EXEC_FLUSH:
1195           res = gfc_trans_flush (code);
1196           break;
1197
1198         case EXEC_SYNC_ALL:
1199         case EXEC_SYNC_IMAGES:
1200         case EXEC_SYNC_MEMORY:
1201           res = gfc_trans_sync (code, code->op);
1202           break;
1203
1204         case EXEC_FORALL:
1205           res = gfc_trans_forall (code);
1206           break;
1207
1208         case EXEC_WHERE:
1209           res = gfc_trans_where (code);
1210           break;
1211
1212         case EXEC_ALLOCATE:
1213           res = gfc_trans_allocate (code);
1214           break;
1215
1216         case EXEC_DEALLOCATE:
1217           res = gfc_trans_deallocate (code);
1218           break;
1219
1220         case EXEC_OPEN:
1221           res = gfc_trans_open (code);
1222           break;
1223
1224         case EXEC_CLOSE:
1225           res = gfc_trans_close (code);
1226           break;
1227
1228         case EXEC_READ:
1229           res = gfc_trans_read (code);
1230           break;
1231
1232         case EXEC_WRITE:
1233           res = gfc_trans_write (code);
1234           break;
1235
1236         case EXEC_IOLENGTH:
1237           res = gfc_trans_iolength (code);
1238           break;
1239
1240         case EXEC_BACKSPACE:
1241           res = gfc_trans_backspace (code);
1242           break;
1243
1244         case EXEC_ENDFILE:
1245           res = gfc_trans_endfile (code);
1246           break;
1247
1248         case EXEC_INQUIRE:
1249           res = gfc_trans_inquire (code);
1250           break;
1251
1252         case EXEC_WAIT:
1253           res = gfc_trans_wait (code);
1254           break;
1255
1256         case EXEC_REWIND:
1257           res = gfc_trans_rewind (code);
1258           break;
1259
1260         case EXEC_TRANSFER:
1261           res = gfc_trans_transfer (code);
1262           break;
1263
1264         case EXEC_DT_END:
1265           res = gfc_trans_dt_end (code);
1266           break;
1267
1268         case EXEC_OMP_ATOMIC:
1269         case EXEC_OMP_BARRIER:
1270         case EXEC_OMP_CRITICAL:
1271         case EXEC_OMP_DO:
1272         case EXEC_OMP_FLUSH:
1273         case EXEC_OMP_MASTER:
1274         case EXEC_OMP_ORDERED:
1275         case EXEC_OMP_PARALLEL:
1276         case EXEC_OMP_PARALLEL_DO:
1277         case EXEC_OMP_PARALLEL_SECTIONS:
1278         case EXEC_OMP_PARALLEL_WORKSHARE:
1279         case EXEC_OMP_SECTIONS:
1280         case EXEC_OMP_SINGLE:
1281         case EXEC_OMP_TASK:
1282         case EXEC_OMP_TASKWAIT:
1283         case EXEC_OMP_WORKSHARE:
1284           res = gfc_trans_omp_directive (code);
1285           break;
1286
1287         default:
1288           internal_error ("gfc_trans_code(): Bad statement code");
1289         }
1290
1291       gfc_set_backend_locus (&code->loc);
1292
1293       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1294         {
1295           if (TREE_CODE (res) != STATEMENT_LIST)
1296             SET_EXPR_LOCATION (res, input_location);
1297             
1298           /* Add the new statement to the block.  */
1299           gfc_add_expr_to_block (&block, res);
1300         }
1301     }
1302
1303   /* Return the finished block.  */
1304   return gfc_finish_block (&block);
1305 }
1306
1307
1308 /* Translate an executable statement with condition, cond.  The condition is
1309    used by gfc_trans_do to test for IO result conditions inside implied
1310    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1311
1312 tree
1313 gfc_trans_code_cond (gfc_code * code, tree cond)
1314 {
1315   return trans_code (code, cond);
1316 }
1317
1318 /* Translate an executable statement without condition.  */
1319
1320 tree
1321 gfc_trans_code (gfc_code * code)
1322 {
1323   return trans_code (code, NULL_TREE);
1324 }
1325
1326
1327 /* This function is called after a complete program unit has been parsed
1328    and resolved.  */
1329
1330 void
1331 gfc_generate_code (gfc_namespace * ns)
1332 {
1333   ompws_flags = 0;
1334   if (ns->is_block_data)
1335     {
1336       gfc_generate_block_data (ns);
1337       return;
1338     }
1339
1340   gfc_generate_function_code (ns);
1341 }
1342
1343
1344 /* This function is called after a complete module has been parsed
1345    and resolved.  */
1346
1347 void
1348 gfc_generate_module_code (gfc_namespace * ns)
1349 {
1350   gfc_namespace *n;
1351   struct module_htab_entry *entry;
1352
1353   gcc_assert (ns->proc_name->backend_decl == NULL);
1354   ns->proc_name->backend_decl
1355     = build_decl (ns->proc_name->declared_at.lb->location,
1356                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1357                   void_type_node);
1358   entry = gfc_find_module (ns->proc_name->name);
1359   if (entry->namespace_decl)
1360     /* Buggy sourcecode, using a module before defining it?  */
1361     htab_empty (entry->decls);
1362   entry->namespace_decl = ns->proc_name->backend_decl;
1363
1364   gfc_generate_module_vars (ns);
1365
1366   /* We need to generate all module function prototypes first, to allow
1367      sibling calls.  */
1368   for (n = ns->contained; n; n = n->sibling)
1369     {
1370       gfc_entry_list *el;
1371
1372       if (!n->proc_name)
1373         continue;
1374
1375       gfc_create_function_decl (n);
1376       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1377       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1378       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1379       for (el = ns->entries; el; el = el->next)
1380         {
1381           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1382           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1383           gfc_module_add_decl (entry, el->sym->backend_decl);
1384         }
1385     }
1386
1387   for (n = ns->contained; n; n = n->sibling)
1388     {
1389       if (!n->proc_name)
1390         continue;
1391
1392       gfc_generate_function_code (n);
1393     }
1394 }
1395