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_free;
77 tree gfor_fndecl_allocate;
78 tree gfor_fndecl_allocate64;
79 tree gfor_fndecl_deallocate;
80 tree gfor_fndecl_pause_numeric;
81 tree gfor_fndecl_pause_string;
82 tree gfor_fndecl_stop_numeric;
83 tree gfor_fndecl_stop_string;
84 tree gfor_fndecl_select_string;
85 tree gfor_fndecl_runtime_error;
86 tree gfor_fndecl_in_pack;
87 tree gfor_fndecl_in_unpack;
88 tree gfor_fndecl_associated;
91 /* Math functions. Many other math functions are handled in
94 gfc_powdecl_list gfor_fndecl_math_powi[3][2];
95 tree gfor_fndecl_math_cpowf;
96 tree gfor_fndecl_math_cpow;
97 tree gfor_fndecl_math_ishftc4;
98 tree gfor_fndecl_math_ishftc8;
99 tree gfor_fndecl_math_exponent4;
100 tree gfor_fndecl_math_exponent8;
103 /* String functions. */
105 tree gfor_fndecl_copy_string;
106 tree gfor_fndecl_compare_string;
107 tree gfor_fndecl_concat_string;
108 tree gfor_fndecl_string_len_trim;
109 tree gfor_fndecl_string_index;
110 tree gfor_fndecl_string_scan;
111 tree gfor_fndecl_string_verify;
112 tree gfor_fndecl_string_trim;
113 tree gfor_fndecl_string_repeat;
114 tree gfor_fndecl_adjustl;
115 tree gfor_fndecl_adjustr;
118 /* Other misc. runtime library functions. */
120 tree gfor_fndecl_size0;
121 tree gfor_fndecl_size1;
122 tree gfor_fndecl_iargc;
124 /* Intrinsic functions implemented in FORTRAN. */
125 tree gfor_fndecl_si_kind;
126 tree gfor_fndecl_sr_kind;
130 gfc_add_decl_to_parent_function (tree decl)
133 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
134 DECL_NONLOCAL (decl) = 1;
135 TREE_CHAIN (decl) = saved_parent_function_decls;
136 saved_parent_function_decls = decl;
140 gfc_add_decl_to_function (tree decl)
143 TREE_USED (decl) = 1;
144 DECL_CONTEXT (decl) = current_function_decl;
145 TREE_CHAIN (decl) = saved_function_decls;
146 saved_function_decls = decl;
150 /* Build a backend label declaration. Set TREE_USED for named labels.
151 The context of the label is always the current_function_decl. All
152 labels are marked artificial. */
155 gfc_build_label_decl (tree label_id)
157 /* 2^32 temporaries should be enough. */
158 static unsigned int tmp_num = 1;
162 if (label_id == NULL_TREE)
164 /* Build an internal label name. */
165 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
166 label_id = get_identifier (label_name);
171 /* Build the LABEL_DECL node. Labels have no type. */
172 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
173 DECL_CONTEXT (label_decl) = current_function_decl;
174 DECL_MODE (label_decl) = VOIDmode;
176 /* We always define the label as used, even if the original source
177 file never references the label. We don't want all kinds of
178 spurious warnings for old-style Fortran code with too many
180 TREE_USED (label_decl) = 1;
182 DECL_ARTIFICIAL (label_decl) = 1;
187 /* Returns the return label for the current function. */
190 gfc_get_return_label (void)
192 char name[GFC_MAX_SYMBOL_LEN + 10];
194 if (current_function_return_label)
195 return current_function_return_label;
197 sprintf (name, "__return_%s",
198 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
200 current_function_return_label =
201 gfc_build_label_decl (get_identifier (name));
203 DECL_ARTIFICIAL (current_function_return_label) = 1;
205 return current_function_return_label;
209 /* Set the backend source location of a decl. */
212 gfc_set_decl_location (tree decl, locus * loc)
214 #ifdef USE_MAPPED_LOCATION
215 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
217 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
218 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
223 /* Return the backend label declaration for a given label structure,
224 or create it if it doesn't exist yet. */
227 gfc_get_label_decl (gfc_st_label * lp)
229 if (lp->backend_decl)
230 return lp->backend_decl;
233 char label_name[GFC_MAX_SYMBOL_LEN + 1];
236 /* Validate the label declaration from the front end. */
237 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
239 /* Build a mangled name for the label. */
240 sprintf (label_name, "__label_%.6d", lp->value);
242 /* Build the LABEL_DECL node. */
243 label_decl = gfc_build_label_decl (get_identifier (label_name));
245 /* Tell the debugger where the label came from. */
246 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
247 gfc_set_decl_location (label_decl, &lp->where);
249 DECL_ARTIFICIAL (label_decl) = 1;
251 /* Store the label in the label list and return the LABEL_DECL. */
252 lp->backend_decl = label_decl;
258 /* Convert a gfc_symbol to an identifier of the same name. */
261 gfc_sym_identifier (gfc_symbol * sym)
263 return (get_identifier (sym->name));
267 /* Construct mangled name from symbol name. */
270 gfc_sym_mangled_identifier (gfc_symbol * sym)
272 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
274 if (sym->module == NULL)
275 return gfc_sym_identifier (sym);
278 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
279 return get_identifier (name);
284 /* Construct mangled function name from symbol name. */
287 gfc_sym_mangled_function_id (gfc_symbol * sym)
290 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
292 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
293 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
295 if (strcmp (sym->name, "MAIN__") == 0
296 || sym->attr.proc == PROC_INTRINSIC)
297 return get_identifier (sym->name);
299 if (gfc_option.flag_underscoring)
301 has_underscore = strchr (sym->name, '_') != 0;
302 if (gfc_option.flag_second_underscore && has_underscore)
303 snprintf (name, sizeof name, "%s__", sym->name);
305 snprintf (name, sizeof name, "%s_", sym->name);
306 return get_identifier (name);
309 return get_identifier (sym->name);
313 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
314 return get_identifier (name);
319 /* Returns true if a variable of specified size should go on the stack. */
322 gfc_can_put_var_on_stack (tree size)
324 unsigned HOST_WIDE_INT low;
326 if (!INTEGER_CST_P (size))
329 if (gfc_option.flag_max_stack_var_size < 0)
332 if (TREE_INT_CST_HIGH (size) != 0)
335 low = TREE_INT_CST_LOW (size);
336 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
339 /* TODO: Set a per-function stack size limit. */
345 /* Finish processing of a declaration and install its initial value. */
348 gfc_finish_decl (tree decl, tree init)
350 if (TREE_CODE (decl) == PARM_DECL)
351 gcc_assert (init == NULL_TREE);
352 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
353 -- it overlaps DECL_ARG_TYPE. */
354 else if (init == NULL_TREE)
355 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
357 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
359 if (init != NULL_TREE)
361 if (TREE_CODE (decl) != TYPE_DECL)
362 DECL_INITIAL (decl) = init;
365 /* typedef foo = bar; store the type of bar as the type of foo. */
366 TREE_TYPE (decl) = TREE_TYPE (init);
367 DECL_INITIAL (decl) = init = 0;
371 if (TREE_CODE (decl) == VAR_DECL)
373 if (DECL_SIZE (decl) == NULL_TREE
374 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
375 layout_decl (decl, 0);
377 /* A static variable with an incomplete type is an error if it is
378 initialized. Also if it is not file scope. Otherwise, let it
379 through, but if it is not `extern' then it may cause an error
381 /* An automatic variable with an incomplete type is an error. */
382 if (DECL_SIZE (decl) == NULL_TREE
383 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
384 || DECL_CONTEXT (decl) != 0)
385 : !DECL_EXTERNAL (decl)))
387 gfc_fatal_error ("storage size not known");
390 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
391 && (DECL_SIZE (decl) != 0)
392 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
394 gfc_fatal_error ("storage size not constant");
401 /* Apply symbol attributes to a variable, and add it to the function scope. */
404 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
406 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
407 This is the equivalent of the TARGET variables.
408 We also need to set this if the variable is passed by reference in a
410 if (sym->attr.target)
411 TREE_ADDRESSABLE (decl) = 1;
412 /* If it wasn't used we wouldn't be getting it. */
413 TREE_USED (decl) = 1;
415 /* Chain this decl to the pending declarations. Don't do pushdecl()
416 because this would add them to the current scope rather than the
418 if (current_function_decl != NULL_TREE)
420 if (sym->ns->proc_name->backend_decl == current_function_decl)
421 gfc_add_decl_to_function (decl);
423 gfc_add_decl_to_parent_function (decl);
426 /* If a variable is USE associated, it's always external. */
427 if (sym->attr.use_assoc)
429 DECL_EXTERNAL (decl) = 1;
430 TREE_PUBLIC (decl) = 1;
432 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
434 /* TODO: Don't set sym->module for result or dummy variables. */
435 gcc_assert (current_function_decl == NULL_TREE);
436 /* This is the declaration of a module variable. */
437 TREE_PUBLIC (decl) = 1;
438 TREE_STATIC (decl) = 1;
441 if ((sym->attr.save || sym->attr.data || sym->value)
442 && !sym->attr.use_assoc)
443 TREE_STATIC (decl) = 1;
445 /* Keep variables larger than max-stack-var-size off stack. */
446 if (!sym->ns->proc_name->attr.recursive
447 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
448 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
449 TREE_STATIC (decl) = 1;
453 /* Allocate the lang-specific part of a decl. */
456 gfc_allocate_lang_decl (tree decl)
458 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
459 ggc_alloc_cleared (sizeof (struct lang_decl));
462 /* Remember a symbol to generate initialization/cleanup code at function
466 gfc_defer_symbol_init (gfc_symbol * sym)
472 /* Don't add a symbol twice. */
476 last = head = sym->ns->proc_name;
479 /* Make sure that setup code for dummy variables which are used in the
480 setup of other variables is generated first. */
483 /* Find the first dummy arg seen after us, or the first non-dummy arg.
484 This is a circular list, so don't go past the head. */
486 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
492 /* Insert in between last and p. */
498 /* Create an array index type variable with function scope. */
501 create_index_var (const char * pfx, int nest)
505 decl = gfc_create_var_np (gfc_array_index_type, pfx);
507 gfc_add_decl_to_parent_function (decl);
509 gfc_add_decl_to_function (decl);
514 /* Create variables to hold all the non-constant bits of info for a
515 descriptorless array. Remember these in the lang-specific part of the
519 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
525 type = TREE_TYPE (decl);
527 /* We just use the descriptor, if there is one. */
528 if (GFC_DESCRIPTOR_TYPE_P (type))
531 gcc_assert (GFC_ARRAY_TYPE_P (type));
532 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
533 && !sym->attr.contained;
535 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
537 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
538 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
539 /* Don't try to use the unknown bound for assumed shape arrays. */
540 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
541 && (sym->as->type != AS_ASSUMED_SIZE
542 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
543 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
545 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
546 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
548 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
550 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
553 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
555 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
560 /* For some dummy arguments we don't use the actual argument directly.
561 Instead we create a local decl and use that. This allows us to perform
562 initialization, and construct full type information. */
565 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
575 if (sym->attr.pointer || sym->attr.allocatable)
578 /* Add to list of variables if not a fake result variable. */
579 if (sym->attr.result || sym->attr.dummy)
580 gfc_defer_symbol_init (sym);
582 type = TREE_TYPE (dummy);
583 gcc_assert (TREE_CODE (dummy) == PARM_DECL
584 && POINTER_TYPE_P (type));
586 /* Do we know the element size? */
587 known_size = sym->ts.type != BT_CHARACTER
588 || INTEGER_CST_P (sym->ts.cl->backend_decl);
590 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
592 /* For descriptorless arrays with known element size the actual
593 argument is sufficient. */
594 gcc_assert (GFC_ARRAY_TYPE_P (type));
595 gfc_build_qualified_array (dummy, sym);
599 type = TREE_TYPE (type);
600 if (GFC_DESCRIPTOR_TYPE_P (type))
602 /* Create a decriptorless array pointer. */
605 if (!gfc_option.flag_repack_arrays)
607 if (as->type == AS_ASSUMED_SIZE)
612 if (as->type == AS_EXPLICIT)
615 for (n = 0; n < as->rank; n++)
619 && as->upper[n]->expr_type == EXPR_CONSTANT
620 && as->lower[n]->expr_type == EXPR_CONSTANT))
628 type = gfc_typenode_for_spec (&sym->ts);
629 type = gfc_get_nodesc_array_type (type, sym->as, packed);
633 /* We now have an expression for the element size, so create a fully
634 qualified type. Reset sym->backend decl or this will just return the
636 sym->backend_decl = NULL_TREE;
637 type = gfc_sym_type (sym);
641 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
642 decl = build_decl (VAR_DECL, get_identifier (name), type);
644 DECL_ARTIFICIAL (decl) = 1;
645 TREE_PUBLIC (decl) = 0;
646 TREE_STATIC (decl) = 0;
647 DECL_EXTERNAL (decl) = 0;
649 /* We should never get deferred shape arrays here. We used to because of
651 gcc_assert (sym->as->type != AS_DEFERRED);
656 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
660 GFC_DECL_PACKED_ARRAY (decl) = 1;
664 gfc_build_qualified_array (decl, sym);
666 if (DECL_LANG_SPECIFIC (dummy))
667 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
669 gfc_allocate_lang_decl (decl);
671 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
673 if (sym->ns->proc_name->backend_decl == current_function_decl
674 || sym->attr.contained)
675 gfc_add_decl_to_function (decl);
677 gfc_add_decl_to_parent_function (decl);
683 /* Return a constant or a variable to use as a string length. Does not
684 add the decl to the current scope. */
687 gfc_create_string_length (gfc_symbol * sym)
691 gcc_assert (sym->ts.cl);
692 gfc_conv_const_charlen (sym->ts.cl);
694 if (sym->ts.cl->backend_decl == NULL_TREE)
696 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
698 /* Also prefix the mangled name. */
699 strcpy (&name[1], sym->name);
701 length = build_decl (VAR_DECL, get_identifier (name),
702 gfc_charlen_type_node);
703 DECL_ARTIFICIAL (length) = 1;
704 TREE_USED (length) = 1;
705 gfc_defer_symbol_init (sym);
706 sym->ts.cl->backend_decl = length;
709 return sym->ts.cl->backend_decl;
713 /* Return the decl for a gfc_symbol, create it if it doesn't already
717 gfc_get_symbol_decl (gfc_symbol * sym)
720 tree length = NULL_TREE;
723 gcc_assert (sym->attr.referenced);
725 if (sym->ns && sym->ns->proc_name->attr.function)
726 byref = gfc_return_by_reference (sym->ns->proc_name);
730 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
732 /* Return via extra parameter. */
733 if (sym->attr.result && byref
734 && !sym->backend_decl)
737 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
738 /* For entry master function skip over the __entry
740 if (sym->ns->proc_name->attr.entry_master)
741 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
744 /* Dummy variables should already have been created. */
745 gcc_assert (sym->backend_decl);
747 /* Create a character length variable. */
748 if (sym->ts.type == BT_CHARACTER)
750 if (sym->ts.cl->backend_decl == NULL_TREE)
752 length = gfc_create_string_length (sym);
753 if (TREE_CODE (length) != INTEGER_CST)
755 gfc_finish_var_decl (length, sym);
756 gfc_defer_symbol_init (sym);
761 /* Use a copy of the descriptor for dummy arrays. */
762 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
765 gfc_build_dummy_array_decl (sym, sym->backend_decl);
768 TREE_USED (sym->backend_decl) = 1;
769 return sym->backend_decl;
772 if (sym->backend_decl)
773 return sym->backend_decl;
775 /* Catch function declarations. Only used for actual parameters. */
776 if (sym->attr.flavor == FL_PROCEDURE)
778 decl = gfc_get_extern_function_decl (sym);
782 if (sym->attr.intrinsic)
783 internal_error ("intrinsic variable which isn't a procedure");
785 /* Create string length decl first so that they can be used in the
787 if (sym->ts.type == BT_CHARACTER)
788 length = gfc_create_string_length (sym);
790 /* Create the decl for the variable. */
791 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
793 gfc_set_decl_location (decl, &sym->declared_at);
795 /* Symbols from modules should have their assembler names mangled.
796 This is done here rather than in gfc_finish_var_decl because it
797 is different for string length variables. */
799 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
801 if (sym->attr.dimension)
803 /* Create variables to hold the non-constant bits of array info. */
804 gfc_build_qualified_array (decl, sym);
806 /* Remember this variable for allocation/cleanup. */
807 gfc_defer_symbol_init (sym);
809 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
810 GFC_DECL_PACKED_ARRAY (decl) = 1;
813 gfc_finish_var_decl (decl, sym);
815 if (sym->attr.assign)
817 gfc_allocate_lang_decl (decl);
818 GFC_DECL_ASSIGN (decl) = 1;
819 length = gfc_create_var (gfc_charlen_type_node, sym->name);
820 GFC_DECL_STRING_LEN (decl) = length;
821 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
822 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
823 TREE_STATIC (length) = TREE_STATIC (decl);
824 /* STRING_LENGTH is also used as flag. Less than -1 means that
825 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
826 target label's address. Other value is the length of format string
827 and ASSIGN_ADDR is the address of format string. */
828 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
831 if (sym->ts.type == BT_CHARACTER)
833 /* Character variables need special handling. */
834 gfc_allocate_lang_decl (decl);
836 if (TREE_CODE (length) != INTEGER_CST)
838 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
842 /* Also prefix the mangled name for symbols from modules. */
843 strcpy (&name[1], sym->name);
846 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
847 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
849 gfc_finish_var_decl (length, sym);
850 gcc_assert (!sym->value);
853 sym->backend_decl = decl;
855 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
857 /* Add static initializer. */
858 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
859 TREE_TYPE (decl), sym->attr.dimension,
860 sym->attr.pointer || sym->attr.allocatable);
867 /* Substitute a temporary variable in place of the real one. */
870 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
872 save->attr = sym->attr;
873 save->decl = sym->backend_decl;
875 gfc_clear_attr (&sym->attr);
876 sym->attr.referenced = 1;
877 sym->attr.flavor = FL_VARIABLE;
879 sym->backend_decl = decl;
883 /* Restore the original variable. */
886 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
888 sym->attr = save->attr;
889 sym->backend_decl = save->decl;
893 /* Get a basic decl for an external function. */
896 gfc_get_extern_function_decl (gfc_symbol * sym)
901 gfc_intrinsic_sym *isym;
903 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
907 if (sym->backend_decl)
908 return sym->backend_decl;
910 /* We should never be creating external decls for alternate entry points.
911 The procedure may be an alternate entry point, but we don't want/need
913 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
915 if (sym->attr.intrinsic)
917 /* Call the resolution function to get the actual name. This is
918 a nasty hack which relies on the resolution functions only looking
919 at the first argument. We pass NULL for the second argument
920 otherwise things like AINT get confused. */
921 isym = gfc_find_function (sym->name);
922 gcc_assert (isym->resolve.f0 != NULL);
924 memset (&e, 0, sizeof (e));
925 e.expr_type = EXPR_FUNCTION;
927 memset (&argexpr, 0, sizeof (argexpr));
928 gcc_assert (isym->formal);
929 argexpr.ts = isym->formal->ts;
931 if (isym->formal->next == NULL)
932 isym->resolve.f1 (&e, &argexpr);
935 /* All specific intrinsics take one or two arguments. */
936 gcc_assert (isym->formal->next->next == NULL);
937 isym->resolve.f2 (&e, &argexpr, NULL);
940 if (gfc_option.flag_f2c
941 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
942 || e.ts.type == BT_COMPLEX))
944 /* Specific which needs a different implementation if f2c
945 calling conventions are used. */
946 sprintf (s, "f2c_specific%s", e.value.function.name);
949 sprintf (s, "specific%s", e.value.function.name);
951 name = get_identifier (s);
956 name = gfc_sym_identifier (sym);
957 mangled_name = gfc_sym_mangled_function_id (sym);
960 type = gfc_get_function_type (sym);
961 fndecl = build_decl (FUNCTION_DECL, name, type);
963 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
964 /* If the return type is a pointer, avoid alias issues by setting
965 DECL_IS_MALLOC to nonzero. This means that the function should be
966 treated as if it were a malloc, meaning it returns a pointer that
968 if (POINTER_TYPE_P (type))
969 DECL_IS_MALLOC (fndecl) = 1;
971 /* Set the context of this decl. */
972 if (0 && sym->ns && sym->ns->proc_name)
974 /* TODO: Add external decls to the appropriate scope. */
975 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
979 /* Global declaration, e.g. intrinsic subroutine. */
980 DECL_CONTEXT (fndecl) = NULL_TREE;
983 DECL_EXTERNAL (fndecl) = 1;
985 /* This specifies if a function is globally addressable, i.e. it is
986 the opposite of declaring static in C. */
987 TREE_PUBLIC (fndecl) = 1;
989 /* Set attributes for PURE functions. A call to PURE function in the
990 Fortran 95 sense is both pure and without side effects in the C
992 if (sym->attr.pure || sym->attr.elemental)
994 if (sym->attr.function)
995 DECL_IS_PURE (fndecl) = 1;
996 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
997 parameters and don't use alternate returns (is this
998 allowed?). In that case, calls to them are meaningless, and
999 can be optimized away. See also in build_function_decl(). */
1000 TREE_SIDE_EFFECTS (fndecl) = 0;
1003 sym->backend_decl = fndecl;
1005 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1006 pushdecl_top_level (fndecl);
1012 /* Create a declaration for a procedure. For external functions (in the C
1013 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1014 a master function with alternate entry points. */
1017 build_function_decl (gfc_symbol * sym)
1020 symbol_attribute attr;
1022 gfc_formal_arglist *f;
1024 gcc_assert (!sym->backend_decl);
1025 gcc_assert (!sym->attr.external);
1027 /* Set the line and filename. sym->declared_at seems to point to the
1028 last statement for subroutines, but it'll do for now. */
1029 gfc_set_backend_locus (&sym->declared_at);
1031 /* Allow only one nesting level. Allow public declarations. */
1032 gcc_assert (current_function_decl == NULL_TREE
1033 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1035 type = gfc_get_function_type (sym);
1036 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1038 /* Perform name mangling if this is a top level or module procedure. */
1039 if (current_function_decl == NULL_TREE)
1040 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1042 /* Figure out the return type of the declared function, and build a
1043 RESULT_DECL for it. If this is a subroutine with alternate
1044 returns, build a RESULT_DECL for it. */
1047 result_decl = NULL_TREE;
1048 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1051 if (gfc_return_by_reference (sym))
1052 type = void_type_node;
1055 if (sym->result != sym)
1056 result_decl = gfc_sym_identifier (sym->result);
1058 type = TREE_TYPE (TREE_TYPE (fndecl));
1063 /* Look for alternate return placeholders. */
1064 int has_alternate_returns = 0;
1065 for (f = sym->formal; f; f = f->next)
1069 has_alternate_returns = 1;
1074 if (has_alternate_returns)
1075 type = integer_type_node;
1077 type = void_type_node;
1080 result_decl = build_decl (RESULT_DECL, result_decl, type);
1081 DECL_ARTIFICIAL (result_decl) = 1;
1082 DECL_IGNORED_P (result_decl) = 1;
1083 DECL_CONTEXT (result_decl) = fndecl;
1084 DECL_RESULT (fndecl) = result_decl;
1086 /* Don't call layout_decl for a RESULT_DECL.
1087 layout_decl (result_decl, 0); */
1089 /* If the return type is a pointer, avoid alias issues by setting
1090 DECL_IS_MALLOC to nonzero. This means that the function should be
1091 treated as if it were a malloc, meaning it returns a pointer that
1093 if (POINTER_TYPE_P (type))
1094 DECL_IS_MALLOC (fndecl) = 1;
1096 /* Set up all attributes for the function. */
1097 DECL_CONTEXT (fndecl) = current_function_decl;
1098 DECL_EXTERNAL (fndecl) = 0;
1100 /* This specifies if a function is globally visible, i.e. it is
1101 the opposite of declaring static in C. */
1102 if (DECL_CONTEXT (fndecl) == NULL_TREE
1103 && !sym->attr.entry_master)
1104 TREE_PUBLIC (fndecl) = 1;
1106 /* TREE_STATIC means the function body is defined here. */
1107 TREE_STATIC (fndecl) = 1;
1109 /* Set attributes for PURE functions. A call to a PURE function in the
1110 Fortran 95 sense is both pure and without side effects in the C
1112 if (attr.pure || attr.elemental)
1114 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1115 including a alternate return. In that case it can also be
1116 marked as PURE. See also in gfc_get_extern_function_decl(). */
1118 DECL_IS_PURE (fndecl) = 1;
1119 TREE_SIDE_EFFECTS (fndecl) = 0;
1122 /* Layout the function declaration and put it in the binding level
1123 of the current function. */
1126 sym->backend_decl = fndecl;
1130 /* Create the DECL_ARGUMENTS for a procedure. */
1133 create_function_arglist (gfc_symbol * sym)
1136 gfc_formal_arglist *f;
1143 fndecl = sym->backend_decl;
1145 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1146 the new FUNCTION_DECL node. */
1147 arglist = NULL_TREE;
1148 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1150 if (sym->attr.entry_master)
1152 type = TREE_VALUE (typelist);
1153 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1155 DECL_CONTEXT (parm) = fndecl;
1156 DECL_ARG_TYPE (parm) = type;
1157 TREE_READONLY (parm) = 1;
1158 gfc_finish_decl (parm, NULL_TREE);
1160 arglist = chainon (arglist, parm);
1161 typelist = TREE_CHAIN (typelist);
1164 if (gfc_return_by_reference (sym))
1166 type = TREE_VALUE (typelist);
1167 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1169 DECL_CONTEXT (parm) = fndecl;
1170 DECL_ARG_TYPE (parm) = type;
1171 TREE_READONLY (parm) = 1;
1172 DECL_ARTIFICIAL (parm) = 1;
1173 gfc_finish_decl (parm, NULL_TREE);
1175 arglist = chainon (arglist, parm);
1176 typelist = TREE_CHAIN (typelist);
1178 if (sym->ts.type == BT_CHARACTER)
1180 gfc_allocate_lang_decl (parm);
1182 /* Length of character result. */
1183 type = TREE_VALUE (typelist);
1184 gcc_assert (type == gfc_charlen_type_node);
1186 length = build_decl (PARM_DECL,
1187 get_identifier (".__result"),
1189 if (!sym->ts.cl->length)
1191 sym->ts.cl->backend_decl = length;
1192 TREE_USED (length) = 1;
1194 gcc_assert (TREE_CODE (length) == PARM_DECL);
1195 arglist = chainon (arglist, length);
1196 typelist = TREE_CHAIN (typelist);
1197 DECL_CONTEXT (length) = fndecl;
1198 DECL_ARG_TYPE (length) = type;
1199 TREE_READONLY (length) = 1;
1200 DECL_ARTIFICIAL (length) = 1;
1201 gfc_finish_decl (length, NULL_TREE);
1205 for (f = sym->formal; f; f = f->next)
1207 if (f->sym != NULL) /* ignore alternate returns. */
1211 type = TREE_VALUE (typelist);
1213 /* Build a the argument declaration. */
1214 parm = build_decl (PARM_DECL,
1215 gfc_sym_identifier (f->sym), type);
1217 /* Fill in arg stuff. */
1218 DECL_CONTEXT (parm) = fndecl;
1219 DECL_ARG_TYPE (parm) = type;
1220 /* All implementation args are read-only. */
1221 TREE_READONLY (parm) = 1;
1223 gfc_finish_decl (parm, NULL_TREE);
1225 f->sym->backend_decl = parm;
1227 arglist = chainon (arglist, parm);
1228 typelist = TREE_CHAIN (typelist);
1232 /* Add the hidden string length parameters. */
1234 for (f = sym->formal; f; f = f->next)
1236 char name[GFC_MAX_SYMBOL_LEN + 2];
1237 /* Ignore alternate returns. */
1241 if (f->sym->ts.type != BT_CHARACTER)
1244 parm = f->sym->backend_decl;
1245 type = TREE_VALUE (typelist);
1246 gcc_assert (type == gfc_charlen_type_node);
1248 strcpy (&name[1], f->sym->name);
1250 length = build_decl (PARM_DECL, get_identifier (name), type);
1252 arglist = chainon (arglist, length);
1253 DECL_CONTEXT (length) = fndecl;
1254 DECL_ARTIFICIAL (length) = 1;
1255 DECL_ARG_TYPE (length) = type;
1256 TREE_READONLY (length) = 1;
1257 gfc_finish_decl (length, NULL_TREE);
1259 /* TODO: Check string lengths when -fbounds-check. */
1261 /* Use the passed value for assumed length variables. */
1262 if (!f->sym->ts.cl->length)
1264 TREE_USED (length) = 1;
1265 if (!f->sym->ts.cl->backend_decl)
1266 f->sym->ts.cl->backend_decl = length;
1269 /* there is already another variable using this
1270 gfc_charlen node, build a new one for this variable
1271 and chain it into the list of gfc_charlens.
1272 This happens for e.g. in the case
1274 since CHARACTER declarations on the same line share
1275 the same gfc_charlen node. */
1278 cl = gfc_get_charlen ();
1279 cl->backend_decl = length;
1280 cl->next = f->sym->ts.cl->next;
1281 f->sym->ts.cl->next = cl;
1286 parm = TREE_CHAIN (parm);
1287 typelist = TREE_CHAIN (typelist);
1290 gcc_assert (TREE_VALUE (typelist) == void_type_node);
1291 DECL_ARGUMENTS (fndecl) = arglist;
1294 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1297 gfc_gimplify_function (tree fndecl)
1299 struct cgraph_node *cgn;
1301 gimplify_function_tree (fndecl);
1302 dump_function (TDI_generic, fndecl);
1304 /* Convert all nested functions to GIMPLE now. We do things in this order
1305 so that items like VLA sizes are expanded properly in the context of the
1306 correct function. */
1307 cgn = cgraph_node (fndecl);
1308 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1309 gfc_gimplify_function (cgn->decl);
1313 /* Do the setup necessary before generating the body of a function. */
1316 trans_function_start (gfc_symbol * sym)
1320 fndecl = sym->backend_decl;
1322 /* Let GCC know the current scope is this function. */
1323 current_function_decl = fndecl;
1325 /* Let the world know what we're about to do. */
1326 announce_function (fndecl);
1328 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1330 /* Create RTL for function declaration. */
1331 rest_of_decl_compilation (fndecl, 1, 0);
1334 /* Create RTL for function definition. */
1335 make_decl_rtl (fndecl);
1337 init_function_start (fndecl);
1339 /* Even though we're inside a function body, we still don't want to
1340 call expand_expr to calculate the size of a variable-sized array.
1341 We haven't necessarily assigned RTL to all variables yet, so it's
1342 not safe to try to expand expressions involving them. */
1343 cfun->x_dont_save_pending_sizes_p = 1;
1345 /* function.c requires a push at the start of the function. */
1349 /* Create thunks for alternate entry points. */
1352 build_entry_thunks (gfc_namespace * ns)
1354 gfc_formal_arglist *formal;
1355 gfc_formal_arglist *thunk_formal;
1357 gfc_symbol *thunk_sym;
1365 /* This should always be a toplevel function. */
1366 gcc_assert (current_function_decl == NULL_TREE);
1368 gfc_get_backend_locus (&old_loc);
1369 for (el = ns->entries; el; el = el->next)
1371 thunk_sym = el->sym;
1373 build_function_decl (thunk_sym);
1374 create_function_arglist (thunk_sym);
1376 trans_function_start (thunk_sym);
1378 thunk_fndecl = thunk_sym->backend_decl;
1380 gfc_start_block (&body);
1382 /* Pass extra parameter identifying this entry point. */
1383 tmp = build_int_cst (gfc_array_index_type, el->id);
1384 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1385 string_args = NULL_TREE;
1387 if (thunk_sym->attr.function)
1389 if (gfc_return_by_reference (ns->proc_name))
1391 tree ref = DECL_ARGUMENTS (current_function_decl);
1392 args = tree_cons (NULL_TREE, ref, args);
1393 if (ns->proc_name->ts.type == BT_CHARACTER)
1394 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1399 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1401 /* Ignore alternate returns. */
1402 if (formal->sym == NULL)
1405 /* We don't have a clever way of identifying arguments, so resort to
1406 a brute-force search. */
1407 for (thunk_formal = thunk_sym->formal;
1409 thunk_formal = thunk_formal->next)
1411 if (thunk_formal->sym == formal->sym)
1417 /* Pass the argument. */
1418 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1420 if (formal->sym->ts.type == BT_CHARACTER)
1422 tmp = thunk_formal->sym->ts.cl->backend_decl;
1423 string_args = tree_cons (NULL_TREE, tmp, string_args);
1428 /* Pass NULL for a missing argument. */
1429 args = tree_cons (NULL_TREE, null_pointer_node, args);
1430 if (formal->sym->ts.type == BT_CHARACTER)
1432 tmp = convert (gfc_charlen_type_node, integer_zero_node);
1433 string_args = tree_cons (NULL_TREE, tmp, string_args);
1438 /* Call the master function. */
1439 args = nreverse (args);
1440 args = chainon (args, nreverse (string_args));
1441 tmp = ns->proc_name->backend_decl;
1442 tmp = gfc_build_function_call (tmp, args);
1443 if (ns->proc_name->attr.mixed_entry_master)
1445 tree union_decl, field;
1446 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1448 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1449 TREE_TYPE (master_type));
1450 DECL_ARTIFICIAL (union_decl) = 1;
1451 DECL_EXTERNAL (union_decl) = 0;
1452 TREE_PUBLIC (union_decl) = 0;
1453 TREE_USED (union_decl) = 1;
1454 layout_decl (union_decl, 0);
1455 pushdecl (union_decl);
1457 DECL_CONTEXT (union_decl) = current_function_decl;
1458 tmp = build2 (MODIFY_EXPR,
1459 TREE_TYPE (union_decl),
1461 gfc_add_expr_to_block (&body, tmp);
1463 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1464 field; field = TREE_CHAIN (field))
1465 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1466 thunk_sym->result->name) == 0)
1468 gcc_assert (field != NULL_TREE);
1469 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1471 tmp = build2 (MODIFY_EXPR,
1472 TREE_TYPE (DECL_RESULT (current_function_decl)),
1473 DECL_RESULT (current_function_decl), tmp);
1474 tmp = build1_v (RETURN_EXPR, tmp);
1476 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1479 tmp = build2 (MODIFY_EXPR,
1480 TREE_TYPE (DECL_RESULT (current_function_decl)),
1481 DECL_RESULT (current_function_decl), tmp);
1482 tmp = build1_v (RETURN_EXPR, tmp);
1484 gfc_add_expr_to_block (&body, tmp);
1486 /* Finish off this function and send it for code generation. */
1487 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1489 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1491 /* Output the GENERIC tree. */
1492 dump_function (TDI_original, thunk_fndecl);
1494 /* Store the end of the function, so that we get good line number
1495 info for the epilogue. */
1496 cfun->function_end_locus = input_location;
1498 /* We're leaving the context of this function, so zap cfun.
1499 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1500 tree_rest_of_compilation. */
1503 current_function_decl = NULL_TREE;
1505 gfc_gimplify_function (thunk_fndecl);
1506 cgraph_finalize_function (thunk_fndecl, false);
1508 /* We share the symbols in the formal argument list with other entry
1509 points and the master function. Clear them so that they are
1510 recreated for each function. */
1511 for (formal = thunk_sym->formal; formal; formal = formal->next)
1512 if (formal->sym != NULL) /* Ignore alternate returns. */
1514 formal->sym->backend_decl = NULL_TREE;
1515 if (formal->sym->ts.type == BT_CHARACTER)
1516 formal->sym->ts.cl->backend_decl = NULL_TREE;
1519 if (thunk_sym->attr.function)
1521 if (thunk_sym->ts.type == BT_CHARACTER)
1522 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1523 if (thunk_sym->result->ts.type == BT_CHARACTER)
1524 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1528 gfc_set_backend_locus (&old_loc);
1532 /* Create a decl for a function, and create any thunks for alternate entry
1536 gfc_create_function_decl (gfc_namespace * ns)
1538 /* Create a declaration for the master function. */
1539 build_function_decl (ns->proc_name);
1541 /* Compile the entry thunks. */
1543 build_entry_thunks (ns);
1545 /* Now create the read argument list. */
1546 create_function_arglist (ns->proc_name);
1549 /* Return the decl used to hold the function return value. */
1552 gfc_get_fake_result_decl (gfc_symbol * sym)
1557 char name[GFC_MAX_SYMBOL_LEN + 10];
1560 && sym->ns->proc_name->backend_decl == current_function_decl
1561 && sym->ns->proc_name->attr.mixed_entry_master
1562 && sym != sym->ns->proc_name)
1564 decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1569 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1570 field; field = TREE_CHAIN (field))
1571 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1575 gcc_assert (field != NULL_TREE);
1576 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1582 if (current_fake_result_decl != NULL_TREE)
1583 return current_fake_result_decl;
1585 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1590 if (sym->ts.type == BT_CHARACTER
1591 && !sym->ts.cl->backend_decl)
1593 length = gfc_create_string_length (sym);
1594 gfc_finish_var_decl (length, sym);
1597 if (gfc_return_by_reference (sym))
1599 decl = DECL_ARGUMENTS (current_function_decl);
1601 if (sym->ns->proc_name->backend_decl == current_function_decl
1602 && sym->ns->proc_name->attr.entry_master)
1603 decl = TREE_CHAIN (decl);
1605 TREE_USED (decl) = 1;
1607 decl = gfc_build_dummy_array_decl (sym, decl);
1611 sprintf (name, "__result_%.20s",
1612 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1614 decl = build_decl (VAR_DECL, get_identifier (name),
1615 TREE_TYPE (TREE_TYPE (current_function_decl)));
1617 DECL_ARTIFICIAL (decl) = 1;
1618 DECL_EXTERNAL (decl) = 0;
1619 TREE_PUBLIC (decl) = 0;
1620 TREE_USED (decl) = 1;
1622 layout_decl (decl, 0);
1624 gfc_add_decl_to_function (decl);
1627 current_fake_result_decl = decl;
1633 /* Builds a function decl. The remaining parameters are the types of the
1634 function arguments. Negative nargs indicates a varargs function. */
1637 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1646 /* Library functions must be declared with global scope. */
1647 gcc_assert (current_function_decl == NULL_TREE);
1649 va_start (p, nargs);
1652 /* Create a list of the argument types. */
1653 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1655 argtype = va_arg (p, tree);
1656 arglist = gfc_chainon_list (arglist, argtype);
1661 /* Terminate the list. */
1662 arglist = gfc_chainon_list (arglist, void_type_node);
1665 /* Build the function type and decl. */
1666 fntype = build_function_type (rettype, arglist);
1667 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1669 /* Mark this decl as external. */
1670 DECL_EXTERNAL (fndecl) = 1;
1671 TREE_PUBLIC (fndecl) = 1;
1677 rest_of_decl_compilation (fndecl, 1, 0);
1683 gfc_build_intrinsic_function_decls (void)
1685 tree gfc_int4_type_node = gfc_get_int_type (4);
1686 tree gfc_int8_type_node = gfc_get_int_type (8);
1687 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1688 tree gfc_real4_type_node = gfc_get_real_type (4);
1689 tree gfc_real8_type_node = gfc_get_real_type (8);
1690 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1691 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1693 /* String functions. */
1694 gfor_fndecl_copy_string =
1695 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1698 gfc_charlen_type_node, pchar_type_node,
1699 gfc_charlen_type_node, pchar_type_node);
1701 gfor_fndecl_compare_string =
1702 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1705 gfc_charlen_type_node, pchar_type_node,
1706 gfc_charlen_type_node, pchar_type_node);
1708 gfor_fndecl_concat_string =
1709 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1712 gfc_charlen_type_node, pchar_type_node,
1713 gfc_charlen_type_node, pchar_type_node,
1714 gfc_charlen_type_node, pchar_type_node);
1716 gfor_fndecl_string_len_trim =
1717 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1719 2, gfc_charlen_type_node,
1722 gfor_fndecl_string_index =
1723 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1725 5, gfc_charlen_type_node, pchar_type_node,
1726 gfc_charlen_type_node, pchar_type_node,
1727 gfc_logical4_type_node);
1729 gfor_fndecl_string_scan =
1730 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1732 5, gfc_charlen_type_node, pchar_type_node,
1733 gfc_charlen_type_node, pchar_type_node,
1734 gfc_logical4_type_node);
1736 gfor_fndecl_string_verify =
1737 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1739 5, gfc_charlen_type_node, pchar_type_node,
1740 gfc_charlen_type_node, pchar_type_node,
1741 gfc_logical4_type_node);
1743 gfor_fndecl_string_trim =
1744 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1747 build_pointer_type (gfc_charlen_type_node),
1749 gfc_charlen_type_node,
1752 gfor_fndecl_string_repeat =
1753 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1757 gfc_charlen_type_node,
1759 gfc_int4_type_node);
1761 gfor_fndecl_adjustl =
1762 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1766 gfc_charlen_type_node, pchar_type_node);
1768 gfor_fndecl_adjustr =
1769 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1773 gfc_charlen_type_node, pchar_type_node);
1775 gfor_fndecl_si_kind =
1776 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1781 gfor_fndecl_sr_kind =
1782 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1787 /* Power functions. */
1793 static int kinds[2] = {4, 8};
1794 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1796 for (ikind=0; ikind < 2; ikind++)
1798 itype = gfc_get_int_type (kinds[ikind]);
1799 for (kind = 0; kind < 2; kind ++)
1801 type = gfc_get_int_type (kinds[kind]);
1802 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1803 gfor_fndecl_math_powi[kind][ikind].integer =
1804 gfc_build_library_function_decl (get_identifier (name),
1805 type, 2, type, itype);
1807 type = gfc_get_real_type (kinds[kind]);
1808 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1809 gfor_fndecl_math_powi[kind][ikind].real =
1810 gfc_build_library_function_decl (get_identifier (name),
1811 type, 2, type, itype);
1813 type = gfc_get_complex_type (kinds[kind]);
1814 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1815 gfor_fndecl_math_powi[kind][ikind].cmplx =
1816 gfc_build_library_function_decl (get_identifier (name),
1817 type, 2, type, itype);
1822 gfor_fndecl_math_cpowf =
1823 gfc_build_library_function_decl (get_identifier ("cpowf"),
1824 gfc_complex4_type_node,
1825 1, gfc_complex4_type_node);
1826 gfor_fndecl_math_cpow =
1827 gfc_build_library_function_decl (get_identifier ("cpow"),
1828 gfc_complex8_type_node,
1829 1, gfc_complex8_type_node);
1830 gfor_fndecl_math_ishftc4 =
1831 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1833 3, gfc_int4_type_node,
1834 gfc_int4_type_node, gfc_int4_type_node);
1835 gfor_fndecl_math_ishftc8 =
1836 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1838 3, gfc_int8_type_node,
1839 gfc_int8_type_node, gfc_int8_type_node);
1840 gfor_fndecl_math_exponent4 =
1841 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1843 1, gfc_real4_type_node);
1844 gfor_fndecl_math_exponent8 =
1845 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1847 1, gfc_real8_type_node);
1849 /* Other functions. */
1851 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1852 gfc_array_index_type,
1853 1, pvoid_type_node);
1855 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1856 gfc_array_index_type,
1858 gfc_array_index_type);
1861 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1867 /* Make prototypes for runtime library functions. */
1870 gfc_build_builtin_function_decls (void)
1872 tree gfc_int4_type_node = gfc_get_int_type (4);
1873 tree gfc_int8_type_node = gfc_get_int_type (8);
1874 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1875 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
1877 /* Treat these two internal malloc wrappers as malloc. */
1878 gfor_fndecl_internal_malloc =
1879 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1880 pvoid_type_node, 1, gfc_int4_type_node);
1881 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
1883 gfor_fndecl_internal_malloc64 =
1884 gfc_build_library_function_decl (get_identifier
1885 (PREFIX("internal_malloc64")),
1886 pvoid_type_node, 1, gfc_int8_type_node);
1887 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
1889 gfor_fndecl_internal_free =
1890 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1891 void_type_node, 1, pvoid_type_node);
1893 gfor_fndecl_allocate =
1894 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1895 void_type_node, 2, ppvoid_type_node,
1896 gfc_int4_type_node);
1898 gfor_fndecl_allocate64 =
1899 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1900 void_type_node, 2, ppvoid_type_node,
1901 gfc_int8_type_node);
1903 gfor_fndecl_deallocate =
1904 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1905 void_type_node, 2, ppvoid_type_node,
1906 gfc_pint4_type_node);
1908 gfor_fndecl_stop_numeric =
1909 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1910 void_type_node, 1, gfc_int4_type_node);
1912 gfor_fndecl_stop_string =
1913 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1914 void_type_node, 2, pchar_type_node,
1915 gfc_int4_type_node);
1917 gfor_fndecl_pause_numeric =
1918 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1919 void_type_node, 1, gfc_int4_type_node);
1921 gfor_fndecl_pause_string =
1922 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1923 void_type_node, 2, pchar_type_node,
1924 gfc_int4_type_node);
1926 gfor_fndecl_select_string =
1927 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1928 pvoid_type_node, 0);
1930 gfor_fndecl_runtime_error =
1931 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1934 pchar_type_node, pchar_type_node,
1935 gfc_int4_type_node);
1936 /* The runtime_error function does not return. */
1937 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
1939 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1940 get_identifier (PREFIX("internal_pack")),
1941 pvoid_type_node, 1, pvoid_type_node);
1943 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1944 get_identifier (PREFIX("internal_unpack")),
1945 pvoid_type_node, 1, pvoid_type_node);
1947 gfor_fndecl_associated =
1948 gfc_build_library_function_decl (
1949 get_identifier (PREFIX("associated")),
1950 gfc_logical4_type_node,
1955 gfc_build_intrinsic_function_decls ();
1956 gfc_build_intrinsic_lib_fndecls ();
1957 gfc_build_io_library_fndecls ();
1961 /* Evaluate the length of dummy character variables. */
1964 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1968 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1970 gfc_start_block (&body);
1972 /* Evaluate the string length expression. */
1973 gfc_trans_init_string_length (cl, &body);
1975 gfc_add_expr_to_block (&body, fnbody);
1976 return gfc_finish_block (&body);
1980 /* Allocate and cleanup an automatic character variable. */
1983 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1989 gcc_assert (sym->backend_decl);
1990 gcc_assert (sym->ts.cl && sym->ts.cl->length);
1992 gfc_start_block (&body);
1994 /* Evaluate the string length expression. */
1995 gfc_trans_init_string_length (sym->ts.cl, &body);
1997 decl = sym->backend_decl;
1999 /* Emit a DECL_EXPR for this variable, which will cause the
2000 gimplifier to allocate storage, and all that good stuff. */
2001 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2002 gfc_add_expr_to_block (&body, tmp);
2004 gfc_add_expr_to_block (&body, fnbody);
2005 return gfc_finish_block (&body);
2009 /* Generate function entry and exit code, and add it to the function body.
2011 Allocation and initialization of array variables.
2012 Allocation of character string variables.
2013 Initialization and possibly repacking of dummy arrays. */
2016 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2021 /* Deal with implicit return variables. Explicit return variables will
2022 already have been added. */
2023 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2025 if (!current_fake_result_decl)
2027 gfc_entry_list *el = NULL;
2028 if (proc_sym->attr.entry_master)
2030 for (el = proc_sym->ns->entries; el; el = el->next)
2031 if (el->sym != el->sym->result)
2035 warning (0, "Function does not return a value");
2037 else if (proc_sym->as)
2039 fnbody = gfc_trans_dummy_array_bias (proc_sym,
2040 current_fake_result_decl,
2043 else if (proc_sym->ts.type == BT_CHARACTER)
2045 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2046 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2049 gcc_assert (gfc_option.flag_f2c
2050 && proc_sym->ts.type == BT_COMPLEX);
2053 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2055 if (sym->attr.dimension)
2057 switch (sym->as->type)
2060 if (sym->attr.dummy || sym->attr.result)
2062 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2063 else if (sym->attr.pointer || sym->attr.allocatable)
2065 if (TREE_STATIC (sym->backend_decl))
2066 gfc_trans_static_array_pointer (sym);
2068 fnbody = gfc_trans_deferred_array (sym, fnbody);
2072 gfc_get_backend_locus (&loc);
2073 gfc_set_backend_locus (&sym->declared_at);
2074 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2076 gfc_set_backend_locus (&loc);
2080 case AS_ASSUMED_SIZE:
2081 /* Must be a dummy parameter. */
2082 gcc_assert (sym->attr.dummy);
2084 /* We should always pass assumed size arrays the g77 way. */
2085 fnbody = gfc_trans_g77_array (sym, fnbody);
2088 case AS_ASSUMED_SHAPE:
2089 /* Must be a dummy parameter. */
2090 gcc_assert (sym->attr.dummy);
2092 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2097 fnbody = gfc_trans_deferred_array (sym, fnbody);
2104 else if (sym->ts.type == BT_CHARACTER)
2106 gfc_get_backend_locus (&loc);
2107 gfc_set_backend_locus (&sym->declared_at);
2108 if (sym->attr.dummy || sym->attr.result)
2109 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2111 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2112 gfc_set_backend_locus (&loc);
2122 /* Output an initialized decl for a module variable. */
2125 gfc_create_module_variable (gfc_symbol * sym)
2129 /* Only output symbols from this module. */
2130 if (sym->ns != module_namespace)
2132 /* I don't think this should ever happen. */
2133 internal_error ("module symbol %s in wrong namespace", sym->name);
2136 /* Only output variables and array valued parameters. */
2137 if (sym->attr.flavor != FL_VARIABLE
2138 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2141 /* Don't generate variables from other modules. Variables from
2142 COMMONs will already have been generated. */
2143 if (sym->attr.use_assoc || sym->attr.in_common)
2146 if (sym->backend_decl)
2147 internal_error ("backend decl for module variable %s already exists",
2150 /* We always want module variables to be created. */
2151 sym->attr.referenced = 1;
2152 /* Create the decl. */
2153 decl = gfc_get_symbol_decl (sym);
2155 /* Create the variable. */
2157 rest_of_decl_compilation (decl, 1, 0);
2159 /* Also add length of strings. */
2160 if (sym->ts.type == BT_CHARACTER)
2164 length = sym->ts.cl->backend_decl;
2165 if (!INTEGER_CST_P (length))
2168 rest_of_decl_compilation (length, 1, 0);
2174 /* Generate all the required code for module variables. */
2177 gfc_generate_module_vars (gfc_namespace * ns)
2179 module_namespace = ns;
2181 /* Check if the frontend left the namespace in a reasonable state. */
2182 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2184 /* Generate COMMON blocks. */
2185 gfc_trans_common (ns);
2187 /* Create decls for all the module variables. */
2188 gfc_traverse_ns (ns, gfc_create_module_variable);
2192 gfc_generate_contained_functions (gfc_namespace * parent)
2196 /* We create all the prototypes before generating any code. */
2197 for (ns = parent->contained; ns; ns = ns->sibling)
2199 /* Skip namespaces from used modules. */
2200 if (ns->parent != parent)
2203 gfc_create_function_decl (ns);
2206 for (ns = parent->contained; ns; ns = ns->sibling)
2208 /* Skip namespaces from used modules. */
2209 if (ns->parent != parent)
2212 gfc_generate_function_code (ns);
2217 /* Generate decls for all local variables. We do this to ensure correct
2218 handling of expressions which only appear in the specification of
2222 generate_local_decl (gfc_symbol * sym)
2224 if (sym->attr.flavor == FL_VARIABLE)
2226 if (sym->attr.referenced)
2227 gfc_get_symbol_decl (sym);
2228 else if (sym->attr.dummy && warn_unused_parameter)
2229 warning (0, "unused parameter %qs", sym->name);
2230 /* Warn for unused variables, but not if they're inside a common
2231 block or are use-associated. */
2232 else if (warn_unused_variable
2233 && !(sym->attr.in_common || sym->attr.use_assoc))
2234 warning (0, "unused variable %qs", sym->name);
2239 generate_local_vars (gfc_namespace * ns)
2241 gfc_traverse_ns (ns, generate_local_decl);
2245 /* Generate a switch statement to jump to the correct entry point. Also
2246 creates the label decls for the entry points. */
2249 gfc_trans_entry_master_switch (gfc_entry_list * el)
2256 gfc_init_block (&block);
2257 for (; el; el = el->next)
2259 /* Add the case label. */
2260 label = gfc_build_label_decl (NULL_TREE);
2261 val = build_int_cst (gfc_array_index_type, el->id);
2262 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2263 gfc_add_expr_to_block (&block, tmp);
2265 /* And jump to the actual entry point. */
2266 label = gfc_build_label_decl (NULL_TREE);
2267 tmp = build1_v (GOTO_EXPR, label);
2268 gfc_add_expr_to_block (&block, tmp);
2270 /* Save the label decl. */
2273 tmp = gfc_finish_block (&block);
2274 /* The first argument selects the entry point. */
2275 val = DECL_ARGUMENTS (current_function_decl);
2276 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2281 /* Generate code for a function. */
2284 gfc_generate_function_code (gfc_namespace * ns)
2295 sym = ns->proc_name;
2297 /* Check that the frontend isn't still using this. */
2298 gcc_assert (sym->tlink == NULL);
2301 /* Create the declaration for functions with global scope. */
2302 if (!sym->backend_decl)
2303 gfc_create_function_decl (ns);
2305 fndecl = sym->backend_decl;
2306 old_context = current_function_decl;
2310 push_function_context ();
2311 saved_parent_function_decls = saved_function_decls;
2312 saved_function_decls = NULL_TREE;
2315 trans_function_start (sym);
2317 /* Will be created as needed. */
2318 current_fake_result_decl = NULL_TREE;
2320 gfc_start_block (&block);
2322 gfc_generate_contained_functions (ns);
2324 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2326 /* Copy length backend_decls to all entry point result
2331 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2332 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2333 for (el = ns->entries; el; el = el->next)
2334 el->sym->result->ts.cl->backend_decl = backend_decl;
2337 /* Translate COMMON blocks. */
2338 gfc_trans_common (ns);
2340 generate_local_vars (ns);
2342 current_function_return_label = NULL;
2344 /* Now generate the code for the body of this function. */
2345 gfc_init_block (&body);
2347 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2348 && sym->attr.subroutine)
2350 tree alternate_return;
2351 alternate_return = gfc_get_fake_result_decl (sym);
2352 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2357 /* Jump to the correct entry point. */
2358 tmp = gfc_trans_entry_master_switch (ns->entries);
2359 gfc_add_expr_to_block (&body, tmp);
2362 tmp = gfc_trans_code (ns->code);
2363 gfc_add_expr_to_block (&body, tmp);
2365 /* Add a return label if needed. */
2366 if (current_function_return_label)
2368 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2369 gfc_add_expr_to_block (&body, tmp);
2372 tmp = gfc_finish_block (&body);
2373 /* Add code to create and cleanup arrays. */
2374 tmp = gfc_trans_deferred_vars (sym, tmp);
2375 gfc_add_expr_to_block (&block, tmp);
2377 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2379 if (sym->attr.subroutine || sym == sym->result)
2381 result = current_fake_result_decl;
2382 current_fake_result_decl = NULL_TREE;
2385 result = sym->result->backend_decl;
2387 if (result == NULL_TREE)
2388 warning (0, "Function return value not set");
2391 /* Set the return value to the dummy result variable. */
2392 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2393 DECL_RESULT (fndecl), result);
2394 tmp = build1_v (RETURN_EXPR, tmp);
2395 gfc_add_expr_to_block (&block, tmp);
2399 /* Add all the decls we created during processing. */
2400 decl = saved_function_decls;
2405 next = TREE_CHAIN (decl);
2406 TREE_CHAIN (decl) = NULL_TREE;
2410 saved_function_decls = NULL_TREE;
2412 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2414 /* Finish off this function and send it for code generation. */
2416 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2418 /* Output the GENERIC tree. */
2419 dump_function (TDI_original, fndecl);
2421 /* Store the end of the function, so that we get good line number
2422 info for the epilogue. */
2423 cfun->function_end_locus = input_location;
2425 /* We're leaving the context of this function, so zap cfun.
2426 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2427 tree_rest_of_compilation. */
2432 pop_function_context ();
2433 saved_function_decls = saved_parent_function_decls;
2435 current_function_decl = old_context;
2437 if (decl_function_context (fndecl))
2438 /* Register this function with cgraph just far enough to get it
2439 added to our parent's nested function list. */
2440 (void) cgraph_node (fndecl);
2443 gfc_gimplify_function (fndecl);
2444 cgraph_finalize_function (fndecl, false);
2449 gfc_generate_constructors (void)
2451 gcc_assert (gfc_static_ctors == NULL_TREE);
2459 if (gfc_static_ctors == NULL_TREE)
2462 fnname = get_file_function_name ('I');
2463 type = build_function_type (void_type_node,
2464 gfc_chainon_list (NULL_TREE, void_type_node));
2466 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2467 TREE_PUBLIC (fndecl) = 1;
2469 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2470 DECL_ARTIFICIAL (decl) = 1;
2471 DECL_IGNORED_P (decl) = 1;
2472 DECL_CONTEXT (decl) = fndecl;
2473 DECL_RESULT (fndecl) = decl;
2477 current_function_decl = fndecl;
2479 rest_of_decl_compilation (fndecl, 1, 0);
2481 make_decl_rtl (fndecl);
2483 init_function_start (fndecl);
2487 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2490 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2491 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2496 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2498 free_after_parsing (cfun);
2499 free_after_compilation (cfun);
2501 tree_rest_of_compilation (fndecl);
2503 current_function_decl = NULL_TREE;
2507 /* Translates a BLOCK DATA program unit. This means emitting the
2508 commons contained therein plus their initializations. We also emit
2509 a globally visible symbol to make sure that each BLOCK DATA program
2510 unit remains unique. */
2513 gfc_generate_block_data (gfc_namespace * ns)
2518 /* Tell the backend the source location of the block data. */
2520 gfc_set_backend_locus (&ns->proc_name->declared_at);
2522 gfc_set_backend_locus (&gfc_current_locus);
2524 /* Process the DATA statements. */
2525 gfc_trans_common (ns);
2527 /* Create a global symbol with the mane of the block data. This is to
2528 generate linker errors if the same name is used twice. It is never
2531 id = gfc_sym_mangled_function_id (ns->proc_name);
2533 id = get_identifier ("__BLOCK_DATA__");
2535 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2536 TREE_PUBLIC (decl) = 1;
2537 TREE_STATIC (decl) = 1;
2540 rest_of_decl_compilation (decl, 1, 0);
2543 #include "gt-fortran-trans-decl.h"