OSDN Git Service

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