OSDN Git Service

PR fortran/30723
[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 2, 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 COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "tree.h"
27 #include "tree-gimple.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 char gfc_msg_bounds[] = N_("Array bound mismatch");
51 char gfc_msg_fault[] = N_("Array reference out of bounds");
52 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   return create_tmp_var_raw (type, prefix);
107 }
108
109
110 /* Like above, but also adds it to the current scope.  */
111
112 tree
113 gfc_create_var (tree type, const char *prefix)
114 {
115   tree tmp;
116
117   tmp = gfc_create_var_np (type, prefix);
118
119   pushdecl (tmp);
120
121   return tmp;
122 }
123
124
125 /* If the an expression is not constant, evaluate it now.  We assign the
126    result of the expression to an artificially created variable VAR, and
127    return a pointer to the VAR_DECL node for this variable.  */
128
129 tree
130 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
131 {
132   tree var;
133
134   if (CONSTANT_CLASS_P (expr))
135     return expr;
136
137   var = gfc_create_var (TREE_TYPE (expr), NULL);
138   gfc_add_modify_expr (pblock, var, expr);
139
140   return var;
141 }
142
143
144 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
145    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
146    LHS <- RHS.  */
147
148 void
149 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
150                 bool tuples_p)
151 {
152   tree tmp;
153
154 #ifdef ENABLE_CHECKING
155   /* Make sure that the types of the rhs and the lhs are the same
156      for scalar assignments.  We should probably have something
157      similar for aggregates, but right now removing that check just
158      breaks everything.  */
159   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
160               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
161 #endif
162
163   tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
164                      void_type_node, lhs, rhs);
165   gfc_add_expr_to_block (pblock, tmp);
166 }
167
168
169 /* Create a new scope/binding level and initialize a block.  Care must be
170    taken when translating expressions as any temporaries will be placed in
171    the innermost scope.  */
172
173 void
174 gfc_start_block (stmtblock_t * block)
175 {
176   /* Start a new binding level.  */
177   pushlevel (0);
178   block->has_scope = 1;
179
180   /* The block is empty.  */
181   block->head = NULL_TREE;
182 }
183
184
185 /* Initialize a block without creating a new scope.  */
186
187 void
188 gfc_init_block (stmtblock_t * block)
189 {
190   block->head = NULL_TREE;
191   block->has_scope = 0;
192 }
193
194
195 /* Sometimes we create a scope but it turns out that we don't actually
196    need it.  This function merges the scope of BLOCK with its parent.
197    Only variable decls will be merged, you still need to add the code.  */
198
199 void
200 gfc_merge_block_scope (stmtblock_t * block)
201 {
202   tree decl;
203   tree next;
204
205   gcc_assert (block->has_scope);
206   block->has_scope = 0;
207
208   /* Remember the decls in this scope.  */
209   decl = getdecls ();
210   poplevel (0, 0, 0);
211
212   /* Add them to the parent scope.  */
213   while (decl != NULL_TREE)
214     {
215       next = TREE_CHAIN (decl);
216       TREE_CHAIN (decl) = NULL_TREE;
217
218       pushdecl (decl);
219       decl = next;
220     }
221 }
222
223
224 /* Finish a scope containing a block of statements.  */
225
226 tree
227 gfc_finish_block (stmtblock_t * stmtblock)
228 {
229   tree decl;
230   tree expr;
231   tree block;
232
233   expr = stmtblock->head;
234   if (!expr)
235     expr = build_empty_stmt ();
236
237   stmtblock->head = NULL_TREE;
238
239   if (stmtblock->has_scope)
240     {
241       decl = getdecls ();
242
243       if (decl)
244         {
245           block = poplevel (1, 0, 0);
246           expr = build3_v (BIND_EXPR, decl, expr, block);
247         }
248       else
249         poplevel (0, 0, 0);
250     }
251
252   return expr;
253 }
254
255
256 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
257    natural type is used.  */
258
259 tree
260 gfc_build_addr_expr (tree type, tree t)
261 {
262   tree base_type = TREE_TYPE (t);
263   tree natural_type;
264
265   if (type && POINTER_TYPE_P (type)
266       && TREE_CODE (base_type) == ARRAY_TYPE
267       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
268          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
269     natural_type = type;
270   else
271     natural_type = build_pointer_type (base_type);
272
273   if (TREE_CODE (t) == INDIRECT_REF)
274     {
275       if (!type)
276         type = natural_type;
277       t = TREE_OPERAND (t, 0);
278       natural_type = TREE_TYPE (t);
279     }
280   else
281     {
282       if (DECL_P (t))
283         TREE_ADDRESSABLE (t) = 1;
284       t = build1 (ADDR_EXPR, natural_type, t);
285     }
286
287   if (type && natural_type != type)
288     t = convert (type, t);
289
290   return t;
291 }
292
293
294 /* Build an ARRAY_REF with its natural type.  */
295
296 tree
297 gfc_build_array_ref (tree base, tree offset)
298 {
299   tree type = TREE_TYPE (base);
300   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
301   type = TREE_TYPE (type);
302
303   if (DECL_P (base))
304     TREE_ADDRESSABLE (base) = 1;
305
306   /* Strip NON_LVALUE_EXPR nodes.  */
307   STRIP_TYPE_NOPS (offset);
308
309   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
310 }
311
312
313 /* Generate a runtime error if COND is true.  */
314
315 void
316 gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
317                          locus * where)
318 {
319   stmtblock_t block;
320   tree body;
321   tree tmp;
322   tree arg, arg2;
323   char *message;
324   int line;
325
326   if (integer_zerop (cond))
327     return;
328
329   /* The code to generate the error.  */
330   gfc_start_block (&block);
331
332   if (where)
333     {
334 #ifdef USE_MAPPED_LOCATION
335       line = LOCATION_LINE (where->lb->location);
336 #else 
337       line = where->lb->linenum;
338 #endif
339       asprintf (&message, "At line %d of file %s",  line,
340                 where->lb->file->filename);
341     }
342   else
343     asprintf (&message, "In file '%s', around line %d",
344               gfc_source_file, input_line + 1);
345
346   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
347   gfc_free(message);
348   
349   asprintf (&message, "%s", _(msgid));
350   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
351   gfc_free(message);
352
353   tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2);
354   gfc_add_expr_to_block (&block, tmp);
355
356   body = gfc_finish_block (&block);
357
358   if (integer_onep (cond))
359     {
360       gfc_add_expr_to_block (pblock, body);
361     }
362   else
363     {
364       /* Tell the compiler that this isn't likely.  */
365       cond = fold_convert (long_integer_type_node, cond);
366       tmp = build_int_cst (long_integer_type_node, 0);
367       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
368       cond = fold_convert (boolean_type_node, cond);
369
370       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
371       gfc_add_expr_to_block (pblock, tmp);
372     }
373 }
374
375
376 /* Call malloc to allocate size bytes of memory, with special conditions:
377       + if size < 0, generate a runtime error,
378       + if size == 0, return a NULL pointer,
379       + if malloc returns NULL, issue a runtime error.  */
380 tree
381 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
382 {
383   tree tmp, msg, negative, zero, malloc_result, null_result, res;
384   stmtblock_t block2;
385
386   size = gfc_evaluate_now (size, block);
387
388   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
389     size = fold_convert (size_type_node, size);
390
391   /* Create a variable to hold the result.  */
392   res = gfc_create_var (pvoid_type_node, NULL);
393
394   /* size < 0 ?  */
395   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
396                           build_int_cst (size_type_node, 0));
397   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
398       ("Attempt to allocate a negative amount of memory."));
399   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
400                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
401                      build_empty_stmt ());
402   gfc_add_expr_to_block (block, tmp);
403
404   /* Call malloc and check the result.  */
405   gfc_start_block (&block2);
406   gfc_add_modify_expr (&block2, res,
407                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
408                        size));
409   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
410                              build_int_cst (pvoid_type_node, 0));
411   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
412       ("Memory allocation failed"));
413   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
414                      build_call_expr (gfor_fndecl_os_error, 1, msg),
415                      build_empty_stmt ());
416   gfc_add_expr_to_block (&block2, tmp);
417   malloc_result = gfc_finish_block (&block2);
418
419   /* size == 0  */
420   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
421                       build_int_cst (size_type_node, 0));
422   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
423                      build_int_cst (pvoid_type_node, 0));
424   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
425   gfc_add_expr_to_block (block, tmp);
426
427   if (type != NULL)
428     res = fold_convert (type, res);
429   return res;
430 }
431
432
433 /* Free a given variable, if it's not NULL.  */
434 tree
435 gfc_call_free (tree var)
436 {
437   stmtblock_t block;
438   tree tmp, cond, call;
439
440   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
441     var = fold_convert (pvoid_type_node, var);
442
443   gfc_start_block (&block);
444   var = gfc_evaluate_now (var, &block);
445   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
446                       build_int_cst (pvoid_type_node, 0));
447   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
448   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
449                      build_empty_stmt ());
450   gfc_add_expr_to_block (&block, tmp);
451
452   return gfc_finish_block (&block);
453 }
454
455
456 /* Add a statement to a block.  */
457
458 void
459 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
460 {
461   gcc_assert (block);
462
463   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
464     return;
465
466   if (block->head)
467     {
468       if (TREE_CODE (block->head) != STATEMENT_LIST)
469         {
470           tree tmp;
471
472           tmp = block->head;
473           block->head = NULL_TREE;
474           append_to_statement_list (tmp, &block->head);
475         }
476       append_to_statement_list (expr, &block->head);
477     }
478   else
479     /* Don't bother creating a list if we only have a single statement.  */
480     block->head = expr;
481 }
482
483
484 /* Add a block the end of a block.  */
485
486 void
487 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
488 {
489   gcc_assert (append);
490   gcc_assert (!append->has_scope);
491
492   gfc_add_expr_to_block (block, append->head);
493   append->head = NULL_TREE;
494 }
495
496
497 /* Get the current locus.  The structure may not be complete, and should
498    only be used with gfc_set_backend_locus.  */
499
500 void
501 gfc_get_backend_locus (locus * loc)
502 {
503   loc->lb = gfc_getmem (sizeof (gfc_linebuf));    
504 #ifdef USE_MAPPED_LOCATION
505   loc->lb->location = input_location;
506 #else
507   loc->lb->linenum = input_line;
508 #endif
509   loc->lb->file = gfc_current_backend_file;
510 }
511
512
513 /* Set the current locus.  */
514
515 void
516 gfc_set_backend_locus (locus * loc)
517 {
518   gfc_current_backend_file = loc->lb->file;
519 #ifdef USE_MAPPED_LOCATION
520   input_location = loc->lb->location;
521 #else
522   input_line = loc->lb->linenum;
523   input_filename = loc->lb->file->filename;
524 #endif
525 }
526
527
528 /* Translate an executable statement.  */
529
530 tree
531 gfc_trans_code (gfc_code * code)
532 {
533   stmtblock_t block;
534   tree res;
535
536   if (!code)
537     return build_empty_stmt ();
538
539   gfc_start_block (&block);
540
541   /* Translate statements one by one to GIMPLE trees until we reach
542      the end of this gfc_code branch.  */
543   for (; code; code = code->next)
544     {
545       if (code->here != 0)
546         {
547           res = gfc_trans_label_here (code);
548           gfc_add_expr_to_block (&block, res);
549         }
550
551       switch (code->op)
552         {
553         case EXEC_NOP:
554           res = NULL_TREE;
555           break;
556
557         case EXEC_ASSIGN:
558           res = gfc_trans_assign (code);
559           break;
560
561         case EXEC_LABEL_ASSIGN:
562           res = gfc_trans_label_assign (code);
563           break;
564
565         case EXEC_POINTER_ASSIGN:
566           res = gfc_trans_pointer_assign (code);
567           break;
568
569         case EXEC_INIT_ASSIGN:
570           res = gfc_trans_init_assign (code);
571           break;
572
573         case EXEC_CONTINUE:
574           res = NULL_TREE;
575           break;
576
577         case EXEC_CYCLE:
578           res = gfc_trans_cycle (code);
579           break;
580
581         case EXEC_EXIT:
582           res = gfc_trans_exit (code);
583           break;
584
585         case EXEC_GOTO:
586           res = gfc_trans_goto (code);
587           break;
588
589         case EXEC_ENTRY:
590           res = gfc_trans_entry (code);
591           break;
592
593         case EXEC_PAUSE:
594           res = gfc_trans_pause (code);
595           break;
596
597         case EXEC_STOP:
598           res = gfc_trans_stop (code);
599           break;
600
601         case EXEC_CALL:
602           res = gfc_trans_call (code, false);
603           break;
604
605         case EXEC_ASSIGN_CALL:
606           res = gfc_trans_call (code, true);
607           break;
608
609         case EXEC_RETURN:
610           res = gfc_trans_return (code);
611           break;
612
613         case EXEC_IF:
614           res = gfc_trans_if (code);
615           break;
616
617         case EXEC_ARITHMETIC_IF:
618           res = gfc_trans_arithmetic_if (code);
619           break;
620
621         case EXEC_DO:
622           res = gfc_trans_do (code);
623           break;
624
625         case EXEC_DO_WHILE:
626           res = gfc_trans_do_while (code);
627           break;
628
629         case EXEC_SELECT:
630           res = gfc_trans_select (code);
631           break;
632
633         case EXEC_FLUSH:
634           res = gfc_trans_flush (code);
635           break;
636
637         case EXEC_FORALL:
638           res = gfc_trans_forall (code);
639           break;
640
641         case EXEC_WHERE:
642           res = gfc_trans_where (code);
643           break;
644
645         case EXEC_ALLOCATE:
646           res = gfc_trans_allocate (code);
647           break;
648
649         case EXEC_DEALLOCATE:
650           res = gfc_trans_deallocate (code);
651           break;
652
653         case EXEC_OPEN:
654           res = gfc_trans_open (code);
655           break;
656
657         case EXEC_CLOSE:
658           res = gfc_trans_close (code);
659           break;
660
661         case EXEC_READ:
662           res = gfc_trans_read (code);
663           break;
664
665         case EXEC_WRITE:
666           res = gfc_trans_write (code);
667           break;
668
669         case EXEC_IOLENGTH:
670           res = gfc_trans_iolength (code);
671           break;
672
673         case EXEC_BACKSPACE:
674           res = gfc_trans_backspace (code);
675           break;
676
677         case EXEC_ENDFILE:
678           res = gfc_trans_endfile (code);
679           break;
680
681         case EXEC_INQUIRE:
682           res = gfc_trans_inquire (code);
683           break;
684
685         case EXEC_REWIND:
686           res = gfc_trans_rewind (code);
687           break;
688
689         case EXEC_TRANSFER:
690           res = gfc_trans_transfer (code);
691           break;
692
693         case EXEC_DT_END:
694           res = gfc_trans_dt_end (code);
695           break;
696
697         case EXEC_OMP_ATOMIC:
698         case EXEC_OMP_BARRIER:
699         case EXEC_OMP_CRITICAL:
700         case EXEC_OMP_DO:
701         case EXEC_OMP_FLUSH:
702         case EXEC_OMP_MASTER:
703         case EXEC_OMP_ORDERED:
704         case EXEC_OMP_PARALLEL:
705         case EXEC_OMP_PARALLEL_DO:
706         case EXEC_OMP_PARALLEL_SECTIONS:
707         case EXEC_OMP_PARALLEL_WORKSHARE:
708         case EXEC_OMP_SECTIONS:
709         case EXEC_OMP_SINGLE:
710         case EXEC_OMP_WORKSHARE:
711           res = gfc_trans_omp_directive (code);
712           break;
713
714         default:
715           internal_error ("gfc_trans_code(): Bad statement code");
716         }
717
718       gfc_set_backend_locus (&code->loc);
719
720       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
721         {
722           if (TREE_CODE (res) == STATEMENT_LIST)
723             annotate_all_with_locus (&res, input_location);
724           else
725             SET_EXPR_LOCATION (res, input_location);
726             
727           /* Add the new statement to the block.  */
728           gfc_add_expr_to_block (&block, res);
729         }
730     }
731
732   /* Return the finished block.  */
733   return gfc_finish_block (&block);
734 }
735
736
737 /* This function is called after a complete program unit has been parsed
738    and resolved.  */
739
740 void
741 gfc_generate_code (gfc_namespace * ns)
742 {
743   if (ns->is_block_data)
744     {
745       gfc_generate_block_data (ns);
746       return;
747     }
748
749   gfc_generate_function_code (ns);
750 }
751
752
753 /* This function is called after a complete module has been parsed
754    and resolved.  */
755
756 void
757 gfc_generate_module_code (gfc_namespace * ns)
758 {
759   gfc_namespace *n;
760
761   gfc_generate_module_vars (ns);
762
763   /* We need to generate all module function prototypes first, to allow
764      sibling calls.  */
765   for (n = ns->contained; n; n = n->sibling)
766     {
767       if (!n->proc_name)
768         continue;
769
770       gfc_create_function_decl (n);
771     }
772
773   for (n = ns->contained; n; n = n->sibling)
774     {
775       if (!n->proc_name)
776         continue;
777
778       gfc_generate_function_code (n);
779     }
780 }
781