OSDN Git Service

PR libfortran/20006
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans.c
1 /* Code translation -- generate GCC trees from gfc_code.
2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Paul Brook
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING.  If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA.  */
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 "gfortran.h"
32 #include "trans.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
37
38 /* Naming convention for backend interface code:
39
40    gfc_trans_*  translate gfc_code into STMT trees.
41
42    gfc_conv_*   expression conversion
43
44    gfc_get_*    get a backend tree representation of a decl or type  */
45
46 static gfc_file *gfc_current_backend_file;
47
48
49 /* Advance along TREE_CHAIN n times.  */
50
51 tree
52 gfc_advance_chain (tree t, int n)
53 {
54   for (; n > 0; n--)
55     {
56       gcc_assert (t != NULL_TREE);
57       t = TREE_CHAIN (t);
58     }
59   return t;
60 }
61
62
63 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
64
65 tree
66 gfc_chainon_list (tree list, tree add)
67 {
68   tree l;
69
70   l = tree_cons (NULL_TREE, add, NULL_TREE);
71
72   return chainon (list, l);
73 }
74
75
76 /* Strip off a legitimate source ending from the input
77    string NAME of length LEN.  */
78
79 static inline void
80 remove_suffix (char *name, int len)
81 {
82   int i;
83
84   for (i = 2; i < 8 && len > i; i++)
85     {
86       if (name[len - i] == '.')
87         {
88           name[len - i] = '\0';
89           break;
90         }
91     }
92 }
93
94
95 /* Creates a variable declaration with a given TYPE.  */
96
97 tree
98 gfc_create_var_np (tree type, const char *prefix)
99 {
100   return create_tmp_var_raw (type, prefix);
101 }
102
103
104 /* Like above, but also adds it to the current scope.  */
105
106 tree
107 gfc_create_var (tree type, const char *prefix)
108 {
109   tree tmp;
110
111   tmp = gfc_create_var_np (type, prefix);
112
113   pushdecl (tmp);
114
115   return tmp;
116 }
117
118
119 /* If the an expression is not constant, evaluate it now.  We assign the
120    result of the expression to an artificially created variable VAR, and
121    return a pointer to the VAR_DECL node for this variable.  */
122
123 tree
124 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
125 {
126   tree var;
127
128   if (CONSTANT_CLASS_P (expr))
129     return expr;
130
131   var = gfc_create_var (TREE_TYPE (expr), NULL);
132   gfc_add_modify_expr (pblock, var, expr);
133
134   return var;
135 }
136
137
138 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
139    A MODIFY_EXPR is an assignment: LHS <- RHS.  */
140
141 void
142 gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
143 {
144   tree tmp;
145
146 #ifdef ENABLE_CHECKING
147   /* Make sure that the types of the rhs and the lhs are the same
148      for scalar assignments.  We should probably have something
149      similar for aggregates, but right now removing that check just
150      breaks everything.  */
151   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
152               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
153 #endif
154
155   tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
156   gfc_add_expr_to_block (pblock, tmp);
157 }
158
159
160 /* Create a new scope/binding level and initialize a block.  Care must be
161    taken when translating expressions as any temporaries will be placed in
162    the innermost scope.  */
163
164 void
165 gfc_start_block (stmtblock_t * block)
166 {
167   /* Start a new binding level.  */
168   pushlevel (0);
169   block->has_scope = 1;
170
171   /* The block is empty.  */
172   block->head = NULL_TREE;
173 }
174
175
176 /* Initialize a block without creating a new scope.  */
177
178 void
179 gfc_init_block (stmtblock_t * block)
180 {
181   block->head = NULL_TREE;
182   block->has_scope = 0;
183 }
184
185
186 /* Sometimes we create a scope but it turns out that we don't actually
187    need it.  This function merges the scope of BLOCK with its parent.
188    Only variable decls will be merged, you still need to add the code.  */
189
190 void
191 gfc_merge_block_scope (stmtblock_t * block)
192 {
193   tree decl;
194   tree next;
195
196   gcc_assert (block->has_scope);
197   block->has_scope = 0;
198
199   /* Remember the decls in this scope.  */
200   decl = getdecls ();
201   poplevel (0, 0, 0);
202
203   /* Add them to the parent scope.  */
204   while (decl != NULL_TREE)
205     {
206       next = TREE_CHAIN (decl);
207       TREE_CHAIN (decl) = NULL_TREE;
208
209       pushdecl (decl);
210       decl = next;
211     }
212 }
213
214
215 /* Finish a scope containing a block of statements.  */
216
217 tree
218 gfc_finish_block (stmtblock_t * stmtblock)
219 {
220   tree decl;
221   tree expr;
222   tree block;
223
224   expr = stmtblock->head;
225   if (!expr)
226     expr = build_empty_stmt ();
227
228   stmtblock->head = NULL_TREE;
229
230   if (stmtblock->has_scope)
231     {
232       decl = getdecls ();
233
234       if (decl)
235         {
236           block = poplevel (1, 0, 0);
237           expr = build3_v (BIND_EXPR, decl, expr, block);
238         }
239       else
240         poplevel (0, 0, 0);
241     }
242
243   return expr;
244 }
245
246
247 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
248    natural type is used.  */
249
250 tree
251 gfc_build_addr_expr (tree type, tree t)
252 {
253   tree base_type = TREE_TYPE (t);
254   tree natural_type;
255
256   if (type && POINTER_TYPE_P (type)
257       && TREE_CODE (base_type) == ARRAY_TYPE
258       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
259          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
260     natural_type = type;
261   else
262     natural_type = build_pointer_type (base_type);
263
264   if (TREE_CODE (t) == INDIRECT_REF)
265     {
266       if (!type)
267         type = natural_type;
268       t = TREE_OPERAND (t, 0);
269       natural_type = TREE_TYPE (t);
270     }
271   else
272     {
273       if (DECL_P (t))
274         TREE_ADDRESSABLE (t) = 1;
275       t = build1 (ADDR_EXPR, natural_type, t);
276     }
277
278   if (type && natural_type != type)
279     t = convert (type, t);
280
281   return t;
282 }
283
284
285 /* Build an INDIRECT_REF with its natural type.  */
286
287 tree
288 gfc_build_indirect_ref (tree t)
289 {
290   tree type = TREE_TYPE (t);
291   gcc_assert (POINTER_TYPE_P (type));
292   type = TREE_TYPE (type);
293
294   if (TREE_CODE (t) == ADDR_EXPR)
295     return TREE_OPERAND (t, 0);
296   else
297     return build1 (INDIRECT_REF, type, t);
298 }
299
300
301 /* Build an ARRAY_REF with its natural type.  */
302
303 tree
304 gfc_build_array_ref (tree base, tree offset)
305 {
306   tree type = TREE_TYPE (base);
307   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
308   type = TREE_TYPE (type);
309
310   if (DECL_P (base))
311     TREE_ADDRESSABLE (base) = 1;
312
313   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
314 }
315
316
317 /* Given a function declaration FNDECL and an argument list ARGLIST,
318    build a CALL_EXPR.  */
319
320 tree
321 gfc_build_function_call (tree fndecl, tree arglist)
322 {
323   tree fn;
324   tree call;
325
326   fn = gfc_build_addr_expr (NULL, fndecl);
327   call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), 
328                  fn, arglist, NULL);
329   TREE_SIDE_EFFECTS (call) = 1;
330
331   return call;
332 }
333
334
335 /* Generate a runtime error if COND is true.  */
336
337 void
338 gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
339 {
340   stmtblock_t block;
341   tree body;
342   tree tmp;
343   tree args;
344
345   cond = fold (cond);
346
347   if (integer_zerop (cond))
348     return;
349
350   /* The code to generate the error.  */
351   gfc_start_block (&block);
352
353   gcc_assert (TREE_CODE (msg) == STRING_CST);
354
355   TREE_USED (msg) = 1;
356
357   tmp = gfc_build_addr_expr (pchar_type_node, msg);
358   args = gfc_chainon_list (NULL_TREE, tmp);
359
360   tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
361   args = gfc_chainon_list (args, tmp);
362
363   tmp = build_int_cst (NULL_TREE, input_line);
364   args = gfc_chainon_list (args, tmp);
365
366   tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
367   gfc_add_expr_to_block (&block, tmp);
368
369   body = gfc_finish_block (&block);
370
371   if (integer_onep (cond))
372     {
373       gfc_add_expr_to_block (pblock, body);
374     }
375   else
376     {
377       /* Tell the compiler that this isn't likely.  */
378       tmp = gfc_chainon_list (NULL_TREE, cond);
379       tmp = gfc_chainon_list (tmp, integer_zero_node);
380       cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
381
382       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
383       gfc_add_expr_to_block (pblock, tmp);
384     }
385 }
386
387
388 /* Add a statement to a block.  */
389
390 void
391 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
392 {
393   gcc_assert (block);
394
395   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
396     return;
397
398   if (TREE_CODE (expr) != STATEMENT_LIST)
399     expr = fold (expr);
400
401   if (block->head)
402     {
403       if (TREE_CODE (block->head) != STATEMENT_LIST)
404         {
405           tree tmp;
406
407           tmp = block->head;
408           block->head = NULL_TREE;
409           append_to_statement_list (tmp, &block->head);
410         }
411       append_to_statement_list (expr, &block->head);
412     }
413   else
414     /* Don't bother creating a list if we only have a single statement.  */
415     block->head = expr;
416 }
417
418
419 /* Add a block the end of a block.  */
420
421 void
422 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
423 {
424   gcc_assert (append);
425   gcc_assert (!append->has_scope);
426
427   gfc_add_expr_to_block (block, append->head);
428   append->head = NULL_TREE;
429 }
430
431
432 /* Get the current locus.  The structure may not be complete, and should
433    only be used with gfc_set_backend_locus.  */
434
435 void
436 gfc_get_backend_locus (locus * loc)
437 {
438   loc->lb = gfc_getmem (sizeof (gfc_linebuf));    
439 #ifdef USE_MAPPED_LOCATION
440   loc->lb->location = input_location;
441 #else
442   loc->lb->linenum = input_line;
443 #endif
444   loc->lb->file = gfc_current_backend_file;
445 }
446
447
448 /* Set the current locus.  */
449
450 void
451 gfc_set_backend_locus (locus * loc)
452 {
453   gfc_current_backend_file = loc->lb->file;
454 #ifdef USE_MAPPED_LOCATION
455   input_location = loc->lb->location;
456 #else
457   input_line = loc->lb->linenum;
458   input_filename = loc->lb->file->filename;
459 #endif
460 }
461
462
463 /* Translate an executable statement.  */
464
465 tree
466 gfc_trans_code (gfc_code * code)
467 {
468   stmtblock_t block;
469   tree res;
470
471   if (!code)
472     return build_empty_stmt ();
473
474   gfc_start_block (&block);
475
476   /* Translate statements one by one to GIMPLE trees until we reach
477      the end of this gfc_code branch.  */
478   for (; code; code = code->next)
479     {
480       if (code->here != 0)
481         {
482           res = gfc_trans_label_here (code);
483           gfc_add_expr_to_block (&block, res);
484         }
485
486       switch (code->op)
487         {
488         case EXEC_NOP:
489           res = NULL_TREE;
490           break;
491
492         case EXEC_ASSIGN:
493           res = gfc_trans_assign (code);
494           break;
495
496         case EXEC_LABEL_ASSIGN:
497           res = gfc_trans_label_assign (code);
498           break;
499
500         case EXEC_POINTER_ASSIGN:
501           res = gfc_trans_pointer_assign (code);
502           break;
503
504         case EXEC_CONTINUE:
505           res = NULL_TREE;
506           break;
507
508         case EXEC_CYCLE:
509           res = gfc_trans_cycle (code);
510           break;
511
512         case EXEC_EXIT:
513           res = gfc_trans_exit (code);
514           break;
515
516         case EXEC_GOTO:
517           res = gfc_trans_goto (code);
518           break;
519
520         case EXEC_ENTRY:
521           res = gfc_trans_entry (code);
522           break;
523
524         case EXEC_PAUSE:
525           res = gfc_trans_pause (code);
526           break;
527
528         case EXEC_STOP:
529           res = gfc_trans_stop (code);
530           break;
531
532         case EXEC_CALL:
533           res = gfc_trans_call (code);
534           break;
535
536         case EXEC_RETURN:
537           res = gfc_trans_return (code);
538           break;
539
540         case EXEC_IF:
541           res = gfc_trans_if (code);
542           break;
543
544         case EXEC_ARITHMETIC_IF:
545           res = gfc_trans_arithmetic_if (code);
546           break;
547
548         case EXEC_DO:
549           res = gfc_trans_do (code);
550           break;
551
552         case EXEC_DO_WHILE:
553           res = gfc_trans_do_while (code);
554           break;
555
556         case EXEC_SELECT:
557           res = gfc_trans_select (code);
558           break;
559
560         case EXEC_FLUSH:
561           res = gfc_trans_flush (code);
562           break;
563
564         case EXEC_FORALL:
565           res = gfc_trans_forall (code);
566           break;
567
568         case EXEC_WHERE:
569           res = gfc_trans_where (code);
570           break;
571
572         case EXEC_ALLOCATE:
573           res = gfc_trans_allocate (code);
574           break;
575
576         case EXEC_DEALLOCATE:
577           res = gfc_trans_deallocate (code);
578           break;
579
580         case EXEC_OPEN:
581           res = gfc_trans_open (code);
582           break;
583
584         case EXEC_CLOSE:
585           res = gfc_trans_close (code);
586           break;
587
588         case EXEC_READ:
589           res = gfc_trans_read (code);
590           break;
591
592         case EXEC_WRITE:
593           res = gfc_trans_write (code);
594           break;
595
596         case EXEC_IOLENGTH:
597           res = gfc_trans_iolength (code);
598           break;
599
600         case EXEC_BACKSPACE:
601           res = gfc_trans_backspace (code);
602           break;
603
604         case EXEC_ENDFILE:
605           res = gfc_trans_endfile (code);
606           break;
607
608         case EXEC_INQUIRE:
609           res = gfc_trans_inquire (code);
610           break;
611
612         case EXEC_REWIND:
613           res = gfc_trans_rewind (code);
614           break;
615
616         case EXEC_TRANSFER:
617           res = gfc_trans_transfer (code);
618           break;
619
620         case EXEC_DT_END:
621           res = gfc_trans_dt_end (code);
622           break;
623
624         default:
625           internal_error ("gfc_trans_code(): Bad statement code");
626         }
627
628       gfc_set_backend_locus (&code->loc);
629
630       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
631         {
632           if (TREE_CODE (res) == STATEMENT_LIST)
633             annotate_all_with_locus (&res, input_location);
634           else
635             SET_EXPR_LOCATION (res, input_location);
636             
637           /* Add the new statement to the block.  */
638           gfc_add_expr_to_block (&block, res);
639         }
640     }
641
642   /* Return the finished block.  */
643   return gfc_finish_block (&block);
644 }
645
646
647 /* This function is called after a complete program unit has been parsed
648    and resolved.  */
649
650 void
651 gfc_generate_code (gfc_namespace * ns)
652 {
653   if (ns->is_block_data)
654     {
655       gfc_generate_block_data (ns);
656       return;
657     }
658
659   /* Main program subroutine.  */
660   if (!ns->proc_name)
661     {
662       gfc_symbol *main_program;
663       symbol_attribute attr;
664
665       /* Lots of things get upset if a subroutine doesn't have a symbol, so we
666          make one now.  Hopefully we've set all the required fields.  */
667       gfc_get_symbol ("MAIN__", ns, &main_program);
668       gfc_clear_attr (&attr);
669       attr.flavor = FL_PROCEDURE;
670       attr.proc = PROC_UNKNOWN;
671       attr.subroutine = 1;
672       attr.access = ACCESS_PUBLIC;
673       attr.is_main_program = 1;
674       main_program->attr = attr;
675
676       /* Set the location to the first line of code.  */
677       if (ns->code)
678         main_program->declared_at = ns->code->loc;
679       ns->proc_name = main_program;
680       gfc_commit_symbols ();
681     }
682
683   gfc_generate_function_code (ns);
684 }
685
686
687 /* This function is called after a complete module has been parsed
688    and resolved.  */
689
690 void
691 gfc_generate_module_code (gfc_namespace * ns)
692 {
693   gfc_namespace *n;
694
695   gfc_generate_module_vars (ns);
696
697   /* We need to generate all module function prototypes first, to allow
698      sibling calls.  */
699   for (n = ns->contained; n; n = n->sibling)
700     {
701       if (!n->proc_name)
702         continue;
703
704       gfc_create_function_decl (n);
705     }
706
707   for (n = ns->contained; n; n = n->sibling)
708     {
709       if (!n->proc_name)
710         continue;
711
712       gfc_generate_function_code (n);
713     }
714 }
715