1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
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
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
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, 59 Temple Place - Suite 330, Boston, MA
24 #include "coretypes.h"
26 #include "tree-gimple.h"
36 #include "trans-stmt.h"
37 #include "trans-array.h"
38 #include "trans-types.h"
39 #include "trans-const.h"
41 /* Naming convention for backend interface code:
43 gfc_trans_* translate gfc_code into STMT trees.
45 gfc_conv_* expression conversion
47 gfc_get_* get a backend tree representation of a decl or type */
49 static gfc_file
*gfc_current_backend_file
;
52 /* Advance along TREE_CHAIN n times. */
55 gfc_advance_chain (tree t
, int n
)
59 assert (t
!= NULL_TREE
);
66 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
69 gfc_chainon_list (tree list
, tree add
)
73 l
= tree_cons (NULL_TREE
, add
, NULL_TREE
);
75 return chainon (list
, l
);
79 /* Strip off a legitimate source ending from the input
80 string NAME of length LEN. */
83 remove_suffix (char *name
, int len
)
87 for (i
= 2; i
< 8 && len
> i
; i
++)
89 if (name
[len
- i
] == '.')
98 /* Creates a variable declaration with a given TYPE. */
101 gfc_create_var_np (tree type
, const char *prefix
)
103 return create_tmp_var_raw (type
, prefix
);
107 /* Like above, but also adds it to the current scope. */
110 gfc_create_var (tree type
, const char *prefix
)
114 tmp
= gfc_create_var_np (type
, prefix
);
122 /* If the an expression is not constant, evaluate it now. We assign the
123 result of the expression to an artificially created variable VAR, and
124 return a pointer to the VAR_DECL node for this variable. */
127 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
131 if (TREE_CODE_CLASS (TREE_CODE (expr
)) == 'c')
134 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
135 gfc_add_modify_expr (pblock
, var
, expr
);
141 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
142 A MODIFY_EXPR is an assignment: LHS <- RHS. */
145 gfc_add_modify_expr (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
149 tmp
= fold (build_v (MODIFY_EXPR
, lhs
, rhs
));
150 gfc_add_expr_to_block (pblock
, tmp
);
154 /* Create a new scope/binding level and initialize a block. Care must be
155 taken when translating expessions as any temporaries will be placed in
156 the innermost scope. */
159 gfc_start_block (stmtblock_t
* block
)
161 /* Start a new binding level. */
163 block
->has_scope
= 1;
165 /* The block is empty. */
166 block
->head
= NULL_TREE
;
170 /* Initialize a block without creating a new scope. */
173 gfc_init_block (stmtblock_t
* block
)
175 block
->head
= NULL_TREE
;
176 block
->has_scope
= 0;
180 /* Sometimes we create a scope but it turns out that we don't actually
181 need it. This function merges the scope of BLOCK with its parent.
182 Only variable decls will be merged, you still need to add the code. */
185 gfc_merge_block_scope (stmtblock_t
* block
)
190 assert (block
->has_scope
);
191 block
->has_scope
= 0;
193 /* Remember the decls in this scope. */
197 /* Add them to the parent scope. */
198 while (decl
!= NULL_TREE
)
200 next
= TREE_CHAIN (decl
);
201 TREE_CHAIN (decl
) = NULL_TREE
;
209 /* Finish a scope containing a block of statements. */
212 gfc_finish_block (stmtblock_t
* stmtblock
)
218 expr
= stmtblock
->head
;
220 expr
= build_empty_stmt ();
222 stmtblock
->head
= NULL_TREE
;
224 if (stmtblock
->has_scope
)
230 block
= poplevel (1, 0, 0);
231 expr
= build_v (BIND_EXPR
, decl
, expr
, block
);
241 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
242 natural type is used. */
245 gfc_build_addr_expr (tree type
, tree t
)
247 tree base_type
= TREE_TYPE (t
);
250 if (type
&& POINTER_TYPE_P (type
)
251 && TREE_CODE (base_type
) == ARRAY_TYPE
252 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
253 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
256 natural_type
= build_pointer_type (base_type
);
258 if (TREE_CODE (t
) == INDIRECT_REF
)
262 t
= TREE_OPERAND (t
, 0);
263 natural_type
= TREE_TYPE (t
);
268 TREE_ADDRESSABLE (t
) = 1;
269 t
= build1 (ADDR_EXPR
, natural_type
, t
);
272 if (type
&& natural_type
!= type
)
273 t
= convert (type
, t
);
279 /* Build an INDIRECT_REF with its natural type. */
282 gfc_build_indirect_ref (tree t
)
284 tree type
= TREE_TYPE (t
);
285 if (!POINTER_TYPE_P (type
))
287 type
= TREE_TYPE (type
);
289 if (TREE_CODE (t
) == ADDR_EXPR
)
290 return TREE_OPERAND (t
, 0);
292 return build1 (INDIRECT_REF
, type
, t
);
296 /* Build an ARRAY_REF with its natural type. */
299 gfc_build_array_ref (tree base
, tree offset
)
301 tree type
= TREE_TYPE (base
);
302 if (TREE_CODE (type
) != ARRAY_TYPE
)
304 type
= TREE_TYPE (type
);
307 TREE_ADDRESSABLE (base
) = 1;
309 return build (ARRAY_REF
, type
, base
, offset
);
313 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
314 build a CALL_EXPR. */
317 gfc_build_function_call (tree fndecl
, tree arglist
)
322 fn
= gfc_build_addr_expr (NULL
, fndecl
);
323 call
= build (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fndecl
)), fn
, arglist
, NULL
);
324 TREE_SIDE_EFFECTS (call
) = 1;
330 /* Generate a runtime error if COND is true. */
333 gfc_trans_runtime_check (tree cond
, tree msg
, stmtblock_t
* pblock
)
342 if (integer_zerop (cond
))
345 /* The code to generate the error. */
346 gfc_start_block (&block
);
348 assert (TREE_CODE (msg
) == STRING_CST
);
352 tmp
= gfc_build_addr_expr (pchar_type_node
, msg
);
353 args
= gfc_chainon_list (NULL_TREE
, tmp
);
355 tmp
= gfc_build_addr_expr (pchar_type_node
, gfc_strconst_current_filename
);
356 args
= gfc_chainon_list (args
, tmp
);
358 tmp
= build_int_2 (input_line
, 0);
359 args
= gfc_chainon_list (args
, tmp
);
361 tmp
= gfc_build_function_call (gfor_fndecl_runtime_error
, args
);
362 gfc_add_expr_to_block (&block
, tmp
);
364 body
= gfc_finish_block (&block
);
366 if (integer_onep (cond
))
368 gfc_add_expr_to_block (pblock
, body
);
372 /* Tell the compiler that this isn't likely. */
373 tmp
= gfc_chainon_list (NULL_TREE
, cond
);
374 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
375 cond
= gfc_build_function_call (built_in_decls
[BUILT_IN_EXPECT
], tmp
);
377 tmp
= build_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
378 gfc_add_expr_to_block (pblock
, tmp
);
383 /* Add a statement to a block. */
386 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
390 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
393 if (TREE_CODE (expr
) != STATEMENT_LIST
)
398 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
403 block
->head
= NULL_TREE
;
404 append_to_statement_list (tmp
, &block
->head
);
406 append_to_statement_list (expr
, &block
->head
);
409 /* Don't bother creating a list if we only have a single statement. */
414 /* Add a block the end of a block. */
417 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
420 assert (!append
->has_scope
);
422 gfc_add_expr_to_block (block
, append
->head
);
423 append
->head
= NULL_TREE
;
427 /* Get the current locus. The structure may not be complete, and should
428 only be used with gfc_set_backend_locus. */
431 gfc_get_backend_locus (locus
* loc
)
433 loc
->lb
= gfc_getmem (sizeof (gfc_linebuf
));
434 loc
->lb
->linenum
= input_line
- 1;
435 loc
->lb
->file
= gfc_current_backend_file
;
439 /* Set the current locus. */
442 gfc_set_backend_locus (locus
* loc
)
444 input_line
= loc
->lb
->linenum
;
445 gfc_current_backend_file
= loc
->lb
->file
;
446 input_filename
= loc
->lb
->file
->filename
;
450 /* Translate an executable statement. */
453 gfc_trans_code (gfc_code
* code
)
459 return build_empty_stmt ();
461 gfc_start_block (&block
);
463 /* Translate statements one by one to GIMPLE trees until we reach
464 the end of this gfc_code branch. */
465 for (; code
; code
= code
->next
)
467 gfc_set_backend_locus (&code
->loc
);
471 res
= gfc_trans_label_here (code
);
472 gfc_add_expr_to_block (&block
, res
);
482 res
= gfc_trans_assign (code
);
485 case EXEC_LABEL_ASSIGN
:
486 res
= gfc_trans_label_assign (code
);
489 case EXEC_POINTER_ASSIGN
:
490 res
= gfc_trans_pointer_assign (code
);
498 res
= gfc_trans_cycle (code
);
502 res
= gfc_trans_exit (code
);
506 res
= gfc_trans_goto (code
);
510 res
= gfc_trans_pause (code
);
514 res
= gfc_trans_stop (code
);
518 res
= gfc_trans_call (code
);
522 res
= gfc_trans_return (code
);
526 res
= gfc_trans_if (code
);
529 case EXEC_ARITHMETIC_IF
:
530 res
= gfc_trans_arithmetic_if (code
);
534 res
= gfc_trans_do (code
);
538 res
= gfc_trans_do_while (code
);
542 res
= gfc_trans_select (code
);
546 res
= gfc_trans_forall (code
);
550 res
= gfc_trans_where (code
);
554 res
= gfc_trans_allocate (code
);
557 case EXEC_DEALLOCATE
:
558 res
= gfc_trans_deallocate (code
);
562 res
= gfc_trans_open (code
);
566 res
= gfc_trans_close (code
);
570 res
= gfc_trans_read (code
);
574 res
= gfc_trans_write (code
);
578 res
= gfc_trans_iolength (code
);
582 res
= gfc_trans_backspace (code
);
586 res
= gfc_trans_endfile (code
);
590 res
= gfc_trans_inquire (code
);
594 res
= gfc_trans_rewind (code
);
598 res
= gfc_trans_transfer (code
);
602 res
= gfc_trans_dt_end (code
);
606 internal_error ("gfc_trans_code(): Bad statement code");
609 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
611 if (TREE_CODE (res
) == STATEMENT_LIST
)
612 annotate_all_with_locus (&res
, input_location
);
614 annotate_with_locus (res
, input_location
);
616 /* Add the new statemment to the block. */
617 gfc_add_expr_to_block (&block
, res
);
621 /* Return the finished block. */
622 return gfc_finish_block (&block
);
626 /* This function is called after a complete program unit has been parsed
630 gfc_generate_code (gfc_namespace
* ns
)
632 gfc_symbol
*main_program
= NULL
;
633 symbol_attribute attr
;
635 /* Main program subroutine. */
638 /* Lots of things get upset if a subroutine doesn't have a symbol, so we
639 make one now. Hopefully we've set all the required fields. */
640 gfc_get_symbol ("MAIN__", ns
, &main_program
);
641 gfc_clear_attr (&attr
);
642 attr
.flavor
= FL_PROCEDURE
;
643 attr
.proc
= PROC_UNKNOWN
;
645 attr
.access
= ACCESS_PUBLIC
;
646 main_program
->attr
= attr
;
647 ns
->proc_name
= main_program
;
648 gfc_commit_symbols ();
651 gfc_generate_function_code (ns
);
655 /* This function is called after a complete module has been parsed
659 gfc_generate_module_code (gfc_namespace
* ns
)
663 gfc_generate_module_vars (ns
);
665 /* We need to generate all module function prototypes first, to allow
667 for (n
= ns
->contained
; n
; n
= n
->sibling
)
672 gfc_build_function_decl (n
->proc_name
);
675 for (n
= ns
->contained
; n
; n
= n
->sibling
)
680 gfc_generate_function_code (n
);