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
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, 51 Franklin Street, Fifth Floor, Boston, MA
24 #include "coretypes.h"
26 #include "tree-gimple.h"
33 #include "trans-stmt.h"
34 #include "trans-array.h"
35 #include "trans-types.h"
36 #include "trans-const.h"
38 /* Naming convention for backend interface code:
40 gfc_trans_* translate gfc_code into STMT trees.
42 gfc_conv_* expression conversion
44 gfc_get_* get a backend tree representation of a decl or type */
46 static gfc_file
*gfc_current_backend_file
;
49 /* Advance along TREE_CHAIN n times. */
52 gfc_advance_chain (tree t
, int n
)
56 gcc_assert (t
!= NULL_TREE
);
63 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
66 gfc_chainon_list (tree list
, tree add
)
70 l
= tree_cons (NULL_TREE
, add
, NULL_TREE
);
72 return chainon (list
, l
);
76 /* Strip off a legitimate source ending from the input
77 string NAME of length LEN. */
80 remove_suffix (char *name
, int len
)
84 for (i
= 2; i
< 8 && len
> i
; i
++)
86 if (name
[len
- i
] == '.')
95 /* Creates a variable declaration with a given TYPE. */
98 gfc_create_var_np (tree type
, const char *prefix
)
100 return create_tmp_var_raw (type
, prefix
);
104 /* Like above, but also adds it to the current scope. */
107 gfc_create_var (tree type
, const char *prefix
)
111 tmp
= gfc_create_var_np (type
, prefix
);
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. */
124 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
128 if (CONSTANT_CLASS_P (expr
))
131 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
132 gfc_add_modify_expr (pblock
, var
, expr
);
138 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
139 A MODIFY_EXPR is an assignment: LHS <- RHS. */
142 gfc_add_modify_expr (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
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
)));
155 tmp
= fold_build2 (MODIFY_EXPR
, void_type_node
, lhs
, rhs
);
156 gfc_add_expr_to_block (pblock
, tmp
);
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. */
165 gfc_start_block (stmtblock_t
* block
)
167 /* Start a new binding level. */
169 block
->has_scope
= 1;
171 /* The block is empty. */
172 block
->head
= NULL_TREE
;
176 /* Initialize a block without creating a new scope. */
179 gfc_init_block (stmtblock_t
* block
)
181 block
->head
= NULL_TREE
;
182 block
->has_scope
= 0;
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. */
191 gfc_merge_block_scope (stmtblock_t
* block
)
196 gcc_assert (block
->has_scope
);
197 block
->has_scope
= 0;
199 /* Remember the decls in this scope. */
203 /* Add them to the parent scope. */
204 while (decl
!= NULL_TREE
)
206 next
= TREE_CHAIN (decl
);
207 TREE_CHAIN (decl
) = NULL_TREE
;
215 /* Finish a scope containing a block of statements. */
218 gfc_finish_block (stmtblock_t
* stmtblock
)
224 expr
= stmtblock
->head
;
226 expr
= build_empty_stmt ();
228 stmtblock
->head
= NULL_TREE
;
230 if (stmtblock
->has_scope
)
236 block
= poplevel (1, 0, 0);
237 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
247 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
248 natural type is used. */
251 gfc_build_addr_expr (tree type
, tree t
)
253 tree base_type
= TREE_TYPE (t
);
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
)))
262 natural_type
= build_pointer_type (base_type
);
264 if (TREE_CODE (t
) == INDIRECT_REF
)
268 t
= TREE_OPERAND (t
, 0);
269 natural_type
= TREE_TYPE (t
);
274 TREE_ADDRESSABLE (t
) = 1;
275 t
= build1 (ADDR_EXPR
, natural_type
, t
);
278 if (type
&& natural_type
!= type
)
279 t
= convert (type
, t
);
285 /* Build an INDIRECT_REF with its natural type. */
288 gfc_build_indirect_ref (tree t
)
290 tree type
= TREE_TYPE (t
);
291 gcc_assert (POINTER_TYPE_P (type
));
292 type
= TREE_TYPE (type
);
294 if (TREE_CODE (t
) == ADDR_EXPR
)
295 return TREE_OPERAND (t
, 0);
297 return build1 (INDIRECT_REF
, type
, t
);
301 /* Build an ARRAY_REF with its natural type. */
304 gfc_build_array_ref (tree base
, tree offset
)
306 tree type
= TREE_TYPE (base
);
307 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
308 type
= TREE_TYPE (type
);
311 TREE_ADDRESSABLE (base
) = 1;
313 return build4 (ARRAY_REF
, type
, base
, offset
, NULL_TREE
, NULL_TREE
);
317 /* Given a function declaration FNDECL and an argument list ARGLIST,
318 build a CALL_EXPR. */
321 gfc_build_function_call (tree fndecl
, tree arglist
)
326 fn
= gfc_build_addr_expr (NULL
, fndecl
);
327 call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fndecl
)),
329 TREE_SIDE_EFFECTS (call
) = 1;
335 /* Generate a runtime error if COND is true. */
338 gfc_trans_runtime_check (tree cond
, tree msg
, stmtblock_t
* pblock
)
347 if (integer_zerop (cond
))
350 /* The code to generate the error. */
351 gfc_start_block (&block
);
353 gcc_assert (TREE_CODE (msg
) == STRING_CST
);
357 tmp
= gfc_build_addr_expr (pchar_type_node
, msg
);
358 args
= gfc_chainon_list (NULL_TREE
, tmp
);
360 tmp
= gfc_build_addr_expr (pchar_type_node
, gfc_strconst_current_filename
);
361 args
= gfc_chainon_list (args
, tmp
);
363 tmp
= build_int_cst (NULL_TREE
, input_line
);
364 args
= gfc_chainon_list (args
, tmp
);
366 tmp
= gfc_build_function_call (gfor_fndecl_runtime_error
, args
);
367 gfc_add_expr_to_block (&block
, tmp
);
369 body
= gfc_finish_block (&block
);
371 if (integer_onep (cond
))
373 gfc_add_expr_to_block (pblock
, body
);
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
);
382 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
383 gfc_add_expr_to_block (pblock
, tmp
);
388 /* Add a statement to a block. */
391 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
395 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
398 if (TREE_CODE (expr
) != STATEMENT_LIST
)
403 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
408 block
->head
= NULL_TREE
;
409 append_to_statement_list (tmp
, &block
->head
);
411 append_to_statement_list (expr
, &block
->head
);
414 /* Don't bother creating a list if we only have a single statement. */
419 /* Add a block the end of a block. */
422 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
425 gcc_assert (!append
->has_scope
);
427 gfc_add_expr_to_block (block
, append
->head
);
428 append
->head
= NULL_TREE
;
432 /* Get the current locus. The structure may not be complete, and should
433 only be used with gfc_set_backend_locus. */
436 gfc_get_backend_locus (locus
* loc
)
438 loc
->lb
= gfc_getmem (sizeof (gfc_linebuf
));
439 #ifdef USE_MAPPED_LOCATION
440 loc
->lb
->location
= input_location
;
442 loc
->lb
->linenum
= input_line
;
444 loc
->lb
->file
= gfc_current_backend_file
;
448 /* Set the current locus. */
451 gfc_set_backend_locus (locus
* loc
)
453 gfc_current_backend_file
= loc
->lb
->file
;
454 #ifdef USE_MAPPED_LOCATION
455 input_location
= loc
->lb
->location
;
457 input_line
= loc
->lb
->linenum
;
458 input_filename
= loc
->lb
->file
->filename
;
463 /* Translate an executable statement. */
466 gfc_trans_code (gfc_code
* code
)
472 return build_empty_stmt ();
474 gfc_start_block (&block
);
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
)
482 res
= gfc_trans_label_here (code
);
483 gfc_add_expr_to_block (&block
, res
);
493 res
= gfc_trans_assign (code
);
496 case EXEC_LABEL_ASSIGN
:
497 res
= gfc_trans_label_assign (code
);
500 case EXEC_POINTER_ASSIGN
:
501 res
= gfc_trans_pointer_assign (code
);
509 res
= gfc_trans_cycle (code
);
513 res
= gfc_trans_exit (code
);
517 res
= gfc_trans_goto (code
);
521 res
= gfc_trans_entry (code
);
525 res
= gfc_trans_pause (code
);
529 res
= gfc_trans_stop (code
);
533 res
= gfc_trans_call (code
);
537 res
= gfc_trans_return (code
);
541 res
= gfc_trans_if (code
);
544 case EXEC_ARITHMETIC_IF
:
545 res
= gfc_trans_arithmetic_if (code
);
549 res
= gfc_trans_do (code
);
553 res
= gfc_trans_do_while (code
);
557 res
= gfc_trans_select (code
);
561 res
= gfc_trans_flush (code
);
565 res
= gfc_trans_forall (code
);
569 res
= gfc_trans_where (code
);
573 res
= gfc_trans_allocate (code
);
576 case EXEC_DEALLOCATE
:
577 res
= gfc_trans_deallocate (code
);
581 res
= gfc_trans_open (code
);
585 res
= gfc_trans_close (code
);
589 res
= gfc_trans_read (code
);
593 res
= gfc_trans_write (code
);
597 res
= gfc_trans_iolength (code
);
601 res
= gfc_trans_backspace (code
);
605 res
= gfc_trans_endfile (code
);
609 res
= gfc_trans_inquire (code
);
613 res
= gfc_trans_rewind (code
);
617 res
= gfc_trans_transfer (code
);
621 res
= gfc_trans_dt_end (code
);
625 internal_error ("gfc_trans_code(): Bad statement code");
628 gfc_set_backend_locus (&code
->loc
);
630 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
632 if (TREE_CODE (res
) == STATEMENT_LIST
)
633 annotate_all_with_locus (&res
, input_location
);
635 SET_EXPR_LOCATION (res
, input_location
);
637 /* Add the new statement to the block. */
638 gfc_add_expr_to_block (&block
, res
);
642 /* Return the finished block. */
643 return gfc_finish_block (&block
);
647 /* This function is called after a complete program unit has been parsed
651 gfc_generate_code (gfc_namespace
* ns
)
653 if (ns
->is_block_data
)
655 gfc_generate_block_data (ns
);
659 gfc_generate_function_code (ns
);
663 /* This function is called after a complete module has been parsed
667 gfc_generate_module_code (gfc_namespace
* ns
)
671 gfc_generate_module_vars (ns
);
673 /* We need to generate all module function prototypes first, to allow
675 for (n
= ns
->contained
; n
; n
= n
->sibling
)
680 gfc_create_function_decl (n
);
683 for (n
= ns
->contained
; n
; n
= n
->sibling
)
688 gfc_generate_function_code (n
);