OSDN Git Service

21c56045a44f9d5f37a232a1b59fc311de50a445
[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"
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_fault[] = N_("Array reference out of bounds");
51 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
52
53
54 /* Advance along TREE_CHAIN n times.  */
55
56 tree
57 gfc_advance_chain (tree t, int n)
58 {
59   for (; n > 0; n--)
60     {
61       gcc_assert (t != NULL_TREE);
62       t = TREE_CHAIN (t);
63     }
64   return t;
65 }
66
67
68 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
69
70 tree
71 gfc_chainon_list (tree list, tree add)
72 {
73   tree l;
74
75   l = tree_cons (NULL_TREE, add, NULL_TREE);
76
77   return chainon (list, l);
78 }
79
80
81 /* Strip off a legitimate source ending from the input
82    string NAME of length LEN.  */
83
84 static inline void
85 remove_suffix (char *name, int len)
86 {
87   int i;
88
89   for (i = 2; i < 8 && len > i; i++)
90     {
91       if (name[len - i] == '.')
92         {
93           name[len - i] = '\0';
94           break;
95         }
96     }
97 }
98
99
100 /* Creates a variable declaration with a given TYPE.  */
101
102 tree
103 gfc_create_var_np (tree type, const char *prefix)
104 {
105   tree t;
106   
107   t = create_tmp_var_raw (type, prefix);
108
109   /* No warnings for anonymous variables.  */
110   if (prefix == NULL)
111     TREE_NO_WARNING (t) = 1;
112
113   return t;
114 }
115
116
117 /* Like above, but also adds it to the current scope.  */
118
119 tree
120 gfc_create_var (tree type, const char *prefix)
121 {
122   tree tmp;
123
124   tmp = gfc_create_var_np (type, prefix);
125
126   pushdecl (tmp);
127
128   return tmp;
129 }
130
131
132 /* If the expression is not constant, evaluate it now.  We assign the
133    result of the expression to an artificially created variable VAR, and
134    return a pointer to the VAR_DECL node for this variable.  */
135
136 tree
137 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
138 {
139   tree var;
140
141   if (CONSTANT_CLASS_P (expr))
142     return expr;
143
144   var = gfc_create_var (TREE_TYPE (expr), NULL);
145   gfc_add_modify (pblock, var, expr);
146
147   return var;
148 }
149
150
151 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.  
152    A MODIFY_EXPR is an assignment:
153    LHS <- RHS.  */
154
155 void
156 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
157 {
158   tree tmp;
159
160 #ifdef ENABLE_CHECKING
161   tree t1, t2;
162   t1 = TREE_TYPE (rhs);
163   t2 = TREE_TYPE (lhs);
164   /* Make sure that the types of the rhs and the lhs are the same
165      for scalar assignments.  We should probably have something
166      similar for aggregates, but right now removing that check just
167      breaks everything.  */
168   gcc_assert (t1 == t2
169               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
170 #endif
171
172   tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
173   gfc_add_expr_to_block (pblock, tmp);
174 }
175
176
177 /* Create a new scope/binding level and initialize a block.  Care must be
178    taken when translating expressions as any temporaries will be placed in
179    the innermost scope.  */
180
181 void
182 gfc_start_block (stmtblock_t * block)
183 {
184   /* Start a new binding level.  */
185   pushlevel (0);
186   block->has_scope = 1;
187
188   /* The block is empty.  */
189   block->head = NULL_TREE;
190 }
191
192
193 /* Initialize a block without creating a new scope.  */
194
195 void
196 gfc_init_block (stmtblock_t * block)
197 {
198   block->head = NULL_TREE;
199   block->has_scope = 0;
200 }
201
202
203 /* Sometimes we create a scope but it turns out that we don't actually
204    need it.  This function merges the scope of BLOCK with its parent.
205    Only variable decls will be merged, you still need to add the code.  */
206
207 void
208 gfc_merge_block_scope (stmtblock_t * block)
209 {
210   tree decl;
211   tree next;
212
213   gcc_assert (block->has_scope);
214   block->has_scope = 0;
215
216   /* Remember the decls in this scope.  */
217   decl = getdecls ();
218   poplevel (0, 0, 0);
219
220   /* Add them to the parent scope.  */
221   while (decl != NULL_TREE)
222     {
223       next = TREE_CHAIN (decl);
224       TREE_CHAIN (decl) = NULL_TREE;
225
226       pushdecl (decl);
227       decl = next;
228     }
229 }
230
231
232 /* Finish a scope containing a block of statements.  */
233
234 tree
235 gfc_finish_block (stmtblock_t * stmtblock)
236 {
237   tree decl;
238   tree expr;
239   tree block;
240
241   expr = stmtblock->head;
242   if (!expr)
243     expr = build_empty_stmt (input_location);
244
245   stmtblock->head = NULL_TREE;
246
247   if (stmtblock->has_scope)
248     {
249       decl = getdecls ();
250
251       if (decl)
252         {
253           block = poplevel (1, 0, 0);
254           expr = build3_v (BIND_EXPR, decl, expr, block);
255         }
256       else
257         poplevel (0, 0, 0);
258     }
259
260   return expr;
261 }
262
263
264 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
265    natural type is used.  */
266
267 tree
268 gfc_build_addr_expr (tree type, tree t)
269 {
270   tree base_type = TREE_TYPE (t);
271   tree natural_type;
272
273   if (type && POINTER_TYPE_P (type)
274       && TREE_CODE (base_type) == ARRAY_TYPE
275       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
276          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
277     {
278       tree min_val = size_zero_node;
279       tree type_domain = TYPE_DOMAIN (base_type);
280       if (type_domain && TYPE_MIN_VALUE (type_domain))
281         min_val = TYPE_MIN_VALUE (type_domain);
282       t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
283                         t, min_val, NULL_TREE, NULL_TREE));
284       natural_type = type;
285     }
286   else
287     natural_type = build_pointer_type (base_type);
288
289   if (TREE_CODE (t) == INDIRECT_REF)
290     {
291       if (!type)
292         type = natural_type;
293       t = TREE_OPERAND (t, 0);
294       natural_type = TREE_TYPE (t);
295     }
296   else
297     {
298       tree base = get_base_address (t);
299       if (base && DECL_P (base))
300         TREE_ADDRESSABLE (base) = 1;
301       t = fold_build1 (ADDR_EXPR, natural_type, t);
302     }
303
304   if (type && natural_type != type)
305     t = convert (type, t);
306
307   return t;
308 }
309
310
311 /* Build an ARRAY_REF with its natural type.  */
312
313 tree
314 gfc_build_array_ref (tree base, tree offset, tree decl)
315 {
316   tree type = TREE_TYPE (base);
317   tree tmp;
318
319   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
320   type = TREE_TYPE (type);
321
322   if (DECL_P (base))
323     TREE_ADDRESSABLE (base) = 1;
324
325   /* Strip NON_LVALUE_EXPR nodes.  */
326   STRIP_TYPE_NOPS (offset);
327
328   /* If the array reference is to a pointer, whose target contains a
329      subreference, use the span that is stored with the backend decl
330      and reference the element with pointer arithmetic.  */
331   if (decl && (TREE_CODE (decl) == FIELD_DECL
332                  || TREE_CODE (decl) == VAR_DECL
333                  || TREE_CODE (decl) == PARM_DECL)
334         && GFC_DECL_SUBREF_ARRAY_P (decl)
335         && !integer_zerop (GFC_DECL_SPAN(decl)))
336     {
337       offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
338                             offset, GFC_DECL_SPAN(decl));
339       tmp = gfc_build_addr_expr (pvoid_type_node, base);
340       tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
341                          tmp, fold_convert (sizetype, offset));
342       tmp = fold_convert (build_pointer_type (type), tmp);
343       if (!TYPE_STRING_FLAG (type))
344         tmp = build_fold_indirect_ref_loc (input_location, tmp);
345       return tmp;
346     }
347   else
348     /* Otherwise use a straightforward array reference.  */
349     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
350 }
351
352
353 /* Generate a call to print a runtime error possibly including multiple
354    arguments and a locus.  */
355
356 tree
357 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
358 {
359   va_list ap;
360
361   va_start (ap, msgid);
362   return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
363 }
364
365 tree
366 gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
367                                 va_list ap)
368 {
369   stmtblock_t block;
370   tree tmp;
371   tree arg, arg2;
372   tree *argarray;
373   tree fntype;
374   char *message;
375   const char *p;
376   int line, nargs, i;
377
378   /* Compute the number of extra arguments from the format string.  */
379   for (p = msgid, nargs = 0; *p; p++)
380     if (*p == '%')
381       {
382         p++;
383         if (*p != '%')
384           nargs++;
385       }
386
387   /* The code to generate the error.  */
388   gfc_start_block (&block);
389
390   if (where)
391     {
392       line = LOCATION_LINE (where->lb->location);
393       asprintf (&message, "At line %d of file %s",  line,
394                 where->lb->file->filename);
395     }
396   else
397     asprintf (&message, "In file '%s', around line %d",
398               gfc_source_file, input_line + 1);
399
400   arg = gfc_build_addr_expr (pchar_type_node,
401                              gfc_build_localized_cstring_const (message));
402   gfc_free(message);
403   
404   asprintf (&message, "%s", _(msgid));
405   arg2 = gfc_build_addr_expr (pchar_type_node,
406                               gfc_build_localized_cstring_const (message));
407   gfc_free(message);
408
409   /* Build the argument array.  */
410   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
411   argarray[0] = arg;
412   argarray[1] = arg2;
413   for (i = 0; i < nargs; i++)
414     argarray[2 + i] = va_arg (ap, tree);
415   va_end (ap);
416   
417   /* Build the function call to runtime_(warning,error)_at; because of the
418      variable number of arguments, we can't use build_call_expr_loc dinput_location,
419      irectly.  */
420   if (error)
421     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
422   else
423     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
424
425   tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
426                                  fold_build1 (ADDR_EXPR,
427                                               build_pointer_type (fntype),
428                                               error
429                                               ? gfor_fndecl_runtime_error_at
430                                               : gfor_fndecl_runtime_warning_at),
431                                  nargs + 2, argarray);
432   gfc_add_expr_to_block (&block, tmp);
433
434   return gfc_finish_block (&block);
435 }
436
437
438 /* Generate a runtime error if COND is true.  */
439
440 void
441 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
442                          locus * where, const char * msgid, ...)
443 {
444   va_list ap;
445   stmtblock_t block;
446   tree body;
447   tree tmp;
448   tree tmpvar = NULL;
449
450   if (integer_zerop (cond))
451     return;
452
453   if (once)
454     {
455        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
456        TREE_STATIC (tmpvar) = 1;
457        DECL_INITIAL (tmpvar) = boolean_true_node;
458        gfc_add_expr_to_block (pblock, tmpvar);
459     }
460
461   gfc_start_block (&block);
462
463   /* The code to generate the error.  */
464   va_start (ap, msgid);
465   gfc_add_expr_to_block (&block,
466                          gfc_trans_runtime_error_vararg (error, where,
467                                                          msgid, ap));
468
469   if (once)
470     gfc_add_modify (&block, tmpvar, boolean_false_node);
471
472   body = gfc_finish_block (&block);
473
474   if (integer_onep (cond))
475     {
476       gfc_add_expr_to_block (pblock, body);
477     }
478   else
479     {
480       /* Tell the compiler that this isn't likely.  */
481       if (once)
482         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
483                             cond);
484       else
485         cond = fold_convert (long_integer_type_node, cond);
486
487       tmp = build_int_cst (long_integer_type_node, 0);
488       cond = build_call_expr_loc (input_location,
489                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
490       cond = fold_convert (boolean_type_node, cond);
491
492       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
493       gfc_add_expr_to_block (pblock, tmp);
494     }
495 }
496
497
498 /* Call malloc to allocate size bytes of memory, with special conditions:
499       + if size <= 0, return a malloced area of size 1,
500       + if malloc returns NULL, issue a runtime error.  */
501 tree
502 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
503 {
504   tree tmp, msg, malloc_result, null_result, res;
505   stmtblock_t block2;
506
507   size = gfc_evaluate_now (size, block);
508
509   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
510     size = fold_convert (size_type_node, size);
511
512   /* Create a variable to hold the result.  */
513   res = gfc_create_var (prvoid_type_node, NULL);
514
515   /* Call malloc.  */
516   gfc_start_block (&block2);
517
518   size = fold_build2 (MAX_EXPR, size_type_node, size,
519                       build_int_cst (size_type_node, 1));
520
521   gfc_add_modify (&block2, res,
522                   fold_convert (prvoid_type_node,
523                                 build_call_expr_loc (input_location,
524                                    built_in_decls[BUILT_IN_MALLOC], 1, size)));
525
526   /* Optionally check whether malloc was successful.  */
527   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
528     {
529       null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
530                                  build_int_cst (pvoid_type_node, 0));
531       msg = gfc_build_addr_expr (pchar_type_node,
532               gfc_build_localized_cstring_const ("Memory allocation failed"));
533       tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
534               build_call_expr_loc (input_location,
535                                    gfor_fndecl_os_error, 1, msg),
536                                    build_empty_stmt (input_location));
537       gfc_add_expr_to_block (&block2, tmp);
538     }
539
540   malloc_result = gfc_finish_block (&block2);
541
542   gfc_add_expr_to_block (block, malloc_result);
543
544   if (type != NULL)
545     res = fold_convert (type, res);
546   return res;
547 }
548
549
550 /* Allocate memory, using an optional status argument.
551  
552    This function follows the following pseudo-code:
553
554     void *
555     allocate (size_t size, integer_type* stat)
556     {
557       void *newmem;
558     
559       if (stat)
560         *stat = 0;
561
562       // The only time this can happen is the size wraps around.
563       if (size < 0)
564       {
565         if (stat)
566         {
567           *stat = LIBERROR_ALLOCATION;
568           newmem = NULL;
569         }
570         else
571           runtime_error ("Attempt to allocate negative amount of memory. "
572                          "Possible integer overflow");
573       }
574       else
575       {
576         newmem = malloc (MAX (size, 1));
577         if (newmem == NULL)
578         {
579           if (stat)
580             *stat = LIBERROR_ALLOCATION;
581           else
582             runtime_error ("Out of memory");
583         }
584       }
585
586       return newmem;
587     }  */
588 tree
589 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
590 {
591   stmtblock_t alloc_block;
592   tree res, tmp, error, msg, cond;
593   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
594
595   /* Evaluate size only once, and make sure it has the right type.  */
596   size = gfc_evaluate_now (size, block);
597   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
598     size = fold_convert (size_type_node, size);
599
600   /* Create a variable to hold the result.  */
601   res = gfc_create_var (prvoid_type_node, NULL);
602
603   /* Set the optional status variable to zero.  */
604   if (status != NULL_TREE && !integer_zerop (status))
605     {
606       tmp = fold_build2 (MODIFY_EXPR, status_type,
607                          fold_build1 (INDIRECT_REF, status_type, status),
608                          build_int_cst (status_type, 0));
609       tmp = fold_build3 (COND_EXPR, void_type_node,
610                          fold_build2 (NE_EXPR, boolean_type_node, status,
611                                       build_int_cst (TREE_TYPE (status), 0)),
612                          tmp, build_empty_stmt (input_location));
613       gfc_add_expr_to_block (block, tmp);
614     }
615
616   /* Generate the block of code handling (size < 0).  */
617   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
618                         ("Attempt to allocate negative amount of memory. "
619                          "Possible integer overflow"));
620   error = build_call_expr_loc (input_location,
621                            gfor_fndecl_runtime_error, 1, msg);
622
623   if (status != NULL_TREE && !integer_zerop (status))
624     {
625       /* Set the status variable if it's present.  */
626       stmtblock_t set_status_block;
627
628       gfc_start_block (&set_status_block);
629       gfc_add_modify (&set_status_block,
630                       fold_build1 (INDIRECT_REF, status_type, status),
631                            build_int_cst (status_type, LIBERROR_ALLOCATION));
632       gfc_add_modify (&set_status_block, res,
633                            build_int_cst (prvoid_type_node, 0));
634
635       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
636                          build_int_cst (TREE_TYPE (status), 0));
637       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
638                            gfc_finish_block (&set_status_block));
639     }
640
641   /* The allocation itself.  */
642   gfc_start_block (&alloc_block);
643   gfc_add_modify (&alloc_block, res,
644                   fold_convert (prvoid_type_node,
645                                 build_call_expr_loc (input_location,
646                                    built_in_decls[BUILT_IN_MALLOC], 1,
647                                         fold_build2 (MAX_EXPR, size_type_node,
648                                                      size,
649                                                      build_int_cst (size_type_node, 1)))));
650
651   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
652                                                 ("Out of memory"));
653   tmp = build_call_expr_loc (input_location,
654                          gfor_fndecl_os_error, 1, msg);
655
656   if (status != NULL_TREE && !integer_zerop (status))
657     {
658       /* Set the status variable if it's present.  */
659       tree tmp2;
660
661       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
662                           build_int_cst (TREE_TYPE (status), 0));
663       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
664                           fold_build1 (INDIRECT_REF, status_type, status),
665                           build_int_cst (status_type, LIBERROR_ALLOCATION));
666       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
667                          tmp2);
668     }
669
670   tmp = fold_build3 (COND_EXPR, void_type_node,
671                      fold_build2 (EQ_EXPR, boolean_type_node, res,
672                                   build_int_cst (prvoid_type_node, 0)),
673                      tmp, build_empty_stmt (input_location));
674   gfc_add_expr_to_block (&alloc_block, tmp);
675
676   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
677                       build_int_cst (TREE_TYPE (size), 0));
678   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
679                      gfc_finish_block (&alloc_block));
680   gfc_add_expr_to_block (block, tmp);
681
682   return res;
683 }
684
685
686 /* Generate code for an ALLOCATE statement when the argument is an
687    allocatable array.  If the array is currently allocated, it is an
688    error to allocate it again.
689  
690    This function follows the following pseudo-code:
691   
692     void *
693     allocate_array (void *mem, size_t size, integer_type *stat)
694     {
695       if (mem == NULL)
696         return allocate (size, stat);
697       else
698       {
699         if (stat)
700         {
701           free (mem);
702           mem = allocate (size, stat);
703           *stat = LIBERROR_ALLOCATION;
704           return mem;
705         }
706         else
707           runtime_error ("Attempting to allocate already allocated array");
708       }
709     }
710     
711     expr must be set to the original expression being allocated for its locus
712     and variable name in case a runtime error has to be printed.  */
713 tree
714 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
715                                 tree status, gfc_expr* expr)
716 {
717   stmtblock_t alloc_block;
718   tree res, tmp, null_mem, alloc, error;
719   tree type = TREE_TYPE (mem);
720
721   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
722     size = fold_convert (size_type_node, size);
723
724   /* Create a variable to hold the result.  */
725   res = gfc_create_var (type, NULL);
726   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
727                           build_int_cst (type, 0));
728
729   /* If mem is NULL, we call gfc_allocate_with_status.  */
730   gfc_start_block (&alloc_block);
731   tmp = gfc_allocate_with_status (&alloc_block, size, status);
732   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
733   alloc = gfc_finish_block (&alloc_block);
734
735   /* Otherwise, we issue a runtime error or set the status variable.  */
736   if (expr)
737     {
738       tree varname;
739
740       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
741       varname = gfc_build_cstring_const (expr->symtree->name);
742       varname = gfc_build_addr_expr (pchar_type_node, varname);
743
744       error = gfc_trans_runtime_error (true, &expr->where,
745                                        "Attempting to allocate already"
746                                        " allocated array '%s'",
747                                        varname);
748     }
749   else
750     error = gfc_trans_runtime_error (true, NULL,
751                                      "Attempting to allocate already allocated"
752                                      "array");
753
754   if (status != NULL_TREE && !integer_zerop (status))
755     {
756       tree status_type = TREE_TYPE (TREE_TYPE (status));
757       stmtblock_t set_status_block;
758
759       gfc_start_block (&set_status_block);
760       tmp = build_call_expr_loc (input_location,
761                              built_in_decls[BUILT_IN_FREE], 1,
762                              fold_convert (pvoid_type_node, mem));
763       gfc_add_expr_to_block (&set_status_block, tmp);
764
765       tmp = gfc_allocate_with_status (&set_status_block, size, status);
766       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
767
768       gfc_add_modify (&set_status_block,
769                            fold_build1 (INDIRECT_REF, status_type, status),
770                            build_int_cst (status_type, LIBERROR_ALLOCATION));
771
772       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
773                          build_int_cst (status_type, 0));
774       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
775                            gfc_finish_block (&set_status_block));
776     }
777
778   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
779   gfc_add_expr_to_block (block, tmp);
780
781   return res;
782 }
783
784
785 /* Free a given variable, if it's not NULL.  */
786 tree
787 gfc_call_free (tree var)
788 {
789   stmtblock_t block;
790   tree tmp, cond, call;
791
792   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
793     var = fold_convert (pvoid_type_node, var);
794
795   gfc_start_block (&block);
796   var = gfc_evaluate_now (var, &block);
797   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
798                       build_int_cst (pvoid_type_node, 0));
799   call = build_call_expr_loc (input_location,
800                           built_in_decls[BUILT_IN_FREE], 1, var);
801   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
802                      build_empty_stmt (input_location));
803   gfc_add_expr_to_block (&block, tmp);
804
805   return gfc_finish_block (&block);
806 }
807
808
809
810 /* User-deallocate; we emit the code directly from the front-end, and the
811    logic is the same as the previous library function:
812
813     void
814     deallocate (void *pointer, GFC_INTEGER_4 * stat)
815     {
816       if (!pointer)
817         {
818           if (stat)
819             *stat = 1;
820           else
821             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
822         }
823       else
824         {
825           free (pointer);
826           if (stat)
827             *stat = 0;
828         }
829     }
830
831    In this front-end version, status doesn't have to be GFC_INTEGER_4.
832    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
833    even when no status variable is passed to us (this is used for
834    unconditional deallocation generated by the front-end at end of
835    each procedure).
836    
837    If a runtime-message is possible, `expr' must point to the original
838    expression being deallocated for its locus and variable name.  */
839 tree
840 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
841                             gfc_expr* expr)
842 {
843   stmtblock_t null, non_null;
844   tree cond, tmp, error;
845
846   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
847                       build_int_cst (TREE_TYPE (pointer), 0));
848
849   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
850      we emit a runtime error.  */
851   gfc_start_block (&null);
852   if (!can_fail)
853     {
854       tree varname;
855
856       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
857
858       varname = gfc_build_cstring_const (expr->symtree->name);
859       varname = gfc_build_addr_expr (pchar_type_node, varname);
860
861       error = gfc_trans_runtime_error (true, &expr->where,
862                                        "Attempt to DEALLOCATE unallocated '%s'",
863                                        varname);
864     }
865   else
866     error = build_empty_stmt (input_location);
867
868   if (status != NULL_TREE && !integer_zerop (status))
869     {
870       tree status_type = TREE_TYPE (TREE_TYPE (status));
871       tree cond2;
872
873       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
874                            build_int_cst (TREE_TYPE (status), 0));
875       tmp = fold_build2 (MODIFY_EXPR, status_type,
876                          fold_build1 (INDIRECT_REF, status_type, status),
877                          build_int_cst (status_type, 1));
878       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
879     }
880
881   gfc_add_expr_to_block (&null, error);
882
883   /* When POINTER is not NULL, we free it.  */
884   gfc_start_block (&non_null);
885   tmp = build_call_expr_loc (input_location,
886                          built_in_decls[BUILT_IN_FREE], 1,
887                          fold_convert (pvoid_type_node, pointer));
888   gfc_add_expr_to_block (&non_null, tmp);
889
890   if (status != NULL_TREE && !integer_zerop (status))
891     {
892       /* We set STATUS to zero if it is present.  */
893       tree status_type = TREE_TYPE (TREE_TYPE (status));
894       tree cond2;
895
896       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
897                            build_int_cst (TREE_TYPE (status), 0));
898       tmp = fold_build2 (MODIFY_EXPR, status_type,
899                          fold_build1 (INDIRECT_REF, status_type, status),
900                          build_int_cst (status_type, 0));
901       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
902                          build_empty_stmt (input_location));
903       gfc_add_expr_to_block (&non_null, tmp);
904     }
905
906   return fold_build3 (COND_EXPR, void_type_node, cond,
907                       gfc_finish_block (&null), gfc_finish_block (&non_null));
908 }
909
910
911 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
912    following pseudo-code:
913
914 void *
915 internal_realloc (void *mem, size_t size)
916 {
917   if (size < 0)
918     runtime_error ("Attempt to allocate a negative amount of memory.");
919   res = realloc (mem, size);
920   if (!res && size != 0)
921     _gfortran_os_error ("Out of memory");
922
923   if (size == 0)
924     return NULL;
925
926   return res;
927 }  */
928 tree
929 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
930 {
931   tree msg, res, negative, nonzero, zero, null_result, tmp;
932   tree type = TREE_TYPE (mem);
933
934   size = gfc_evaluate_now (size, block);
935
936   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
937     size = fold_convert (size_type_node, size);
938
939   /* Create a variable to hold the result.  */
940   res = gfc_create_var (type, NULL);
941
942   /* size < 0 ?  */
943   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
944                           build_int_cst (size_type_node, 0));
945   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
946       ("Attempt to allocate a negative amount of memory."));
947   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
948                      build_call_expr_loc (input_location,
949                                       gfor_fndecl_runtime_error, 1, msg),
950                      build_empty_stmt (input_location));
951   gfc_add_expr_to_block (block, tmp);
952
953   /* Call realloc and check the result.  */
954   tmp = build_call_expr_loc (input_location,
955                          built_in_decls[BUILT_IN_REALLOC], 2,
956                          fold_convert (pvoid_type_node, mem), size);
957   gfc_add_modify (block, res, fold_convert (type, tmp));
958   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
959                              build_int_cst (pvoid_type_node, 0));
960   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
961                          build_int_cst (size_type_node, 0));
962   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
963                              nonzero);
964   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
965                                                 ("Out of memory"));
966   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
967                      build_call_expr_loc (input_location,
968                                       gfor_fndecl_os_error, 1, msg),
969                      build_empty_stmt (input_location));
970   gfc_add_expr_to_block (block, tmp);
971
972   /* if (size == 0) then the result is NULL.  */
973   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
974   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
975   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
976                      build_empty_stmt (input_location));
977   gfc_add_expr_to_block (block, tmp);
978
979   return res;
980 }
981
982 /* Add a statement to a block.  */
983
984 void
985 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
986 {
987   gcc_assert (block);
988
989   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
990     return;
991
992   if (block->head)
993     {
994       if (TREE_CODE (block->head) != STATEMENT_LIST)
995         {
996           tree tmp;
997
998           tmp = block->head;
999           block->head = NULL_TREE;
1000           append_to_statement_list (tmp, &block->head);
1001         }
1002       append_to_statement_list (expr, &block->head);
1003     }
1004   else
1005     /* Don't bother creating a list if we only have a single statement.  */
1006     block->head = expr;
1007 }
1008
1009
1010 /* Add a block the end of a block.  */
1011
1012 void
1013 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1014 {
1015   gcc_assert (append);
1016   gcc_assert (!append->has_scope);
1017
1018   gfc_add_expr_to_block (block, append->head);
1019   append->head = NULL_TREE;
1020 }
1021
1022
1023 /* Get the current locus.  The structure may not be complete, and should
1024    only be used with gfc_set_backend_locus.  */
1025
1026 void
1027 gfc_get_backend_locus (locus * loc)
1028 {
1029   loc->lb = XCNEW (gfc_linebuf);
1030   loc->lb->location = input_location;
1031   loc->lb->file = gfc_current_backend_file;
1032 }
1033
1034
1035 /* Set the current locus.  */
1036
1037 void
1038 gfc_set_backend_locus (locus * loc)
1039 {
1040   gfc_current_backend_file = loc->lb->file;
1041   input_location = loc->lb->location;
1042 }
1043
1044
1045 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1046    This static function is wrapped by gfc_trans_code_cond and
1047    gfc_trans_code.  */
1048
1049 static tree
1050 trans_code (gfc_code * code, tree cond)
1051 {
1052   stmtblock_t block;
1053   tree res;
1054
1055   if (!code)
1056     return build_empty_stmt (input_location);
1057
1058   gfc_start_block (&block);
1059
1060   /* Translate statements one by one into GENERIC trees until we reach
1061      the end of this gfc_code branch.  */
1062   for (; code; code = code->next)
1063     {
1064       if (code->here != 0)
1065         {
1066           res = gfc_trans_label_here (code);
1067           gfc_add_expr_to_block (&block, res);
1068         }
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