OSDN Git Service

827f54eaa206460e5e69b39793e2fe86375be65a
[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   /* 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 (TREE_TYPE (rhs) == TREE_TYPE (lhs)
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 ();
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 (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 directly.  */
417   if (error)
418     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
419   else
420     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
421
422   tmp = fold_builtin_call_array (TREE_TYPE (fntype),
423                                  fold_build1 (ADDR_EXPR,
424                                               build_pointer_type (fntype),
425                                               error
426                                               ? gfor_fndecl_runtime_error_at
427                                               : gfor_fndecl_runtime_warning_at),
428                                  nargs + 2, argarray);
429   gfc_add_expr_to_block (&block, tmp);
430
431   return gfc_finish_block (&block);
432 }
433
434
435 /* Generate a runtime error if COND is true.  */
436
437 void
438 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
439                          locus * where, const char * msgid, ...)
440 {
441   va_list ap;
442   stmtblock_t block;
443   tree body;
444   tree tmp;
445   tree tmpvar = NULL;
446
447   if (integer_zerop (cond))
448     return;
449
450   if (once)
451     {
452        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
453        TREE_STATIC (tmpvar) = 1;
454        DECL_INITIAL (tmpvar) = boolean_true_node;
455        gfc_add_expr_to_block (pblock, tmpvar);
456     }
457
458   gfc_start_block (&block);
459
460   /* The code to generate the error.  */
461   va_start (ap, msgid);
462   gfc_add_expr_to_block (&block,
463                          gfc_trans_runtime_error_vararg (error, where,
464                                                          msgid, ap));
465
466   if (once)
467     gfc_add_modify (&block, tmpvar, boolean_false_node);
468
469   body = gfc_finish_block (&block);
470
471   if (integer_onep (cond))
472     {
473       gfc_add_expr_to_block (pblock, body);
474     }
475   else
476     {
477       /* Tell the compiler that this isn't likely.  */
478       if (once)
479         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
480                             cond);
481       else
482         cond = fold_convert (long_integer_type_node, cond);
483
484       tmp = build_int_cst (long_integer_type_node, 0);
485       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
486       cond = fold_convert (boolean_type_node, cond);
487
488       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
489       gfc_add_expr_to_block (pblock, tmp);
490     }
491 }
492
493
494 /* Call malloc to allocate size bytes of memory, with special conditions:
495       + if size < 0, generate a runtime error,
496       + if size == 0, return a malloced area of size 1,
497       + if malloc returns NULL, issue a runtime error.  */
498 tree
499 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
500 {
501   tree tmp, msg, negative, malloc_result, null_result, res;
502   stmtblock_t block2;
503
504   size = gfc_evaluate_now (size, block);
505
506   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
507     size = fold_convert (size_type_node, size);
508
509   /* Create a variable to hold the result.  */
510   res = gfc_create_var (pvoid_type_node, NULL);
511
512   /* size < 0 ?  */
513   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
514                           build_int_cst (size_type_node, 0));
515   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
516       ("Attempt to allocate a negative amount of memory."));
517   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
518                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
519                      build_empty_stmt ());
520   gfc_add_expr_to_block (block, tmp);
521
522   /* Call malloc and check the result.  */
523   gfc_start_block (&block2);
524
525   size = fold_build2 (MAX_EXPR, size_type_node, size,
526                       build_int_cst (size_type_node, 1));
527
528   gfc_add_modify (&block2, res,
529                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
530                        size));
531   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
532                              build_int_cst (pvoid_type_node, 0));
533   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
534       ("Memory allocation failed"));
535   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
536                      build_call_expr (gfor_fndecl_os_error, 1, msg),
537                      build_empty_stmt ());
538   gfc_add_expr_to_block (&block2, tmp);
539   malloc_result = gfc_finish_block (&block2);
540
541   gfc_add_expr_to_block (block, malloc_result);
542
543   if (type != NULL)
544     res = fold_convert (type, res);
545   return res;
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 (pvoid_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,
609                                       status, build_int_cst (status_type, 0)),
610                          tmp, build_empty_stmt ());
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 (gfor_fndecl_runtime_error, 1, msg);
619
620   if (status != NULL_TREE && !integer_zerop (status))
621     {
622       /* Set the status variable if it's present.  */
623       stmtblock_t set_status_block;
624
625       gfc_start_block (&set_status_block);
626       gfc_add_modify (&set_status_block,
627                            fold_build1 (INDIRECT_REF, status_type, status),
628                            build_int_cst (status_type, LIBERROR_ALLOCATION));
629       gfc_add_modify (&set_status_block, res,
630                            build_int_cst (pvoid_type_node, 0));
631
632       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
633                          build_int_cst (status_type, 0));
634       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
635                            gfc_finish_block (&set_status_block));
636     }
637
638   /* The allocation itself.  */
639   gfc_start_block (&alloc_block);
640   gfc_add_modify (&alloc_block, res,
641                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
642                                         fold_build2 (MAX_EXPR, size_type_node,
643                                                      size,
644                                                      build_int_cst (size_type_node, 1))));
645
646   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
647                                                 ("Out of memory"));
648   tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
649
650   if (status != NULL_TREE && !integer_zerop (status))
651     {
652       /* Set the status variable if it's present.  */
653       tree tmp2;
654
655       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
656                           build_int_cst (status_type, 0));
657       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
658                           fold_build1 (INDIRECT_REF, status_type, status),
659                           build_int_cst (status_type, LIBERROR_ALLOCATION));
660       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
661                          tmp2);
662     }
663
664   tmp = fold_build3 (COND_EXPR, void_type_node,
665                      fold_build2 (EQ_EXPR, boolean_type_node, res,
666                                   build_int_cst (pvoid_type_node, 0)),
667                      tmp, build_empty_stmt ());
668   gfc_add_expr_to_block (&alloc_block, tmp);
669
670   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
671                       build_int_cst (TREE_TYPE (size), 0));
672   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
673                      gfc_finish_block (&alloc_block));
674   gfc_add_expr_to_block (block, tmp);
675
676   return res;
677 }
678
679
680 /* Generate code for an ALLOCATE statement when the argument is an
681    allocatable array.  If the array is currently allocated, it is an
682    error to allocate it again.
683  
684    This function follows the following pseudo-code:
685   
686     void *
687     allocate_array (void *mem, size_t size, integer_type *stat)
688     {
689       if (mem == NULL)
690         return allocate (size, stat);
691       else
692       {
693         if (stat)
694         {
695           free (mem);
696           mem = allocate (size, stat);
697           *stat = LIBERROR_ALLOCATION;
698           return mem;
699         }
700         else
701           runtime_error ("Attempting to allocate already allocated array");
702     }
703     
704     expr must be set to the original expression being allocated for its locus
705     and variable name in case a runtime error has to be printed.  */
706 tree
707 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
708                                 tree status, gfc_expr* expr)
709 {
710   stmtblock_t alloc_block;
711   tree res, tmp, null_mem, alloc, error;
712   tree type = TREE_TYPE (mem);
713
714   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
715     size = fold_convert (size_type_node, size);
716
717   /* Create a variable to hold the result.  */
718   res = gfc_create_var (pvoid_type_node, NULL);
719   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
720                           build_int_cst (type, 0));
721
722   /* If mem is NULL, we call gfc_allocate_with_status.  */
723   gfc_start_block (&alloc_block);
724   tmp = gfc_allocate_with_status (&alloc_block, size, status);
725   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
726   alloc = gfc_finish_block (&alloc_block);
727
728   /* Otherwise, we issue a runtime error or set the status variable.  */
729   if (expr)
730     {
731       tree varname;
732
733       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
734       varname = gfc_build_cstring_const (expr->symtree->name);
735       varname = gfc_build_addr_expr (pchar_type_node, varname);
736
737       error = gfc_trans_runtime_error (true, &expr->where,
738                                        "Attempting to allocate already"
739                                        " allocated array '%s'",
740                                        varname);
741     }
742   else
743     error = gfc_trans_runtime_error (true, NULL,
744                                      "Attempting to allocate already allocated"
745                                      "array");
746
747   if (status != NULL_TREE && !integer_zerop (status))
748     {
749       tree status_type = TREE_TYPE (TREE_TYPE (status));
750       stmtblock_t set_status_block;
751
752       gfc_start_block (&set_status_block);
753       tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
754                              fold_convert (pvoid_type_node, mem));
755       gfc_add_expr_to_block (&set_status_block, tmp);
756
757       tmp = gfc_allocate_with_status (&set_status_block, size, status);
758       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
759
760       gfc_add_modify (&set_status_block,
761                            fold_build1 (INDIRECT_REF, status_type, status),
762                            build_int_cst (status_type, LIBERROR_ALLOCATION));
763
764       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
765                          build_int_cst (status_type, 0));
766       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
767                            gfc_finish_block (&set_status_block));
768     }
769
770   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
771   gfc_add_expr_to_block (block, tmp);
772
773   return res;
774 }
775
776
777 /* Free a given variable, if it's not NULL.  */
778 tree
779 gfc_call_free (tree var)
780 {
781   stmtblock_t block;
782   tree tmp, cond, call;
783
784   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
785     var = fold_convert (pvoid_type_node, var);
786
787   gfc_start_block (&block);
788   var = gfc_evaluate_now (var, &block);
789   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
790                       build_int_cst (pvoid_type_node, 0));
791   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
792   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
793                      build_empty_stmt ());
794   gfc_add_expr_to_block (&block, tmp);
795
796   return gfc_finish_block (&block);
797 }
798
799
800
801 /* User-deallocate; we emit the code directly from the front-end, and the
802    logic is the same as the previous library function:
803
804     void
805     deallocate (void *pointer, GFC_INTEGER_4 * stat)
806     {
807       if (!pointer)
808         {
809           if (stat)
810             *stat = 1;
811           else
812             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
813         }
814       else
815         {
816           free (pointer);
817           if (stat)
818             *stat = 0;
819         }
820     }
821
822    In this front-end version, status doesn't have to be GFC_INTEGER_4.
823    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
824    even when no status variable is passed to us (this is used for
825    unconditional deallocation generated by the front-end at end of
826    each procedure).
827    
828    If a runtime-message is possible, `expr' must point to the original
829    expression being deallocated for its locus and variable name.  */
830 tree
831 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
832                             gfc_expr* expr)
833 {
834   stmtblock_t null, non_null;
835   tree cond, tmp, error;
836
837   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
838                       build_int_cst (TREE_TYPE (pointer), 0));
839
840   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
841      we emit a runtime error.  */
842   gfc_start_block (&null);
843   if (!can_fail)
844     {
845       tree varname;
846
847       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
848
849       varname = gfc_build_cstring_const (expr->symtree->name);
850       varname = gfc_build_addr_expr (pchar_type_node, varname);
851
852       error = gfc_trans_runtime_error (true, &expr->where,
853                                        "Attempt to DEALLOCATE unallocated '%s'",
854                                        varname);
855     }
856   else
857     error = build_empty_stmt ();
858
859   if (status != NULL_TREE && !integer_zerop (status))
860     {
861       tree status_type = TREE_TYPE (TREE_TYPE (status));
862       tree cond2;
863
864       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
865                            build_int_cst (TREE_TYPE (status), 0));
866       tmp = fold_build2 (MODIFY_EXPR, status_type,
867                          fold_build1 (INDIRECT_REF, status_type, status),
868                          build_int_cst (status_type, 1));
869       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
870     }
871
872   gfc_add_expr_to_block (&null, error);
873
874   /* When POINTER is not NULL, we free it.  */
875   gfc_start_block (&non_null);
876   tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
877                          fold_convert (pvoid_type_node, pointer));
878   gfc_add_expr_to_block (&non_null, tmp);
879
880   if (status != NULL_TREE && !integer_zerop (status))
881     {
882       /* We set STATUS to zero if it is present.  */
883       tree status_type = TREE_TYPE (TREE_TYPE (status));
884       tree cond2;
885
886       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
887                            build_int_cst (TREE_TYPE (status), 0));
888       tmp = fold_build2 (MODIFY_EXPR, status_type,
889                          fold_build1 (INDIRECT_REF, status_type, status),
890                          build_int_cst (status_type, 0));
891       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
892                          build_empty_stmt ());
893       gfc_add_expr_to_block (&non_null, tmp);
894     }
895
896   return fold_build3 (COND_EXPR, void_type_node, cond,
897                       gfc_finish_block (&null), gfc_finish_block (&non_null));
898 }
899
900
901 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
902    following pseudo-code:
903
904 void *
905 internal_realloc (void *mem, size_t size)
906 {
907   if (size < 0)
908     runtime_error ("Attempt to allocate a negative amount of memory.");
909   res = realloc (mem, size);
910   if (!res && size != 0)
911     _gfortran_os_error ("Out of memory");
912
913   if (size == 0)
914     return NULL;
915
916   return res;
917 }  */
918 tree
919 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
920 {
921   tree msg, res, negative, nonzero, zero, null_result, tmp;
922   tree type = TREE_TYPE (mem);
923
924   size = gfc_evaluate_now (size, block);
925
926   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
927     size = fold_convert (size_type_node, size);
928
929   /* Create a variable to hold the result.  */
930   res = gfc_create_var (type, NULL);
931
932   /* size < 0 ?  */
933   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
934                           build_int_cst (size_type_node, 0));
935   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
936       ("Attempt to allocate a negative amount of memory."));
937   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
938                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
939                      build_empty_stmt ());
940   gfc_add_expr_to_block (block, tmp);
941
942   /* Call realloc and check the result.  */
943   tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
944                          fold_convert (pvoid_type_node, mem), size);
945   gfc_add_modify (block, res, fold_convert (type, tmp));
946   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
947                              build_int_cst (pvoid_type_node, 0));
948   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
949                          build_int_cst (size_type_node, 0));
950   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
951                              nonzero);
952   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
953                                                 ("Out of memory"));
954   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
955                      build_call_expr (gfor_fndecl_os_error, 1, msg),
956                      build_empty_stmt ());
957   gfc_add_expr_to_block (block, tmp);
958
959   /* if (size == 0) then the result is NULL.  */
960   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
961   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
962   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
963                      build_empty_stmt ());
964   gfc_add_expr_to_block (block, tmp);
965
966   return res;
967 }
968
969 /* Add a statement to a block.  */
970
971 void
972 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
973 {
974   gcc_assert (block);
975
976   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
977     return;
978
979   if (block->head)
980     {
981       if (TREE_CODE (block->head) != STATEMENT_LIST)
982         {
983           tree tmp;
984
985           tmp = block->head;
986           block->head = NULL_TREE;
987           append_to_statement_list (tmp, &block->head);
988         }
989       append_to_statement_list (expr, &block->head);
990     }
991   else
992     /* Don't bother creating a list if we only have a single statement.  */
993     block->head = expr;
994 }
995
996
997 /* Add a block the end of a block.  */
998
999 void
1000 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1001 {
1002   gcc_assert (append);
1003   gcc_assert (!append->has_scope);
1004
1005   gfc_add_expr_to_block (block, append->head);
1006   append->head = NULL_TREE;
1007 }
1008
1009
1010 /* Get the current locus.  The structure may not be complete, and should
1011    only be used with gfc_set_backend_locus.  */
1012
1013 void
1014 gfc_get_backend_locus (locus * loc)
1015 {
1016   loc->lb = XCNEW (gfc_linebuf);
1017   loc->lb->location = input_location;
1018   loc->lb->file = gfc_current_backend_file;
1019 }
1020
1021
1022 /* Set the current locus.  */
1023
1024 void
1025 gfc_set_backend_locus (locus * loc)
1026 {
1027   gfc_current_backend_file = loc->lb->file;
1028   input_location = loc->lb->location;
1029 }
1030
1031
1032 /* Translate an executable statement.  */
1033
1034 tree
1035 gfc_trans_code (gfc_code * code)
1036 {
1037   stmtblock_t block;
1038   tree res;
1039
1040   if (!code)
1041     return build_empty_stmt ();
1042
1043   gfc_start_block (&block);
1044
1045   /* Translate statements one by one into GENERIC trees until we reach
1046      the end of this gfc_code branch.  */
1047   for (; code; code = code->next)
1048     {
1049       if (code->here != 0)
1050         {
1051           res = gfc_trans_label_here (code);
1052           gfc_add_expr_to_block (&block, res);
1053         }
1054
1055       switch (code->op)
1056         {
1057         case EXEC_NOP:
1058         case EXEC_END_BLOCK:
1059           res = NULL_TREE;
1060           break;
1061
1062         case EXEC_ASSIGN:
1063           res = gfc_trans_assign (code);
1064           break;
1065
1066         case EXEC_LABEL_ASSIGN:
1067           res = gfc_trans_label_assign (code);
1068           break;
1069
1070         case EXEC_POINTER_ASSIGN:
1071           res = gfc_trans_pointer_assign (code);
1072           break;
1073
1074         case EXEC_INIT_ASSIGN:
1075           res = gfc_trans_init_assign (code);
1076           break;
1077
1078         case EXEC_CONTINUE:
1079           res = NULL_TREE;
1080           break;
1081
1082         case EXEC_CYCLE:
1083           res = gfc_trans_cycle (code);
1084           break;
1085
1086         case EXEC_EXIT:
1087           res = gfc_trans_exit (code);
1088           break;
1089
1090         case EXEC_GOTO:
1091           res = gfc_trans_goto (code);
1092           break;
1093
1094         case EXEC_ENTRY:
1095           res = gfc_trans_entry (code);
1096           break;
1097
1098         case EXEC_PAUSE:
1099           res = gfc_trans_pause (code);
1100           break;
1101
1102         case EXEC_STOP:
1103           res = gfc_trans_stop (code);
1104           break;
1105
1106         case EXEC_CALL:
1107           /* For MVBITS we've got the special exception that we need a
1108              dependency check, too.  */
1109           {
1110             bool is_mvbits = false;
1111             if (code->resolved_isym
1112                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1113               is_mvbits = true;
1114             res = gfc_trans_call (code, is_mvbits);
1115           }
1116           break;
1117
1118         case EXEC_ASSIGN_CALL:
1119           res = gfc_trans_call (code, true);
1120           break;
1121
1122         case EXEC_RETURN:
1123           res = gfc_trans_return (code);
1124           break;
1125
1126         case EXEC_IF:
1127           res = gfc_trans_if (code);
1128           break;
1129
1130         case EXEC_ARITHMETIC_IF:
1131           res = gfc_trans_arithmetic_if (code);
1132           break;
1133
1134         case EXEC_DO:
1135           res = gfc_trans_do (code);
1136           break;
1137
1138         case EXEC_DO_WHILE:
1139           res = gfc_trans_do_while (code);
1140           break;
1141
1142         case EXEC_SELECT:
1143           res = gfc_trans_select (code);
1144           break;
1145
1146         case EXEC_FLUSH:
1147           res = gfc_trans_flush (code);
1148           break;
1149
1150         case EXEC_FORALL:
1151           res = gfc_trans_forall (code);
1152           break;
1153
1154         case EXEC_WHERE:
1155           res = gfc_trans_where (code);
1156           break;
1157
1158         case EXEC_ALLOCATE:
1159           res = gfc_trans_allocate (code);
1160           break;
1161
1162         case EXEC_DEALLOCATE:
1163           res = gfc_trans_deallocate (code);
1164           break;
1165
1166         case EXEC_OPEN:
1167           res = gfc_trans_open (code);
1168           break;
1169
1170         case EXEC_CLOSE:
1171           res = gfc_trans_close (code);
1172           break;
1173
1174         case EXEC_READ:
1175           res = gfc_trans_read (code);
1176           break;
1177
1178         case EXEC_WRITE:
1179           res = gfc_trans_write (code);
1180           break;
1181
1182         case EXEC_IOLENGTH:
1183           res = gfc_trans_iolength (code);
1184           break;
1185
1186         case EXEC_BACKSPACE:
1187           res = gfc_trans_backspace (code);
1188           break;
1189
1190         case EXEC_ENDFILE:
1191           res = gfc_trans_endfile (code);
1192           break;
1193
1194         case EXEC_INQUIRE:
1195           res = gfc_trans_inquire (code);
1196           break;
1197
1198         case EXEC_WAIT:
1199           res = gfc_trans_wait (code);
1200           break;
1201
1202         case EXEC_REWIND:
1203           res = gfc_trans_rewind (code);
1204           break;
1205
1206         case EXEC_TRANSFER:
1207           res = gfc_trans_transfer (code);
1208           break;
1209
1210         case EXEC_DT_END:
1211           res = gfc_trans_dt_end (code);
1212           break;
1213
1214         case EXEC_OMP_ATOMIC:
1215         case EXEC_OMP_BARRIER:
1216         case EXEC_OMP_CRITICAL:
1217         case EXEC_OMP_DO:
1218         case EXEC_OMP_FLUSH:
1219         case EXEC_OMP_MASTER:
1220         case EXEC_OMP_ORDERED:
1221         case EXEC_OMP_PARALLEL:
1222         case EXEC_OMP_PARALLEL_DO:
1223         case EXEC_OMP_PARALLEL_SECTIONS:
1224         case EXEC_OMP_PARALLEL_WORKSHARE:
1225         case EXEC_OMP_SECTIONS:
1226         case EXEC_OMP_SINGLE:
1227         case EXEC_OMP_TASK:
1228         case EXEC_OMP_TASKWAIT:
1229         case EXEC_OMP_WORKSHARE:
1230           res = gfc_trans_omp_directive (code);
1231           break;
1232
1233         default:
1234           internal_error ("gfc_trans_code(): Bad statement code");
1235         }
1236
1237       gfc_set_backend_locus (&code->loc);
1238
1239       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1240         {
1241           if (TREE_CODE (res) == STATEMENT_LIST)
1242             tree_annotate_all_with_location (&res, input_location);
1243           else
1244             SET_EXPR_LOCATION (res, input_location);
1245             
1246           /* Add the new statement to the block.  */
1247           gfc_add_expr_to_block (&block, res);
1248         }
1249     }
1250
1251   /* Return the finished block.  */
1252   return gfc_finish_block (&block);
1253 }
1254
1255
1256 /* This function is called after a complete program unit has been parsed
1257    and resolved.  */
1258
1259 void
1260 gfc_generate_code (gfc_namespace * ns)
1261 {
1262   if (ns->is_block_data)
1263     {
1264       gfc_generate_block_data (ns);
1265       return;
1266     }
1267
1268   gfc_generate_function_code (ns);
1269 }
1270
1271
1272 /* This function is called after a complete module has been parsed
1273    and resolved.  */
1274
1275 void
1276 gfc_generate_module_code (gfc_namespace * ns)
1277 {
1278   gfc_namespace *n;
1279   struct module_htab_entry *entry;
1280
1281   gcc_assert (ns->proc_name->backend_decl == NULL);
1282   ns->proc_name->backend_decl
1283     = build_decl (NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1284                   void_type_node);
1285   gfc_set_decl_location (ns->proc_name->backend_decl,
1286                          &ns->proc_name->declared_at);
1287   entry = gfc_find_module (ns->proc_name->name);
1288   if (entry->namespace_decl)
1289     /* Buggy sourcecode, using a module before defining it?  */
1290     htab_empty (entry->decls);
1291   entry->namespace_decl = ns->proc_name->backend_decl;
1292
1293   gfc_generate_module_vars (ns);
1294
1295   /* We need to generate all module function prototypes first, to allow
1296      sibling calls.  */
1297   for (n = ns->contained; n; n = n->sibling)
1298     {
1299       gfc_entry_list *el;
1300
1301       if (!n->proc_name)
1302         continue;
1303
1304       gfc_create_function_decl (n);
1305       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1306       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1307       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1308       for (el = ns->entries; el; el = el->next)
1309         {
1310           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1311           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1312           gfc_module_add_decl (entry, el->sym->backend_decl);
1313         }
1314     }
1315
1316   for (n = ns->contained; n; n = n->sibling)
1317     {
1318       if (!n->proc_name)
1319         continue;
1320
1321       gfc_generate_function_code (n);
1322     }
1323 }
1324