1 /* Backend function setup
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
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 #include "trans-const.h"
42 /* Only for gfc_trans_code. Shouldn't need to include this. */
43 #include "trans-stmt.h"
45 #define MAX_LABEL_VALUE 99999
48 /* Holds the result of the function if no result variable specified. */
50 static GTY(()) tree current_fake_result_decl;
52 static GTY(()) tree current_function_return_label;
55 /* Holds the variable DECLs for the current function. */
57 static GTY(()) tree saved_function_decls = NULL_TREE;
58 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
61 /* The namespace of the module we're currently generating. Only used while
62 outputting decls for module variables. Do not rely on this being set. */
64 static gfc_namespace *module_namespace;
67 /* List of static constructor functions. */
69 tree gfc_static_ctors;
72 /* Function declarations for builtin library functions. */
74 tree gfor_fndecl_internal_malloc;
75 tree gfor_fndecl_internal_malloc64;
76 tree gfor_fndecl_internal_realloc;
77 tree gfor_fndecl_internal_realloc64;
78 tree gfor_fndecl_internal_free;
79 tree gfor_fndecl_allocate;
80 tree gfor_fndecl_allocate64;
81 tree gfor_fndecl_deallocate;
82 tree gfor_fndecl_pause_numeric;
83 tree gfor_fndecl_pause_string;
84 tree gfor_fndecl_stop_numeric;
85 tree gfor_fndecl_stop_string;
86 tree gfor_fndecl_select_string;
87 tree gfor_fndecl_runtime_error;
88 tree gfor_fndecl_set_std;
89 tree gfor_fndecl_in_pack;
90 tree gfor_fndecl_in_unpack;
91 tree gfor_fndecl_associated;
94 /* Math functions. Many other math functions are handled in
97 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
98 tree gfor_fndecl_math_cpowf;
99 tree gfor_fndecl_math_cpow;
100 tree gfor_fndecl_math_cpowl10;
101 tree gfor_fndecl_math_cpowl16;
102 tree gfor_fndecl_math_ishftc4;
103 tree gfor_fndecl_math_ishftc8;
104 tree gfor_fndecl_math_ishftc16;
105 tree gfor_fndecl_math_exponent4;
106 tree gfor_fndecl_math_exponent8;
107 tree gfor_fndecl_math_exponent10;
108 tree gfor_fndecl_math_exponent16;
111 /* String functions. */
113 tree gfor_fndecl_copy_string;
114 tree gfor_fndecl_compare_string;
115 tree gfor_fndecl_concat_string;
116 tree gfor_fndecl_string_len_trim;
117 tree gfor_fndecl_string_index;
118 tree gfor_fndecl_string_scan;
119 tree gfor_fndecl_string_verify;
120 tree gfor_fndecl_string_trim;
121 tree gfor_fndecl_string_repeat;
122 tree gfor_fndecl_adjustl;
123 tree gfor_fndecl_adjustr;
126 /* Other misc. runtime library functions. */
128 tree gfor_fndecl_size0;
129 tree gfor_fndecl_size1;
130 tree gfor_fndecl_iargc;
132 /* Intrinsic functions implemented in FORTRAN. */
133 tree gfor_fndecl_si_kind;
134 tree gfor_fndecl_sr_kind;
138 gfc_add_decl_to_parent_function (tree decl)
141 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
142 DECL_NONLOCAL (decl) = 1;
143 TREE_CHAIN (decl) = saved_parent_function_decls;
144 saved_parent_function_decls = decl;
148 gfc_add_decl_to_function (tree decl)
151 TREE_USED (decl) = 1;
152 DECL_CONTEXT (decl) = current_function_decl;
153 TREE_CHAIN (decl) = saved_function_decls;
154 saved_function_decls = decl;
158 /* Build a backend label declaration. Set TREE_USED for named labels.
159 The context of the label is always the current_function_decl. All
160 labels are marked artificial. */
163 gfc_build_label_decl (tree label_id)
165 /* 2^32 temporaries should be enough. */
166 static unsigned int tmp_num = 1;
170 if (label_id == NULL_TREE)
172 /* Build an internal label name. */
173 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
174 label_id = get_identifier (label_name);
179 /* Build the LABEL_DECL node. Labels have no type. */
180 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
181 DECL_CONTEXT (label_decl) = current_function_decl;
182 DECL_MODE (label_decl) = VOIDmode;
184 /* We always define the label as used, even if the original source
185 file never references the label. We don't want all kinds of
186 spurious warnings for old-style Fortran code with too many
188 TREE_USED (label_decl) = 1;
190 DECL_ARTIFICIAL (label_decl) = 1;
195 /* Returns the return label for the current function. */
198 gfc_get_return_label (void)
200 char name[GFC_MAX_SYMBOL_LEN + 10];
202 if (current_function_return_label)
203 return current_function_return_label;
205 sprintf (name, "__return_%s",
206 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
208 current_function_return_label =
209 gfc_build_label_decl (get_identifier (name));
211 DECL_ARTIFICIAL (current_function_return_label) = 1;
213 return current_function_return_label;
217 /* Set the backend source location of a decl. */
220 gfc_set_decl_location (tree decl, locus * loc)
222 #ifdef USE_MAPPED_LOCATION
223 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
225 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
226 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
231 /* Return the backend label declaration for a given label structure,
232 or create it if it doesn't exist yet. */
235 gfc_get_label_decl (gfc_st_label * lp)
237 if (lp->backend_decl)
238 return lp->backend_decl;
241 char label_name[GFC_MAX_SYMBOL_LEN + 1];
244 /* Validate the label declaration from the front end. */
245 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
247 /* Build a mangled name for the label. */
248 sprintf (label_name, "__label_%.6d", lp->value);
250 /* Build the LABEL_DECL node. */
251 label_decl = gfc_build_label_decl (get_identifier (label_name));
253 /* Tell the debugger where the label came from. */
254 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
255 gfc_set_decl_location (label_decl, &lp->where);
257 DECL_ARTIFICIAL (label_decl) = 1;
259 /* Store the label in the label list and return the LABEL_DECL. */
260 lp->backend_decl = label_decl;
266 /* Convert a gfc_symbol to an identifier of the same name. */
269 gfc_sym_identifier (gfc_symbol * sym)
271 return (get_identifier (sym->name));
275 /* Construct mangled name from symbol name. */
278 gfc_sym_mangled_identifier (gfc_symbol * sym)
280 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
282 if (sym->module == NULL)
283 return gfc_sym_identifier (sym);
286 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
287 return get_identifier (name);
292 /* Construct mangled function name from symbol name. */
295 gfc_sym_mangled_function_id (gfc_symbol * sym)
298 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
300 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
301 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
303 if (strcmp (sym->name, "MAIN__") == 0
304 || sym->attr.proc == PROC_INTRINSIC)
305 return get_identifier (sym->name);
307 if (gfc_option.flag_underscoring)
309 has_underscore = strchr (sym->name, '_') != 0;
310 if (gfc_option.flag_second_underscore && has_underscore)
311 snprintf (name, sizeof name, "%s__", sym->name);
313 snprintf (name, sizeof name, "%s_", sym->name);
314 return get_identifier (name);
317 return get_identifier (sym->name);
321 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
322 return get_identifier (name);
327 /* Returns true if a variable of specified size should go on the stack. */
330 gfc_can_put_var_on_stack (tree size)
332 unsigned HOST_WIDE_INT low;
334 if (!INTEGER_CST_P (size))
337 if (gfc_option.flag_max_stack_var_size < 0)
340 if (TREE_INT_CST_HIGH (size) != 0)
343 low = TREE_INT_CST_LOW (size);
344 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
347 /* TODO: Set a per-function stack size limit. */
353 /* Finish processing of a declaration and install its initial value. */
356 gfc_finish_decl (tree decl, tree init)
358 if (TREE_CODE (decl) == PARM_DECL)
359 gcc_assert (init == NULL_TREE);
360 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
361 -- it overlaps DECL_ARG_TYPE. */
362 else if (init == NULL_TREE)
363 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
365 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
367 if (init != NULL_TREE)
369 if (TREE_CODE (decl) != TYPE_DECL)
370 DECL_INITIAL (decl) = init;
373 /* typedef foo = bar; store the type of bar as the type of foo. */
374 TREE_TYPE (decl) = TREE_TYPE (init);
375 DECL_INITIAL (decl) = init = 0;
379 if (TREE_CODE (decl) == VAR_DECL)
381 if (DECL_SIZE (decl) == NULL_TREE
382 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
383 layout_decl (decl, 0);
385 /* A static variable with an incomplete type is an error if it is
386 initialized. Also if it is not file scope. Otherwise, let it
387 through, but if it is not `extern' then it may cause an error
389 /* An automatic variable with an incomplete type is an error. */
390 if (DECL_SIZE (decl) == NULL_TREE
391 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
392 || DECL_CONTEXT (decl) != 0)
393 : !DECL_EXTERNAL (decl)))
395 gfc_fatal_error ("storage size not known");
398 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
399 && (DECL_SIZE (decl) != 0)
400 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
402 gfc_fatal_error ("storage size not constant");
409 /* Apply symbol attributes to a variable, and add it to the function scope. */
412 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
414 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
415 This is the equivalent of the TARGET variables.
416 We also need to set this if the variable is passed by reference in a
418 if (sym->attr.target)
419 TREE_ADDRESSABLE (decl) = 1;
420 /* If it wasn't used we wouldn't be getting it. */
421 TREE_USED (decl) = 1;
423 /* Chain this decl to the pending declarations. Don't do pushdecl()
424 because this would add them to the current scope rather than the
426 if (current_function_decl != NULL_TREE)
428 if (sym->ns->proc_name->backend_decl == current_function_decl)
429 gfc_add_decl_to_function (decl);
431 gfc_add_decl_to_parent_function (decl);
434 /* If a variable is USE associated, it's always external. */
435 if (sym->attr.use_assoc)
437 DECL_EXTERNAL (decl) = 1;
438 TREE_PUBLIC (decl) = 1;
440 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
442 /* TODO: Don't set sym->module for result or dummy variables. */
443 gcc_assert (current_function_decl == NULL_TREE);
444 /* This is the declaration of a module variable. */
445 TREE_PUBLIC (decl) = 1;
446 TREE_STATIC (decl) = 1;
449 if ((sym->attr.save || sym->attr.data || sym->value)
450 && !sym->attr.use_assoc)
451 TREE_STATIC (decl) = 1;
453 /* Keep variables larger than max-stack-var-size off stack. */
454 if (!sym->ns->proc_name->attr.recursive
455 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
456 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
457 TREE_STATIC (decl) = 1;
461 /* Allocate the lang-specific part of a decl. */
464 gfc_allocate_lang_decl (tree decl)
466 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
467 ggc_alloc_cleared (sizeof (struct lang_decl));
470 /* Remember a symbol to generate initialization/cleanup code at function
474 gfc_defer_symbol_init (gfc_symbol * sym)
480 /* Don't add a symbol twice. */
484 last = head = sym->ns->proc_name;
487 /* Make sure that setup code for dummy variables which are used in the
488 setup of other variables is generated first. */
491 /* Find the first dummy arg seen after us, or the first non-dummy arg.
492 This is a circular list, so don't go past the head. */
494 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
500 /* Insert in between last and p. */
506 /* Create an array index type variable with function scope. */
509 create_index_var (const char * pfx, int nest)
513 decl = gfc_create_var_np (gfc_array_index_type, pfx);
515 gfc_add_decl_to_parent_function (decl);
517 gfc_add_decl_to_function (decl);
522 /* Create variables to hold all the non-constant bits of info for a
523 descriptorless array. Remember these in the lang-specific part of the
527 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
533 type = TREE_TYPE (decl);
535 /* We just use the descriptor, if there is one. */
536 if (GFC_DESCRIPTOR_TYPE_P (type))
539 gcc_assert (GFC_ARRAY_TYPE_P (type));
540 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
541 && !sym->attr.contained;
543 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
545 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
546 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
547 /* Don't try to use the unknown bound for assumed shape arrays. */
548 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
549 && (sym->as->type != AS_ASSUMED_SIZE
550 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
551 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
553 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
554 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
556 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
558 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
561 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
563 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
568 /* For some dummy arguments we don't use the actual argument directly.
569 Instead we create a local decl and use that. This allows us to perform
570 initialization, and construct full type information. */
573 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
583 if (sym->attr.pointer || sym->attr.allocatable)
586 /* Add to list of variables if not a fake result variable. */
587 if (sym->attr.result || sym->attr.dummy)
588 gfc_defer_symbol_init (sym);
590 type = TREE_TYPE (dummy);
591 gcc_assert (TREE_CODE (dummy) == PARM_DECL
592 && POINTER_TYPE_P (type));
594 /* Do we know the element size? */
595 known_size = sym->ts.type != BT_CHARACTER
596 || INTEGER_CST_P (sym->ts.cl->backend_decl);
598 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
600 /* For descriptorless arrays with known element size the actual
601 argument is sufficient. */
602 gcc_assert (GFC_ARRAY_TYPE_P (type));
603 gfc_build_qualified_array (dummy, sym);
607 type = TREE_TYPE (type);
608 if (GFC_DESCRIPTOR_TYPE_P (type))
610 /* Create a decriptorless array pointer. */
613 if (!gfc_option.flag_repack_arrays)
615 if (as->type == AS_ASSUMED_SIZE)
620 if (as->type == AS_EXPLICIT)
623 for (n = 0; n < as->rank; n++)
627 && as->upper[n]->expr_type == EXPR_CONSTANT
628 && as->lower[n]->expr_type == EXPR_CONSTANT))
636 type = gfc_typenode_for_spec (&sym->ts);
637 type = gfc_get_nodesc_array_type (type, sym->as, packed);
641 /* We now have an expression for the element size, so create a fully
642 qualified type. Reset sym->backend decl or this will just return the
644 sym->backend_decl = NULL_TREE;
645 type = gfc_sym_type (sym);
649 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
650 decl = build_decl (VAR_DECL, get_identifier (name), type);
652 DECL_ARTIFICIAL (decl) = 1;
653 TREE_PUBLIC (decl) = 0;
654 TREE_STATIC (decl) = 0;
655 DECL_EXTERNAL (decl) = 0;
657 /* We should never get deferred shape arrays here. We used to because of
659 gcc_assert (sym->as->type != AS_DEFERRED);
664 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
668 GFC_DECL_PACKED_ARRAY (decl) = 1;
672 gfc_build_qualified_array (decl, sym);
674 if (DECL_LANG_SPECIFIC (dummy))
675 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
677 gfc_allocate_lang_decl (decl);
679 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
681 if (sym->ns->proc_name->backend_decl == current_function_decl
682 || sym->attr.contained)
683 gfc_add_decl_to_function (decl);
685 gfc_add_decl_to_parent_function (decl);
691 /* Return a constant or a variable to use as a string length. Does not
692 add the decl to the current scope. */
695 gfc_create_string_length (gfc_symbol * sym)
699 gcc_assert (sym->ts.cl);
700 gfc_conv_const_charlen (sym->ts.cl);
702 if (sym->ts.cl->backend_decl == NULL_TREE)
704 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
706 /* Also prefix the mangled name. */
707 strcpy (&name[1], sym->name);
709 length = build_decl (VAR_DECL, get_identifier (name),
710 gfc_charlen_type_node);
711 DECL_ARTIFICIAL (length) = 1;
712 TREE_USED (length) = 1;
713 gfc_defer_symbol_init (sym);
714 sym->ts.cl->backend_decl = length;
717 return sym->ts.cl->backend_decl;
721 /* Return the decl for a gfc_symbol, create it if it doesn't already
725 gfc_get_symbol_decl (gfc_symbol * sym)
728 tree length = NULL_TREE;
731 gcc_assert (sym->attr.referenced);
733 if (sym->ns && sym->ns->proc_name->attr.function)
734 byref = gfc_return_by_reference (sym->ns->proc_name);
738 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
740 /* Return via extra parameter. */
741 if (sym->attr.result && byref
742 && !sym->backend_decl)
745 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
746 /* For entry master function skip over the __entry
748 if (sym->ns->proc_name->attr.entry_master)
749 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
752 /* Dummy variables should already have been created. */
753 gcc_assert (sym->backend_decl);
755 /* Create a character length variable. */
756 if (sym->ts.type == BT_CHARACTER)
758 if (sym->ts.cl->backend_decl == NULL_TREE)
760 length = gfc_create_string_length (sym);
761 if (TREE_CODE (length) != INTEGER_CST)
763 gfc_finish_var_decl (length, sym);
764 gfc_defer_symbol_init (sym);
769 /* Use a copy of the descriptor for dummy arrays. */
770 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
773 gfc_build_dummy_array_decl (sym, sym->backend_decl);
776 TREE_USED (sym->backend_decl) = 1;
777 return sym->backend_decl;
780 if (sym->backend_decl)
781 return sym->backend_decl;
783 /* Catch function declarations. Only used for actual parameters. */
784 if (sym->attr.flavor == FL_PROCEDURE)
786 decl = gfc_get_extern_function_decl (sym);
790 if (sym->attr.intrinsic)
791 internal_error ("intrinsic variable which isn't a procedure");
793 /* Create string length decl first so that they can be used in the
795 if (sym->ts.type == BT_CHARACTER)
796 length = gfc_create_string_length (sym);
798 /* Create the decl for the variable. */
799 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
801 gfc_set_decl_location (decl, &sym->declared_at);
803 /* Symbols from modules should have their assembler names mangled.
804 This is done here rather than in gfc_finish_var_decl because it
805 is different for string length variables. */
807 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
809 if (sym->attr.dimension)
811 /* Create variables to hold the non-constant bits of array info. */
812 gfc_build_qualified_array (decl, sym);
814 /* Remember this variable for allocation/cleanup. */
815 gfc_defer_symbol_init (sym);
817 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
818 GFC_DECL_PACKED_ARRAY (decl) = 1;
821 gfc_finish_var_decl (decl, sym);
823 if (sym->attr.assign)
825 gfc_allocate_lang_decl (decl);
826 GFC_DECL_ASSIGN (decl) = 1;
827 length = gfc_create_var (gfc_charlen_type_node, sym->name);
828 GFC_DECL_STRING_LEN (decl) = length;
829 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
830 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
831 TREE_STATIC (length) = TREE_STATIC (decl);
832 /* STRING_LENGTH is also used as flag. Less than -1 means that
833 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
834 target label's address. Other value is the length of format string
835 and ASSIGN_ADDR is the address of format string. */
836 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
839 if (sym->ts.type == BT_CHARACTER)
841 /* Character variables need special handling. */
842 gfc_allocate_lang_decl (decl);
844 if (TREE_CODE (length) != INTEGER_CST)
846 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
850 /* Also prefix the mangled name for symbols from modules. */
851 strcpy (&name[1], sym->name);
854 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
855 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
857 gfc_finish_var_decl (length, sym);
858 gcc_assert (!sym->value);
861 sym->backend_decl = decl;
863 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
865 /* Add static initializer. */
866 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
867 TREE_TYPE (decl), sym->attr.dimension,
868 sym->attr.pointer || sym->attr.allocatable);
875 /* Substitute a temporary variable in place of the real one. */
878 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
880 save->attr = sym->attr;
881 save->decl = sym->backend_decl;
883 gfc_clear_attr (&sym->attr);
884 sym->attr.referenced = 1;
885 sym->attr.flavor = FL_VARIABLE;
887 sym->backend_decl = decl;
891 /* Restore the original variable. */
894 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
896 sym->attr = save->attr;
897 sym->backend_decl = save->decl;
901 /* Get a basic decl for an external function. */
904 gfc_get_extern_function_decl (gfc_symbol * sym)
909 gfc_intrinsic_sym *isym;
911 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
915 if (sym->backend_decl)
916 return sym->backend_decl;
918 /* We should never be creating external decls for alternate entry points.
919 The procedure may be an alternate entry point, but we don't want/need
921 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
923 if (sym->attr.intrinsic)
925 /* Call the resolution function to get the actual name. This is
926 a nasty hack which relies on the resolution functions only looking
927 at the first argument. We pass NULL for the second argument
928 otherwise things like AINT get confused. */
929 isym = gfc_find_function (sym->name);
930 gcc_assert (isym->resolve.f0 != NULL);
932 memset (&e, 0, sizeof (e));
933 e.expr_type = EXPR_FUNCTION;
935 memset (&argexpr, 0, sizeof (argexpr));
936 gcc_assert (isym->formal);
937 argexpr.ts = isym->formal->ts;
939 if (isym->formal->next == NULL)
940 isym->resolve.f1 (&e, &argexpr);
943 /* All specific intrinsics take one or two arguments. */
944 gcc_assert (isym->formal->next->next == NULL);
945 isym->resolve.f2 (&e, &argexpr, NULL);
948 if (gfc_option.flag_f2c
949 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
950 || e.ts.type == BT_COMPLEX))
952 /* Specific which needs a different implementation if f2c
953 calling conventions are used. */
954 sprintf (s, "f2c_specific%s", e.value.function.name);
957 sprintf (s, "specific%s", e.value.function.name);
959 name = get_identifier (s);
964 name = gfc_sym_identifier (sym);
965 mangled_name = gfc_sym_mangled_function_id (sym);
968 type = gfc_get_function_type (sym);
969 fndecl = build_decl (FUNCTION_DECL, name, type);
971 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
972 /* If the return type is a pointer, avoid alias issues by setting
973 DECL_IS_MALLOC to nonzero. This means that the function should be
974 treated as if it were a malloc, meaning it returns a pointer that
976 if (POINTER_TYPE_P (type))
977 DECL_IS_MALLOC (fndecl) = 1;
979 /* Set the context of this decl. */
980 if (0 && sym->ns && sym->ns->proc_name)
982 /* TODO: Add external decls to the appropriate scope. */
983 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
987 /* Global declaration, e.g. intrinsic subroutine. */
988 DECL_CONTEXT (fndecl) = NULL_TREE;
991 DECL_EXTERNAL (fndecl) = 1;
993 /* This specifies if a function is globally addressable, i.e. it is
994 the opposite of declaring static in C. */
995 TREE_PUBLIC (fndecl) = 1;
997 /* Set attributes for PURE functions. A call to PURE function in the
998 Fortran 95 sense is both pure and without side effects in the C
1000 if (sym->attr.pure || sym->attr.elemental)
1002 if (sym->attr.function)
1003 DECL_IS_PURE (fndecl) = 1;
1004 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1005 parameters and don't use alternate returns (is this
1006 allowed?). In that case, calls to them are meaningless, and
1007 can be optimized away. See also in build_function_decl(). */
1008 TREE_SIDE_EFFECTS (fndecl) = 0;
1011 /* Mark non-returning functions. */
1012 if (sym->attr.noreturn)
1013 TREE_THIS_VOLATILE(fndecl) = 1;
1015 sym->backend_decl = fndecl;
1017 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1018 pushdecl_top_level (fndecl);
1024 /* Create a declaration for a procedure. For external functions (in the C
1025 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1026 a master function with alternate entry points. */
1029 build_function_decl (gfc_symbol * sym)
1032 symbol_attribute attr;
1034 gfc_formal_arglist *f;
1036 gcc_assert (!sym->backend_decl);
1037 gcc_assert (!sym->attr.external);
1039 /* Set the line and filename. sym->declared_at seems to point to the
1040 last statement for subroutines, but it'll do for now. */
1041 gfc_set_backend_locus (&sym->declared_at);
1043 /* Allow only one nesting level. Allow public declarations. */
1044 gcc_assert (current_function_decl == NULL_TREE
1045 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1047 type = gfc_get_function_type (sym);
1048 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1050 /* Perform name mangling if this is a top level or module procedure. */
1051 if (current_function_decl == NULL_TREE)
1052 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1054 /* Figure out the return type of the declared function, and build a
1055 RESULT_DECL for it. If this is a subroutine with alternate
1056 returns, build a RESULT_DECL for it. */
1059 result_decl = NULL_TREE;
1060 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1063 if (gfc_return_by_reference (sym))
1064 type = void_type_node;
1067 if (sym->result != sym)
1068 result_decl = gfc_sym_identifier (sym->result);
1070 type = TREE_TYPE (TREE_TYPE (fndecl));
1075 /* Look for alternate return placeholders. */
1076 int has_alternate_returns = 0;
1077 for (f = sym->formal; f; f = f->next)
1081 has_alternate_returns = 1;
1086 if (has_alternate_returns)
1087 type = integer_type_node;
1089 type = void_type_node;
1092 result_decl = build_decl (RESULT_DECL, result_decl, type);
1093 DECL_ARTIFICIAL (result_decl) = 1;
1094 DECL_IGNORED_P (result_decl) = 1;
1095 DECL_CONTEXT (result_decl) = fndecl;
1096 DECL_RESULT (fndecl) = result_decl;
1098 /* Don't call layout_decl for a RESULT_DECL.
1099 layout_decl (result_decl, 0); */
1101 /* If the return type is a pointer, avoid alias issues by setting
1102 DECL_IS_MALLOC to nonzero. This means that the function should be
1103 treated as if it were a malloc, meaning it returns a pointer that
1105 if (POINTER_TYPE_P (type))
1106 DECL_IS_MALLOC (fndecl) = 1;
1108 /* Set up all attributes for the function. */
1109 DECL_CONTEXT (fndecl) = current_function_decl;
1110 DECL_EXTERNAL (fndecl) = 0;
1112 /* This specifies if a function is globally visible, i.e. it is
1113 the opposite of declaring static in C. */
1114 if (DECL_CONTEXT (fndecl) == NULL_TREE
1115 && !sym->attr.entry_master)
1116 TREE_PUBLIC (fndecl) = 1;
1118 /* TREE_STATIC means the function body is defined here. */
1119 TREE_STATIC (fndecl) = 1;
1121 /* Set attributes for PURE functions. A call to a PURE function in the
1122 Fortran 95 sense is both pure and without side effects in the C
1124 if (attr.pure || attr.elemental)
1126 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1127 including a alternate return. In that case it can also be
1128 marked as PURE. See also in gfc_get_extern_function_decl(). */
1130 DECL_IS_PURE (fndecl) = 1;
1131 TREE_SIDE_EFFECTS (fndecl) = 0;
1134 /* Layout the function declaration and put it in the binding level
1135 of the current function. */
1138 sym->backend_decl = fndecl;
1142 /* Create the DECL_ARGUMENTS for a procedure. */
1145 create_function_arglist (gfc_symbol * sym)
1148 gfc_formal_arglist *f;
1155 fndecl = sym->backend_decl;
1157 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1158 the new FUNCTION_DECL node. */
1159 arglist = NULL_TREE;
1160 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1162 if (sym->attr.entry_master)
1164 type = TREE_VALUE (typelist);
1165 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1167 DECL_CONTEXT (parm) = fndecl;
1168 DECL_ARG_TYPE (parm) = type;
1169 TREE_READONLY (parm) = 1;
1170 gfc_finish_decl (parm, NULL_TREE);
1172 arglist = chainon (arglist, parm);
1173 typelist = TREE_CHAIN (typelist);
1176 if (gfc_return_by_reference (sym))
1178 type = TREE_VALUE (typelist);
1179 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1181 DECL_CONTEXT (parm) = fndecl;
1182 DECL_ARG_TYPE (parm) = type;
1183 TREE_READONLY (parm) = 1;
1184 DECL_ARTIFICIAL (parm) = 1;
1185 gfc_finish_decl (parm, NULL_TREE);
1187 arglist = chainon (arglist, parm);
1188 typelist = TREE_CHAIN (typelist);
1190 if (sym->ts.type == BT_CHARACTER)
1192 gfc_allocate_lang_decl (parm);
1194 /* Length of character result. */
1195 type = TREE_VALUE (typelist);
1196 gcc_assert (type == gfc_charlen_type_node);
1198 length = build_decl (PARM_DECL,
1199 get_identifier (".__result"),
1201 if (!sym->ts.cl->length)
1203 sym->ts.cl->backend_decl = length;
1204 TREE_USED (length) = 1;
1206 gcc_assert (TREE_CODE (length) == PARM_DECL);
1207 arglist = chainon (arglist, length);
1208 typelist = TREE_CHAIN (typelist);
1209 DECL_CONTEXT (length) = fndecl;
1210 DECL_ARG_TYPE (length) = type;
1211 TREE_READONLY (length) = 1;
1212 DECL_ARTIFICIAL (length) = 1;
1213 gfc_finish_decl (length, NULL_TREE);
1217 for (f = sym->formal; f; f = f->next)
1219 if (f->sym != NULL) /* ignore alternate returns. */
1223 type = TREE_VALUE (typelist);
1225 /* Build a the argument declaration. */
1226 parm = build_decl (PARM_DECL,
1227 gfc_sym_identifier (f->sym), type);
1229 /* Fill in arg stuff. */
1230 DECL_CONTEXT (parm) = fndecl;
1231 DECL_ARG_TYPE (parm) = type;
1232 /* All implementation args are read-only. */
1233 TREE_READONLY (parm) = 1;
1235 gfc_finish_decl (parm, NULL_TREE);
1237 f->sym->backend_decl = parm;
1239 arglist = chainon (arglist, parm);
1240 typelist = TREE_CHAIN (typelist);
1244 /* Add the hidden string length parameters. */
1246 for (f = sym->formal; f; f = f->next)
1248 char name[GFC_MAX_SYMBOL_LEN + 2];
1249 /* Ignore alternate returns. */
1253 if (f->sym->ts.type != BT_CHARACTER)
1256 parm = f->sym->backend_decl;
1257 type = TREE_VALUE (typelist);
1258 gcc_assert (type == gfc_charlen_type_node);
1260 strcpy (&name[1], f->sym->name);
1262 length = build_decl (PARM_DECL, get_identifier (name), type);
1264 arglist = chainon (arglist, length);
1265 DECL_CONTEXT (length) = fndecl;
1266 DECL_ARTIFICIAL (length) = 1;
1267 DECL_ARG_TYPE (length) = type;
1268 TREE_READONLY (length) = 1;
1269 gfc_finish_decl (length, NULL_TREE);
1271 /* TODO: Check string lengths when -fbounds-check. */
1273 /* Use the passed value for assumed length variables. */
1274 if (!f->sym->ts.cl->length)
1276 TREE_USED (length) = 1;
1277 if (!f->sym->ts.cl->backend_decl)
1278 f->sym->ts.cl->backend_decl = length;
1281 /* there is already another variable using this
1282 gfc_charlen node, build a new one for this variable
1283 and chain it into the list of gfc_charlens.
1284 This happens for e.g. in the case
1286 since CHARACTER declarations on the same line share
1287 the same gfc_charlen node. */
1290 cl = gfc_get_charlen ();
1291 cl->backend_decl = length;
1292 cl->next = f->sym->ts.cl->next;
1293 f->sym->ts.cl->next = cl;
1298 parm = TREE_CHAIN (parm);
1299 typelist = TREE_CHAIN (typelist);
1302 gcc_assert (TREE_VALUE (typelist) == void_type_node);
1303 DECL_ARGUMENTS (fndecl) = arglist;
1306 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1309 gfc_gimplify_function (tree fndecl)
1311 struct cgraph_node *cgn;
1313 gimplify_function_tree (fndecl);
1314 dump_function (TDI_generic, fndecl);
1316 /* Convert all nested functions to GIMPLE now. We do things in this order
1317 so that items like VLA sizes are expanded properly in the context of the
1318 correct function. */
1319 cgn = cgraph_node (fndecl);
1320 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1321 gfc_gimplify_function (cgn->decl);
1325 /* Do the setup necessary before generating the body of a function. */
1328 trans_function_start (gfc_symbol * sym)
1332 fndecl = sym->backend_decl;
1334 /* Let GCC know the current scope is this function. */
1335 current_function_decl = fndecl;
1337 /* Let the world know what we're about to do. */
1338 announce_function (fndecl);
1340 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1342 /* Create RTL for function declaration. */
1343 rest_of_decl_compilation (fndecl, 1, 0);
1346 /* Create RTL for function definition. */
1347 make_decl_rtl (fndecl);
1349 init_function_start (fndecl);
1351 /* Even though we're inside a function body, we still don't want to
1352 call expand_expr to calculate the size of a variable-sized array.
1353 We haven't necessarily assigned RTL to all variables yet, so it's
1354 not safe to try to expand expressions involving them. */
1355 cfun->x_dont_save_pending_sizes_p = 1;
1357 /* function.c requires a push at the start of the function. */
1361 /* Create thunks for alternate entry points. */
1364 build_entry_thunks (gfc_namespace * ns)
1366 gfc_formal_arglist *formal;
1367 gfc_formal_arglist *thunk_formal;
1369 gfc_symbol *thunk_sym;
1377 /* This should always be a toplevel function. */
1378 gcc_assert (current_function_decl == NULL_TREE);
1380 gfc_get_backend_locus (&old_loc);
1381 for (el = ns->entries; el; el = el->next)
1383 thunk_sym = el->sym;
1385 build_function_decl (thunk_sym);
1386 create_function_arglist (thunk_sym);
1388 trans_function_start (thunk_sym);
1390 thunk_fndecl = thunk_sym->backend_decl;
1392 gfc_start_block (&body);
1394 /* Pass extra parameter identifying this entry point. */
1395 tmp = build_int_cst (gfc_array_index_type, el->id);
1396 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1397 string_args = NULL_TREE;
1399 if (thunk_sym->attr.function)
1401 if (gfc_return_by_reference (ns->proc_name))
1403 tree ref = DECL_ARGUMENTS (current_function_decl);
1404 args = tree_cons (NULL_TREE, ref, args);
1405 if (ns->proc_name->ts.type == BT_CHARACTER)
1406 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1411 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1413 /* Ignore alternate returns. */
1414 if (formal->sym == NULL)
1417 /* We don't have a clever way of identifying arguments, so resort to
1418 a brute-force search. */
1419 for (thunk_formal = thunk_sym->formal;
1421 thunk_formal = thunk_formal->next)
1423 if (thunk_formal->sym == formal->sym)
1429 /* Pass the argument. */
1430 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1432 if (formal->sym->ts.type == BT_CHARACTER)
1434 tmp = thunk_formal->sym->ts.cl->backend_decl;
1435 string_args = tree_cons (NULL_TREE, tmp, string_args);
1440 /* Pass NULL for a missing argument. */
1441 args = tree_cons (NULL_TREE, null_pointer_node, args);
1442 if (formal->sym->ts.type == BT_CHARACTER)
1444 tmp = convert (gfc_charlen_type_node, integer_zero_node);
1445 string_args = tree_cons (NULL_TREE, tmp, string_args);
1450 /* Call the master function. */
1451 args = nreverse (args);
1452 args = chainon (args, nreverse (string_args));
1453 tmp = ns->proc_name->backend_decl;
1454 tmp = gfc_build_function_call (tmp, args);
1455 if (ns->proc_name->attr.mixed_entry_master)
1457 tree union_decl, field;
1458 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1460 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1461 TREE_TYPE (master_type));
1462 DECL_ARTIFICIAL (union_decl) = 1;
1463 DECL_EXTERNAL (union_decl) = 0;
1464 TREE_PUBLIC (union_decl) = 0;
1465 TREE_USED (union_decl) = 1;
1466 layout_decl (union_decl, 0);
1467 pushdecl (union_decl);
1469 DECL_CONTEXT (union_decl) = current_function_decl;
1470 tmp = build2 (MODIFY_EXPR,
1471 TREE_TYPE (union_decl),
1473 gfc_add_expr_to_block (&body, tmp);
1475 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1476 field; field = TREE_CHAIN (field))
1477 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1478 thunk_sym->result->name) == 0)
1480 gcc_assert (field != NULL_TREE);
1481 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1483 tmp = build2 (MODIFY_EXPR,
1484 TREE_TYPE (DECL_RESULT (current_function_decl)),
1485 DECL_RESULT (current_function_decl), tmp);
1486 tmp = build1_v (RETURN_EXPR, tmp);
1488 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1491 tmp = build2 (MODIFY_EXPR,
1492 TREE_TYPE (DECL_RESULT (current_function_decl)),
1493 DECL_RESULT (current_function_decl), tmp);
1494 tmp = build1_v (RETURN_EXPR, tmp);
1496 gfc_add_expr_to_block (&body, tmp);
1498 /* Finish off this function and send it for code generation. */
1499 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1501 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1503 /* Output the GENERIC tree. */
1504 dump_function (TDI_original, thunk_fndecl);
1506 /* Store the end of the function, so that we get good line number
1507 info for the epilogue. */
1508 cfun->function_end_locus = input_location;
1510 /* We're leaving the context of this function, so zap cfun.
1511 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1512 tree_rest_of_compilation. */
1515 current_function_decl = NULL_TREE;
1517 gfc_gimplify_function (thunk_fndecl);
1518 cgraph_finalize_function (thunk_fndecl, false);
1520 /* We share the symbols in the formal argument list with other entry
1521 points and the master function. Clear them so that they are
1522 recreated for each function. */
1523 for (formal = thunk_sym->formal; formal; formal = formal->next)
1524 if (formal->sym != NULL) /* Ignore alternate returns. */
1526 formal->sym->backend_decl = NULL_TREE;
1527 if (formal->sym->ts.type == BT_CHARACTER)
1528 formal->sym->ts.cl->backend_decl = NULL_TREE;
1531 if (thunk_sym->attr.function)
1533 if (thunk_sym->ts.type == BT_CHARACTER)
1534 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1535 if (thunk_sym->result->ts.type == BT_CHARACTER)
1536 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1540 gfc_set_backend_locus (&old_loc);
1544 /* Create a decl for a function, and create any thunks for alternate entry
1548 gfc_create_function_decl (gfc_namespace * ns)
1550 /* Create a declaration for the master function. */
1551 build_function_decl (ns->proc_name);
1553 /* Compile the entry thunks. */
1555 build_entry_thunks (ns);
1557 /* Now create the read argument list. */
1558 create_function_arglist (ns->proc_name);
1561 /* Return the decl used to hold the function return value. */
1564 gfc_get_fake_result_decl (gfc_symbol * sym)
1569 char name[GFC_MAX_SYMBOL_LEN + 10];
1572 && sym->ns->proc_name->backend_decl == current_function_decl
1573 && sym->ns->proc_name->attr.mixed_entry_master
1574 && sym != sym->ns->proc_name)
1576 decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1581 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1582 field; field = TREE_CHAIN (field))
1583 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1587 gcc_assert (field != NULL_TREE);
1588 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1594 if (current_fake_result_decl != NULL_TREE)
1595 return current_fake_result_decl;
1597 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1602 if (sym->ts.type == BT_CHARACTER
1603 && !sym->ts.cl->backend_decl)
1605 length = gfc_create_string_length (sym);
1606 gfc_finish_var_decl (length, sym);
1609 if (gfc_return_by_reference (sym))
1611 decl = DECL_ARGUMENTS (current_function_decl);
1613 if (sym->ns->proc_name->backend_decl == current_function_decl
1614 && sym->ns->proc_name->attr.entry_master)
1615 decl = TREE_CHAIN (decl);
1617 TREE_USED (decl) = 1;
1619 decl = gfc_build_dummy_array_decl (sym, decl);
1623 sprintf (name, "__result_%.20s",
1624 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1626 decl = build_decl (VAR_DECL, get_identifier (name),
1627 TREE_TYPE (TREE_TYPE (current_function_decl)));
1629 DECL_ARTIFICIAL (decl) = 1;
1630 DECL_EXTERNAL (decl) = 0;
1631 TREE_PUBLIC (decl) = 0;
1632 TREE_USED (decl) = 1;
1634 layout_decl (decl, 0);
1636 gfc_add_decl_to_function (decl);
1639 current_fake_result_decl = decl;
1645 /* Builds a function decl. The remaining parameters are the types of the
1646 function arguments. Negative nargs indicates a varargs function. */
1649 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1658 /* Library functions must be declared with global scope. */
1659 gcc_assert (current_function_decl == NULL_TREE);
1661 va_start (p, nargs);
1664 /* Create a list of the argument types. */
1665 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1667 argtype = va_arg (p, tree);
1668 arglist = gfc_chainon_list (arglist, argtype);
1673 /* Terminate the list. */
1674 arglist = gfc_chainon_list (arglist, void_type_node);
1677 /* Build the function type and decl. */
1678 fntype = build_function_type (rettype, arglist);
1679 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1681 /* Mark this decl as external. */
1682 DECL_EXTERNAL (fndecl) = 1;
1683 TREE_PUBLIC (fndecl) = 1;
1689 rest_of_decl_compilation (fndecl, 1, 0);
1695 gfc_build_intrinsic_function_decls (void)
1697 tree gfc_int4_type_node = gfc_get_int_type (4);
1698 tree gfc_int8_type_node = gfc_get_int_type (8);
1699 tree gfc_int16_type_node = gfc_get_int_type (16);
1700 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1701 tree gfc_real4_type_node = gfc_get_real_type (4);
1702 tree gfc_real8_type_node = gfc_get_real_type (8);
1703 tree gfc_real10_type_node = gfc_get_real_type (10);
1704 tree gfc_real16_type_node = gfc_get_real_type (16);
1705 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1706 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1707 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1708 tree gfc_complex16_type_node = gfc_get_complex_type (16);
1710 /* String functions. */
1711 gfor_fndecl_copy_string =
1712 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1715 gfc_charlen_type_node, pchar_type_node,
1716 gfc_charlen_type_node, pchar_type_node);
1718 gfor_fndecl_compare_string =
1719 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1722 gfc_charlen_type_node, pchar_type_node,
1723 gfc_charlen_type_node, pchar_type_node);
1725 gfor_fndecl_concat_string =
1726 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1729 gfc_charlen_type_node, pchar_type_node,
1730 gfc_charlen_type_node, pchar_type_node,
1731 gfc_charlen_type_node, pchar_type_node);
1733 gfor_fndecl_string_len_trim =
1734 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1736 2, gfc_charlen_type_node,
1739 gfor_fndecl_string_index =
1740 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1742 5, gfc_charlen_type_node, pchar_type_node,
1743 gfc_charlen_type_node, pchar_type_node,
1744 gfc_logical4_type_node);
1746 gfor_fndecl_string_scan =
1747 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1749 5, gfc_charlen_type_node, pchar_type_node,
1750 gfc_charlen_type_node, pchar_type_node,
1751 gfc_logical4_type_node);
1753 gfor_fndecl_string_verify =
1754 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1756 5, gfc_charlen_type_node, pchar_type_node,
1757 gfc_charlen_type_node, pchar_type_node,
1758 gfc_logical4_type_node);
1760 gfor_fndecl_string_trim =
1761 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1764 build_pointer_type (gfc_charlen_type_node),
1766 gfc_charlen_type_node,
1769 gfor_fndecl_string_repeat =
1770 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1774 gfc_charlen_type_node,
1776 gfc_int4_type_node);
1778 gfor_fndecl_adjustl =
1779 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1783 gfc_charlen_type_node, pchar_type_node);
1785 gfor_fndecl_adjustr =
1786 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1790 gfc_charlen_type_node, pchar_type_node);
1792 gfor_fndecl_si_kind =
1793 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1798 gfor_fndecl_sr_kind =
1799 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1804 /* Power functions. */
1806 tree ctype, rtype, itype, jtype;
1807 int rkind, ikind, jkind;
1810 static int ikinds[NIKINDS] = {4, 8, 16};
1811 static int rkinds[NRKINDS] = {4, 8, 10, 16};
1812 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
1814 for (ikind=0; ikind < NIKINDS; ikind++)
1816 itype = gfc_get_int_type (ikinds[ikind]);
1818 for (jkind=0; jkind < NIKINDS; jkind++)
1820 jtype = gfc_get_int_type (ikinds[jkind]);
1823 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
1825 gfor_fndecl_math_powi[jkind][ikind].integer =
1826 gfc_build_library_function_decl (get_identifier (name),
1827 jtype, 2, jtype, itype);
1831 for (rkind = 0; rkind < NRKINDS; rkind ++)
1833 rtype = gfc_get_real_type (rkinds[rkind]);
1836 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
1838 gfor_fndecl_math_powi[rkind][ikind].real =
1839 gfc_build_library_function_decl (get_identifier (name),
1840 rtype, 2, rtype, itype);
1843 ctype = gfc_get_complex_type (rkinds[rkind]);
1846 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
1848 gfor_fndecl_math_powi[rkind][ikind].cmplx =
1849 gfc_build_library_function_decl (get_identifier (name),
1850 ctype, 2,ctype, itype);
1858 gfor_fndecl_math_cpowf =
1859 gfc_build_library_function_decl (get_identifier ("cpowf"),
1860 gfc_complex4_type_node,
1861 1, gfc_complex4_type_node);
1862 gfor_fndecl_math_cpow =
1863 gfc_build_library_function_decl (get_identifier ("cpow"),
1864 gfc_complex8_type_node,
1865 1, gfc_complex8_type_node);
1866 if (gfc_complex10_type_node)
1867 gfor_fndecl_math_cpowl10 =
1868 gfc_build_library_function_decl (get_identifier ("cpowl"),
1869 gfc_complex10_type_node, 1,
1870 gfc_complex10_type_node);
1871 if (gfc_complex16_type_node)
1872 gfor_fndecl_math_cpowl16 =
1873 gfc_build_library_function_decl (get_identifier ("cpowl"),
1874 gfc_complex16_type_node, 1,
1875 gfc_complex16_type_node);
1877 gfor_fndecl_math_ishftc4 =
1878 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1880 3, gfc_int4_type_node,
1881 gfc_int4_type_node, gfc_int4_type_node);
1882 gfor_fndecl_math_ishftc8 =
1883 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1885 3, gfc_int8_type_node,
1886 gfc_int4_type_node, gfc_int4_type_node);
1887 if (gfc_int16_type_node)
1888 gfor_fndecl_math_ishftc16 =
1889 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
1890 gfc_int16_type_node, 3,
1891 gfc_int16_type_node,
1893 gfc_int4_type_node);
1895 gfor_fndecl_math_exponent4 =
1896 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1898 1, gfc_real4_type_node);
1899 gfor_fndecl_math_exponent8 =
1900 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1902 1, gfc_real8_type_node);
1903 if (gfc_real10_type_node)
1904 gfor_fndecl_math_exponent10 =
1905 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
1906 gfc_int4_type_node, 1,
1907 gfc_real10_type_node);
1908 if (gfc_real16_type_node)
1909 gfor_fndecl_math_exponent16 =
1910 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
1911 gfc_int4_type_node, 1,
1912 gfc_real16_type_node);
1914 /* Other functions. */
1916 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1917 gfc_array_index_type,
1918 1, pvoid_type_node);
1920 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1921 gfc_array_index_type,
1923 gfc_array_index_type);
1926 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1932 /* Make prototypes for runtime library functions. */
1935 gfc_build_builtin_function_decls (void)
1937 tree gfc_int4_type_node = gfc_get_int_type (4);
1938 tree gfc_int8_type_node = gfc_get_int_type (8);
1939 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1940 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
1942 /* Treat these two internal malloc wrappers as malloc. */
1943 gfor_fndecl_internal_malloc =
1944 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1945 pvoid_type_node, 1, gfc_int4_type_node);
1946 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
1948 gfor_fndecl_internal_malloc64 =
1949 gfc_build_library_function_decl (get_identifier
1950 (PREFIX("internal_malloc64")),
1951 pvoid_type_node, 1, gfc_int8_type_node);
1952 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
1954 gfor_fndecl_internal_realloc =
1955 gfc_build_library_function_decl (get_identifier
1956 (PREFIX("internal_realloc")),
1957 pvoid_type_node, 2, pvoid_type_node,
1958 gfc_int4_type_node);
1960 gfor_fndecl_internal_realloc64 =
1961 gfc_build_library_function_decl (get_identifier
1962 (PREFIX("internal_realloc64")),
1963 pvoid_type_node, 2, pvoid_type_node,
1964 gfc_int8_type_node);
1966 gfor_fndecl_internal_free =
1967 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1968 void_type_node, 1, pvoid_type_node);
1970 gfor_fndecl_allocate =
1971 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1972 void_type_node, 2, ppvoid_type_node,
1973 gfc_int4_type_node);
1975 gfor_fndecl_allocate64 =
1976 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1977 void_type_node, 2, ppvoid_type_node,
1978 gfc_int8_type_node);
1980 gfor_fndecl_deallocate =
1981 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1982 void_type_node, 2, ppvoid_type_node,
1983 gfc_pint4_type_node);
1985 gfor_fndecl_stop_numeric =
1986 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1987 void_type_node, 1, gfc_int4_type_node);
1989 /* Stop doesn't return. */
1990 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
1992 gfor_fndecl_stop_string =
1993 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1994 void_type_node, 2, pchar_type_node,
1995 gfc_int4_type_node);
1996 /* Stop doesn't return. */
1997 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
1999 gfor_fndecl_pause_numeric =
2000 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2001 void_type_node, 1, gfc_int4_type_node);
2003 gfor_fndecl_pause_string =
2004 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2005 void_type_node, 2, pchar_type_node,
2006 gfc_int4_type_node);
2008 gfor_fndecl_select_string =
2009 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2010 pvoid_type_node, 0);
2012 gfor_fndecl_runtime_error =
2013 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2016 pchar_type_node, pchar_type_node,
2017 gfc_int4_type_node);
2018 /* The runtime_error function does not return. */
2019 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2021 gfor_fndecl_set_std =
2022 gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2026 gfc_int4_type_node);
2028 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2029 get_identifier (PREFIX("internal_pack")),
2030 pvoid_type_node, 1, pvoid_type_node);
2032 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2033 get_identifier (PREFIX("internal_unpack")),
2034 pvoid_type_node, 1, pvoid_type_node);
2036 gfor_fndecl_associated =
2037 gfc_build_library_function_decl (
2038 get_identifier (PREFIX("associated")),
2039 gfc_logical4_type_node,
2044 gfc_build_intrinsic_function_decls ();
2045 gfc_build_intrinsic_lib_fndecls ();
2046 gfc_build_io_library_fndecls ();
2050 /* Evaluate the length of dummy character variables. */
2053 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
2057 gfc_finish_decl (cl->backend_decl, NULL_TREE);
2059 gfc_start_block (&body);
2061 /* Evaluate the string length expression. */
2062 gfc_trans_init_string_length (cl, &body);
2064 gfc_add_expr_to_block (&body, fnbody);
2065 return gfc_finish_block (&body);
2069 /* Allocate and cleanup an automatic character variable. */
2072 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2078 gcc_assert (sym->backend_decl);
2079 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2081 gfc_start_block (&body);
2083 /* Evaluate the string length expression. */
2084 gfc_trans_init_string_length (sym->ts.cl, &body);
2086 decl = sym->backend_decl;
2088 /* Emit a DECL_EXPR for this variable, which will cause the
2089 gimplifier to allocate storage, and all that good stuff. */
2090 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2091 gfc_add_expr_to_block (&body, tmp);
2093 gfc_add_expr_to_block (&body, fnbody);
2094 return gfc_finish_block (&body);
2098 /* Generate function entry and exit code, and add it to the function body.
2100 Allocation and initialization of array variables.
2101 Allocation of character string variables.
2102 Initialization and possibly repacking of dummy arrays. */
2105 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2110 /* Deal with implicit return variables. Explicit return variables will
2111 already have been added. */
2112 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2114 if (!current_fake_result_decl)
2116 gfc_entry_list *el = NULL;
2117 if (proc_sym->attr.entry_master)
2119 for (el = proc_sym->ns->entries; el; el = el->next)
2120 if (el->sym != el->sym->result)
2124 warning (0, "Function does not return a value");
2126 else if (proc_sym->as)
2128 fnbody = gfc_trans_dummy_array_bias (proc_sym,
2129 current_fake_result_decl,
2132 else if (proc_sym->ts.type == BT_CHARACTER)
2134 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2135 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2138 gcc_assert (gfc_option.flag_f2c
2139 && proc_sym->ts.type == BT_COMPLEX);
2142 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2144 if (sym->attr.dimension)
2146 switch (sym->as->type)
2149 if (sym->attr.dummy || sym->attr.result)
2151 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2152 else if (sym->attr.pointer || sym->attr.allocatable)
2154 if (TREE_STATIC (sym->backend_decl))
2155 gfc_trans_static_array_pointer (sym);
2157 fnbody = gfc_trans_deferred_array (sym, fnbody);
2161 gfc_get_backend_locus (&loc);
2162 gfc_set_backend_locus (&sym->declared_at);
2163 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2165 gfc_set_backend_locus (&loc);
2169 case AS_ASSUMED_SIZE:
2170 /* Must be a dummy parameter. */
2171 gcc_assert (sym->attr.dummy);
2173 /* We should always pass assumed size arrays the g77 way. */
2174 fnbody = gfc_trans_g77_array (sym, fnbody);
2177 case AS_ASSUMED_SHAPE:
2178 /* Must be a dummy parameter. */
2179 gcc_assert (sym->attr.dummy);
2181 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2186 fnbody = gfc_trans_deferred_array (sym, fnbody);
2193 else if (sym->ts.type == BT_CHARACTER)
2195 gfc_get_backend_locus (&loc);
2196 gfc_set_backend_locus (&sym->declared_at);
2197 if (sym->attr.dummy || sym->attr.result)
2198 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2200 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2201 gfc_set_backend_locus (&loc);
2211 /* Output an initialized decl for a module variable. */
2214 gfc_create_module_variable (gfc_symbol * sym)
2218 /* Only output symbols from this module. */
2219 if (sym->ns != module_namespace)
2221 /* I don't think this should ever happen. */
2222 internal_error ("module symbol %s in wrong namespace", sym->name);
2225 /* Only output variables and array valued parameters. */
2226 if (sym->attr.flavor != FL_VARIABLE
2227 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2230 /* Don't generate variables from other modules. Variables from
2231 COMMONs will already have been generated. */
2232 if (sym->attr.use_assoc || sym->attr.in_common)
2235 /* Equivalenced variables arrive here after creation. */
2236 if (sym->backend_decl && sym->equiv_built)
2239 if (sym->backend_decl)
2240 internal_error ("backend decl for module variable %s already exists",
2243 /* We always want module variables to be created. */
2244 sym->attr.referenced = 1;
2245 /* Create the decl. */
2246 decl = gfc_get_symbol_decl (sym);
2248 /* Create the variable. */
2250 rest_of_decl_compilation (decl, 1, 0);
2252 /* Also add length of strings. */
2253 if (sym->ts.type == BT_CHARACTER)
2257 length = sym->ts.cl->backend_decl;
2258 if (!INTEGER_CST_P (length))
2261 rest_of_decl_compilation (length, 1, 0);
2267 /* Generate all the required code for module variables. */
2270 gfc_generate_module_vars (gfc_namespace * ns)
2272 module_namespace = ns;
2274 /* Check if the frontend left the namespace in a reasonable state. */
2275 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2277 /* Generate COMMON blocks. */
2278 gfc_trans_common (ns);
2280 /* Create decls for all the module variables. */
2281 gfc_traverse_ns (ns, gfc_create_module_variable);
2285 gfc_generate_contained_functions (gfc_namespace * parent)
2289 /* We create all the prototypes before generating any code. */
2290 for (ns = parent->contained; ns; ns = ns->sibling)
2292 /* Skip namespaces from used modules. */
2293 if (ns->parent != parent)
2296 gfc_create_function_decl (ns);
2299 for (ns = parent->contained; ns; ns = ns->sibling)
2301 /* Skip namespaces from used modules. */
2302 if (ns->parent != parent)
2305 gfc_generate_function_code (ns);
2310 /* Generate decls for all local variables. We do this to ensure correct
2311 handling of expressions which only appear in the specification of
2315 generate_local_decl (gfc_symbol * sym)
2317 if (sym->attr.flavor == FL_VARIABLE)
2319 if (sym->attr.referenced)
2320 gfc_get_symbol_decl (sym);
2321 else if (sym->attr.dummy && warn_unused_parameter)
2322 warning (0, "unused parameter %qs", sym->name);
2323 /* Warn for unused variables, but not if they're inside a common
2324 block or are use-associated. */
2325 else if (warn_unused_variable
2326 && !(sym->attr.in_common || sym->attr.use_assoc))
2327 warning (0, "unused variable %qs", sym->name);
2332 generate_local_vars (gfc_namespace * ns)
2334 gfc_traverse_ns (ns, generate_local_decl);
2338 /* Generate a switch statement to jump to the correct entry point. Also
2339 creates the label decls for the entry points. */
2342 gfc_trans_entry_master_switch (gfc_entry_list * el)
2349 gfc_init_block (&block);
2350 for (; el; el = el->next)
2352 /* Add the case label. */
2353 label = gfc_build_label_decl (NULL_TREE);
2354 val = build_int_cst (gfc_array_index_type, el->id);
2355 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2356 gfc_add_expr_to_block (&block, tmp);
2358 /* And jump to the actual entry point. */
2359 label = gfc_build_label_decl (NULL_TREE);
2360 tmp = build1_v (GOTO_EXPR, label);
2361 gfc_add_expr_to_block (&block, tmp);
2363 /* Save the label decl. */
2366 tmp = gfc_finish_block (&block);
2367 /* The first argument selects the entry point. */
2368 val = DECL_ARGUMENTS (current_function_decl);
2369 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2374 /* Generate code for a function. */
2377 gfc_generate_function_code (gfc_namespace * ns)
2388 sym = ns->proc_name;
2390 /* Check that the frontend isn't still using this. */
2391 gcc_assert (sym->tlink == NULL);
2394 /* Create the declaration for functions with global scope. */
2395 if (!sym->backend_decl)
2396 gfc_create_function_decl (ns);
2398 fndecl = sym->backend_decl;
2399 old_context = current_function_decl;
2403 push_function_context ();
2404 saved_parent_function_decls = saved_function_decls;
2405 saved_function_decls = NULL_TREE;
2408 trans_function_start (sym);
2410 /* Will be created as needed. */
2411 current_fake_result_decl = NULL_TREE;
2413 gfc_start_block (&block);
2415 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2417 /* Copy length backend_decls to all entry point result
2422 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2423 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2424 for (el = ns->entries; el; el = el->next)
2425 el->sym->result->ts.cl->backend_decl = backend_decl;
2428 /* Translate COMMON blocks. */
2429 gfc_trans_common (ns);
2431 gfc_generate_contained_functions (ns);
2433 generate_local_vars (ns);
2435 current_function_return_label = NULL;
2437 /* Now generate the code for the body of this function. */
2438 gfc_init_block (&body);
2440 /* If this is the main program and we compile with -pedantic, add a call
2441 to set_std to set up the runtime library Fortran language standard
2443 if (sym->attr.is_main_program && pedantic)
2445 tree arglist, gfc_int4_type_node;
2447 gfc_int4_type_node = gfc_get_int_type (4);
2448 arglist = gfc_chainon_list (NULL_TREE,
2449 build_int_cst (gfc_int4_type_node,
2450 gfc_option.warn_std));
2451 arglist = gfc_chainon_list (arglist,
2452 build_int_cst (gfc_int4_type_node,
2453 gfc_option.allow_std));
2454 tmp = gfc_build_function_call (gfor_fndecl_set_std, arglist);
2455 gfc_add_expr_to_block (&body, tmp);
2458 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2459 && sym->attr.subroutine)
2461 tree alternate_return;
2462 alternate_return = gfc_get_fake_result_decl (sym);
2463 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2468 /* Jump to the correct entry point. */
2469 tmp = gfc_trans_entry_master_switch (ns->entries);
2470 gfc_add_expr_to_block (&body, tmp);
2473 tmp = gfc_trans_code (ns->code);
2474 gfc_add_expr_to_block (&body, tmp);
2476 /* Add a return label if needed. */
2477 if (current_function_return_label)
2479 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2480 gfc_add_expr_to_block (&body, tmp);
2483 tmp = gfc_finish_block (&body);
2484 /* Add code to create and cleanup arrays. */
2485 tmp = gfc_trans_deferred_vars (sym, tmp);
2486 gfc_add_expr_to_block (&block, tmp);
2488 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2490 if (sym->attr.subroutine || sym == sym->result)
2492 result = current_fake_result_decl;
2493 current_fake_result_decl = NULL_TREE;
2496 result = sym->result->backend_decl;
2498 if (result == NULL_TREE)
2499 warning (0, "Function return value not set");
2502 /* Set the return value to the dummy result variable. */
2503 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2504 DECL_RESULT (fndecl), result);
2505 tmp = build1_v (RETURN_EXPR, tmp);
2506 gfc_add_expr_to_block (&block, tmp);
2510 /* Add all the decls we created during processing. */
2511 decl = saved_function_decls;
2516 next = TREE_CHAIN (decl);
2517 TREE_CHAIN (decl) = NULL_TREE;
2521 saved_function_decls = NULL_TREE;
2523 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2525 /* Finish off this function and send it for code generation. */
2527 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2529 /* Output the GENERIC tree. */
2530 dump_function (TDI_original, fndecl);
2532 /* Store the end of the function, so that we get good line number
2533 info for the epilogue. */
2534 cfun->function_end_locus = input_location;
2536 /* We're leaving the context of this function, so zap cfun.
2537 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2538 tree_rest_of_compilation. */
2543 pop_function_context ();
2544 saved_function_decls = saved_parent_function_decls;
2546 current_function_decl = old_context;
2548 if (decl_function_context (fndecl))
2549 /* Register this function with cgraph just far enough to get it
2550 added to our parent's nested function list. */
2551 (void) cgraph_node (fndecl);
2554 gfc_gimplify_function (fndecl);
2555 cgraph_finalize_function (fndecl, false);
2560 gfc_generate_constructors (void)
2562 gcc_assert (gfc_static_ctors == NULL_TREE);
2570 if (gfc_static_ctors == NULL_TREE)
2573 fnname = get_file_function_name ('I');
2574 type = build_function_type (void_type_node,
2575 gfc_chainon_list (NULL_TREE, void_type_node));
2577 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2578 TREE_PUBLIC (fndecl) = 1;
2580 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2581 DECL_ARTIFICIAL (decl) = 1;
2582 DECL_IGNORED_P (decl) = 1;
2583 DECL_CONTEXT (decl) = fndecl;
2584 DECL_RESULT (fndecl) = decl;
2588 current_function_decl = fndecl;
2590 rest_of_decl_compilation (fndecl, 1, 0);
2592 make_decl_rtl (fndecl);
2594 init_function_start (fndecl);
2598 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2601 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2602 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2607 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2609 free_after_parsing (cfun);
2610 free_after_compilation (cfun);
2612 tree_rest_of_compilation (fndecl);
2614 current_function_decl = NULL_TREE;
2618 /* Translates a BLOCK DATA program unit. This means emitting the
2619 commons contained therein plus their initializations. We also emit
2620 a globally visible symbol to make sure that each BLOCK DATA program
2621 unit remains unique. */
2624 gfc_generate_block_data (gfc_namespace * ns)
2629 /* Tell the backend the source location of the block data. */
2631 gfc_set_backend_locus (&ns->proc_name->declared_at);
2633 gfc_set_backend_locus (&gfc_current_locus);
2635 /* Process the DATA statements. */
2636 gfc_trans_common (ns);
2638 /* Create a global symbol with the mane of the block data. This is to
2639 generate linker errors if the same name is used twice. It is never
2642 id = gfc_sym_mangled_function_id (ns->proc_name);
2644 id = get_identifier ("__BLOCK_DATA__");
2646 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2647 TREE_PUBLIC (decl) = 1;
2648 TREE_STATIC (decl) = 1;
2651 rest_of_decl_compilation (decl, 1, 0);
2654 #include "gt-fortran-trans-decl.h"