OSDN Git Service

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