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"
35 #include "trans-stmt.h"
36 #include "trans-array.h"
37 #include "trans-types.h"
38 #include "trans-const.h"
40 /* Naming convention for backend interface code:
42 gfc_trans_* translate gfc_code into STMT trees.
44 gfc_conv_* expression conversion
46 gfc_get_* get a backend tree representation of a decl or type */
48 static gfc_file
*gfc_current_backend_file
;
51 /* Advance along TREE_CHAIN n times. */
54 gfc_advance_chain (tree t
, int n
)
58 gcc_assert (t
!= NULL_TREE
);
65 /* Wrap a node in a TREE_LIST node and add it to the end of a list. */
68 gfc_chainon_list (tree list
, tree add
)
72 l
= tree_cons (NULL_TREE
, add
, NULL_TREE
);
74 return chainon (list
, l
);
78 /* Strip off a legitimate source ending from the input
79 string NAME of length LEN. */
82 remove_suffix (char *name
, int len
)
86 for (i
= 2; i
< 8 && len
> i
; i
++)
88 if (name
[len
- i
] == '.')
97 /* Creates a variable declaration with a given TYPE. */
100 gfc_create_var_np (tree type
, const char *prefix
)
102 return create_tmp_var_raw (type
, prefix
);
106 /* Like above, but also adds it to the current scope. */
109 gfc_create_var (tree type
, const char *prefix
)
113 tmp
= gfc_create_var_np (type
, prefix
);
121 /* If the an expression is not constant, evaluate it now. We assign the
122 result of the expression to an artificially created variable VAR, and
123 return a pointer to the VAR_DECL node for this variable. */
126 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
130 if (CONSTANT_CLASS_P (expr
))
133 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
134 gfc_add_modify_expr (pblock
, var
, expr
);
140 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
141 A MODIFY_EXPR is an assignment: LHS <- RHS. */
144 gfc_add_modify_expr (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
148 #ifdef ENABLE_CHECKING
149 /* Make sure that the types of the rhs and the lhs are the same
150 for scalar assignments. We should probably have something
151 similar for aggregates, but right now removing that check just
152 breaks everything. */
153 gcc_assert (TREE_TYPE (rhs
) == TREE_TYPE (lhs
)
154 || AGGREGATE_TYPE_P (TREE_TYPE (lhs
)));
157 tmp
= fold (build2_v (MODIFY_EXPR
, lhs
, rhs
));
158 gfc_add_expr_to_block (pblock
, tmp
);
162 /* Create a new scope/binding level and initialize a block. Care must be
163 taken when translating expressions as any temporaries will be placed in
164 the innermost scope. */
167 gfc_start_block (stmtblock_t
* block
)
169 /* Start a new binding level. */
171 block
->has_scope
= 1;
173 /* The block is empty. */
174 block
->head
= NULL_TREE
;
178 /* Initialize a block without creating a new scope. */
181 gfc_init_block (stmtblock_t
* block
)
183 block
->head
= NULL_TREE
;
184 block
->has_scope
= 0;
188 /* Sometimes we create a scope but it turns out that we don't actually
189 need it. This function merges the scope of BLOCK with its parent.
190 Only variable decls will be merged, you still need to add the code. */
193 gfc_merge_block_scope (stmtblock_t
* block
)
198 gcc_assert (block
->has_scope
);
199 block
->has_scope
= 0;
201 /* Remember the decls in this scope. */
205 /* Add them to the parent scope. */
206 while (decl
!= NULL_TREE
)
208 next
= TREE_CHAIN (decl
);
209 TREE_CHAIN (decl
) = NULL_TREE
;
217 /* Finish a scope containing a block of statements. */
220 gfc_finish_block (stmtblock_t
* stmtblock
)
226 expr
= stmtblock
->head
;
228 expr
= build_empty_stmt ();
230 stmtblock
->head
= NULL_TREE
;
232 if (stmtblock
->has_scope
)
238 block
= poplevel (1, 0, 0);
239 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
249 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
250 natural type is used. */
253 gfc_build_addr_expr (tree type
, tree t
)
255 tree base_type
= TREE_TYPE (t
);
258 if (type
&& POINTER_TYPE_P (type
)
259 && TREE_CODE (base_type
) == ARRAY_TYPE
260 && TYPE_MAIN_VARIANT (TREE_TYPE (type
))
261 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type
)))
264 natural_type
= build_pointer_type (base_type
);
266 if (TREE_CODE (t
) == INDIRECT_REF
)
270 t
= TREE_OPERAND (t
, 0);
271 natural_type
= TREE_TYPE (t
);
276 TREE_ADDRESSABLE (t
) = 1;
277 t
= build1 (ADDR_EXPR
, natural_type
, t
);
280 if (type
&& natural_type
!= type
)
281 t
= convert (type
, t
);
287 /* Build an INDIRECT_REF with its natural type. */
290 gfc_build_indirect_ref (tree t
)
292 tree type
= TREE_TYPE (t
);
293 gcc_assert (POINTER_TYPE_P (type
));
294 type
= TREE_TYPE (type
);
296 if (TREE_CODE (t
) == ADDR_EXPR
)
297 return TREE_OPERAND (t
, 0);
299 return build1 (INDIRECT_REF
, type
, t
);
303 /* Build an ARRAY_REF with its natural type. */
306 gfc_build_array_ref (tree base
, tree offset
)
308 tree type
= TREE_TYPE (base
);
309 gcc_assert (TREE_CODE (type
) == ARRAY_TYPE
);
310 type
= TREE_TYPE (type
);
313 TREE_ADDRESSABLE (base
) = 1;
315 return build4 (ARRAY_REF
, type
, base
, offset
, NULL_TREE
, NULL_TREE
);
319 /* Given a funcion declaration FNDECL and an argument list ARGLIST,
320 build a CALL_EXPR. */
323 gfc_build_function_call (tree fndecl
, tree arglist
)
328 fn
= gfc_build_addr_expr (NULL
, fndecl
);
329 call
= build3 (CALL_EXPR
, TREE_TYPE (TREE_TYPE (fndecl
)),
331 TREE_SIDE_EFFECTS (call
) = 1;
337 /* Generate a runtime error if COND is true. */
340 gfc_trans_runtime_check (tree cond
, tree msg
, stmtblock_t
* pblock
)
349 if (integer_zerop (cond
))
352 /* The code to generate the error. */
353 gfc_start_block (&block
);
355 gcc_assert (TREE_CODE (msg
) == STRING_CST
);
359 tmp
= gfc_build_addr_expr (pchar_type_node
, msg
);
360 args
= gfc_chainon_list (NULL_TREE
, tmp
);
362 tmp
= gfc_build_addr_expr (pchar_type_node
, gfc_strconst_current_filename
);
363 args
= gfc_chainon_list (args
, tmp
);
365 tmp
= build_int_cst (NULL_TREE
, input_line
);
366 args
= gfc_chainon_list (args
, tmp
);
368 tmp
= gfc_build_function_call (gfor_fndecl_runtime_error
, args
);
369 gfc_add_expr_to_block (&block
, tmp
);
371 body
= gfc_finish_block (&block
);
373 if (integer_onep (cond
))
375 gfc_add_expr_to_block (pblock
, body
);
379 /* Tell the compiler that this isn't likely. */
380 tmp
= gfc_chainon_list (NULL_TREE
, cond
);
381 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
382 cond
= gfc_build_function_call (built_in_decls
[BUILT_IN_EXPECT
], tmp
);
384 tmp
= build3_v (COND_EXPR
, cond
, body
, build_empty_stmt ());
385 gfc_add_expr_to_block (pblock
, tmp
);
390 /* Add a statement to a block. */
393 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
397 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
400 if (TREE_CODE (expr
) != STATEMENT_LIST
)
405 if (TREE_CODE (block
->head
) != STATEMENT_LIST
)
410 block
->head
= NULL_TREE
;
411 append_to_statement_list (tmp
, &block
->head
);
413 append_to_statement_list (expr
, &block
->head
);
416 /* Don't bother creating a list if we only have a single statement. */
421 /* Add a block the end of a block. */
424 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
427 gcc_assert (!append
->has_scope
);
429 gfc_add_expr_to_block (block
, append
->head
);
430 append
->head
= NULL_TREE
;
434 /* Get the current locus. The structure may not be complete, and should
435 only be used with gfc_set_backend_locus. */
438 gfc_get_backend_locus (locus
* loc
)
440 loc
->lb
= gfc_getmem (sizeof (gfc_linebuf
));
441 #ifdef USE_MAPPED_LOCATION
442 loc
->lb
->location
= input_location
; // FIXME adjust??
444 loc
->lb
->linenum
= input_line
- 1;
446 loc
->lb
->file
= gfc_current_backend_file
;
450 /* Set the current locus. */
453 gfc_set_backend_locus (locus
* loc
)
455 gfc_current_backend_file
= loc
->lb
->file
;
456 #ifdef USE_MAPPED_LOCATION
457 input_location
= loc
->lb
->location
;
459 input_line
= loc
->lb
->linenum
;
460 input_filename
= loc
->lb
->file
->filename
;
465 /* Translate an executable statement. */
468 gfc_trans_code (gfc_code
* code
)
474 return build_empty_stmt ();
476 gfc_start_block (&block
);
478 /* Translate statements one by one to GIMPLE trees until we reach
479 the end of this gfc_code branch. */
480 for (; code
; code
= code
->next
)
484 res
= gfc_trans_label_here (code
);
485 gfc_add_expr_to_block (&block
, res
);
495 res
= gfc_trans_assign (code
);
498 case EXEC_LABEL_ASSIGN
:
499 res
= gfc_trans_label_assign (code
);
502 case EXEC_POINTER_ASSIGN
:
503 res
= gfc_trans_pointer_assign (code
);
511 res
= gfc_trans_cycle (code
);
515 res
= gfc_trans_exit (code
);
519 res
= gfc_trans_goto (code
);
523 res
= gfc_trans_entry (code
);
527 res
= gfc_trans_pause (code
);
531 res
= gfc_trans_stop (code
);
535 res
= gfc_trans_call (code
);
539 res
= gfc_trans_return (code
);
543 res
= gfc_trans_if (code
);
546 case EXEC_ARITHMETIC_IF
:
547 res
= gfc_trans_arithmetic_if (code
);
551 res
= gfc_trans_do (code
);
555 res
= gfc_trans_do_while (code
);
559 res
= gfc_trans_select (code
);
563 res
= gfc_trans_forall (code
);
567 res
= gfc_trans_where (code
);
571 res
= gfc_trans_allocate (code
);
574 case EXEC_DEALLOCATE
:
575 res
= gfc_trans_deallocate (code
);
579 res
= gfc_trans_open (code
);
583 res
= gfc_trans_close (code
);
587 res
= gfc_trans_read (code
);
591 res
= gfc_trans_write (code
);
595 res
= gfc_trans_iolength (code
);
599 res
= gfc_trans_backspace (code
);
603 res
= gfc_trans_endfile (code
);
607 res
= gfc_trans_inquire (code
);
611 res
= gfc_trans_rewind (code
);
615 res
= gfc_trans_transfer (code
);
619 res
= gfc_trans_dt_end (code
);
623 internal_error ("gfc_trans_code(): Bad statement code");
626 gfc_set_backend_locus (&code
->loc
);
628 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
630 if (TREE_CODE (res
) == STATEMENT_LIST
)
631 annotate_all_with_locus (&res
, input_location
);
633 SET_EXPR_LOCATION (res
, input_location
);
635 /* Add the new statement to the block. */
636 gfc_add_expr_to_block (&block
, res
);
640 /* Return the finished block. */
641 return gfc_finish_block (&block
);
645 /* This function is called after a complete program unit has been parsed
649 gfc_generate_code (gfc_namespace
* ns
)
651 gfc_symbol
*main_program
= NULL
;
652 symbol_attribute attr
;
654 if (ns
->is_block_data
)
656 gfc_generate_block_data (ns
);
660 /* Main program subroutine. */
663 /* Lots of things get upset if a subroutine doesn't have a symbol, so we
664 make one now. Hopefully we've set all the required fields. */
665 gfc_get_symbol ("MAIN__", ns
, &main_program
);
666 gfc_clear_attr (&attr
);
667 attr
.flavor
= FL_PROCEDURE
;
668 attr
.proc
= PROC_UNKNOWN
;
670 attr
.access
= ACCESS_PUBLIC
;
671 main_program
->attr
= attr
;
672 /* Set the location to the first line of code. */
674 main_program
->declared_at
= ns
->code
->loc
;
675 ns
->proc_name
= main_program
;
676 gfc_commit_symbols ();
679 gfc_generate_function_code (ns
);
683 /* This function is called after a complete module has been parsed
687 gfc_generate_module_code (gfc_namespace
* ns
)
691 gfc_generate_module_vars (ns
);
693 /* We need to generate all module function prototypes first, to allow
695 for (n
= ns
->contained
; n
; n
= n
->sibling
)
700 gfc_create_function_decl (n
);
703 for (n
= ns
->contained
; n
; n
= n
->sibling
)
708 gfc_generate_function_code (n
);