OSDN Git Service

* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
[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 Free Software
3    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 "tree-gimple.h"
27 #include "ggc.h"
28 #include "toplev.h"
29 #include "defaults.h"
30 #include "real.h"
31 #include "flags.h"
32 #include "gfortran.h"
33 #include "trans.h"
34 #include "trans-stmt.h"
35 #include "trans-array.h"
36 #include "trans-types.h"
37 #include "trans-const.h"
38
39 /* Naming convention for backend interface code:
40
41    gfc_trans_*  translate gfc_code into STMT trees.
42
43    gfc_conv_*   expression conversion
44
45    gfc_get_*    get a backend tree representation of a decl or type  */
46
47 static gfc_file *gfc_current_backend_file;
48
49 char gfc_msg_bounds[] = N_("Array bound mismatch");
50 char gfc_msg_fault[] = N_("Array reference out of bounds");
51 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 an 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_expr (pblock, var, expr);
146
147   return var;
148 }
149
150
151 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
152    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
153    LHS <- RHS.  */
154
155 void
156 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
157                 bool tuples_p)
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 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
171                      void_type_node, lhs, rhs);
172   gfc_add_expr_to_block (pblock, tmp);
173 }
174
175
176 /* Create a new scope/binding level and initialize a block.  Care must be
177    taken when translating expressions as any temporaries will be placed in
178    the innermost scope.  */
179
180 void
181 gfc_start_block (stmtblock_t * block)
182 {
183   /* Start a new binding level.  */
184   pushlevel (0);
185   block->has_scope = 1;
186
187   /* The block is empty.  */
188   block->head = NULL_TREE;
189 }
190
191
192 /* Initialize a block without creating a new scope.  */
193
194 void
195 gfc_init_block (stmtblock_t * block)
196 {
197   block->head = NULL_TREE;
198   block->has_scope = 0;
199 }
200
201
202 /* Sometimes we create a scope but it turns out that we don't actually
203    need it.  This function merges the scope of BLOCK with its parent.
204    Only variable decls will be merged, you still need to add the code.  */
205
206 void
207 gfc_merge_block_scope (stmtblock_t * block)
208 {
209   tree decl;
210   tree next;
211
212   gcc_assert (block->has_scope);
213   block->has_scope = 0;
214
215   /* Remember the decls in this scope.  */
216   decl = getdecls ();
217   poplevel (0, 0, 0);
218
219   /* Add them to the parent scope.  */
220   while (decl != NULL_TREE)
221     {
222       next = TREE_CHAIN (decl);
223       TREE_CHAIN (decl) = NULL_TREE;
224
225       pushdecl (decl);
226       decl = next;
227     }
228 }
229
230
231 /* Finish a scope containing a block of statements.  */
232
233 tree
234 gfc_finish_block (stmtblock_t * stmtblock)
235 {
236   tree decl;
237   tree expr;
238   tree block;
239
240   expr = stmtblock->head;
241   if (!expr)
242     expr = build_empty_stmt ();
243
244   stmtblock->head = NULL_TREE;
245
246   if (stmtblock->has_scope)
247     {
248       decl = getdecls ();
249
250       if (decl)
251         {
252           block = poplevel (1, 0, 0);
253           expr = build3_v (BIND_EXPR, decl, expr, block);
254         }
255       else
256         poplevel (0, 0, 0);
257     }
258
259   return expr;
260 }
261
262
263 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
264    natural type is used.  */
265
266 tree
267 gfc_build_addr_expr (tree type, tree t)
268 {
269   tree base_type = TREE_TYPE (t);
270   tree natural_type;
271
272   if (type && POINTER_TYPE_P (type)
273       && TREE_CODE (base_type) == ARRAY_TYPE
274       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
275          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
276     {
277       tree min_val = size_zero_node;
278       tree type_domain = TYPE_DOMAIN (base_type);
279       if (type_domain && TYPE_MIN_VALUE (type_domain))
280         min_val = TYPE_MIN_VALUE (type_domain);
281       t = build4 (ARRAY_REF, TREE_TYPE (type), t, min_val,
282                   NULL_TREE, NULL_TREE);
283       natural_type = type;
284     }
285   else
286     natural_type = build_pointer_type (base_type);
287
288   if (TREE_CODE (t) == INDIRECT_REF)
289     {
290       if (!type)
291         type = natural_type;
292       t = TREE_OPERAND (t, 0);
293       natural_type = TREE_TYPE (t);
294     }
295   else
296     {
297       if (DECL_P (t))
298         TREE_ADDRESSABLE (t) = 1;
299       t = 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)
313 {
314   tree type = TREE_TYPE (base);
315   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
316   type = TREE_TYPE (type);
317
318   if (DECL_P (base))
319     TREE_ADDRESSABLE (base) = 1;
320
321   /* Strip NON_LVALUE_EXPR nodes.  */
322   STRIP_TYPE_NOPS (offset);
323
324   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
325 }
326
327
328 /* Generate a runtime error if COND is true.  */
329
330 void
331 gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
332                          const char * msgid, ...)
333 {
334   va_list ap;
335   stmtblock_t block;
336   tree body;
337   tree tmp;
338   tree arg, arg2;
339   tree *argarray;
340   tree fntype;
341   char *message;
342   const char *p;
343   int line, nargs, i;
344
345   if (integer_zerop (cond))
346     return;
347
348   /* Compute the number of extra arguments from the format string.  */
349   for (p = msgid, nargs = 0; *p; p++)
350     if (*p == '%')
351       {
352         p++;
353         if (*p != '%')
354           nargs++;
355       }
356
357   /* The code to generate the error.  */
358   gfc_start_block (&block);
359
360   if (where)
361     {
362 #ifdef USE_MAPPED_LOCATION
363       line = LOCATION_LINE (where->lb->location);
364 #else 
365       line = where->lb->linenum;
366 #endif
367       asprintf (&message, "At line %d of file %s",  line,
368                 where->lb->file->filename);
369     }
370   else
371     asprintf (&message, "In file '%s', around line %d",
372               gfc_source_file, input_line + 1);
373
374   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
375   gfc_free(message);
376   
377   asprintf (&message, "%s", _(msgid));
378   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
379   gfc_free(message);
380
381   /* Build the argument array.  */
382   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
383   argarray[0] = arg;
384   argarray[1] = arg2;
385   va_start (ap, msgid);
386   for (i = 0; i < nargs; i++)
387     argarray[2+i] = va_arg (ap, tree);
388   va_end (ap);
389   
390   /* Build the function call to runtime_error_at; because of the variable
391      number of arguments, we can't use build_call_expr directly.  */
392   fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
393   tmp = fold_builtin_call_array (TREE_TYPE (fntype),
394                                  build1 (ADDR_EXPR,
395                                          build_pointer_type (fntype),
396                                          gfor_fndecl_runtime_error_at),
397                                  nargs + 2, argarray);
398   gfc_add_expr_to_block (&block, tmp);
399
400   body = gfc_finish_block (&block);
401
402   if (integer_onep (cond))
403     {
404       gfc_add_expr_to_block (pblock, body);
405     }
406   else
407     {
408       /* Tell the compiler that this isn't likely.  */
409       cond = fold_convert (long_integer_type_node, cond);
410       tmp = build_int_cst (long_integer_type_node, 0);
411       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
412       cond = fold_convert (boolean_type_node, cond);
413
414       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
415       gfc_add_expr_to_block (pblock, tmp);
416     }
417 }
418
419
420 /* Call malloc to allocate size bytes of memory, with special conditions:
421       + if size < 0, generate a runtime error,
422       + if size == 0, return a NULL pointer,
423       + if malloc returns NULL, issue a runtime error.  */
424 tree
425 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
426 {
427   tree tmp, msg, negative, zero, malloc_result, null_result, res;
428   stmtblock_t block2;
429
430   size = gfc_evaluate_now (size, block);
431
432   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
433     size = fold_convert (size_type_node, size);
434
435   /* Create a variable to hold the result.  */
436   res = gfc_create_var (pvoid_type_node, NULL);
437
438   /* size < 0 ?  */
439   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
440                           build_int_cst (size_type_node, 0));
441   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
442       ("Attempt to allocate a negative amount of memory."));
443   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
444                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
445                      build_empty_stmt ());
446   gfc_add_expr_to_block (block, tmp);
447
448   /* Call malloc and check the result.  */
449   gfc_start_block (&block2);
450   gfc_add_modify_expr (&block2, res,
451                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
452                        size));
453   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
454                              build_int_cst (pvoid_type_node, 0));
455   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
456       ("Memory allocation failed"));
457   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
458                      build_call_expr (gfor_fndecl_os_error, 1, msg),
459                      build_empty_stmt ());
460   gfc_add_expr_to_block (&block2, tmp);
461   malloc_result = gfc_finish_block (&block2);
462
463   /* size == 0  */
464   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
465                       build_int_cst (size_type_node, 0));
466   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
467                      build_int_cst (pvoid_type_node, 0));
468   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
469   gfc_add_expr_to_block (block, tmp);
470
471   if (type != NULL)
472     res = fold_convert (type, res);
473   return res;
474 }
475
476 /* The status variable of allocate statement is set to ERROR_ALLOCATION 
477    when the allocation wasn't successful. This value needs to be kept in
478    sync with libgfortran/libgfortran.h.  */
479 #define ERROR_ALLOCATION 5014
480
481 /* Allocate memory, using an optional status argument.
482  
483    This function follows the following pseudo-code:
484
485     void *
486     allocate (size_t size, integer_type* stat)
487     {
488       void *newmem;
489     
490       if (stat)
491         *stat = 0;
492
493       // The only time this can happen is the size wraps around.
494       if (size < 0)
495       {
496         if (stat)
497         {
498           *stat = ERROR_ALLOCATION;
499           newmem = NULL;
500         }
501         else
502           runtime_error ("Attempt to allocate negative amount of memory. "
503                          "Possible integer overflow");
504       }
505       else
506       {
507         newmem = malloc (MAX (size, 1));
508         if (newmem == NULL)
509         {
510           if (stat)
511             *stat = ERROR_ALLOCATION;
512           else
513             runtime_error ("Out of memory");
514         }
515       }
516
517       return newmem;
518     }  */
519 tree
520 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
521 {
522   stmtblock_t alloc_block;
523   tree res, tmp, error, msg, cond;
524   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
525
526   /* Evaluate size only once, and make sure it has the right type.  */
527   size = gfc_evaluate_now (size, block);
528   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
529     size = fold_convert (size_type_node, size);
530
531   /* Create a variable to hold the result.  */
532   res = gfc_create_var (pvoid_type_node, NULL);
533
534   /* Set the optional status variable to zero.  */
535   if (status != NULL_TREE && !integer_zerop (status))
536     {
537       tmp = fold_build2 (MODIFY_EXPR, status_type,
538                          build1 (INDIRECT_REF, status_type, status),
539                          build_int_cst (status_type, 0));
540       tmp = fold_build3 (COND_EXPR, void_type_node,
541                          fold_build2 (NE_EXPR, boolean_type_node,
542                                       status, build_int_cst (status_type, 0)),
543                          tmp, build_empty_stmt ());
544       gfc_add_expr_to_block (block, tmp);
545     }
546
547   /* Generate the block of code handling (size < 0).  */
548   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
549                         ("Attempt to allocate negative amount of memory. "
550                          "Possible integer overflow"));
551   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
552
553   if (status != NULL_TREE && !integer_zerop (status))
554     {
555       /* Set the status variable if it's present.  */
556       stmtblock_t set_status_block;
557
558       gfc_start_block (&set_status_block);
559       gfc_add_modify_expr (&set_status_block,
560                            build1 (INDIRECT_REF, status_type, status),
561                            build_int_cst (status_type, ERROR_ALLOCATION));
562       gfc_add_modify_expr (&set_status_block, res,
563                            build_int_cst (pvoid_type_node, 0));
564
565       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
566                          build_int_cst (status_type, 0));
567       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
568                            gfc_finish_block (&set_status_block));
569     }
570
571   /* The allocation itself.  */
572   gfc_start_block (&alloc_block);
573   gfc_add_modify_expr (&alloc_block, res,
574                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
575                                         fold_build2 (MAX_EXPR, size_type_node,
576                                                      size,
577                                                      build_int_cst (size_type_node, 1))));
578
579   msg = gfc_build_addr_expr (pchar_type_node,
580                              gfc_build_cstring_const ("Out of memory"));
581   tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
582
583   if (status != NULL_TREE && !integer_zerop (status))
584     {
585       /* Set the status variable if it's present.  */
586       tree tmp2;
587
588       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
589                           build_int_cst (status_type, 0));
590       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
591                           build1 (INDIRECT_REF, status_type, status),
592                           build_int_cst (status_type, ERROR_ALLOCATION));
593       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
594                          tmp2);
595     }
596
597   tmp = fold_build3 (COND_EXPR, void_type_node,
598                      fold_build2 (EQ_EXPR, boolean_type_node, res,
599                                   build_int_cst (pvoid_type_node, 0)),
600                      tmp, build_empty_stmt ());
601   gfc_add_expr_to_block (&alloc_block, tmp);
602
603   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
604                       build_int_cst (TREE_TYPE (size), 0));
605   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
606                      gfc_finish_block (&alloc_block));
607   gfc_add_expr_to_block (block, tmp);
608
609   return res;
610 }
611
612
613 /* Generate code for an ALLOCATE statement when the argument is an
614    allocatable array.  If the array is currently allocated, it is an
615    error to allocate it again.
616  
617    This function follows the following pseudo-code:
618   
619     void *
620     allocate_array (void *mem, size_t size, integer_type *stat)
621     {
622       if (mem == NULL)
623         return allocate (size, stat);
624       else
625       {
626         if (stat)
627         {
628           free (mem);
629           mem = allocate (size, stat);
630           *stat = ERROR_ALLOCATION;
631           return mem;
632         }
633         else
634           runtime_error ("Attempting to allocate already allocated array");
635     }  */
636 tree
637 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
638                                 tree status)
639 {
640   stmtblock_t alloc_block;
641   tree res, tmp, null_mem, alloc, error, msg;
642   tree type = TREE_TYPE (mem);
643
644   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
645     size = fold_convert (size_type_node, size);
646
647   /* Create a variable to hold the result.  */
648   res = gfc_create_var (pvoid_type_node, NULL);
649   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
650                           build_int_cst (type, 0));
651
652   /* If mem is NULL, we call gfc_allocate_with_status.  */
653   gfc_start_block (&alloc_block);
654   tmp = gfc_allocate_with_status (&alloc_block, size, status);
655   gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
656   alloc = gfc_finish_block (&alloc_block);
657
658   /* Otherwise, we issue a runtime error or set the status variable.  */
659   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
660                         ("Attempting to allocate already allocated array"));
661   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
662
663   if (status != NULL_TREE && !integer_zerop (status))
664     {
665       tree status_type = TREE_TYPE (TREE_TYPE (status));
666       stmtblock_t set_status_block;
667
668       gfc_start_block (&set_status_block);
669       tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
670                              fold_convert (pvoid_type_node, mem));
671       gfc_add_expr_to_block (&set_status_block, tmp);
672
673       tmp = gfc_allocate_with_status (&set_status_block, size, status);
674       gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
675
676       gfc_add_modify_expr (&set_status_block,
677                            build1 (INDIRECT_REF, status_type, status),
678                            build_int_cst (status_type, ERROR_ALLOCATION));
679
680       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
681                          build_int_cst (status_type, 0));
682       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
683                            gfc_finish_block (&set_status_block));
684     }
685
686   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
687   gfc_add_expr_to_block (block, tmp);
688
689   return res;
690 }
691
692
693 /* Free a given variable, if it's not NULL.  */
694 tree
695 gfc_call_free (tree var)
696 {
697   stmtblock_t block;
698   tree tmp, cond, call;
699
700   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
701     var = fold_convert (pvoid_type_node, var);
702
703   gfc_start_block (&block);
704   var = gfc_evaluate_now (var, &block);
705   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
706                       build_int_cst (pvoid_type_node, 0));
707   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
708   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
709                      build_empty_stmt ());
710   gfc_add_expr_to_block (&block, tmp);
711
712   return gfc_finish_block (&block);
713 }
714
715
716
717 /* User-deallocate; we emit the code directly from the front-end, and the
718    logic is the same as the previous library function:
719
720     void
721     deallocate (void *pointer, GFC_INTEGER_4 * stat)
722     {
723       if (!pointer)
724         {
725           if (stat)
726             *stat = 1;
727           else
728             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
729         }
730       else
731         {
732           free (pointer);
733           if (stat)
734             *stat = 0;
735         }
736     }
737
738    In this front-end version, status doesn't have to be GFC_INTEGER_4.
739    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
740    even when no status variable is passed to us (this is used for
741    unconditional deallocation generated by the front-end at end of
742    each procedure).  */
743 tree
744 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
745 {
746   stmtblock_t null, non_null;
747   tree cond, tmp, error, msg;
748
749   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
750                       build_int_cst (TREE_TYPE (pointer), 0));
751
752   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
753      we emit a runtime error.  */
754   gfc_start_block (&null);
755   if (!can_fail)
756     {
757       msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
758                         ("Attempt to DEALLOCATE unallocated memory."));
759       error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
760     }
761   else
762     error = build_empty_stmt ();
763
764   if (status != NULL_TREE && !integer_zerop (status))
765     {
766       tree status_type = TREE_TYPE (TREE_TYPE (status));
767       tree cond2;
768
769       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
770                            build_int_cst (TREE_TYPE (status), 0));
771       tmp = fold_build2 (MODIFY_EXPR, status_type,
772                          build1 (INDIRECT_REF, status_type, status),
773                          build_int_cst (status_type, 1));
774       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
775     }
776
777   gfc_add_expr_to_block (&null, error);
778
779   /* When POINTER is not NULL, we free it.  */
780   gfc_start_block (&non_null);
781   tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
782                          fold_convert (pvoid_type_node, pointer));
783   gfc_add_expr_to_block (&non_null, tmp);
784
785   if (status != NULL_TREE && !integer_zerop (status))
786     {
787       /* We set STATUS to zero if it is present.  */
788       tree status_type = TREE_TYPE (TREE_TYPE (status));
789       tree cond2;
790
791       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
792                            build_int_cst (TREE_TYPE (status), 0));
793       tmp = fold_build2 (MODIFY_EXPR, status_type,
794                          build1 (INDIRECT_REF, status_type, status),
795                          build_int_cst (status_type, 0));
796       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
797                          build_empty_stmt ());
798       gfc_add_expr_to_block (&non_null, tmp);
799     }
800
801   return fold_build3 (COND_EXPR, void_type_node, cond,
802                       gfc_finish_block (&null), gfc_finish_block (&non_null));
803 }
804
805
806 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
807    following pseudo-code:
808
809 void *
810 internal_realloc (void *mem, size_t size)
811 {
812   if (size < 0)
813     runtime_error ("Attempt to allocate a negative amount of memory.");
814   mem = realloc (mem, size);
815   if (!mem && size != 0)
816     _gfortran_os_error ("Out of memory");
817
818   if (size == 0)
819     return NULL;
820
821   return mem;
822 }  */
823 tree
824 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
825 {
826   tree msg, res, negative, zero, null_result, tmp;
827   tree type = TREE_TYPE (mem);
828
829   size = gfc_evaluate_now (size, block);
830
831   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
832     size = fold_convert (size_type_node, size);
833
834   /* Create a variable to hold the result.  */
835   res = gfc_create_var (type, NULL);
836
837   /* size < 0 ?  */
838   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
839                           build_int_cst (size_type_node, 0));
840   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
841       ("Attempt to allocate a negative amount of memory."));
842   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
843                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
844                      build_empty_stmt ());
845   gfc_add_expr_to_block (block, tmp);
846
847   /* Call realloc and check the result.  */
848   tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
849                          fold_convert (pvoid_type_node, mem), size);
850   gfc_add_modify_expr (block, res, fold_convert (type, tmp));
851   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
852                              build_int_cst (pvoid_type_node, 0));
853   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
854                       build_int_cst (size_type_node, 0));
855   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
856                              zero);
857   msg = gfc_build_addr_expr (pchar_type_node,
858                              gfc_build_cstring_const ("Out of memory"));
859   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
860                      build_call_expr (gfor_fndecl_os_error, 1, msg),
861                      build_empty_stmt ());
862   gfc_add_expr_to_block (block, tmp);
863
864   /* if (size == 0) then the result is NULL.  */
865   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
866   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
867                      build_empty_stmt ());
868   gfc_add_expr_to_block (block, tmp);
869
870   return res;
871 }
872
873 /* Add a statement to a block.  */
874
875 void
876 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
877 {
878   gcc_assert (block);
879
880   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
881     return;
882
883   if (block->head)
884     {
885       if (TREE_CODE (block->head) != STATEMENT_LIST)
886         {
887           tree tmp;
888
889           tmp = block->head;
890           block->head = NULL_TREE;
891           append_to_statement_list (tmp, &block->head);
892         }
893       append_to_statement_list (expr, &block->head);
894     }
895   else
896     /* Don't bother creating a list if we only have a single statement.  */
897     block->head = expr;
898 }
899
900
901 /* Add a block the end of a block.  */
902
903 void
904 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
905 {
906   gcc_assert (append);
907   gcc_assert (!append->has_scope);
908
909   gfc_add_expr_to_block (block, append->head);
910   append->head = NULL_TREE;
911 }
912
913
914 /* Get the current locus.  The structure may not be complete, and should
915    only be used with gfc_set_backend_locus.  */
916
917 void
918 gfc_get_backend_locus (locus * loc)
919 {
920   loc->lb = gfc_getmem (sizeof (gfc_linebuf));    
921 #ifdef USE_MAPPED_LOCATION
922   loc->lb->location = input_location;
923 #else
924   loc->lb->linenum = input_line;
925 #endif
926   loc->lb->file = gfc_current_backend_file;
927 }
928
929
930 /* Set the current locus.  */
931
932 void
933 gfc_set_backend_locus (locus * loc)
934 {
935   gfc_current_backend_file = loc->lb->file;
936 #ifdef USE_MAPPED_LOCATION
937   input_location = loc->lb->location;
938 #else
939   input_line = loc->lb->linenum;
940   input_filename = loc->lb->file->filename;
941 #endif
942 }
943
944
945 /* Translate an executable statement.  */
946
947 tree
948 gfc_trans_code (gfc_code * code)
949 {
950   stmtblock_t block;
951   tree res;
952
953   if (!code)
954     return build_empty_stmt ();
955
956   gfc_start_block (&block);
957
958   /* Translate statements one by one to GIMPLE trees until we reach
959      the end of this gfc_code branch.  */
960   for (; code; code = code->next)
961     {
962       if (code->here != 0)
963         {
964           res = gfc_trans_label_here (code);
965           gfc_add_expr_to_block (&block, res);
966         }
967
968       switch (code->op)
969         {
970         case EXEC_NOP:
971           res = NULL_TREE;
972           break;
973
974         case EXEC_ASSIGN:
975           res = gfc_trans_assign (code);
976           break;
977
978         case EXEC_LABEL_ASSIGN:
979           res = gfc_trans_label_assign (code);
980           break;
981
982         case EXEC_POINTER_ASSIGN:
983           res = gfc_trans_pointer_assign (code);
984           break;
985
986         case EXEC_INIT_ASSIGN:
987           res = gfc_trans_init_assign (code);
988           break;
989
990         case EXEC_CONTINUE:
991           res = NULL_TREE;
992           break;
993
994         case EXEC_CYCLE:
995           res = gfc_trans_cycle (code);
996           break;
997
998         case EXEC_EXIT:
999           res = gfc_trans_exit (code);
1000           break;
1001
1002         case EXEC_GOTO:
1003           res = gfc_trans_goto (code);
1004           break;
1005
1006         case EXEC_ENTRY:
1007           res = gfc_trans_entry (code);
1008           break;
1009
1010         case EXEC_PAUSE:
1011           res = gfc_trans_pause (code);
1012           break;
1013
1014         case EXEC_STOP:
1015           res = gfc_trans_stop (code);
1016           break;
1017
1018         case EXEC_CALL:
1019           res = gfc_trans_call (code, false);
1020           break;
1021
1022         case EXEC_ASSIGN_CALL:
1023           res = gfc_trans_call (code, true);
1024           break;
1025
1026         case EXEC_RETURN:
1027           res = gfc_trans_return (code);
1028           break;
1029
1030         case EXEC_IF:
1031           res = gfc_trans_if (code);
1032           break;
1033
1034         case EXEC_ARITHMETIC_IF:
1035           res = gfc_trans_arithmetic_if (code);
1036           break;
1037
1038         case EXEC_DO:
1039           res = gfc_trans_do (code);
1040           break;
1041
1042         case EXEC_DO_WHILE:
1043           res = gfc_trans_do_while (code);
1044           break;
1045
1046         case EXEC_SELECT:
1047           res = gfc_trans_select (code);
1048           break;
1049
1050         case EXEC_FLUSH:
1051           res = gfc_trans_flush (code);
1052           break;
1053
1054         case EXEC_FORALL:
1055           res = gfc_trans_forall (code);
1056           break;
1057
1058         case EXEC_WHERE:
1059           res = gfc_trans_where (code);
1060           break;
1061
1062         case EXEC_ALLOCATE:
1063           res = gfc_trans_allocate (code);
1064           break;
1065
1066         case EXEC_DEALLOCATE:
1067           res = gfc_trans_deallocate (code);
1068           break;
1069
1070         case EXEC_OPEN:
1071           res = gfc_trans_open (code);
1072           break;
1073
1074         case EXEC_CLOSE:
1075           res = gfc_trans_close (code);
1076           break;
1077
1078         case EXEC_READ:
1079           res = gfc_trans_read (code);
1080           break;
1081
1082         case EXEC_WRITE:
1083           res = gfc_trans_write (code);
1084           break;
1085
1086         case EXEC_IOLENGTH:
1087           res = gfc_trans_iolength (code);
1088           break;
1089
1090         case EXEC_BACKSPACE:
1091           res = gfc_trans_backspace (code);
1092           break;
1093
1094         case EXEC_ENDFILE:
1095           res = gfc_trans_endfile (code);
1096           break;
1097
1098         case EXEC_INQUIRE:
1099           res = gfc_trans_inquire (code);
1100           break;
1101
1102         case EXEC_REWIND:
1103           res = gfc_trans_rewind (code);
1104           break;
1105
1106         case EXEC_TRANSFER:
1107           res = gfc_trans_transfer (code);
1108           break;
1109
1110         case EXEC_DT_END:
1111           res = gfc_trans_dt_end (code);
1112           break;
1113
1114         case EXEC_OMP_ATOMIC:
1115         case EXEC_OMP_BARRIER:
1116         case EXEC_OMP_CRITICAL:
1117         case EXEC_OMP_DO:
1118         case EXEC_OMP_FLUSH:
1119         case EXEC_OMP_MASTER:
1120         case EXEC_OMP_ORDERED:
1121         case EXEC_OMP_PARALLEL:
1122         case EXEC_OMP_PARALLEL_DO:
1123         case EXEC_OMP_PARALLEL_SECTIONS:
1124         case EXEC_OMP_PARALLEL_WORKSHARE:
1125         case EXEC_OMP_SECTIONS:
1126         case EXEC_OMP_SINGLE:
1127         case EXEC_OMP_WORKSHARE:
1128           res = gfc_trans_omp_directive (code);
1129           break;
1130
1131         default:
1132           internal_error ("gfc_trans_code(): Bad statement code");
1133         }
1134
1135       gfc_set_backend_locus (&code->loc);
1136
1137       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1138         {
1139           if (TREE_CODE (res) == STATEMENT_LIST)
1140             annotate_all_with_locus (&res, input_location);
1141           else
1142             SET_EXPR_LOCATION (res, input_location);
1143             
1144           /* Add the new statement to the block.  */
1145           gfc_add_expr_to_block (&block, res);
1146         }
1147     }
1148
1149   /* Return the finished block.  */
1150   return gfc_finish_block (&block);
1151 }
1152
1153
1154 /* This function is called after a complete program unit has been parsed
1155    and resolved.  */
1156
1157 void
1158 gfc_generate_code (gfc_namespace * ns)
1159 {
1160   if (ns->is_block_data)
1161     {
1162       gfc_generate_block_data (ns);
1163       return;
1164     }
1165
1166   gfc_generate_function_code (ns);
1167 }
1168
1169
1170 /* This function is called after a complete module has been parsed
1171    and resolved.  */
1172
1173 void
1174 gfc_generate_module_code (gfc_namespace * ns)
1175 {
1176   gfc_namespace *n;
1177
1178   gfc_generate_module_vars (ns);
1179
1180   /* We need to generate all module function prototypes first, to allow
1181      sibling calls.  */
1182   for (n = ns->contained; n; n = n->sibling)
1183     {
1184       if (!n->proc_name)
1185         continue;
1186
1187       gfc_create_function_decl (n);
1188     }
1189
1190   for (n = ns->contained; n; n = n->sibling)
1191     {
1192       if (!n->proc_name)
1193         continue;
1194
1195       gfc_generate_function_code (n);
1196     }
1197 }
1198