1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
40 #include "pointer-set.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
48 #define MAX_LABEL_VALUE 99999
51 /* Holds the result of the function if no result variable specified. */
53 static GTY(()) tree current_fake_result_decl;
54 static GTY(()) tree parent_fake_result_decl;
56 static GTY(()) tree current_function_return_label;
59 /* Holds the variable DECLs for the current function. */
61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls;
64 static struct pointer_set_t *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
67 /* The namespace of the module we're currently generating. Only used while
68 outputting decls for module variables. Do not rely on this being set. */
70 static gfc_namespace *module_namespace;
73 /* List of static constructor functions. */
75 tree gfc_static_ctors;
78 /* Function declarations for builtin library functions. */
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_runtime_error;
85 tree gfor_fndecl_runtime_error_at;
86 tree gfor_fndecl_runtime_warning_at;
87 tree gfor_fndecl_os_error;
88 tree gfor_fndecl_generate_error;
89 tree gfor_fndecl_set_args;
90 tree gfor_fndecl_set_fpe;
91 tree gfor_fndecl_set_options;
92 tree gfor_fndecl_set_convert;
93 tree gfor_fndecl_set_record_marker;
94 tree gfor_fndecl_set_max_subrecord_length;
95 tree gfor_fndecl_ctime;
96 tree gfor_fndecl_fdate;
97 tree gfor_fndecl_ttynam;
98 tree gfor_fndecl_in_pack;
99 tree gfor_fndecl_in_unpack;
100 tree gfor_fndecl_associated;
103 /* Math functions. Many other math functions are handled in
104 trans-intrinsic.c. */
106 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
107 tree gfor_fndecl_math_ishftc4;
108 tree gfor_fndecl_math_ishftc8;
109 tree gfor_fndecl_math_ishftc16;
112 /* String functions. */
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_minmax;
122 tree gfor_fndecl_adjustl;
123 tree gfor_fndecl_adjustr;
124 tree gfor_fndecl_select_string;
125 tree gfor_fndecl_compare_string_char4;
126 tree gfor_fndecl_concat_string_char4;
127 tree gfor_fndecl_string_len_trim_char4;
128 tree gfor_fndecl_string_index_char4;
129 tree gfor_fndecl_string_scan_char4;
130 tree gfor_fndecl_string_verify_char4;
131 tree gfor_fndecl_string_trim_char4;
132 tree gfor_fndecl_string_minmax_char4;
133 tree gfor_fndecl_adjustl_char4;
134 tree gfor_fndecl_adjustr_char4;
135 tree gfor_fndecl_select_string_char4;
138 /* Conversion between character kinds. */
139 tree gfor_fndecl_convert_char1_to_char4;
140 tree gfor_fndecl_convert_char4_to_char1;
143 /* Other misc. runtime library functions. */
145 tree gfor_fndecl_size0;
146 tree gfor_fndecl_size1;
147 tree gfor_fndecl_iargc;
148 tree gfor_fndecl_clz128;
149 tree gfor_fndecl_ctz128;
151 /* Intrinsic functions implemented in Fortran. */
152 tree gfor_fndecl_sc_kind;
153 tree gfor_fndecl_si_kind;
154 tree gfor_fndecl_sr_kind;
156 /* BLAS gemm functions. */
157 tree gfor_fndecl_sgemm;
158 tree gfor_fndecl_dgemm;
159 tree gfor_fndecl_cgemm;
160 tree gfor_fndecl_zgemm;
164 gfc_add_decl_to_parent_function (tree decl)
167 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
168 DECL_NONLOCAL (decl) = 1;
169 TREE_CHAIN (decl) = saved_parent_function_decls;
170 saved_parent_function_decls = decl;
174 gfc_add_decl_to_function (tree decl)
177 TREE_USED (decl) = 1;
178 DECL_CONTEXT (decl) = current_function_decl;
179 TREE_CHAIN (decl) = saved_function_decls;
180 saved_function_decls = decl;
184 /* Build a backend label declaration. Set TREE_USED for named labels.
185 The context of the label is always the current_function_decl. All
186 labels are marked artificial. */
189 gfc_build_label_decl (tree label_id)
191 /* 2^32 temporaries should be enough. */
192 static unsigned int tmp_num = 1;
196 if (label_id == NULL_TREE)
198 /* Build an internal label name. */
199 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
200 label_id = get_identifier (label_name);
205 /* Build the LABEL_DECL node. Labels have no type. */
206 label_decl = build_decl (input_location,
207 LABEL_DECL, label_id, void_type_node);
208 DECL_CONTEXT (label_decl) = current_function_decl;
209 DECL_MODE (label_decl) = VOIDmode;
211 /* We always define the label as used, even if the original source
212 file never references the label. We don't want all kinds of
213 spurious warnings for old-style Fortran code with too many
215 TREE_USED (label_decl) = 1;
217 DECL_ARTIFICIAL (label_decl) = 1;
222 /* Returns the return label for the current function. */
225 gfc_get_return_label (void)
227 char name[GFC_MAX_SYMBOL_LEN + 10];
229 if (current_function_return_label)
230 return current_function_return_label;
232 sprintf (name, "__return_%s",
233 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
235 current_function_return_label =
236 gfc_build_label_decl (get_identifier (name));
238 DECL_ARTIFICIAL (current_function_return_label) = 1;
240 return current_function_return_label;
244 /* Set the backend source location of a decl. */
247 gfc_set_decl_location (tree decl, locus * loc)
249 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
253 /* Return the backend label declaration for a given label structure,
254 or create it if it doesn't exist yet. */
257 gfc_get_label_decl (gfc_st_label * lp)
259 if (lp->backend_decl)
260 return lp->backend_decl;
263 char label_name[GFC_MAX_SYMBOL_LEN + 1];
266 /* Validate the label declaration from the front end. */
267 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
269 /* Build a mangled name for the label. */
270 sprintf (label_name, "__label_%.6d", lp->value);
272 /* Build the LABEL_DECL node. */
273 label_decl = gfc_build_label_decl (get_identifier (label_name));
275 /* Tell the debugger where the label came from. */
276 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
277 gfc_set_decl_location (label_decl, &lp->where);
279 DECL_ARTIFICIAL (label_decl) = 1;
281 /* Store the label in the label list and return the LABEL_DECL. */
282 lp->backend_decl = label_decl;
288 /* Convert a gfc_symbol to an identifier of the same name. */
291 gfc_sym_identifier (gfc_symbol * sym)
293 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
294 return (get_identifier ("MAIN__"));
296 return (get_identifier (sym->name));
300 /* Construct mangled name from symbol name. */
303 gfc_sym_mangled_identifier (gfc_symbol * sym)
305 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
307 /* Prevent the mangling of identifiers that have an assigned
308 binding label (mainly those that are bind(c)). */
309 if (sym->attr.is_bind_c == 1
310 && sym->binding_label[0] != '\0')
311 return get_identifier(sym->binding_label);
313 if (sym->module == NULL)
314 return gfc_sym_identifier (sym);
317 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
318 return get_identifier (name);
323 /* Construct mangled function name from symbol name. */
326 gfc_sym_mangled_function_id (gfc_symbol * sym)
329 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
331 /* It may be possible to simply use the binding label if it's
332 provided, and remove the other checks. Then we could use it
333 for other things if we wished. */
334 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
335 sym->binding_label[0] != '\0')
336 /* use the binding label rather than the mangled name */
337 return get_identifier (sym->binding_label);
339 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
340 || (sym->module != NULL && (sym->attr.external
341 || sym->attr.if_source == IFSRC_IFBODY)))
343 /* Main program is mangled into MAIN__. */
344 if (sym->attr.is_main_program)
345 return get_identifier ("MAIN__");
347 /* Intrinsic procedures are never mangled. */
348 if (sym->attr.proc == PROC_INTRINSIC)
349 return get_identifier (sym->name);
351 if (gfc_option.flag_underscoring)
353 has_underscore = strchr (sym->name, '_') != 0;
354 if (gfc_option.flag_second_underscore && has_underscore)
355 snprintf (name, sizeof name, "%s__", sym->name);
357 snprintf (name, sizeof name, "%s_", sym->name);
358 return get_identifier (name);
361 return get_identifier (sym->name);
365 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
366 return get_identifier (name);
371 /* Returns true if a variable of specified size should go on the stack. */
374 gfc_can_put_var_on_stack (tree size)
376 unsigned HOST_WIDE_INT low;
378 if (!INTEGER_CST_P (size))
381 if (gfc_option.flag_max_stack_var_size < 0)
384 if (TREE_INT_CST_HIGH (size) != 0)
387 low = TREE_INT_CST_LOW (size);
388 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
391 /* TODO: Set a per-function stack size limit. */
397 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
398 an expression involving its corresponding pointer. There are
399 2 cases; one for variable size arrays, and one for everything else,
400 because variable-sized arrays require one fewer level of
404 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
406 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
409 /* Parameters need to be dereferenced. */
410 if (sym->cp_pointer->attr.dummy)
411 ptr_decl = build_fold_indirect_ref_loc (input_location,
414 /* Check to see if we're dealing with a variable-sized array. */
415 if (sym->attr.dimension
416 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
418 /* These decls will be dereferenced later, so we don't dereference
420 value = convert (TREE_TYPE (decl), ptr_decl);
424 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
426 value = build_fold_indirect_ref_loc (input_location,
430 SET_DECL_VALUE_EXPR (decl, value);
431 DECL_HAS_VALUE_EXPR_P (decl) = 1;
432 GFC_DECL_CRAY_POINTEE (decl) = 1;
433 /* This is a fake variable just for debugging purposes. */
434 TREE_ASM_WRITTEN (decl) = 1;
438 /* Finish processing of a declaration without an initial value. */
441 gfc_finish_decl (tree decl)
443 gcc_assert (TREE_CODE (decl) == PARM_DECL
444 || DECL_INITIAL (decl) == NULL_TREE);
446 if (TREE_CODE (decl) != VAR_DECL)
449 if (DECL_SIZE (decl) == NULL_TREE
450 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
451 layout_decl (decl, 0);
453 /* A few consistency checks. */
454 /* A static variable with an incomplete type is an error if it is
455 initialized. Also if it is not file scope. Otherwise, let it
456 through, but if it is not `extern' then it may cause an error
458 /* An automatic variable with an incomplete type is an error. */
460 /* We should know the storage size. */
461 gcc_assert (DECL_SIZE (decl) != NULL_TREE
462 || (TREE_STATIC (decl)
463 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
464 : DECL_EXTERNAL (decl)));
466 /* The storage size should be constant. */
467 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
469 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
473 /* Apply symbol attributes to a variable, and add it to the function scope. */
476 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
479 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
480 This is the equivalent of the TARGET variables.
481 We also need to set this if the variable is passed by reference in a
484 /* Set DECL_VALUE_EXPR for Cray Pointees. */
485 if (sym->attr.cray_pointee)
486 gfc_finish_cray_pointee (decl, sym);
488 if (sym->attr.target)
489 TREE_ADDRESSABLE (decl) = 1;
490 /* If it wasn't used we wouldn't be getting it. */
491 TREE_USED (decl) = 1;
493 /* Chain this decl to the pending declarations. Don't do pushdecl()
494 because this would add them to the current scope rather than the
496 if (current_function_decl != NULL_TREE)
498 if (sym->ns->proc_name->backend_decl == current_function_decl
499 || sym->result == sym)
500 gfc_add_decl_to_function (decl);
502 gfc_add_decl_to_parent_function (decl);
505 if (sym->attr.cray_pointee)
508 if(sym->attr.is_bind_c == 1)
510 /* We need to put variables that are bind(c) into the common
511 segment of the object file, because this is what C would do.
512 gfortran would typically put them in either the BSS or
513 initialized data segments, and only mark them as common if
514 they were part of common blocks. However, if they are not put
515 into common space, then C cannot initialize global fortran
516 variables that it interoperates with and the draft says that
517 either Fortran or C should be able to initialize it (but not
518 both, of course.) (J3/04-007, section 15.3). */
519 TREE_PUBLIC(decl) = 1;
520 DECL_COMMON(decl) = 1;
523 /* If a variable is USE associated, it's always external. */
524 if (sym->attr.use_assoc)
526 DECL_EXTERNAL (decl) = 1;
527 TREE_PUBLIC (decl) = 1;
529 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
531 /* TODO: Don't set sym->module for result or dummy variables. */
532 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
533 /* This is the declaration of a module variable. */
534 TREE_PUBLIC (decl) = 1;
535 TREE_STATIC (decl) = 1;
538 /* Derived types are a bit peculiar because of the possibility of
539 a default initializer; this must be applied each time the variable
540 comes into scope it therefore need not be static. These variables
541 are SAVE_NONE but have an initializer. Otherwise explicitly
542 initialized variables are SAVE_IMPLICIT and explicitly saved are
544 if (!sym->attr.use_assoc
545 && (sym->attr.save != SAVE_NONE || sym->attr.data
546 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
547 TREE_STATIC (decl) = 1;
549 if (sym->attr.volatile_)
551 TREE_THIS_VOLATILE (decl) = 1;
552 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
553 TREE_TYPE (decl) = new_type;
556 /* Keep variables larger than max-stack-var-size off stack. */
557 if (!sym->ns->proc_name->attr.recursive
558 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
559 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
560 /* Put variable length auto array pointers always into stack. */
561 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
562 || sym->attr.dimension == 0
563 || sym->as->type != AS_EXPLICIT
565 || sym->attr.allocatable)
566 && !DECL_ARTIFICIAL (decl))
567 TREE_STATIC (decl) = 1;
569 /* Handle threadprivate variables. */
570 if (sym->attr.threadprivate
571 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
572 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
576 /* Allocate the lang-specific part of a decl. */
579 gfc_allocate_lang_decl (tree decl)
581 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
582 ggc_alloc_cleared (sizeof (struct lang_decl));
585 /* Remember a symbol to generate initialization/cleanup code at function
589 gfc_defer_symbol_init (gfc_symbol * sym)
595 /* Don't add a symbol twice. */
599 last = head = sym->ns->proc_name;
602 /* Make sure that setup code for dummy variables which are used in the
603 setup of other variables is generated first. */
606 /* Find the first dummy arg seen after us, or the first non-dummy arg.
607 This is a circular list, so don't go past the head. */
609 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
615 /* Insert in between last and p. */
621 /* Create an array index type variable with function scope. */
624 create_index_var (const char * pfx, int nest)
628 decl = gfc_create_var_np (gfc_array_index_type, pfx);
630 gfc_add_decl_to_parent_function (decl);
632 gfc_add_decl_to_function (decl);
637 /* Create variables to hold all the non-constant bits of info for a
638 descriptorless array. Remember these in the lang-specific part of the
642 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
648 type = TREE_TYPE (decl);
650 /* We just use the descriptor, if there is one. */
651 if (GFC_DESCRIPTOR_TYPE_P (type))
654 gcc_assert (GFC_ARRAY_TYPE_P (type));
655 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
656 && !sym->attr.contained;
658 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
660 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
662 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
663 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
665 /* Don't try to use the unknown bound for assumed shape arrays. */
666 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
667 && (sym->as->type != AS_ASSUMED_SIZE
668 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
670 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
671 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
674 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
676 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
677 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
680 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
682 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
684 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
687 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
689 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
692 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
693 && sym->as->type != AS_ASSUMED_SIZE)
695 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
696 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
699 if (POINTER_TYPE_P (type))
701 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
702 gcc_assert (TYPE_LANG_SPECIFIC (type)
703 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
704 type = TREE_TYPE (type);
707 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
711 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
712 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
713 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
715 TYPE_DOMAIN (type) = range;
719 if (TYPE_NAME (type) != NULL_TREE
720 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
721 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
723 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
725 for (dim = 0; dim < sym->as->rank - 1; dim++)
727 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
728 gtype = TREE_TYPE (gtype);
730 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
731 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
732 TYPE_NAME (type) = NULL_TREE;
735 if (TYPE_NAME (type) == NULL_TREE)
737 tree gtype = TREE_TYPE (type), rtype, type_decl;
739 for (dim = sym->as->rank - 1; dim >= 0; dim--)
741 rtype = build_range_type (gfc_array_index_type,
742 GFC_TYPE_ARRAY_LBOUND (type, dim),
743 GFC_TYPE_ARRAY_UBOUND (type, dim));
744 gtype = build_array_type (gtype, rtype);
745 /* Ensure the bound variables aren't optimized out at -O0. */
748 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
749 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
750 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
751 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
752 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
753 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
756 TYPE_NAME (type) = type_decl = build_decl (input_location,
757 TYPE_DECL, NULL, gtype);
758 DECL_ORIGINAL_TYPE (type_decl) = gtype;
763 /* For some dummy arguments we don't use the actual argument directly.
764 Instead we create a local decl and use that. This allows us to perform
765 initialization, and construct full type information. */
768 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
778 if (sym->attr.pointer || sym->attr.allocatable)
781 /* Add to list of variables if not a fake result variable. */
782 if (sym->attr.result || sym->attr.dummy)
783 gfc_defer_symbol_init (sym);
785 type = TREE_TYPE (dummy);
786 gcc_assert (TREE_CODE (dummy) == PARM_DECL
787 && POINTER_TYPE_P (type));
789 /* Do we know the element size? */
790 known_size = sym->ts.type != BT_CHARACTER
791 || INTEGER_CST_P (sym->ts.cl->backend_decl);
793 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
795 /* For descriptorless arrays with known element size the actual
796 argument is sufficient. */
797 gcc_assert (GFC_ARRAY_TYPE_P (type));
798 gfc_build_qualified_array (dummy, sym);
802 type = TREE_TYPE (type);
803 if (GFC_DESCRIPTOR_TYPE_P (type))
805 /* Create a descriptorless array pointer. */
809 /* Even when -frepack-arrays is used, symbols with TARGET attribute
811 if (!gfc_option.flag_repack_arrays || sym->attr.target)
813 if (as->type == AS_ASSUMED_SIZE)
814 packed = PACKED_FULL;
818 if (as->type == AS_EXPLICIT)
820 packed = PACKED_FULL;
821 for (n = 0; n < as->rank; n++)
825 && as->upper[n]->expr_type == EXPR_CONSTANT
826 && as->lower[n]->expr_type == EXPR_CONSTANT))
827 packed = PACKED_PARTIAL;
831 packed = PACKED_PARTIAL;
834 type = gfc_typenode_for_spec (&sym->ts);
835 type = gfc_get_nodesc_array_type (type, sym->as, packed);
839 /* We now have an expression for the element size, so create a fully
840 qualified type. Reset sym->backend decl or this will just return the
842 DECL_ARTIFICIAL (sym->backend_decl) = 1;
843 sym->backend_decl = NULL_TREE;
844 type = gfc_sym_type (sym);
845 packed = PACKED_FULL;
848 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
849 decl = build_decl (input_location,
850 VAR_DECL, get_identifier (name), type);
852 DECL_ARTIFICIAL (decl) = 1;
853 TREE_PUBLIC (decl) = 0;
854 TREE_STATIC (decl) = 0;
855 DECL_EXTERNAL (decl) = 0;
857 /* We should never get deferred shape arrays here. We used to because of
859 gcc_assert (sym->as->type != AS_DEFERRED);
861 if (packed == PACKED_PARTIAL)
862 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
863 else if (packed == PACKED_FULL)
864 GFC_DECL_PACKED_ARRAY (decl) = 1;
866 gfc_build_qualified_array (decl, sym);
868 if (DECL_LANG_SPECIFIC (dummy))
869 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
871 gfc_allocate_lang_decl (decl);
873 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
875 if (sym->ns->proc_name->backend_decl == current_function_decl
876 || sym->attr.contained)
877 gfc_add_decl_to_function (decl);
879 gfc_add_decl_to_parent_function (decl);
884 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
885 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
886 pointing to the artificial variable for debug info purposes. */
889 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
893 if (! nonlocal_dummy_decl_pset)
894 nonlocal_dummy_decl_pset = pointer_set_create ();
896 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
899 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
900 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
901 TREE_TYPE (sym->backend_decl));
902 DECL_ARTIFICIAL (decl) = 0;
903 TREE_USED (decl) = 1;
904 TREE_PUBLIC (decl) = 0;
905 TREE_STATIC (decl) = 0;
906 DECL_EXTERNAL (decl) = 0;
907 if (DECL_BY_REFERENCE (dummy))
908 DECL_BY_REFERENCE (decl) = 1;
909 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
910 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
911 DECL_HAS_VALUE_EXPR_P (decl) = 1;
912 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
913 TREE_CHAIN (decl) = nonlocal_dummy_decls;
914 nonlocal_dummy_decls = decl;
917 /* Return a constant or a variable to use as a string length. Does not
918 add the decl to the current scope. */
921 gfc_create_string_length (gfc_symbol * sym)
923 gcc_assert (sym->ts.cl);
924 gfc_conv_const_charlen (sym->ts.cl);
926 if (sym->ts.cl->backend_decl == NULL_TREE)
929 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
931 /* Also prefix the mangled name. */
932 strcpy (&name[1], sym->name);
934 length = build_decl (input_location,
935 VAR_DECL, get_identifier (name),
936 gfc_charlen_type_node);
937 DECL_ARTIFICIAL (length) = 1;
938 TREE_USED (length) = 1;
939 if (sym->ns->proc_name->tlink != NULL)
940 gfc_defer_symbol_init (sym);
942 sym->ts.cl->backend_decl = length;
945 gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
946 return sym->ts.cl->backend_decl;
949 /* If a variable is assigned a label, we add another two auxiliary
953 gfc_add_assign_aux_vars (gfc_symbol * sym)
959 gcc_assert (sym->backend_decl);
961 decl = sym->backend_decl;
962 gfc_allocate_lang_decl (decl);
963 GFC_DECL_ASSIGN (decl) = 1;
964 length = build_decl (input_location,
965 VAR_DECL, create_tmp_var_name (sym->name),
966 gfc_charlen_type_node);
967 addr = build_decl (input_location,
968 VAR_DECL, create_tmp_var_name (sym->name),
970 gfc_finish_var_decl (length, sym);
971 gfc_finish_var_decl (addr, sym);
972 /* STRING_LENGTH is also used as flag. Less than -1 means that
973 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
974 target label's address. Otherwise, value is the length of a format string
975 and ASSIGN_ADDR is its address. */
976 if (TREE_STATIC (length))
977 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
979 gfc_defer_symbol_init (sym);
981 GFC_DECL_STRING_LEN (decl) = length;
982 GFC_DECL_ASSIGN_ADDR (decl) = addr;
987 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
992 for (id = 0; id < EXT_ATTR_NUM; id++)
993 if (sym_attr.ext_attr & (1 << id))
995 attr = build_tree_list (
996 get_identifier (ext_attr_list[id].middle_end_name),
998 list = chainon (list, attr);
1005 /* Return the decl for a gfc_symbol, create it if it doesn't already
1009 gfc_get_symbol_decl (gfc_symbol * sym)
1012 tree length = NULL_TREE;
1016 gcc_assert (sym->attr.referenced
1017 || sym->attr.use_assoc
1018 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
1020 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1021 byref = gfc_return_by_reference (sym->ns->proc_name);
1025 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1027 /* Return via extra parameter. */
1028 if (sym->attr.result && byref
1029 && !sym->backend_decl)
1032 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1033 /* For entry master function skip over the __entry
1035 if (sym->ns->proc_name->attr.entry_master)
1036 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1039 /* Dummy variables should already have been created. */
1040 gcc_assert (sym->backend_decl);
1042 /* Create a character length variable. */
1043 if (sym->ts.type == BT_CHARACTER)
1045 if (sym->ts.cl->backend_decl == NULL_TREE)
1046 length = gfc_create_string_length (sym);
1048 length = sym->ts.cl->backend_decl;
1049 if (TREE_CODE (length) == VAR_DECL
1050 && DECL_CONTEXT (length) == NULL_TREE)
1052 /* Add the string length to the same context as the symbol. */
1053 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1054 gfc_add_decl_to_function (length);
1056 gfc_add_decl_to_parent_function (length);
1058 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1059 DECL_CONTEXT (length));
1061 gfc_defer_symbol_init (sym);
1065 /* Use a copy of the descriptor for dummy arrays. */
1066 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1068 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1069 /* Prevent the dummy from being detected as unused if it is copied. */
1070 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1071 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1072 sym->backend_decl = decl;
1075 TREE_USED (sym->backend_decl) = 1;
1076 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1078 gfc_add_assign_aux_vars (sym);
1081 if (sym->attr.dimension
1082 && DECL_LANG_SPECIFIC (sym->backend_decl)
1083 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1084 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1085 gfc_nonlocal_dummy_array_decl (sym);
1087 return sym->backend_decl;
1090 if (sym->backend_decl)
1091 return sym->backend_decl;
1093 /* Catch function declarations. Only used for actual parameters and
1094 procedure pointers. */
1095 if (sym->attr.flavor == FL_PROCEDURE)
1097 decl = gfc_get_extern_function_decl (sym);
1098 gfc_set_decl_location (decl, &sym->declared_at);
1102 if (sym->attr.intrinsic)
1103 internal_error ("intrinsic variable which isn't a procedure");
1105 /* Create string length decl first so that they can be used in the
1106 type declaration. */
1107 if (sym->ts.type == BT_CHARACTER)
1108 length = gfc_create_string_length (sym);
1110 /* Create the decl for the variable. */
1111 decl = build_decl (sym->declared_at.lb->location,
1112 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1114 /* Symbols from modules should have their assembler names mangled.
1115 This is done here rather than in gfc_finish_var_decl because it
1116 is different for string length variables. */
1119 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1120 if (sym->attr.use_assoc)
1121 DECL_IGNORED_P (decl) = 1;
1124 if (sym->attr.dimension)
1126 /* Create variables to hold the non-constant bits of array info. */
1127 gfc_build_qualified_array (decl, sym);
1129 /* Remember this variable for allocation/cleanup. */
1130 gfc_defer_symbol_init (sym);
1132 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1133 GFC_DECL_PACKED_ARRAY (decl) = 1;
1136 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1137 gfc_defer_symbol_init (sym);
1138 /* This applies a derived type default initializer. */
1139 else if (sym->ts.type == BT_DERIVED
1140 && sym->attr.save == SAVE_NONE
1142 && !sym->attr.allocatable
1143 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1144 && !sym->attr.use_assoc)
1145 gfc_defer_symbol_init (sym);
1147 gfc_finish_var_decl (decl, sym);
1149 if (sym->ts.type == BT_CHARACTER)
1151 /* Character variables need special handling. */
1152 gfc_allocate_lang_decl (decl);
1154 if (TREE_CODE (length) != INTEGER_CST)
1156 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1160 /* Also prefix the mangled name for symbols from modules. */
1161 strcpy (&name[1], sym->name);
1164 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1165 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1167 gfc_finish_var_decl (length, sym);
1168 gcc_assert (!sym->value);
1171 else if (sym->attr.subref_array_pointer)
1173 /* We need the span for these beasts. */
1174 gfc_allocate_lang_decl (decl);
1177 if (sym->attr.subref_array_pointer)
1180 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1181 span = build_decl (input_location,
1182 VAR_DECL, create_tmp_var_name ("span"),
1183 gfc_array_index_type);
1184 gfc_finish_var_decl (span, sym);
1185 TREE_STATIC (span) = TREE_STATIC (decl);
1186 DECL_ARTIFICIAL (span) = 1;
1187 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1189 GFC_DECL_SPAN (decl) = span;
1190 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1193 sym->backend_decl = decl;
1195 if (sym->attr.assign)
1196 gfc_add_assign_aux_vars (sym);
1198 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1200 /* Add static initializer. */
1201 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1202 TREE_TYPE (decl), sym->attr.dimension,
1203 sym->attr.pointer || sym->attr.allocatable);
1206 if (!TREE_STATIC (decl)
1207 && POINTER_TYPE_P (TREE_TYPE (decl))
1208 && !sym->attr.pointer
1209 && !sym->attr.allocatable
1210 && !sym->attr.proc_pointer)
1211 DECL_BY_REFERENCE (decl) = 1;
1213 /* Add attributes to variables. Functions are handled elsewhere. */
1214 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1215 decl_attributes (&decl, attributes, 0);
1221 /* Substitute a temporary variable in place of the real one. */
1224 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1226 save->attr = sym->attr;
1227 save->decl = sym->backend_decl;
1229 gfc_clear_attr (&sym->attr);
1230 sym->attr.referenced = 1;
1231 sym->attr.flavor = FL_VARIABLE;
1233 sym->backend_decl = decl;
1237 /* Restore the original variable. */
1240 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1242 sym->attr = save->attr;
1243 sym->backend_decl = save->decl;
1247 /* Declare a procedure pointer. */
1250 get_proc_pointer_decl (gfc_symbol *sym)
1255 decl = sym->backend_decl;
1259 decl = build_decl (input_location,
1260 VAR_DECL, get_identifier (sym->name),
1261 build_pointer_type (gfc_get_function_type (sym)));
1263 if ((sym->ns->proc_name
1264 && sym->ns->proc_name->backend_decl == current_function_decl)
1265 || sym->attr.contained)
1266 gfc_add_decl_to_function (decl);
1267 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1268 gfc_add_decl_to_parent_function (decl);
1270 sym->backend_decl = decl;
1272 /* If a variable is USE associated, it's always external. */
1273 if (sym->attr.use_assoc)
1275 DECL_EXTERNAL (decl) = 1;
1276 TREE_PUBLIC (decl) = 1;
1278 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1280 /* This is the declaration of a module variable. */
1281 TREE_PUBLIC (decl) = 1;
1282 TREE_STATIC (decl) = 1;
1285 if (!sym->attr.use_assoc
1286 && (sym->attr.save != SAVE_NONE || sym->attr.data
1287 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1288 TREE_STATIC (decl) = 1;
1290 if (TREE_STATIC (decl) && sym->value)
1292 /* Add static initializer. */
1293 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1294 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1297 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1298 decl_attributes (&decl, attributes, 0);
1304 /* Get a basic decl for an external function. */
1307 gfc_get_extern_function_decl (gfc_symbol * sym)
1313 gfc_intrinsic_sym *isym;
1315 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1320 if (sym->backend_decl)
1321 return sym->backend_decl;
1323 /* We should never be creating external decls for alternate entry points.
1324 The procedure may be an alternate entry point, but we don't want/need
1326 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1328 if (sym->attr.proc_pointer)
1329 return get_proc_pointer_decl (sym);
1331 /* See if this is an external procedure from the same file. If so,
1332 return the backend_decl. */
1333 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1335 if (gfc_option.flag_whole_file
1336 && !sym->backend_decl
1338 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1339 && gsym->ns->proc_name->backend_decl)
1341 /* If the namespace has entries, the proc_name is the
1342 entry master. Find the entry and use its backend_decl.
1343 otherwise, use the proc_name backend_decl. */
1344 if (gsym->ns->entries)
1346 gfc_entry_list *entry = gsym->ns->entries;
1348 for (; entry; entry = entry->next)
1350 if (strcmp (gsym->name, entry->sym->name) == 0)
1352 sym->backend_decl = entry->sym->backend_decl;
1359 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1362 if (sym->backend_decl)
1363 return sym->backend_decl;
1366 if (sym->attr.intrinsic)
1368 /* Call the resolution function to get the actual name. This is
1369 a nasty hack which relies on the resolution functions only looking
1370 at the first argument. We pass NULL for the second argument
1371 otherwise things like AINT get confused. */
1372 isym = gfc_find_function (sym->name);
1373 gcc_assert (isym->resolve.f0 != NULL);
1375 memset (&e, 0, sizeof (e));
1376 e.expr_type = EXPR_FUNCTION;
1378 memset (&argexpr, 0, sizeof (argexpr));
1379 gcc_assert (isym->formal);
1380 argexpr.ts = isym->formal->ts;
1382 if (isym->formal->next == NULL)
1383 isym->resolve.f1 (&e, &argexpr);
1386 if (isym->formal->next->next == NULL)
1387 isym->resolve.f2 (&e, &argexpr, NULL);
1390 if (isym->formal->next->next->next == NULL)
1391 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1394 /* All specific intrinsics take less than 5 arguments. */
1395 gcc_assert (isym->formal->next->next->next->next == NULL);
1396 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1401 if (gfc_option.flag_f2c
1402 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1403 || e.ts.type == BT_COMPLEX))
1405 /* Specific which needs a different implementation if f2c
1406 calling conventions are used. */
1407 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1410 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1412 name = get_identifier (s);
1413 mangled_name = name;
1417 name = gfc_sym_identifier (sym);
1418 mangled_name = gfc_sym_mangled_function_id (sym);
1421 type = gfc_get_function_type (sym);
1422 fndecl = build_decl (input_location,
1423 FUNCTION_DECL, name, type);
1425 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1427 /* Set the context of this decl. */
1428 if (0 && sym->ns && sym->ns->proc_name)
1430 /* TODO: Add external decls to the appropriate scope. */
1431 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1435 /* Global declaration, e.g. intrinsic subroutine. */
1436 DECL_CONTEXT (fndecl) = NULL_TREE;
1439 DECL_EXTERNAL (fndecl) = 1;
1441 /* This specifies if a function is globally addressable, i.e. it is
1442 the opposite of declaring static in C. */
1443 TREE_PUBLIC (fndecl) = 1;
1445 /* Set attributes for PURE functions. A call to PURE function in the
1446 Fortran 95 sense is both pure and without side effects in the C
1448 if (sym->attr.pure || sym->attr.elemental)
1450 if (sym->attr.function && !gfc_return_by_reference (sym))
1451 DECL_PURE_P (fndecl) = 1;
1452 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1453 parameters and don't use alternate returns (is this
1454 allowed?). In that case, calls to them are meaningless, and
1455 can be optimized away. See also in build_function_decl(). */
1456 TREE_SIDE_EFFECTS (fndecl) = 0;
1459 /* Mark non-returning functions. */
1460 if (sym->attr.noreturn)
1461 TREE_THIS_VOLATILE(fndecl) = 1;
1463 sym->backend_decl = fndecl;
1465 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1466 pushdecl_top_level (fndecl);
1468 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1469 decl_attributes (&fndecl, attributes, 0);
1475 /* Create a declaration for a procedure. For external functions (in the C
1476 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1477 a master function with alternate entry points. */
1480 build_function_decl (gfc_symbol * sym)
1482 tree fndecl, type, attributes;
1483 symbol_attribute attr;
1485 gfc_formal_arglist *f;
1487 gcc_assert (!sym->backend_decl);
1488 gcc_assert (!sym->attr.external);
1490 /* Set the line and filename. sym->declared_at seems to point to the
1491 last statement for subroutines, but it'll do for now. */
1492 gfc_set_backend_locus (&sym->declared_at);
1494 /* Allow only one nesting level. Allow public declarations. */
1495 gcc_assert (current_function_decl == NULL_TREE
1496 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1497 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1500 type = gfc_get_function_type (sym);
1501 fndecl = build_decl (input_location,
1502 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1504 /* Perform name mangling if this is a top level or module procedure. */
1505 if (current_function_decl == NULL_TREE)
1506 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1508 /* Figure out the return type of the declared function, and build a
1509 RESULT_DECL for it. If this is a subroutine with alternate
1510 returns, build a RESULT_DECL for it. */
1513 result_decl = NULL_TREE;
1514 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1517 if (gfc_return_by_reference (sym))
1518 type = void_type_node;
1521 if (sym->result != sym)
1522 result_decl = gfc_sym_identifier (sym->result);
1524 type = TREE_TYPE (TREE_TYPE (fndecl));
1529 /* Look for alternate return placeholders. */
1530 int has_alternate_returns = 0;
1531 for (f = sym->formal; f; f = f->next)
1535 has_alternate_returns = 1;
1540 if (has_alternate_returns)
1541 type = integer_type_node;
1543 type = void_type_node;
1546 result_decl = build_decl (input_location,
1547 RESULT_DECL, result_decl, type);
1548 DECL_ARTIFICIAL (result_decl) = 1;
1549 DECL_IGNORED_P (result_decl) = 1;
1550 DECL_CONTEXT (result_decl) = fndecl;
1551 DECL_RESULT (fndecl) = result_decl;
1553 /* Don't call layout_decl for a RESULT_DECL.
1554 layout_decl (result_decl, 0); */
1556 /* Set up all attributes for the function. */
1557 DECL_CONTEXT (fndecl) = current_function_decl;
1558 DECL_EXTERNAL (fndecl) = 0;
1560 /* This specifies if a function is globally visible, i.e. it is
1561 the opposite of declaring static in C. */
1562 if (DECL_CONTEXT (fndecl) == NULL_TREE
1563 && !sym->attr.entry_master && !sym->attr.is_main_program)
1564 TREE_PUBLIC (fndecl) = 1;
1566 /* TREE_STATIC means the function body is defined here. */
1567 TREE_STATIC (fndecl) = 1;
1569 /* Set attributes for PURE functions. A call to a PURE function in the
1570 Fortran 95 sense is both pure and without side effects in the C
1572 if (attr.pure || attr.elemental)
1574 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1575 including an alternate return. In that case it can also be
1576 marked as PURE. See also in gfc_get_extern_function_decl(). */
1577 if (attr.function && !gfc_return_by_reference (sym))
1578 DECL_PURE_P (fndecl) = 1;
1579 TREE_SIDE_EFFECTS (fndecl) = 0;
1582 attributes = add_attributes_to_decl (attr, NULL_TREE);
1583 decl_attributes (&fndecl, attributes, 0);
1585 /* Layout the function declaration and put it in the binding level
1586 of the current function. */
1589 sym->backend_decl = fndecl;
1593 /* Create the DECL_ARGUMENTS for a procedure. */
1596 create_function_arglist (gfc_symbol * sym)
1599 gfc_formal_arglist *f;
1600 tree typelist, hidden_typelist;
1601 tree arglist, hidden_arglist;
1605 fndecl = sym->backend_decl;
1607 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1608 the new FUNCTION_DECL node. */
1609 arglist = NULL_TREE;
1610 hidden_arglist = NULL_TREE;
1611 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1613 if (sym->attr.entry_master)
1615 type = TREE_VALUE (typelist);
1616 parm = build_decl (input_location,
1617 PARM_DECL, get_identifier ("__entry"), type);
1619 DECL_CONTEXT (parm) = fndecl;
1620 DECL_ARG_TYPE (parm) = type;
1621 TREE_READONLY (parm) = 1;
1622 gfc_finish_decl (parm);
1623 DECL_ARTIFICIAL (parm) = 1;
1625 arglist = chainon (arglist, parm);
1626 typelist = TREE_CHAIN (typelist);
1629 if (gfc_return_by_reference (sym))
1631 tree type = TREE_VALUE (typelist), length = NULL;
1633 if (sym->ts.type == BT_CHARACTER)
1635 /* Length of character result. */
1636 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1637 gcc_assert (len_type == gfc_charlen_type_node);
1639 length = build_decl (input_location,
1641 get_identifier (".__result"),
1643 if (!sym->ts.cl->length)
1645 sym->ts.cl->backend_decl = length;
1646 TREE_USED (length) = 1;
1648 gcc_assert (TREE_CODE (length) == PARM_DECL);
1649 DECL_CONTEXT (length) = fndecl;
1650 DECL_ARG_TYPE (length) = len_type;
1651 TREE_READONLY (length) = 1;
1652 DECL_ARTIFICIAL (length) = 1;
1653 gfc_finish_decl (length);
1654 if (sym->ts.cl->backend_decl == NULL
1655 || sym->ts.cl->backend_decl == length)
1660 if (sym->ts.cl->backend_decl == NULL)
1662 tree len = build_decl (input_location,
1664 get_identifier ("..__result"),
1665 gfc_charlen_type_node);
1666 DECL_ARTIFICIAL (len) = 1;
1667 TREE_USED (len) = 1;
1668 sym->ts.cl->backend_decl = len;
1671 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1672 arg = sym->result ? sym->result : sym;
1673 backend_decl = arg->backend_decl;
1674 /* Temporary clear it, so that gfc_sym_type creates complete
1676 arg->backend_decl = NULL;
1677 type = gfc_sym_type (arg);
1678 arg->backend_decl = backend_decl;
1679 type = build_reference_type (type);
1683 parm = build_decl (input_location,
1684 PARM_DECL, get_identifier ("__result"), type);
1686 DECL_CONTEXT (parm) = fndecl;
1687 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1688 TREE_READONLY (parm) = 1;
1689 DECL_ARTIFICIAL (parm) = 1;
1690 gfc_finish_decl (parm);
1692 arglist = chainon (arglist, parm);
1693 typelist = TREE_CHAIN (typelist);
1695 if (sym->ts.type == BT_CHARACTER)
1697 gfc_allocate_lang_decl (parm);
1698 arglist = chainon (arglist, length);
1699 typelist = TREE_CHAIN (typelist);
1703 hidden_typelist = typelist;
1704 for (f = sym->formal; f; f = f->next)
1705 if (f->sym != NULL) /* Ignore alternate returns. */
1706 hidden_typelist = TREE_CHAIN (hidden_typelist);
1708 for (f = sym->formal; f; f = f->next)
1710 char name[GFC_MAX_SYMBOL_LEN + 2];
1712 /* Ignore alternate returns. */
1716 type = TREE_VALUE (typelist);
1718 if (f->sym->ts.type == BT_CHARACTER)
1720 tree len_type = TREE_VALUE (hidden_typelist);
1721 tree length = NULL_TREE;
1722 gcc_assert (len_type == gfc_charlen_type_node);
1724 strcpy (&name[1], f->sym->name);
1726 length = build_decl (input_location,
1727 PARM_DECL, get_identifier (name), len_type);
1729 hidden_arglist = chainon (hidden_arglist, length);
1730 DECL_CONTEXT (length) = fndecl;
1731 DECL_ARTIFICIAL (length) = 1;
1732 DECL_ARG_TYPE (length) = len_type;
1733 TREE_READONLY (length) = 1;
1734 gfc_finish_decl (length);
1736 /* Remember the passed value. */
1737 if (f->sym->ts.cl->passed_length != NULL)
1739 /* This can happen if the same type is used for multiple
1740 arguments. We need to copy cl as otherwise
1741 cl->passed_length gets overwritten. */
1742 gfc_charlen *cl, *cl2;
1744 f->sym->ts.cl = gfc_get_charlen();
1745 f->sym->ts.cl->length = cl->length;
1746 f->sym->ts.cl->backend_decl = cl->backend_decl;
1747 f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
1748 f->sym->ts.cl->resolved = cl->resolved;
1749 cl2 = f->sym->ts.cl->next;
1750 f->sym->ts.cl->next = cl;
1753 f->sym->ts.cl->passed_length = length;
1755 /* Use the passed value for assumed length variables. */
1756 if (!f->sym->ts.cl->length)
1758 TREE_USED (length) = 1;
1759 gcc_assert (!f->sym->ts.cl->backend_decl);
1760 f->sym->ts.cl->backend_decl = length;
1763 hidden_typelist = TREE_CHAIN (hidden_typelist);
1765 if (f->sym->ts.cl->backend_decl == NULL
1766 || f->sym->ts.cl->backend_decl == length)
1768 if (f->sym->ts.cl->backend_decl == NULL)
1769 gfc_create_string_length (f->sym);
1771 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1772 if (f->sym->attr.flavor == FL_PROCEDURE)
1773 type = build_pointer_type (gfc_get_function_type (f->sym));
1775 type = gfc_sym_type (f->sym);
1779 /* For non-constant length array arguments, make sure they use
1780 a different type node from TYPE_ARG_TYPES type. */
1781 if (f->sym->attr.dimension
1782 && type == TREE_VALUE (typelist)
1783 && TREE_CODE (type) == POINTER_TYPE
1784 && GFC_ARRAY_TYPE_P (type)
1785 && f->sym->as->type != AS_ASSUMED_SIZE
1786 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1788 if (f->sym->attr.flavor == FL_PROCEDURE)
1789 type = build_pointer_type (gfc_get_function_type (f->sym));
1791 type = gfc_sym_type (f->sym);
1794 if (f->sym->attr.proc_pointer)
1795 type = build_pointer_type (type);
1797 /* Build the argument declaration. */
1798 parm = build_decl (input_location,
1799 PARM_DECL, gfc_sym_identifier (f->sym), type);
1801 /* Fill in arg stuff. */
1802 DECL_CONTEXT (parm) = fndecl;
1803 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1804 /* All implementation args are read-only. */
1805 TREE_READONLY (parm) = 1;
1806 if (POINTER_TYPE_P (type)
1807 && (!f->sym->attr.proc_pointer
1808 && f->sym->attr.flavor != FL_PROCEDURE))
1809 DECL_BY_REFERENCE (parm) = 1;
1811 gfc_finish_decl (parm);
1813 f->sym->backend_decl = parm;
1815 arglist = chainon (arglist, parm);
1816 typelist = TREE_CHAIN (typelist);
1819 /* Add the hidden string length parameters, unless the procedure
1821 if (!sym->attr.is_bind_c)
1822 arglist = chainon (arglist, hidden_arglist);
1824 gcc_assert (hidden_typelist == NULL_TREE
1825 || TREE_VALUE (hidden_typelist) == void_type_node);
1826 DECL_ARGUMENTS (fndecl) = arglist;
1829 /* Do the setup necessary before generating the body of a function. */
1832 trans_function_start (gfc_symbol * sym)
1836 fndecl = sym->backend_decl;
1838 /* Let GCC know the current scope is this function. */
1839 current_function_decl = fndecl;
1841 /* Let the world know what we're about to do. */
1842 announce_function (fndecl);
1844 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1846 /* Create RTL for function declaration. */
1847 rest_of_decl_compilation (fndecl, 1, 0);
1850 /* Create RTL for function definition. */
1851 make_decl_rtl (fndecl);
1853 init_function_start (fndecl);
1855 /* Even though we're inside a function body, we still don't want to
1856 call expand_expr to calculate the size of a variable-sized array.
1857 We haven't necessarily assigned RTL to all variables yet, so it's
1858 not safe to try to expand expressions involving them. */
1859 cfun->dont_save_pending_sizes_p = 1;
1861 /* function.c requires a push at the start of the function. */
1865 /* Create thunks for alternate entry points. */
1868 build_entry_thunks (gfc_namespace * ns)
1870 gfc_formal_arglist *formal;
1871 gfc_formal_arglist *thunk_formal;
1873 gfc_symbol *thunk_sym;
1881 /* This should always be a toplevel function. */
1882 gcc_assert (current_function_decl == NULL_TREE);
1884 gfc_get_backend_locus (&old_loc);
1885 for (el = ns->entries; el; el = el->next)
1887 thunk_sym = el->sym;
1889 build_function_decl (thunk_sym);
1890 create_function_arglist (thunk_sym);
1892 trans_function_start (thunk_sym);
1894 thunk_fndecl = thunk_sym->backend_decl;
1896 gfc_init_block (&body);
1898 /* Pass extra parameter identifying this entry point. */
1899 tmp = build_int_cst (gfc_array_index_type, el->id);
1900 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1901 string_args = NULL_TREE;
1903 if (thunk_sym->attr.function)
1905 if (gfc_return_by_reference (ns->proc_name))
1907 tree ref = DECL_ARGUMENTS (current_function_decl);
1908 args = tree_cons (NULL_TREE, ref, args);
1909 if (ns->proc_name->ts.type == BT_CHARACTER)
1910 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1915 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1917 /* Ignore alternate returns. */
1918 if (formal->sym == NULL)
1921 /* We don't have a clever way of identifying arguments, so resort to
1922 a brute-force search. */
1923 for (thunk_formal = thunk_sym->formal;
1925 thunk_formal = thunk_formal->next)
1927 if (thunk_formal->sym == formal->sym)
1933 /* Pass the argument. */
1934 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1935 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1937 if (formal->sym->ts.type == BT_CHARACTER)
1939 tmp = thunk_formal->sym->ts.cl->backend_decl;
1940 string_args = tree_cons (NULL_TREE, tmp, string_args);
1945 /* Pass NULL for a missing argument. */
1946 args = tree_cons (NULL_TREE, null_pointer_node, args);
1947 if (formal->sym->ts.type == BT_CHARACTER)
1949 tmp = build_int_cst (gfc_charlen_type_node, 0);
1950 string_args = tree_cons (NULL_TREE, tmp, string_args);
1955 /* Call the master function. */
1956 args = nreverse (args);
1957 args = chainon (args, nreverse (string_args));
1958 tmp = ns->proc_name->backend_decl;
1959 tmp = build_function_call_expr (input_location, tmp, args);
1960 if (ns->proc_name->attr.mixed_entry_master)
1962 tree union_decl, field;
1963 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1965 union_decl = build_decl (input_location,
1966 VAR_DECL, get_identifier ("__result"),
1967 TREE_TYPE (master_type));
1968 DECL_ARTIFICIAL (union_decl) = 1;
1969 DECL_EXTERNAL (union_decl) = 0;
1970 TREE_PUBLIC (union_decl) = 0;
1971 TREE_USED (union_decl) = 1;
1972 layout_decl (union_decl, 0);
1973 pushdecl (union_decl);
1975 DECL_CONTEXT (union_decl) = current_function_decl;
1976 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1978 gfc_add_expr_to_block (&body, tmp);
1980 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1981 field; field = TREE_CHAIN (field))
1982 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1983 thunk_sym->result->name) == 0)
1985 gcc_assert (field != NULL_TREE);
1986 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1987 union_decl, field, NULL_TREE);
1988 tmp = fold_build2 (MODIFY_EXPR,
1989 TREE_TYPE (DECL_RESULT (current_function_decl)),
1990 DECL_RESULT (current_function_decl), tmp);
1991 tmp = build1_v (RETURN_EXPR, tmp);
1993 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1996 tmp = fold_build2 (MODIFY_EXPR,
1997 TREE_TYPE (DECL_RESULT (current_function_decl)),
1998 DECL_RESULT (current_function_decl), tmp);
1999 tmp = build1_v (RETURN_EXPR, tmp);
2001 gfc_add_expr_to_block (&body, tmp);
2003 /* Finish off this function and send it for code generation. */
2004 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2007 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2008 DECL_SAVED_TREE (thunk_fndecl)
2009 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2010 DECL_INITIAL (thunk_fndecl));
2012 /* Output the GENERIC tree. */
2013 dump_function (TDI_original, thunk_fndecl);
2015 /* Store the end of the function, so that we get good line number
2016 info for the epilogue. */
2017 cfun->function_end_locus = input_location;
2019 /* We're leaving the context of this function, so zap cfun.
2020 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2021 tree_rest_of_compilation. */
2024 current_function_decl = NULL_TREE;
2026 cgraph_finalize_function (thunk_fndecl, false);
2028 /* We share the symbols in the formal argument list with other entry
2029 points and the master function. Clear them so that they are
2030 recreated for each function. */
2031 for (formal = thunk_sym->formal; formal; formal = formal->next)
2032 if (formal->sym != NULL) /* Ignore alternate returns. */
2034 formal->sym->backend_decl = NULL_TREE;
2035 if (formal->sym->ts.type == BT_CHARACTER)
2036 formal->sym->ts.cl->backend_decl = NULL_TREE;
2039 if (thunk_sym->attr.function)
2041 if (thunk_sym->ts.type == BT_CHARACTER)
2042 thunk_sym->ts.cl->backend_decl = NULL_TREE;
2043 if (thunk_sym->result->ts.type == BT_CHARACTER)
2044 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
2048 gfc_set_backend_locus (&old_loc);
2052 /* Create a decl for a function, and create any thunks for alternate entry
2056 gfc_create_function_decl (gfc_namespace * ns)
2058 /* Create a declaration for the master function. */
2059 build_function_decl (ns->proc_name);
2061 /* Compile the entry thunks. */
2063 build_entry_thunks (ns);
2065 /* Now create the read argument list. */
2066 create_function_arglist (ns->proc_name);
2069 /* Return the decl used to hold the function return value. If
2070 parent_flag is set, the context is the parent_scope. */
2073 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2077 tree this_fake_result_decl;
2078 tree this_function_decl;
2080 char name[GFC_MAX_SYMBOL_LEN + 10];
2084 this_fake_result_decl = parent_fake_result_decl;
2085 this_function_decl = DECL_CONTEXT (current_function_decl);
2089 this_fake_result_decl = current_fake_result_decl;
2090 this_function_decl = current_function_decl;
2094 && sym->ns->proc_name->backend_decl == this_function_decl
2095 && sym->ns->proc_name->attr.entry_master
2096 && sym != sym->ns->proc_name)
2099 if (this_fake_result_decl != NULL)
2100 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2101 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2104 return TREE_VALUE (t);
2105 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2108 this_fake_result_decl = parent_fake_result_decl;
2110 this_fake_result_decl = current_fake_result_decl;
2112 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2116 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2117 field; field = TREE_CHAIN (field))
2118 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2122 gcc_assert (field != NULL_TREE);
2123 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2124 decl, field, NULL_TREE);
2127 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2129 gfc_add_decl_to_parent_function (var);
2131 gfc_add_decl_to_function (var);
2133 SET_DECL_VALUE_EXPR (var, decl);
2134 DECL_HAS_VALUE_EXPR_P (var) = 1;
2135 GFC_DECL_RESULT (var) = 1;
2137 TREE_CHAIN (this_fake_result_decl)
2138 = tree_cons (get_identifier (sym->name), var,
2139 TREE_CHAIN (this_fake_result_decl));
2143 if (this_fake_result_decl != NULL_TREE)
2144 return TREE_VALUE (this_fake_result_decl);
2146 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2151 if (sym->ts.type == BT_CHARACTER)
2153 if (sym->ts.cl->backend_decl == NULL_TREE)
2154 length = gfc_create_string_length (sym);
2156 length = sym->ts.cl->backend_decl;
2157 if (TREE_CODE (length) == VAR_DECL
2158 && DECL_CONTEXT (length) == NULL_TREE)
2159 gfc_add_decl_to_function (length);
2162 if (gfc_return_by_reference (sym))
2164 decl = DECL_ARGUMENTS (this_function_decl);
2166 if (sym->ns->proc_name->backend_decl == this_function_decl
2167 && sym->ns->proc_name->attr.entry_master)
2168 decl = TREE_CHAIN (decl);
2170 TREE_USED (decl) = 1;
2172 decl = gfc_build_dummy_array_decl (sym, decl);
2176 sprintf (name, "__result_%.20s",
2177 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2179 if (!sym->attr.mixed_entry_master && sym->attr.function)
2180 decl = build_decl (input_location,
2181 VAR_DECL, get_identifier (name),
2182 gfc_sym_type (sym));
2184 decl = build_decl (input_location,
2185 VAR_DECL, get_identifier (name),
2186 TREE_TYPE (TREE_TYPE (this_function_decl)));
2187 DECL_ARTIFICIAL (decl) = 1;
2188 DECL_EXTERNAL (decl) = 0;
2189 TREE_PUBLIC (decl) = 0;
2190 TREE_USED (decl) = 1;
2191 GFC_DECL_RESULT (decl) = 1;
2192 TREE_ADDRESSABLE (decl) = 1;
2194 layout_decl (decl, 0);
2197 gfc_add_decl_to_parent_function (decl);
2199 gfc_add_decl_to_function (decl);
2203 parent_fake_result_decl = build_tree_list (NULL, decl);
2205 current_fake_result_decl = build_tree_list (NULL, decl);
2211 /* Builds a function decl. The remaining parameters are the types of the
2212 function arguments. Negative nargs indicates a varargs function. */
2215 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2224 /* Library functions must be declared with global scope. */
2225 gcc_assert (current_function_decl == NULL_TREE);
2227 va_start (p, nargs);
2230 /* Create a list of the argument types. */
2231 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2233 argtype = va_arg (p, tree);
2234 arglist = gfc_chainon_list (arglist, argtype);
2239 /* Terminate the list. */
2240 arglist = gfc_chainon_list (arglist, void_type_node);
2243 /* Build the function type and decl. */
2244 fntype = build_function_type (rettype, arglist);
2245 fndecl = build_decl (input_location,
2246 FUNCTION_DECL, name, fntype);
2248 /* Mark this decl as external. */
2249 DECL_EXTERNAL (fndecl) = 1;
2250 TREE_PUBLIC (fndecl) = 1;
2256 rest_of_decl_compilation (fndecl, 1, 0);
2262 gfc_build_intrinsic_function_decls (void)
2264 tree gfc_int4_type_node = gfc_get_int_type (4);
2265 tree gfc_int8_type_node = gfc_get_int_type (8);
2266 tree gfc_int16_type_node = gfc_get_int_type (16);
2267 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2268 tree pchar1_type_node = gfc_get_pchar_type (1);
2269 tree pchar4_type_node = gfc_get_pchar_type (4);
2271 /* String functions. */
2272 gfor_fndecl_compare_string =
2273 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2274 integer_type_node, 4,
2275 gfc_charlen_type_node, pchar1_type_node,
2276 gfc_charlen_type_node, pchar1_type_node);
2278 gfor_fndecl_concat_string =
2279 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2281 gfc_charlen_type_node, pchar1_type_node,
2282 gfc_charlen_type_node, pchar1_type_node,
2283 gfc_charlen_type_node, pchar1_type_node);
2285 gfor_fndecl_string_len_trim =
2286 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2287 gfc_int4_type_node, 2,
2288 gfc_charlen_type_node, pchar1_type_node);
2290 gfor_fndecl_string_index =
2291 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2292 gfc_int4_type_node, 5,
2293 gfc_charlen_type_node, pchar1_type_node,
2294 gfc_charlen_type_node, pchar1_type_node,
2295 gfc_logical4_type_node);
2297 gfor_fndecl_string_scan =
2298 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2299 gfc_int4_type_node, 5,
2300 gfc_charlen_type_node, pchar1_type_node,
2301 gfc_charlen_type_node, pchar1_type_node,
2302 gfc_logical4_type_node);
2304 gfor_fndecl_string_verify =
2305 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2306 gfc_int4_type_node, 5,
2307 gfc_charlen_type_node, pchar1_type_node,
2308 gfc_charlen_type_node, pchar1_type_node,
2309 gfc_logical4_type_node);
2311 gfor_fndecl_string_trim =
2312 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2314 build_pointer_type (gfc_charlen_type_node),
2315 build_pointer_type (pchar1_type_node),
2316 gfc_charlen_type_node, pchar1_type_node);
2318 gfor_fndecl_string_minmax =
2319 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2321 build_pointer_type (gfc_charlen_type_node),
2322 build_pointer_type (pchar1_type_node),
2323 integer_type_node, integer_type_node);
2325 gfor_fndecl_adjustl =
2326 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2327 void_type_node, 3, pchar1_type_node,
2328 gfc_charlen_type_node, pchar1_type_node);
2330 gfor_fndecl_adjustr =
2331 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2332 void_type_node, 3, pchar1_type_node,
2333 gfc_charlen_type_node, pchar1_type_node);
2335 gfor_fndecl_select_string =
2336 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2337 integer_type_node, 4, pvoid_type_node,
2338 integer_type_node, pchar1_type_node,
2339 gfc_charlen_type_node);
2341 gfor_fndecl_compare_string_char4 =
2342 gfc_build_library_function_decl (get_identifier
2343 (PREFIX("compare_string_char4")),
2344 integer_type_node, 4,
2345 gfc_charlen_type_node, pchar4_type_node,
2346 gfc_charlen_type_node, pchar4_type_node);
2348 gfor_fndecl_concat_string_char4 =
2349 gfc_build_library_function_decl (get_identifier
2350 (PREFIX("concat_string_char4")),
2352 gfc_charlen_type_node, pchar4_type_node,
2353 gfc_charlen_type_node, pchar4_type_node,
2354 gfc_charlen_type_node, pchar4_type_node);
2356 gfor_fndecl_string_len_trim_char4 =
2357 gfc_build_library_function_decl (get_identifier
2358 (PREFIX("string_len_trim_char4")),
2359 gfc_charlen_type_node, 2,
2360 gfc_charlen_type_node, pchar4_type_node);
2362 gfor_fndecl_string_index_char4 =
2363 gfc_build_library_function_decl (get_identifier
2364 (PREFIX("string_index_char4")),
2365 gfc_charlen_type_node, 5,
2366 gfc_charlen_type_node, pchar4_type_node,
2367 gfc_charlen_type_node, pchar4_type_node,
2368 gfc_logical4_type_node);
2370 gfor_fndecl_string_scan_char4 =
2371 gfc_build_library_function_decl (get_identifier
2372 (PREFIX("string_scan_char4")),
2373 gfc_charlen_type_node, 5,
2374 gfc_charlen_type_node, pchar4_type_node,
2375 gfc_charlen_type_node, pchar4_type_node,
2376 gfc_logical4_type_node);
2378 gfor_fndecl_string_verify_char4 =
2379 gfc_build_library_function_decl (get_identifier
2380 (PREFIX("string_verify_char4")),
2381 gfc_charlen_type_node, 5,
2382 gfc_charlen_type_node, pchar4_type_node,
2383 gfc_charlen_type_node, pchar4_type_node,
2384 gfc_logical4_type_node);
2386 gfor_fndecl_string_trim_char4 =
2387 gfc_build_library_function_decl (get_identifier
2388 (PREFIX("string_trim_char4")),
2390 build_pointer_type (gfc_charlen_type_node),
2391 build_pointer_type (pchar4_type_node),
2392 gfc_charlen_type_node, pchar4_type_node);
2394 gfor_fndecl_string_minmax_char4 =
2395 gfc_build_library_function_decl (get_identifier
2396 (PREFIX("string_minmax_char4")),
2398 build_pointer_type (gfc_charlen_type_node),
2399 build_pointer_type (pchar4_type_node),
2400 integer_type_node, integer_type_node);
2402 gfor_fndecl_adjustl_char4 =
2403 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2404 void_type_node, 3, pchar4_type_node,
2405 gfc_charlen_type_node, pchar4_type_node);
2407 gfor_fndecl_adjustr_char4 =
2408 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2409 void_type_node, 3, pchar4_type_node,
2410 gfc_charlen_type_node, pchar4_type_node);
2412 gfor_fndecl_select_string_char4 =
2413 gfc_build_library_function_decl (get_identifier
2414 (PREFIX("select_string_char4")),
2415 integer_type_node, 4, pvoid_type_node,
2416 integer_type_node, pvoid_type_node,
2417 gfc_charlen_type_node);
2420 /* Conversion between character kinds. */
2422 gfor_fndecl_convert_char1_to_char4 =
2423 gfc_build_library_function_decl (get_identifier
2424 (PREFIX("convert_char1_to_char4")),
2426 build_pointer_type (pchar4_type_node),
2427 gfc_charlen_type_node, pchar1_type_node);
2429 gfor_fndecl_convert_char4_to_char1 =
2430 gfc_build_library_function_decl (get_identifier
2431 (PREFIX("convert_char4_to_char1")),
2433 build_pointer_type (pchar1_type_node),
2434 gfc_charlen_type_node, pchar4_type_node);
2436 /* Misc. functions. */
2438 gfor_fndecl_ttynam =
2439 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2443 gfc_charlen_type_node,
2447 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2451 gfc_charlen_type_node);
2454 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2458 gfc_charlen_type_node,
2459 gfc_int8_type_node);
2461 gfor_fndecl_sc_kind =
2462 gfc_build_library_function_decl (get_identifier
2463 (PREFIX("selected_char_kind")),
2464 gfc_int4_type_node, 2,
2465 gfc_charlen_type_node, pchar_type_node);
2467 gfor_fndecl_si_kind =
2468 gfc_build_library_function_decl (get_identifier
2469 (PREFIX("selected_int_kind")),
2470 gfc_int4_type_node, 1, pvoid_type_node);
2472 gfor_fndecl_sr_kind =
2473 gfc_build_library_function_decl (get_identifier
2474 (PREFIX("selected_real_kind")),
2475 gfc_int4_type_node, 2,
2476 pvoid_type_node, pvoid_type_node);
2478 /* Power functions. */
2480 tree ctype, rtype, itype, jtype;
2481 int rkind, ikind, jkind;
2484 static int ikinds[NIKINDS] = {4, 8, 16};
2485 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2486 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2488 for (ikind=0; ikind < NIKINDS; ikind++)
2490 itype = gfc_get_int_type (ikinds[ikind]);
2492 for (jkind=0; jkind < NIKINDS; jkind++)
2494 jtype = gfc_get_int_type (ikinds[jkind]);
2497 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2499 gfor_fndecl_math_powi[jkind][ikind].integer =
2500 gfc_build_library_function_decl (get_identifier (name),
2501 jtype, 2, jtype, itype);
2502 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2506 for (rkind = 0; rkind < NRKINDS; rkind ++)
2508 rtype = gfc_get_real_type (rkinds[rkind]);
2511 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2513 gfor_fndecl_math_powi[rkind][ikind].real =
2514 gfc_build_library_function_decl (get_identifier (name),
2515 rtype, 2, rtype, itype);
2516 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2519 ctype = gfc_get_complex_type (rkinds[rkind]);
2522 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2524 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2525 gfc_build_library_function_decl (get_identifier (name),
2526 ctype, 2,ctype, itype);
2527 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2535 gfor_fndecl_math_ishftc4 =
2536 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2538 3, gfc_int4_type_node,
2539 gfc_int4_type_node, gfc_int4_type_node);
2540 gfor_fndecl_math_ishftc8 =
2541 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2543 3, gfc_int8_type_node,
2544 gfc_int4_type_node, gfc_int4_type_node);
2545 if (gfc_int16_type_node)
2546 gfor_fndecl_math_ishftc16 =
2547 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2548 gfc_int16_type_node, 3,
2549 gfc_int16_type_node,
2551 gfc_int4_type_node);
2553 /* BLAS functions. */
2555 tree pint = build_pointer_type (integer_type_node);
2556 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2557 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2558 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2559 tree pz = build_pointer_type
2560 (gfc_get_complex_type (gfc_default_double_kind));
2562 gfor_fndecl_sgemm = gfc_build_library_function_decl
2564 (gfc_option.flag_underscoring ? "sgemm_"
2566 void_type_node, 15, pchar_type_node,
2567 pchar_type_node, pint, pint, pint, ps, ps, pint,
2568 ps, pint, ps, ps, pint, integer_type_node,
2570 gfor_fndecl_dgemm = gfc_build_library_function_decl
2572 (gfc_option.flag_underscoring ? "dgemm_"
2574 void_type_node, 15, pchar_type_node,
2575 pchar_type_node, pint, pint, pint, pd, pd, pint,
2576 pd, pint, pd, pd, pint, integer_type_node,
2578 gfor_fndecl_cgemm = gfc_build_library_function_decl
2580 (gfc_option.flag_underscoring ? "cgemm_"
2582 void_type_node, 15, pchar_type_node,
2583 pchar_type_node, pint, pint, pint, pc, pc, pint,
2584 pc, pint, pc, pc, pint, integer_type_node,
2586 gfor_fndecl_zgemm = gfc_build_library_function_decl
2588 (gfc_option.flag_underscoring ? "zgemm_"
2590 void_type_node, 15, pchar_type_node,
2591 pchar_type_node, pint, pint, pint, pz, pz, pint,
2592 pz, pint, pz, pz, pint, integer_type_node,
2596 /* Other functions. */
2598 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2599 gfc_array_index_type,
2600 1, pvoid_type_node);
2602 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2603 gfc_array_index_type,
2605 gfc_array_index_type);
2608 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2612 if (gfc_type_for_size (128, true))
2614 tree uint128 = gfc_type_for_size (128, true);
2616 gfor_fndecl_clz128 =
2617 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2618 integer_type_node, 1, uint128);
2620 gfor_fndecl_ctz128 =
2621 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2622 integer_type_node, 1, uint128);
2627 /* Make prototypes for runtime library functions. */
2630 gfc_build_builtin_function_decls (void)
2632 tree gfc_int4_type_node = gfc_get_int_type (4);
2634 gfor_fndecl_stop_numeric =
2635 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2636 void_type_node, 1, gfc_int4_type_node);
2637 /* Stop doesn't return. */
2638 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2640 gfor_fndecl_stop_string =
2641 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2642 void_type_node, 2, pchar_type_node,
2643 gfc_int4_type_node);
2644 /* Stop doesn't return. */
2645 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2647 gfor_fndecl_pause_numeric =
2648 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2649 void_type_node, 1, gfc_int4_type_node);
2651 gfor_fndecl_pause_string =
2652 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2653 void_type_node, 2, pchar_type_node,
2654 gfc_int4_type_node);
2656 gfor_fndecl_runtime_error =
2657 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2658 void_type_node, -1, pchar_type_node);
2659 /* The runtime_error function does not return. */
2660 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2662 gfor_fndecl_runtime_error_at =
2663 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2664 void_type_node, -2, pchar_type_node,
2666 /* The runtime_error_at function does not return. */
2667 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2669 gfor_fndecl_runtime_warning_at =
2670 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2671 void_type_node, -2, pchar_type_node,
2673 gfor_fndecl_generate_error =
2674 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2675 void_type_node, 3, pvoid_type_node,
2676 integer_type_node, pchar_type_node);
2678 gfor_fndecl_os_error =
2679 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2680 void_type_node, 1, pchar_type_node);
2681 /* The runtime_error function does not return. */
2682 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2684 gfor_fndecl_set_args =
2685 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2686 void_type_node, 2, integer_type_node,
2687 build_pointer_type (pchar_type_node));
2689 gfor_fndecl_set_fpe =
2690 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2691 void_type_node, 1, integer_type_node);
2693 /* Keep the array dimension in sync with the call, later in this file. */
2694 gfor_fndecl_set_options =
2695 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2696 void_type_node, 2, integer_type_node,
2697 build_pointer_type (integer_type_node));
2699 gfor_fndecl_set_convert =
2700 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2701 void_type_node, 1, integer_type_node);
2703 gfor_fndecl_set_record_marker =
2704 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2705 void_type_node, 1, integer_type_node);
2707 gfor_fndecl_set_max_subrecord_length =
2708 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2709 void_type_node, 1, integer_type_node);
2711 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2712 get_identifier (PREFIX("internal_pack")),
2713 pvoid_type_node, 1, pvoid_type_node);
2715 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2716 get_identifier (PREFIX("internal_unpack")),
2717 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2719 gfor_fndecl_associated =
2720 gfc_build_library_function_decl (
2721 get_identifier (PREFIX("associated")),
2722 integer_type_node, 2, ppvoid_type_node,
2725 gfc_build_intrinsic_function_decls ();
2726 gfc_build_intrinsic_lib_fndecls ();
2727 gfc_build_io_library_fndecls ();
2731 /* Evaluate the length of dummy character variables. */
2734 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2738 gfc_finish_decl (cl->backend_decl);
2740 gfc_start_block (&body);
2742 /* Evaluate the string length expression. */
2743 gfc_conv_string_length (cl, NULL, &body);
2745 gfc_trans_vla_type_sizes (sym, &body);
2747 gfc_add_expr_to_block (&body, fnbody);
2748 return gfc_finish_block (&body);
2752 /* Allocate and cleanup an automatic character variable. */
2755 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2761 gcc_assert (sym->backend_decl);
2762 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2764 gfc_start_block (&body);
2766 /* Evaluate the string length expression. */
2767 gfc_conv_string_length (sym->ts.cl, NULL, &body);
2769 gfc_trans_vla_type_sizes (sym, &body);
2771 decl = sym->backend_decl;
2773 /* Emit a DECL_EXPR for this variable, which will cause the
2774 gimplifier to allocate storage, and all that good stuff. */
2775 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2776 gfc_add_expr_to_block (&body, tmp);
2778 gfc_add_expr_to_block (&body, fnbody);
2779 return gfc_finish_block (&body);
2782 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2785 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2789 gcc_assert (sym->backend_decl);
2790 gfc_start_block (&body);
2792 /* Set the initial value to length. See the comments in
2793 function gfc_add_assign_aux_vars in this file. */
2794 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2795 build_int_cst (NULL_TREE, -2));
2797 gfc_add_expr_to_block (&body, fnbody);
2798 return gfc_finish_block (&body);
2802 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2804 tree t = *tp, var, val;
2806 if (t == NULL || t == error_mark_node)
2808 if (TREE_CONSTANT (t) || DECL_P (t))
2811 if (TREE_CODE (t) == SAVE_EXPR)
2813 if (SAVE_EXPR_RESOLVED_P (t))
2815 *tp = TREE_OPERAND (t, 0);
2818 val = TREE_OPERAND (t, 0);
2823 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2824 gfc_add_decl_to_function (var);
2825 gfc_add_modify (body, var, val);
2826 if (TREE_CODE (t) == SAVE_EXPR)
2827 TREE_OPERAND (t, 0) = var;
2832 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2836 if (type == NULL || type == error_mark_node)
2839 type = TYPE_MAIN_VARIANT (type);
2841 if (TREE_CODE (type) == INTEGER_TYPE)
2843 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2844 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2846 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2848 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2849 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2852 else if (TREE_CODE (type) == ARRAY_TYPE)
2854 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2855 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2856 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2857 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2859 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2861 TYPE_SIZE (t) = TYPE_SIZE (type);
2862 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2867 /* Make sure all type sizes and array domains are either constant,
2868 or variable or parameter decls. This is a simplified variant
2869 of gimplify_type_sizes, but we can't use it here, as none of the
2870 variables in the expressions have been gimplified yet.
2871 As type sizes and domains for various variable length arrays
2872 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2873 time, without this routine gimplify_type_sizes in the middle-end
2874 could result in the type sizes being gimplified earlier than where
2875 those variables are initialized. */
2878 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2880 tree type = TREE_TYPE (sym->backend_decl);
2882 if (TREE_CODE (type) == FUNCTION_TYPE
2883 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2885 if (! current_fake_result_decl)
2888 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2891 while (POINTER_TYPE_P (type))
2892 type = TREE_TYPE (type);
2894 if (GFC_DESCRIPTOR_TYPE_P (type))
2896 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2898 while (POINTER_TYPE_P (etype))
2899 etype = TREE_TYPE (etype);
2901 gfc_trans_vla_type_sizes_1 (etype, body);
2904 gfc_trans_vla_type_sizes_1 (type, body);
2908 /* Initialize a derived type by building an lvalue from the symbol
2909 and using trans_assignment to do the work. */
2911 gfc_init_default_dt (gfc_symbol * sym, tree body)
2913 stmtblock_t fnblock;
2918 gfc_init_block (&fnblock);
2919 gcc_assert (!sym->attr.allocatable);
2920 gfc_set_sym_referenced (sym);
2921 e = gfc_lval_expr_from_sym (sym);
2922 tmp = gfc_trans_assignment (e, sym->value, false);
2923 if (sym->attr.dummy)
2925 present = gfc_conv_expr_present (sym);
2926 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2927 tmp, build_empty_stmt (input_location));
2929 gfc_add_expr_to_block (&fnblock, tmp);
2932 gfc_add_expr_to_block (&fnblock, body);
2933 return gfc_finish_block (&fnblock);
2937 /* Initialize INTENT(OUT) derived type dummies. As well as giving
2938 them their default initializer, if they do not have allocatable
2939 components, they have their allocatable components deallocated. */
2942 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2944 stmtblock_t fnblock;
2945 gfc_formal_arglist *f;
2949 gfc_init_block (&fnblock);
2950 for (f = proc_sym->formal; f; f = f->next)
2951 if (f->sym && f->sym->attr.intent == INTENT_OUT
2952 && f->sym->ts.type == BT_DERIVED)
2954 if (f->sym->ts.derived->attr.alloc_comp)
2956 tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2957 f->sym->backend_decl,
2958 f->sym->as ? f->sym->as->rank : 0);
2960 present = gfc_conv_expr_present (f->sym);
2961 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2962 tmp, build_empty_stmt (input_location));
2964 gfc_add_expr_to_block (&fnblock, tmp);
2967 if (!f->sym->ts.derived->attr.alloc_comp
2969 body = gfc_init_default_dt (f->sym, body);
2972 gfc_add_expr_to_block (&fnblock, body);
2973 return gfc_finish_block (&fnblock);
2977 /* Generate function entry and exit code, and add it to the function body.
2979 Allocation and initialization of array variables.
2980 Allocation of character string variables.
2981 Initialization and possibly repacking of dummy arrays.
2982 Initialization of ASSIGN statement auxiliary variable. */
2985 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2989 gfc_formal_arglist *f;
2991 bool seen_trans_deferred_array = false;
2993 /* Deal with implicit return variables. Explicit return variables will
2994 already have been added. */
2995 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2997 if (!current_fake_result_decl)
2999 gfc_entry_list *el = NULL;
3000 if (proc_sym->attr.entry_master)
3002 for (el = proc_sym->ns->entries; el; el = el->next)
3003 if (el->sym != el->sym->result)
3006 /* TODO: move to the appropriate place in resolve.c. */
3007 if (warn_return_type && el == NULL)
3008 gfc_warning ("Return value of function '%s' at %L not set",
3009 proc_sym->name, &proc_sym->declared_at);
3011 else if (proc_sym->as)
3013 tree result = TREE_VALUE (current_fake_result_decl);
3014 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3016 /* An automatic character length, pointer array result. */
3017 if (proc_sym->ts.type == BT_CHARACTER
3018 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
3019 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
3022 else if (proc_sym->ts.type == BT_CHARACTER)
3024 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
3025 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
3029 gcc_assert (gfc_option.flag_f2c
3030 && proc_sym->ts.type == BT_COMPLEX);
3033 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3034 should be done here so that the offsets and lbounds of arrays
3036 fnbody = init_intent_out_dt (proc_sym, fnbody);
3038 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3040 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3041 && sym->ts.derived->attr.alloc_comp;
3042 if (sym->attr.dimension)
3044 switch (sym->as->type)
3047 if (sym->attr.dummy || sym->attr.result)
3049 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3050 else if (sym->attr.pointer || sym->attr.allocatable)
3052 if (TREE_STATIC (sym->backend_decl))
3053 gfc_trans_static_array_pointer (sym);
3056 seen_trans_deferred_array = true;
3057 fnbody = gfc_trans_deferred_array (sym, fnbody);
3062 if (sym_has_alloc_comp)
3064 seen_trans_deferred_array = true;
3065 fnbody = gfc_trans_deferred_array (sym, fnbody);
3067 else if (sym->ts.type == BT_DERIVED
3070 && sym->attr.save == SAVE_NONE)
3071 fnbody = gfc_init_default_dt (sym, fnbody);
3073 gfc_get_backend_locus (&loc);
3074 gfc_set_backend_locus (&sym->declared_at);
3075 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3077 gfc_set_backend_locus (&loc);
3081 case AS_ASSUMED_SIZE:
3082 /* Must be a dummy parameter. */
3083 gcc_assert (sym->attr.dummy);
3085 /* We should always pass assumed size arrays the g77 way. */
3086 fnbody = gfc_trans_g77_array (sym, fnbody);
3089 case AS_ASSUMED_SHAPE:
3090 /* Must be a dummy parameter. */
3091 gcc_assert (sym->attr.dummy);
3093 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3098 seen_trans_deferred_array = true;
3099 fnbody = gfc_trans_deferred_array (sym, fnbody);
3105 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3106 fnbody = gfc_trans_deferred_array (sym, fnbody);
3108 else if (sym_has_alloc_comp)
3109 fnbody = gfc_trans_deferred_array (sym, fnbody);
3110 else if (sym->ts.type == BT_CHARACTER)
3112 gfc_get_backend_locus (&loc);
3113 gfc_set_backend_locus (&sym->declared_at);
3114 if (sym->attr.dummy || sym->attr.result)
3115 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
3117 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3118 gfc_set_backend_locus (&loc);
3120 else if (sym->attr.assign)
3122 gfc_get_backend_locus (&loc);
3123 gfc_set_backend_locus (&sym->declared_at);
3124 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3125 gfc_set_backend_locus (&loc);
3127 else if (sym->ts.type == BT_DERIVED
3130 && sym->attr.save == SAVE_NONE)
3131 fnbody = gfc_init_default_dt (sym, fnbody);
3136 gfc_init_block (&body);
3138 for (f = proc_sym->formal; f; f = f->next)
3140 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3142 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3143 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3144 gfc_trans_vla_type_sizes (f->sym, &body);
3148 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3149 && current_fake_result_decl != NULL)
3151 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3152 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3153 gfc_trans_vla_type_sizes (proc_sym, &body);
3156 gfc_add_expr_to_block (&body, fnbody);
3157 return gfc_finish_block (&body);
3160 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3162 /* Hash and equality functions for module_htab. */
3165 module_htab_do_hash (const void *x)
3167 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3171 module_htab_eq (const void *x1, const void *x2)
3173 return strcmp ((((const struct module_htab_entry *)x1)->name),
3174 (const char *)x2) == 0;
3177 /* Hash and equality functions for module_htab's decls. */
3180 module_htab_decls_hash (const void *x)
3182 const_tree t = (const_tree) x;
3183 const_tree n = DECL_NAME (t);
3185 n = TYPE_NAME (TREE_TYPE (t));
3186 return htab_hash_string (IDENTIFIER_POINTER (n));
3190 module_htab_decls_eq (const void *x1, const void *x2)
3192 const_tree t1 = (const_tree) x1;
3193 const_tree n1 = DECL_NAME (t1);
3194 if (n1 == NULL_TREE)
3195 n1 = TYPE_NAME (TREE_TYPE (t1));
3196 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3199 struct module_htab_entry *
3200 gfc_find_module (const char *name)
3205 module_htab = htab_create_ggc (10, module_htab_do_hash,
3206 module_htab_eq, NULL);
3208 slot = htab_find_slot_with_hash (module_htab, name,
3209 htab_hash_string (name), INSERT);
3212 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3214 entry->name = gfc_get_string (name);
3215 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3216 module_htab_decls_eq, NULL);
3217 *slot = (void *) entry;
3219 return (struct module_htab_entry *) *slot;
3223 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3228 if (DECL_NAME (decl))
3229 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3232 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3233 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3235 slot = htab_find_slot_with_hash (entry->decls, name,
3236 htab_hash_string (name), INSERT);
3238 *slot = (void *) decl;
3241 static struct module_htab_entry *cur_module;
3243 /* Output an initialized decl for a module variable. */
3246 gfc_create_module_variable (gfc_symbol * sym)
3250 /* Module functions with alternate entries are dealt with later and
3251 would get caught by the next condition. */
3252 if (sym->attr.entry)
3255 /* Make sure we convert the types of the derived types from iso_c_binding
3257 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3258 && sym->ts.type == BT_DERIVED)
3259 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3261 if (sym->attr.flavor == FL_DERIVED
3262 && sym->backend_decl
3263 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3265 decl = sym->backend_decl;
3266 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3267 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3268 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3269 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3270 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3271 == sym->ns->proc_name->backend_decl);
3272 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3273 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3274 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3277 /* Only output variables, procedure pointers and array valued,
3278 or derived type, parameters. */
3279 if (sym->attr.flavor != FL_VARIABLE
3280 && !(sym->attr.flavor == FL_PARAMETER
3281 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3282 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3285 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3287 decl = sym->backend_decl;
3288 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3289 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3290 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3291 gfc_module_add_decl (cur_module, decl);
3294 /* Don't generate variables from other modules. Variables from
3295 COMMONs will already have been generated. */
3296 if (sym->attr.use_assoc || sym->attr.in_common)
3299 /* Equivalenced variables arrive here after creation. */
3300 if (sym->backend_decl
3301 && (sym->equiv_built || sym->attr.in_equivalence))
3304 if (sym->backend_decl)
3305 internal_error ("backend decl for module variable %s already exists",
3308 /* We always want module variables to be created. */
3309 sym->attr.referenced = 1;
3310 /* Create the decl. */
3311 decl = gfc_get_symbol_decl (sym);
3313 /* Create the variable. */
3315 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3316 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3317 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3318 rest_of_decl_compilation (decl, 1, 0);
3319 gfc_module_add_decl (cur_module, decl);
3321 /* Also add length of strings. */
3322 if (sym->ts.type == BT_CHARACTER)
3326 length = sym->ts.cl->backend_decl;
3327 if (!INTEGER_CST_P (length))
3330 rest_of_decl_compilation (length, 1, 0);
3335 /* Emit debug information for USE statements. */
3338 gfc_trans_use_stmts (gfc_namespace * ns)
3340 gfc_use_list *use_stmt;
3341 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3343 struct module_htab_entry *entry
3344 = gfc_find_module (use_stmt->module_name);
3345 gfc_use_rename *rent;
3347 if (entry->namespace_decl == NULL)
3349 entry->namespace_decl
3350 = build_decl (input_location,
3352 get_identifier (use_stmt->module_name),
3354 DECL_EXTERNAL (entry->namespace_decl) = 1;
3356 gfc_set_backend_locus (&use_stmt->where);
3357 if (!use_stmt->only_flag)
3358 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3360 ns->proc_name->backend_decl,
3362 for (rent = use_stmt->rename; rent; rent = rent->next)
3364 tree decl, local_name;
3367 if (rent->op != INTRINSIC_NONE)
3370 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3371 htab_hash_string (rent->use_name),
3377 st = gfc_find_symtree (ns->sym_root,
3379 ? rent->local_name : rent->use_name);
3380 gcc_assert (st && st->n.sym->attr.use_assoc);
3381 if (st->n.sym->backend_decl
3382 && DECL_P (st->n.sym->backend_decl)
3383 && st->n.sym->module
3384 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3386 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3387 || (TREE_CODE (st->n.sym->backend_decl)
3389 decl = copy_node (st->n.sym->backend_decl);
3390 DECL_CONTEXT (decl) = entry->namespace_decl;
3391 DECL_EXTERNAL (decl) = 1;
3392 DECL_IGNORED_P (decl) = 0;
3393 DECL_INITIAL (decl) = NULL_TREE;
3397 *slot = error_mark_node;
3398 htab_clear_slot (entry->decls, slot);
3403 decl = (tree) *slot;
3404 if (rent->local_name[0])
3405 local_name = get_identifier (rent->local_name);
3407 local_name = NULL_TREE;
3408 gfc_set_backend_locus (&rent->where);
3409 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3410 ns->proc_name->backend_decl,
3411 !use_stmt->only_flag);
3417 /* Return true if expr is a constant initializer that gfc_conv_initializer
3421 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3431 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3433 else if (expr->expr_type == EXPR_STRUCTURE)
3434 return check_constant_initializer (expr, ts, false, false);
3435 else if (expr->expr_type != EXPR_ARRAY)
3437 for (c = expr->value.constructor; c; c = c->next)
3441 if (c->expr->expr_type == EXPR_STRUCTURE)
3443 if (!check_constant_initializer (c->expr, ts, false, false))
3446 else if (c->expr->expr_type != EXPR_CONSTANT)
3451 else switch (ts->type)
3454 if (expr->expr_type != EXPR_STRUCTURE)
3456 cm = expr->ts.derived->components;
3457 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3459 if (!c->expr || cm->attr.allocatable)
3461 if (!check_constant_initializer (c->expr, &cm->ts,
3468 return expr->expr_type == EXPR_CONSTANT;
3472 /* Emit debug info for parameters and unreferenced variables with
3476 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3480 if (sym->attr.flavor != FL_PARAMETER
3481 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3484 if (sym->backend_decl != NULL
3485 || sym->value == NULL
3486 || sym->attr.use_assoc
3489 || sym->attr.function
3490 || sym->attr.intrinsic
3491 || sym->attr.pointer
3492 || sym->attr.allocatable
3493 || sym->attr.cray_pointee
3494 || sym->attr.threadprivate
3495 || sym->attr.is_bind_c
3496 || sym->attr.subref_array_pointer
3497 || sym->attr.assign)
3500 if (sym->ts.type == BT_CHARACTER)
3502 gfc_conv_const_charlen (sym->ts.cl);
3503 if (sym->ts.cl->backend_decl == NULL
3504 || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3507 else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3514 if (sym->as->type != AS_EXPLICIT)
3516 for (n = 0; n < sym->as->rank; n++)
3517 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3518 || sym->as->upper[n] == NULL
3519 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3523 if (!check_constant_initializer (sym->value, &sym->ts,
3524 sym->attr.dimension, false))
3527 /* Create the decl for the variable or constant. */
3528 decl = build_decl (input_location,
3529 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3530 gfc_sym_identifier (sym), gfc_sym_type (sym));
3531 if (sym->attr.flavor == FL_PARAMETER)
3532 TREE_READONLY (decl) = 1;
3533 gfc_set_decl_location (decl, &sym->declared_at);
3534 if (sym->attr.dimension)
3535 GFC_DECL_PACKED_ARRAY (decl) = 1;
3536 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3537 TREE_STATIC (decl) = 1;
3538 TREE_USED (decl) = 1;
3539 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3540 TREE_PUBLIC (decl) = 1;
3542 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3543 sym->attr.dimension, 0);
3544 debug_hooks->global_decl (decl);
3547 /* Generate all the required code for module variables. */
3550 gfc_generate_module_vars (gfc_namespace * ns)
3552 module_namespace = ns;
3553 cur_module = gfc_find_module (ns->proc_name->name);
3555 /* Check if the frontend left the namespace in a reasonable state. */
3556 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3558 /* Generate COMMON blocks. */
3559 gfc_trans_common (ns);
3561 /* Create decls for all the module variables. */
3562 gfc_traverse_ns (ns, gfc_create_module_variable);
3566 gfc_trans_use_stmts (ns);
3567 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3572 gfc_generate_contained_functions (gfc_namespace * parent)
3576 /* We create all the prototypes before generating any code. */
3577 for (ns = parent->contained; ns; ns = ns->sibling)
3579 /* Skip namespaces from used modules. */
3580 if (ns->parent != parent)
3583 gfc_create_function_decl (ns);
3586 for (ns = parent->contained; ns; ns = ns->sibling)
3588 /* Skip namespaces from used modules. */
3589 if (ns->parent != parent)
3592 gfc_generate_function_code (ns);
3597 /* Drill down through expressions for the array specification bounds and
3598 character length calling generate_local_decl for all those variables
3599 that have not already been declared. */
3602 generate_local_decl (gfc_symbol *);
3604 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3607 expr_decls (gfc_expr *e, gfc_symbol *sym,
3608 int *f ATTRIBUTE_UNUSED)
3610 if (e->expr_type != EXPR_VARIABLE
3611 || sym == e->symtree->n.sym
3612 || e->symtree->n.sym->mark
3613 || e->symtree->n.sym->ns != sym->ns)
3616 generate_local_decl (e->symtree->n.sym);
3621 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3623 gfc_traverse_expr (e, sym, expr_decls, 0);
3627 /* Check for dependencies in the character length and array spec. */
3630 generate_dependency_declarations (gfc_symbol *sym)
3634 if (sym->ts.type == BT_CHARACTER
3636 && sym->ts.cl->length
3637 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3638 generate_expr_decls (sym, sym->ts.cl->length);
3640 if (sym->as && sym->as->rank)
3642 for (i = 0; i < sym->as->rank; i++)
3644 generate_expr_decls (sym, sym->as->lower[i]);
3645 generate_expr_decls (sym, sym->as->upper[i]);
3651 /* Generate decls for all local variables. We do this to ensure correct
3652 handling of expressions which only appear in the specification of
3656 generate_local_decl (gfc_symbol * sym)
3658 if (sym->attr.flavor == FL_VARIABLE)
3660 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3661 generate_dependency_declarations (sym);
3663 if (sym->attr.referenced)
3664 gfc_get_symbol_decl (sym);
3665 /* INTENT(out) dummy arguments are likely meant to be set. */
3666 else if (warn_unused_variable
3668 && sym->attr.intent == INTENT_OUT)
3669 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3670 sym->name, &sym->declared_at);
3671 /* Specific warning for unused dummy arguments. */
3672 else if (warn_unused_variable && sym->attr.dummy)
3673 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3675 /* Warn for unused variables, but not if they're inside a common
3676 block or are use-associated. */
3677 else if (warn_unused_variable
3678 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3679 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3682 /* For variable length CHARACTER parameters, the PARM_DECL already
3683 references the length variable, so force gfc_get_symbol_decl
3684 even when not referenced. If optimize > 0, it will be optimized
3685 away anyway. But do this only after emitting -Wunused-parameter
3686 warning if requested. */
3687 if (sym->attr.dummy && !sym->attr.referenced
3688 && sym->ts.type == BT_CHARACTER
3689 && sym->ts.cl->backend_decl != NULL
3690 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3692 sym->attr.referenced = 1;
3693 gfc_get_symbol_decl (sym);
3696 /* INTENT(out) dummy arguments with allocatable components are reset
3697 by default and need to be set referenced to generate the code for
3698 automatic lengths. */
3699 if (sym->attr.dummy && !sym->attr.referenced
3700 && sym->ts.type == BT_DERIVED
3701 && sym->ts.derived->attr.alloc_comp
3702 && sym->attr.intent == INTENT_OUT)
3704 sym->attr.referenced = 1;
3705 gfc_get_symbol_decl (sym);
3709 /* Check for dependencies in the array specification and string
3710 length, adding the necessary declarations to the function. We
3711 mark the symbol now, as well as in traverse_ns, to prevent
3712 getting stuck in a circular dependency. */
3715 /* We do not want the middle-end to warn about unused parameters
3716 as this was already done above. */
3717 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3718 TREE_NO_WARNING(sym->backend_decl) = 1;
3720 else if (sym->attr.flavor == FL_PARAMETER)
3722 if (warn_unused_parameter
3723 && !sym->attr.referenced
3724 && !sym->attr.use_assoc)
3725 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3728 else if (sym->attr.flavor == FL_PROCEDURE)
3730 /* TODO: move to the appropriate place in resolve.c. */
3731 if (warn_return_type
3732 && sym->attr.function
3734 && sym != sym->result
3735 && !sym->result->attr.referenced
3736 && !sym->attr.use_assoc
3737 && sym->attr.if_source != IFSRC_IFBODY)
3739 gfc_warning ("Return value '%s' of function '%s' declared at "
3740 "%L not set", sym->result->name, sym->name,
3741 &sym->result->declared_at);
3743 /* Prevents "Unused variable" warning for RESULT variables. */
3744 sym->result->mark = 1;
3748 if (sym->attr.dummy == 1)
3750 /* Modify the tree type for scalar character dummy arguments of bind(c)
3751 procedures if they are passed by value. The tree type for them will
3752 be promoted to INTEGER_TYPE for the middle end, which appears to be
3753 what C would do with characters passed by-value. The value attribute
3754 implies the dummy is a scalar. */
3755 if (sym->attr.value == 1 && sym->backend_decl != NULL
3756 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3757 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3758 gfc_conv_scalar_char_value (sym, NULL, NULL);
3761 /* Make sure we convert the types of the derived types from iso_c_binding
3763 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3764 && sym->ts.type == BT_DERIVED)
3765 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3769 generate_local_vars (gfc_namespace * ns)
3771 gfc_traverse_ns (ns, generate_local_decl);
3775 /* Generate a switch statement to jump to the correct entry point. Also
3776 creates the label decls for the entry points. */
3779 gfc_trans_entry_master_switch (gfc_entry_list * el)
3786 gfc_init_block (&block);
3787 for (; el; el = el->next)
3789 /* Add the case label. */
3790 label = gfc_build_label_decl (NULL_TREE);
3791 val = build_int_cst (gfc_array_index_type, el->id);
3792 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3793 gfc_add_expr_to_block (&block, tmp);
3795 /* And jump to the actual entry point. */
3796 label = gfc_build_label_decl (NULL_TREE);
3797 tmp = build1_v (GOTO_EXPR, label);
3798 gfc_add_expr_to_block (&block, tmp);
3800 /* Save the label decl. */
3803 tmp = gfc_finish_block (&block);
3804 /* The first argument selects the entry point. */
3805 val = DECL_ARGUMENTS (current_function_decl);
3806 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3811 /* Add code to string lengths of actual arguments passed to a function against
3812 the expected lengths of the dummy arguments. */
3815 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3817 gfc_formal_arglist *formal;
3819 for (formal = sym->formal; formal; formal = formal->next)
3820 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3822 enum tree_code comparison;
3827 const char *message;
3833 gcc_assert (cl->passed_length != NULL_TREE);
3834 gcc_assert (cl->backend_decl != NULL_TREE);
3836 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3837 string lengths must match exactly. Otherwise, it is only required
3838 that the actual string length is *at least* the expected one.
3839 Sequence association allows for a mismatch of the string length
3840 if the actual argument is (part of) an array, but only if the
3841 dummy argument is an array. (See "Sequence association" in
3842 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
3843 if (fsym->attr.pointer || fsym->attr.allocatable
3844 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3846 comparison = NE_EXPR;
3847 message = _("Actual string length does not match the declared one"
3848 " for dummy argument '%s' (%ld/%ld)");
3850 else if (fsym->as && fsym->as->rank != 0)
3854 comparison = LT_EXPR;
3855 message = _("Actual string length is shorter than the declared one"
3856 " for dummy argument '%s' (%ld/%ld)");
3859 /* Build the condition. For optional arguments, an actual length
3860 of 0 is also acceptable if the associated string is NULL, which
3861 means the argument was not passed. */
3862 cond = fold_build2 (comparison, boolean_type_node,
3863 cl->passed_length, cl->backend_decl);
3864 if (fsym->attr.optional)
3870 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3872 fold_convert (gfc_charlen_type_node,
3873 integer_zero_node));
3874 not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3875 fsym->backend_decl, null_pointer_node);
3877 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3878 not_0length, not_absent);
3880 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3881 cond, absent_failed);
3884 /* Build the runtime check. */
3885 argname = gfc_build_cstring_const (fsym->name);
3886 argname = gfc_build_addr_expr (pchar_type_node, argname);
3887 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3889 fold_convert (long_integer_type_node,
3891 fold_convert (long_integer_type_node,
3898 create_main_function (tree fndecl)
3902 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3905 old_context = current_function_decl;
3909 push_function_context ();
3910 saved_parent_function_decls = saved_function_decls;
3911 saved_function_decls = NULL_TREE;
3914 /* main() function must be declared with global scope. */
3915 gcc_assert (current_function_decl == NULL_TREE);
3917 /* Declare the function. */
3918 tmp = build_function_type_list (integer_type_node, integer_type_node,
3919 build_pointer_type (pchar_type_node),
3921 main_identifier_node = get_identifier ("main");
3922 ftn_main = build_decl (input_location, FUNCTION_DECL,
3923 main_identifier_node, tmp);
3924 DECL_EXTERNAL (ftn_main) = 0;
3925 TREE_PUBLIC (ftn_main) = 1;
3926 TREE_STATIC (ftn_main) = 1;
3927 DECL_ATTRIBUTES (ftn_main)
3928 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
3930 /* Setup the result declaration (for "return 0"). */
3931 result_decl = build_decl (input_location,
3932 RESULT_DECL, NULL_TREE, integer_type_node);
3933 DECL_ARTIFICIAL (result_decl) = 1;
3934 DECL_IGNORED_P (result_decl) = 1;
3935 DECL_CONTEXT (result_decl) = ftn_main;
3936 DECL_RESULT (ftn_main) = result_decl;
3938 pushdecl (ftn_main);
3940 /* Get the arguments. */
3942 arglist = NULL_TREE;
3943 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
3945 tmp = TREE_VALUE (typelist);
3946 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
3947 DECL_CONTEXT (argc) = ftn_main;
3948 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
3949 TREE_READONLY (argc) = 1;
3950 gfc_finish_decl (argc);
3951 arglist = chainon (arglist, argc);
3953 typelist = TREE_CHAIN (typelist);
3954 tmp = TREE_VALUE (typelist);
3955 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
3956 DECL_CONTEXT (argv) = ftn_main;
3957 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
3958 TREE_READONLY (argv) = 1;
3959 DECL_BY_REFERENCE (argv) = 1;
3960 gfc_finish_decl (argv);
3961 arglist = chainon (arglist, argv);
3963 DECL_ARGUMENTS (ftn_main) = arglist;
3964 current_function_decl = ftn_main;
3965 announce_function (ftn_main);
3967 rest_of_decl_compilation (ftn_main, 1, 0);
3968 make_decl_rtl (ftn_main);
3969 init_function_start (ftn_main);
3972 gfc_init_block (&body);
3974 /* Call some libgfortran initialization routines, call then MAIN__(). */
3976 /* Call _gfortran_set_args (argc, argv). */
3977 TREE_USED (argc) = 1;
3978 TREE_USED (argv) = 1;
3979 tmp = build_call_expr_loc (input_location,
3980 gfor_fndecl_set_args, 2, argc, argv);
3981 gfc_add_expr_to_block (&body, tmp);
3983 /* Add a call to set_options to set up the runtime library Fortran
3984 language standard parameters. */
3986 tree array_type, array, var;
3988 /* Passing a new option to the library requires four modifications:
3989 + add it to the tree_cons list below
3990 + change the array size in the call to build_array_type
3991 + change the first argument to the library call
3992 gfor_fndecl_set_options
3993 + modify the library (runtime/compile_options.c)! */
3995 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3996 gfc_option.warn_std), NULL_TREE);
3997 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3998 gfc_option.allow_std), array);
3999 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4001 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4002 gfc_option.flag_dump_core), array);
4003 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4004 gfc_option.flag_backtrace), array);
4005 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4006 gfc_option.flag_sign_zero), array);
4008 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4009 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4011 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4012 gfc_option.flag_range_check), array);
4014 array_type = build_array_type (integer_type_node,
4015 build_index_type (build_int_cst (NULL_TREE, 7)));
4016 array = build_constructor_from_list (array_type, nreverse (array));
4017 TREE_CONSTANT (array) = 1;
4018 TREE_STATIC (array) = 1;
4020 /* Create a static variable to hold the jump table. */
4021 var = gfc_create_var (array_type, "options");
4022 TREE_CONSTANT (var) = 1;
4023 TREE_STATIC (var) = 1;
4024 TREE_READONLY (var) = 1;
4025 DECL_INITIAL (var) = array;
4026 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4028 tmp = build_call_expr_loc (input_location,
4029 gfor_fndecl_set_options, 2,
4030 build_int_cst (integer_type_node, 8), var);
4031 gfc_add_expr_to_block (&body, tmp);
4034 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4035 the library will raise a FPE when needed. */
4036 if (gfc_option.fpe != 0)
4038 tmp = build_call_expr_loc (input_location,
4039 gfor_fndecl_set_fpe, 1,
4040 build_int_cst (integer_type_node,
4042 gfc_add_expr_to_block (&body, tmp);
4045 /* If this is the main program and an -fconvert option was provided,
4046 add a call to set_convert. */
4048 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4050 tmp = build_call_expr_loc (input_location,
4051 gfor_fndecl_set_convert, 1,
4052 build_int_cst (integer_type_node,
4053 gfc_option.convert));
4054 gfc_add_expr_to_block (&body, tmp);
4057 /* If this is the main program and an -frecord-marker option was provided,
4058 add a call to set_record_marker. */
4060 if (gfc_option.record_marker != 0)
4062 tmp = build_call_expr_loc (input_location,
4063 gfor_fndecl_set_record_marker, 1,
4064 build_int_cst (integer_type_node,
4065 gfc_option.record_marker));
4066 gfc_add_expr_to_block (&body, tmp);
4069 if (gfc_option.max_subrecord_length != 0)
4071 tmp = build_call_expr_loc (input_location,
4072 gfor_fndecl_set_max_subrecord_length, 1,
4073 build_int_cst (integer_type_node,
4074 gfc_option.max_subrecord_length));
4075 gfc_add_expr_to_block (&body, tmp);
4078 /* Call MAIN__(). */
4079 tmp = build_call_expr_loc (input_location,
4081 gfc_add_expr_to_block (&body, tmp);
4083 /* Mark MAIN__ as used. */
4084 TREE_USED (fndecl) = 1;
4087 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4088 build_int_cst (integer_type_node, 0));
4089 tmp = build1_v (RETURN_EXPR, tmp);
4090 gfc_add_expr_to_block (&body, tmp);
4093 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4096 /* Finish off this function and send it for code generation. */
4098 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4100 DECL_SAVED_TREE (ftn_main)
4101 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4102 DECL_INITIAL (ftn_main));
4104 /* Output the GENERIC tree. */
4105 dump_function (TDI_original, ftn_main);
4107 cgraph_finalize_function (ftn_main, false);
4111 pop_function_context ();
4112 saved_function_decls = saved_parent_function_decls;
4114 current_function_decl = old_context;
4118 /* Generate code for a function. */
4121 gfc_generate_function_code (gfc_namespace * ns)
4131 tree recurcheckvar = NULL;
4136 sym = ns->proc_name;
4138 /* Check that the frontend isn't still using this. */
4139 gcc_assert (sym->tlink == NULL);
4142 /* Create the declaration for functions with global scope. */
4143 if (!sym->backend_decl)
4144 gfc_create_function_decl (ns);
4146 fndecl = sym->backend_decl;
4147 old_context = current_function_decl;
4151 push_function_context ();
4152 saved_parent_function_decls = saved_function_decls;
4153 saved_function_decls = NULL_TREE;
4156 trans_function_start (sym);
4158 gfc_init_block (&block);
4160 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4162 /* Copy length backend_decls to all entry point result
4167 gfc_conv_const_charlen (ns->proc_name->ts.cl);
4168 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4169 for (el = ns->entries; el; el = el->next)
4170 el->sym->result->ts.cl->backend_decl = backend_decl;
4173 /* Translate COMMON blocks. */
4174 gfc_trans_common (ns);
4176 /* Null the parent fake result declaration if this namespace is
4177 a module function or an external procedures. */
4178 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4179 || ns->parent == NULL)
4180 parent_fake_result_decl = NULL_TREE;
4182 gfc_generate_contained_functions (ns);
4184 nonlocal_dummy_decls = NULL;
4185 nonlocal_dummy_decl_pset = NULL;
4187 generate_local_vars (ns);
4189 /* Keep the parent fake result declaration in module functions
4190 or external procedures. */
4191 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4192 || ns->parent == NULL)
4193 current_fake_result_decl = parent_fake_result_decl;
4195 current_fake_result_decl = NULL_TREE;
4197 current_function_return_label = NULL;
4199 /* Now generate the code for the body of this function. */
4200 gfc_init_block (&body);
4202 is_recursive = sym->attr.recursive
4203 || (sym->attr.entry_master
4204 && sym->ns->entries->sym->attr.recursive);
4205 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4209 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4211 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4212 TREE_STATIC (recurcheckvar) = 1;
4213 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4214 gfc_add_expr_to_block (&block, recurcheckvar);
4215 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4216 &sym->declared_at, msg);
4217 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4221 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4222 && sym->attr.subroutine)
4224 tree alternate_return;
4225 alternate_return = gfc_get_fake_result_decl (sym, 0);
4226 gfc_add_modify (&body, alternate_return, integer_zero_node);
4231 /* Jump to the correct entry point. */
4232 tmp = gfc_trans_entry_master_switch (ns->entries);
4233 gfc_add_expr_to_block (&body, tmp);
4236 /* If bounds-checking is enabled, generate code to check passed in actual
4237 arguments against the expected dummy argument attributes (e.g. string
4239 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4240 add_argument_checking (&body, sym);
4242 tmp = gfc_trans_code (ns->code);
4243 gfc_add_expr_to_block (&body, tmp);
4245 /* Add a return label if needed. */
4246 if (current_function_return_label)
4248 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4249 gfc_add_expr_to_block (&body, tmp);
4252 tmp = gfc_finish_block (&body);
4253 /* Add code to create and cleanup arrays. */
4254 tmp = gfc_trans_deferred_vars (sym, tmp);
4256 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4258 if (sym->attr.subroutine || sym == sym->result)
4260 if (current_fake_result_decl != NULL)
4261 result = TREE_VALUE (current_fake_result_decl);
4264 current_fake_result_decl = NULL_TREE;
4267 result = sym->result->backend_decl;
4269 if (result != NULL_TREE && sym->attr.function
4270 && sym->ts.type == BT_DERIVED
4271 && sym->ts.derived->attr.alloc_comp
4272 && !sym->attr.pointer)
4274 rank = sym->as ? sym->as->rank : 0;
4275 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4276 gfc_add_expr_to_block (&block, tmp2);
4279 gfc_add_expr_to_block (&block, tmp);
4281 /* Reset recursion-check variable. */
4282 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4284 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4285 recurcheckvar = NULL;
4288 if (result == NULL_TREE)
4290 /* TODO: move to the appropriate place in resolve.c. */
4291 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4292 gfc_warning ("Return value of function '%s' at %L not set",
4293 sym->name, &sym->declared_at);
4295 TREE_NO_WARNING(sym->backend_decl) = 1;
4299 /* Set the return value to the dummy result variable. The
4300 types may be different for scalar default REAL functions
4301 with -ff2c, therefore we have to convert. */
4302 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4303 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4304 DECL_RESULT (fndecl), tmp);
4305 tmp = build1_v (RETURN_EXPR, tmp);
4306 gfc_add_expr_to_block (&block, tmp);
4311 gfc_add_expr_to_block (&block, tmp);
4312 /* Reset recursion-check variable. */
4313 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4315 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4316 recurcheckvar = NULL;
4321 /* Add all the decls we created during processing. */
4322 decl = saved_function_decls;
4327 next = TREE_CHAIN (decl);
4328 TREE_CHAIN (decl) = NULL_TREE;
4332 saved_function_decls = NULL_TREE;
4334 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4337 /* Finish off this function and send it for code generation. */
4339 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4341 DECL_SAVED_TREE (fndecl)
4342 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4343 DECL_INITIAL (fndecl));
4345 if (nonlocal_dummy_decls)
4347 BLOCK_VARS (DECL_INITIAL (fndecl))
4348 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4349 pointer_set_destroy (nonlocal_dummy_decl_pset);
4350 nonlocal_dummy_decls = NULL;
4351 nonlocal_dummy_decl_pset = NULL;
4354 /* Output the GENERIC tree. */
4355 dump_function (TDI_original, fndecl);
4357 /* Store the end of the function, so that we get good line number
4358 info for the epilogue. */
4359 cfun->function_end_locus = input_location;
4361 /* We're leaving the context of this function, so zap cfun.
4362 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4363 tree_rest_of_compilation. */
4368 pop_function_context ();
4369 saved_function_decls = saved_parent_function_decls;
4371 current_function_decl = old_context;
4373 if (decl_function_context (fndecl))
4374 /* Register this function with cgraph just far enough to get it
4375 added to our parent's nested function list. */
4376 (void) cgraph_node (fndecl);
4378 cgraph_finalize_function (fndecl, false);
4380 gfc_trans_use_stmts (ns);
4381 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4383 if (sym->attr.is_main_program)
4384 create_main_function (fndecl);
4389 gfc_generate_constructors (void)
4391 gcc_assert (gfc_static_ctors == NULL_TREE);
4399 if (gfc_static_ctors == NULL_TREE)
4402 fnname = get_file_function_name ("I");
4403 type = build_function_type (void_type_node,
4404 gfc_chainon_list (NULL_TREE, void_type_node));
4406 fndecl = build_decl (input_location,
4407 FUNCTION_DECL, fnname, type);
4408 TREE_PUBLIC (fndecl) = 1;
4410 decl = build_decl (input_location,
4411 RESULT_DECL, NULL_TREE, void_type_node);
4412 DECL_ARTIFICIAL (decl) = 1;
4413 DECL_IGNORED_P (decl) = 1;
4414 DECL_CONTEXT (decl) = fndecl;
4415 DECL_RESULT (fndecl) = decl;
4419 current_function_decl = fndecl;
4421 rest_of_decl_compilation (fndecl, 1, 0);
4423 make_decl_rtl (fndecl);
4425 init_function_start (fndecl);
4429 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4431 tmp = build_call_expr_loc (input_location,
4432 TREE_VALUE (gfc_static_ctors), 0);
4433 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4439 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4440 DECL_SAVED_TREE (fndecl)
4441 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4442 DECL_INITIAL (fndecl));
4444 free_after_parsing (cfun);
4445 free_after_compilation (cfun);
4447 tree_rest_of_compilation (fndecl);
4449 current_function_decl = NULL_TREE;
4453 /* Translates a BLOCK DATA program unit. This means emitting the
4454 commons contained therein plus their initializations. We also emit
4455 a globally visible symbol to make sure that each BLOCK DATA program
4456 unit remains unique. */
4459 gfc_generate_block_data (gfc_namespace * ns)
4464 /* Tell the backend the source location of the block data. */
4466 gfc_set_backend_locus (&ns->proc_name->declared_at);
4468 gfc_set_backend_locus (&gfc_current_locus);
4470 /* Process the DATA statements. */
4471 gfc_trans_common (ns);
4473 /* Create a global symbol with the mane of the block data. This is to
4474 generate linker errors if the same name is used twice. It is never
4477 id = gfc_sym_mangled_function_id (ns->proc_name);
4479 id = get_identifier ("__BLOCK_DATA__");
4481 decl = build_decl (input_location,
4482 VAR_DECL, id, gfc_array_index_type);
4483 TREE_PUBLIC (decl) = 1;
4484 TREE_STATIC (decl) = 1;
4485 DECL_IGNORED_P (decl) = 1;
4488 rest_of_decl_compilation (decl, 1, 0);
4492 #include "gt-fortran-trans-decl.h"