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 (ptr_decl);
413 /* Check to see if we're dealing with a variable-sized array. */
414 if (sym->attr.dimension
415 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
417 /* These decls will be dereferenced later, so we don't dereference
419 value = convert (TREE_TYPE (decl), ptr_decl);
423 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
425 value = build_fold_indirect_ref (ptr_decl);
428 SET_DECL_VALUE_EXPR (decl, value);
429 DECL_HAS_VALUE_EXPR_P (decl) = 1;
430 GFC_DECL_CRAY_POINTEE (decl) = 1;
431 /* This is a fake variable just for debugging purposes. */
432 TREE_ASM_WRITTEN (decl) = 1;
436 /* Finish processing of a declaration without an initial value. */
439 gfc_finish_decl (tree decl)
441 gcc_assert (TREE_CODE (decl) == PARM_DECL
442 || DECL_INITIAL (decl) == NULL_TREE);
444 if (TREE_CODE (decl) != VAR_DECL)
447 if (DECL_SIZE (decl) == NULL_TREE
448 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
449 layout_decl (decl, 0);
451 /* A few consistency checks. */
452 /* A static variable with an incomplete type is an error if it is
453 initialized. Also if it is not file scope. Otherwise, let it
454 through, but if it is not `extern' then it may cause an error
456 /* An automatic variable with an incomplete type is an error. */
458 /* We should know the storage size. */
459 gcc_assert (DECL_SIZE (decl) != NULL_TREE
460 || (TREE_STATIC (decl)
461 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
462 : DECL_EXTERNAL (decl)));
464 /* The storage size should be constant. */
465 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
467 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
471 /* Apply symbol attributes to a variable, and add it to the function scope. */
474 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
477 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
478 This is the equivalent of the TARGET variables.
479 We also need to set this if the variable is passed by reference in a
482 /* Set DECL_VALUE_EXPR for Cray Pointees. */
483 if (sym->attr.cray_pointee)
484 gfc_finish_cray_pointee (decl, sym);
486 if (sym->attr.target)
487 TREE_ADDRESSABLE (decl) = 1;
488 /* If it wasn't used we wouldn't be getting it. */
489 TREE_USED (decl) = 1;
491 /* Chain this decl to the pending declarations. Don't do pushdecl()
492 because this would add them to the current scope rather than the
494 if (current_function_decl != NULL_TREE)
496 if (sym->ns->proc_name->backend_decl == current_function_decl
497 || sym->result == sym)
498 gfc_add_decl_to_function (decl);
500 gfc_add_decl_to_parent_function (decl);
503 if (sym->attr.cray_pointee)
506 if(sym->attr.is_bind_c == 1)
508 /* We need to put variables that are bind(c) into the common
509 segment of the object file, because this is what C would do.
510 gfortran would typically put them in either the BSS or
511 initialized data segments, and only mark them as common if
512 they were part of common blocks. However, if they are not put
513 into common space, then C cannot initialize global fortran
514 variables that it interoperates with and the draft says that
515 either Fortran or C should be able to initialize it (but not
516 both, of course.) (J3/04-007, section 15.3). */
517 TREE_PUBLIC(decl) = 1;
518 DECL_COMMON(decl) = 1;
521 /* If a variable is USE associated, it's always external. */
522 if (sym->attr.use_assoc)
524 DECL_EXTERNAL (decl) = 1;
525 TREE_PUBLIC (decl) = 1;
527 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
529 /* TODO: Don't set sym->module for result or dummy variables. */
530 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
531 /* This is the declaration of a module variable. */
532 TREE_PUBLIC (decl) = 1;
533 TREE_STATIC (decl) = 1;
536 /* Derived types are a bit peculiar because of the possibility of
537 a default initializer; this must be applied each time the variable
538 comes into scope it therefore need not be static. These variables
539 are SAVE_NONE but have an initializer. Otherwise explicitly
540 initialized variables are SAVE_IMPLICIT and explicitly saved are
542 if (!sym->attr.use_assoc
543 && (sym->attr.save != SAVE_NONE || sym->attr.data
544 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
545 TREE_STATIC (decl) = 1;
547 if (sym->attr.volatile_)
549 TREE_THIS_VOLATILE (decl) = 1;
550 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
551 TREE_TYPE (decl) = new_type;
554 /* Keep variables larger than max-stack-var-size off stack. */
555 if (!sym->ns->proc_name->attr.recursive
556 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
557 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
558 /* Put variable length auto array pointers always into stack. */
559 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
560 || sym->attr.dimension == 0
561 || sym->as->type != AS_EXPLICIT
563 || sym->attr.allocatable)
564 && !DECL_ARTIFICIAL (decl))
565 TREE_STATIC (decl) = 1;
567 /* Handle threadprivate variables. */
568 if (sym->attr.threadprivate
569 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
570 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
574 /* Allocate the lang-specific part of a decl. */
577 gfc_allocate_lang_decl (tree decl)
579 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
580 ggc_alloc_cleared (sizeof (struct lang_decl));
583 /* Remember a symbol to generate initialization/cleanup code at function
587 gfc_defer_symbol_init (gfc_symbol * sym)
593 /* Don't add a symbol twice. */
597 last = head = sym->ns->proc_name;
600 /* Make sure that setup code for dummy variables which are used in the
601 setup of other variables is generated first. */
604 /* Find the first dummy arg seen after us, or the first non-dummy arg.
605 This is a circular list, so don't go past the head. */
607 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
613 /* Insert in between last and p. */
619 /* Create an array index type variable with function scope. */
622 create_index_var (const char * pfx, int nest)
626 decl = gfc_create_var_np (gfc_array_index_type, pfx);
628 gfc_add_decl_to_parent_function (decl);
630 gfc_add_decl_to_function (decl);
635 /* Create variables to hold all the non-constant bits of info for a
636 descriptorless array. Remember these in the lang-specific part of the
640 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
646 type = TREE_TYPE (decl);
648 /* We just use the descriptor, if there is one. */
649 if (GFC_DESCRIPTOR_TYPE_P (type))
652 gcc_assert (GFC_ARRAY_TYPE_P (type));
653 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
654 && !sym->attr.contained;
656 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
658 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
660 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
661 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
663 /* Don't try to use the unknown bound for assumed shape arrays. */
664 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
665 && (sym->as->type != AS_ASSUMED_SIZE
666 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
668 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
669 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
672 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
674 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
675 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
678 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
680 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
682 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
685 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
687 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
690 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
691 && sym->as->type != AS_ASSUMED_SIZE)
693 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
694 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
697 if (POINTER_TYPE_P (type))
699 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
700 gcc_assert (TYPE_LANG_SPECIFIC (type)
701 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
702 type = TREE_TYPE (type);
705 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
709 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
710 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
711 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
713 TYPE_DOMAIN (type) = range;
717 if (TYPE_NAME (type) != NULL_TREE
718 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
719 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
721 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
723 for (dim = 0; dim < sym->as->rank - 1; dim++)
725 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
726 gtype = TREE_TYPE (gtype);
728 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
729 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
730 TYPE_NAME (type) = NULL_TREE;
733 if (TYPE_NAME (type) == NULL_TREE)
735 tree gtype = TREE_TYPE (type), rtype, type_decl;
737 for (dim = sym->as->rank - 1; dim >= 0; dim--)
739 rtype = build_range_type (gfc_array_index_type,
740 GFC_TYPE_ARRAY_LBOUND (type, dim),
741 GFC_TYPE_ARRAY_UBOUND (type, dim));
742 gtype = build_array_type (gtype, rtype);
743 /* Ensure the bound variables aren't optimized out at -O0. */
746 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
747 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
748 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
749 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
750 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
751 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
754 TYPE_NAME (type) = type_decl = build_decl (input_location,
755 TYPE_DECL, NULL, gtype);
756 DECL_ORIGINAL_TYPE (type_decl) = gtype;
761 /* For some dummy arguments we don't use the actual argument directly.
762 Instead we create a local decl and use that. This allows us to perform
763 initialization, and construct full type information. */
766 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
776 if (sym->attr.pointer || sym->attr.allocatable)
779 /* Add to list of variables if not a fake result variable. */
780 if (sym->attr.result || sym->attr.dummy)
781 gfc_defer_symbol_init (sym);
783 type = TREE_TYPE (dummy);
784 gcc_assert (TREE_CODE (dummy) == PARM_DECL
785 && POINTER_TYPE_P (type));
787 /* Do we know the element size? */
788 known_size = sym->ts.type != BT_CHARACTER
789 || INTEGER_CST_P (sym->ts.cl->backend_decl);
791 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
793 /* For descriptorless arrays with known element size the actual
794 argument is sufficient. */
795 gcc_assert (GFC_ARRAY_TYPE_P (type));
796 gfc_build_qualified_array (dummy, sym);
800 type = TREE_TYPE (type);
801 if (GFC_DESCRIPTOR_TYPE_P (type))
803 /* Create a descriptorless array pointer. */
807 /* Even when -frepack-arrays is used, symbols with TARGET attribute
809 if (!gfc_option.flag_repack_arrays || sym->attr.target)
811 if (as->type == AS_ASSUMED_SIZE)
812 packed = PACKED_FULL;
816 if (as->type == AS_EXPLICIT)
818 packed = PACKED_FULL;
819 for (n = 0; n < as->rank; n++)
823 && as->upper[n]->expr_type == EXPR_CONSTANT
824 && as->lower[n]->expr_type == EXPR_CONSTANT))
825 packed = PACKED_PARTIAL;
829 packed = PACKED_PARTIAL;
832 type = gfc_typenode_for_spec (&sym->ts);
833 type = gfc_get_nodesc_array_type (type, sym->as, packed);
837 /* We now have an expression for the element size, so create a fully
838 qualified type. Reset sym->backend decl or this will just return the
840 DECL_ARTIFICIAL (sym->backend_decl) = 1;
841 sym->backend_decl = NULL_TREE;
842 type = gfc_sym_type (sym);
843 packed = PACKED_FULL;
846 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
847 decl = build_decl (input_location,
848 VAR_DECL, get_identifier (name), type);
850 DECL_ARTIFICIAL (decl) = 1;
851 TREE_PUBLIC (decl) = 0;
852 TREE_STATIC (decl) = 0;
853 DECL_EXTERNAL (decl) = 0;
855 /* We should never get deferred shape arrays here. We used to because of
857 gcc_assert (sym->as->type != AS_DEFERRED);
859 if (packed == PACKED_PARTIAL)
860 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
861 else if (packed == PACKED_FULL)
862 GFC_DECL_PACKED_ARRAY (decl) = 1;
864 gfc_build_qualified_array (decl, sym);
866 if (DECL_LANG_SPECIFIC (dummy))
867 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
869 gfc_allocate_lang_decl (decl);
871 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
873 if (sym->ns->proc_name->backend_decl == current_function_decl
874 || sym->attr.contained)
875 gfc_add_decl_to_function (decl);
877 gfc_add_decl_to_parent_function (decl);
882 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
883 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
884 pointing to the artificial variable for debug info purposes. */
887 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
891 if (! nonlocal_dummy_decl_pset)
892 nonlocal_dummy_decl_pset = pointer_set_create ();
894 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
897 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
898 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
899 TREE_TYPE (sym->backend_decl));
900 DECL_ARTIFICIAL (decl) = 0;
901 TREE_USED (decl) = 1;
902 TREE_PUBLIC (decl) = 0;
903 TREE_STATIC (decl) = 0;
904 DECL_EXTERNAL (decl) = 0;
905 if (DECL_BY_REFERENCE (dummy))
906 DECL_BY_REFERENCE (decl) = 1;
907 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
908 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
909 DECL_HAS_VALUE_EXPR_P (decl) = 1;
910 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
911 TREE_CHAIN (decl) = nonlocal_dummy_decls;
912 nonlocal_dummy_decls = decl;
915 /* Return a constant or a variable to use as a string length. Does not
916 add the decl to the current scope. */
919 gfc_create_string_length (gfc_symbol * sym)
921 gcc_assert (sym->ts.cl);
922 gfc_conv_const_charlen (sym->ts.cl);
924 if (sym->ts.cl->backend_decl == NULL_TREE)
927 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
929 /* Also prefix the mangled name. */
930 strcpy (&name[1], sym->name);
932 length = build_decl (input_location,
933 VAR_DECL, get_identifier (name),
934 gfc_charlen_type_node);
935 DECL_ARTIFICIAL (length) = 1;
936 TREE_USED (length) = 1;
937 if (sym->ns->proc_name->tlink != NULL)
938 gfc_defer_symbol_init (sym);
940 sym->ts.cl->backend_decl = length;
943 gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
944 return sym->ts.cl->backend_decl;
947 /* If a variable is assigned a label, we add another two auxiliary
951 gfc_add_assign_aux_vars (gfc_symbol * sym)
957 gcc_assert (sym->backend_decl);
959 decl = sym->backend_decl;
960 gfc_allocate_lang_decl (decl);
961 GFC_DECL_ASSIGN (decl) = 1;
962 length = build_decl (input_location,
963 VAR_DECL, create_tmp_var_name (sym->name),
964 gfc_charlen_type_node);
965 addr = build_decl (input_location,
966 VAR_DECL, create_tmp_var_name (sym->name),
968 gfc_finish_var_decl (length, sym);
969 gfc_finish_var_decl (addr, sym);
970 /* STRING_LENGTH is also used as flag. Less than -1 means that
971 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
972 target label's address. Otherwise, value is the length of a format string
973 and ASSIGN_ADDR is its address. */
974 if (TREE_STATIC (length))
975 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
977 gfc_defer_symbol_init (sym);
979 GFC_DECL_STRING_LEN (decl) = length;
980 GFC_DECL_ASSIGN_ADDR (decl) = addr;
983 /* Return the decl for a gfc_symbol, create it if it doesn't already
987 gfc_get_symbol_decl (gfc_symbol * sym)
990 tree length = NULL_TREE;
993 gcc_assert (sym->attr.referenced
994 || sym->attr.use_assoc
995 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
997 if (sym->ns && sym->ns->proc_name->attr.function)
998 byref = gfc_return_by_reference (sym->ns->proc_name);
1002 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1004 /* Return via extra parameter. */
1005 if (sym->attr.result && byref
1006 && !sym->backend_decl)
1009 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1010 /* For entry master function skip over the __entry
1012 if (sym->ns->proc_name->attr.entry_master)
1013 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1016 /* Dummy variables should already have been created. */
1017 gcc_assert (sym->backend_decl);
1019 /* Create a character length variable. */
1020 if (sym->ts.type == BT_CHARACTER)
1022 if (sym->ts.cl->backend_decl == NULL_TREE)
1023 length = gfc_create_string_length (sym);
1025 length = sym->ts.cl->backend_decl;
1026 if (TREE_CODE (length) == VAR_DECL
1027 && DECL_CONTEXT (length) == NULL_TREE)
1029 /* Add the string length to the same context as the symbol. */
1030 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1031 gfc_add_decl_to_function (length);
1033 gfc_add_decl_to_parent_function (length);
1035 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1036 DECL_CONTEXT (length));
1038 gfc_defer_symbol_init (sym);
1042 /* Use a copy of the descriptor for dummy arrays. */
1043 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1045 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1046 /* Prevent the dummy from being detected as unused if it is copied. */
1047 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1048 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1049 sym->backend_decl = decl;
1052 TREE_USED (sym->backend_decl) = 1;
1053 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1055 gfc_add_assign_aux_vars (sym);
1058 if (sym->attr.dimension
1059 && DECL_LANG_SPECIFIC (sym->backend_decl)
1060 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1061 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1062 gfc_nonlocal_dummy_array_decl (sym);
1064 return sym->backend_decl;
1067 if (sym->backend_decl)
1068 return sym->backend_decl;
1070 /* Catch function declarations. Only used for actual parameters and
1071 procedure pointers. */
1072 if (sym->attr.flavor == FL_PROCEDURE)
1074 decl = gfc_get_extern_function_decl (sym);
1075 gfc_set_decl_location (decl, &sym->declared_at);
1079 if (sym->attr.intrinsic)
1080 internal_error ("intrinsic variable which isn't a procedure");
1082 /* Create string length decl first so that they can be used in the
1083 type declaration. */
1084 if (sym->ts.type == BT_CHARACTER)
1085 length = gfc_create_string_length (sym);
1087 /* Create the decl for the variable. */
1088 decl = build_decl (sym->declared_at.lb->location,
1089 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1091 /* Symbols from modules should have their assembler names mangled.
1092 This is done here rather than in gfc_finish_var_decl because it
1093 is different for string length variables. */
1096 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1097 if (sym->attr.use_assoc)
1098 DECL_IGNORED_P (decl) = 1;
1101 if (sym->attr.dimension)
1103 /* Create variables to hold the non-constant bits of array info. */
1104 gfc_build_qualified_array (decl, sym);
1106 /* Remember this variable for allocation/cleanup. */
1107 gfc_defer_symbol_init (sym);
1109 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1110 GFC_DECL_PACKED_ARRAY (decl) = 1;
1113 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1114 gfc_defer_symbol_init (sym);
1115 /* This applies a derived type default initializer. */
1116 else if (sym->ts.type == BT_DERIVED
1117 && sym->attr.save == SAVE_NONE
1119 && !sym->attr.allocatable
1120 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1121 && !sym->attr.use_assoc)
1122 gfc_defer_symbol_init (sym);
1124 gfc_finish_var_decl (decl, sym);
1126 if (sym->ts.type == BT_CHARACTER)
1128 /* Character variables need special handling. */
1129 gfc_allocate_lang_decl (decl);
1131 if (TREE_CODE (length) != INTEGER_CST)
1133 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1137 /* Also prefix the mangled name for symbols from modules. */
1138 strcpy (&name[1], sym->name);
1141 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1142 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1144 gfc_finish_var_decl (length, sym);
1145 gcc_assert (!sym->value);
1148 else if (sym->attr.subref_array_pointer)
1150 /* We need the span for these beasts. */
1151 gfc_allocate_lang_decl (decl);
1154 if (sym->attr.subref_array_pointer)
1157 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1158 span = build_decl (input_location,
1159 VAR_DECL, create_tmp_var_name ("span"),
1160 gfc_array_index_type);
1161 gfc_finish_var_decl (span, sym);
1162 TREE_STATIC (span) = TREE_STATIC (decl);
1163 DECL_ARTIFICIAL (span) = 1;
1164 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1166 GFC_DECL_SPAN (decl) = span;
1167 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1170 sym->backend_decl = decl;
1172 if (sym->attr.assign)
1173 gfc_add_assign_aux_vars (sym);
1175 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1177 /* Add static initializer. */
1178 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1179 TREE_TYPE (decl), sym->attr.dimension,
1180 sym->attr.pointer || sym->attr.allocatable);
1183 if (!TREE_STATIC (decl)
1184 && POINTER_TYPE_P (TREE_TYPE (decl))
1185 && !sym->attr.pointer
1186 && !sym->attr.allocatable
1187 && !sym->attr.proc_pointer)
1188 DECL_BY_REFERENCE (decl) = 1;
1194 /* Substitute a temporary variable in place of the real one. */
1197 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1199 save->attr = sym->attr;
1200 save->decl = sym->backend_decl;
1202 gfc_clear_attr (&sym->attr);
1203 sym->attr.referenced = 1;
1204 sym->attr.flavor = FL_VARIABLE;
1206 sym->backend_decl = decl;
1210 /* Restore the original variable. */
1213 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1215 sym->attr = save->attr;
1216 sym->backend_decl = save->decl;
1220 /* Declare a procedure pointer. */
1223 get_proc_pointer_decl (gfc_symbol *sym)
1227 decl = sym->backend_decl;
1231 decl = build_decl (input_location,
1232 VAR_DECL, get_identifier (sym->name),
1233 build_pointer_type (gfc_get_function_type (sym)));
1235 if ((sym->ns->proc_name
1236 && sym->ns->proc_name->backend_decl == current_function_decl)
1237 || sym->attr.contained)
1238 gfc_add_decl_to_function (decl);
1239 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1240 gfc_add_decl_to_parent_function (decl);
1242 sym->backend_decl = decl;
1244 /* If a variable is USE associated, it's always external. */
1245 if (sym->attr.use_assoc)
1247 DECL_EXTERNAL (decl) = 1;
1248 TREE_PUBLIC (decl) = 1;
1250 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1252 /* This is the declaration of a module variable. */
1253 TREE_PUBLIC (decl) = 1;
1254 TREE_STATIC (decl) = 1;
1257 if (!sym->attr.use_assoc
1258 && (sym->attr.save != SAVE_NONE || sym->attr.data
1259 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1260 TREE_STATIC (decl) = 1;
1262 if (TREE_STATIC (decl) && sym->value)
1264 /* Add static initializer. */
1265 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1266 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1273 /* Get a basic decl for an external function. */
1276 gfc_get_extern_function_decl (gfc_symbol * sym)
1281 gfc_intrinsic_sym *isym;
1283 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1288 if (sym->backend_decl)
1289 return sym->backend_decl;
1291 /* We should never be creating external decls for alternate entry points.
1292 The procedure may be an alternate entry point, but we don't want/need
1294 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1296 if (sym->attr.proc_pointer)
1297 return get_proc_pointer_decl (sym);
1299 /* See if this is an external procedure from the same file. If so,
1300 return the backend_decl. */
1301 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1303 if (gfc_option.flag_whole_file
1304 && !sym->backend_decl
1306 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1307 && gsym->ns->proc_name->backend_decl)
1309 /* If the namespace has entries, the proc_name is the
1310 entry master. Find the entry and use its backend_decl.
1311 otherwise, use the proc_name backend_decl. */
1312 if (gsym->ns->entries)
1314 gfc_entry_list *entry = gsym->ns->entries;
1316 for (; entry; entry = entry->next)
1318 if (strcmp (gsym->name, entry->sym->name) == 0)
1320 sym->backend_decl = entry->sym->backend_decl;
1327 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1330 if (sym->backend_decl)
1331 return sym->backend_decl;
1334 if (sym->attr.intrinsic)
1336 /* Call the resolution function to get the actual name. This is
1337 a nasty hack which relies on the resolution functions only looking
1338 at the first argument. We pass NULL for the second argument
1339 otherwise things like AINT get confused. */
1340 isym = gfc_find_function (sym->name);
1341 gcc_assert (isym->resolve.f0 != NULL);
1343 memset (&e, 0, sizeof (e));
1344 e.expr_type = EXPR_FUNCTION;
1346 memset (&argexpr, 0, sizeof (argexpr));
1347 gcc_assert (isym->formal);
1348 argexpr.ts = isym->formal->ts;
1350 if (isym->formal->next == NULL)
1351 isym->resolve.f1 (&e, &argexpr);
1354 if (isym->formal->next->next == NULL)
1355 isym->resolve.f2 (&e, &argexpr, NULL);
1358 if (isym->formal->next->next->next == NULL)
1359 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1362 /* All specific intrinsics take less than 5 arguments. */
1363 gcc_assert (isym->formal->next->next->next->next == NULL);
1364 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1369 if (gfc_option.flag_f2c
1370 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1371 || e.ts.type == BT_COMPLEX))
1373 /* Specific which needs a different implementation if f2c
1374 calling conventions are used. */
1375 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1378 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1380 name = get_identifier (s);
1381 mangled_name = name;
1385 name = gfc_sym_identifier (sym);
1386 mangled_name = gfc_sym_mangled_function_id (sym);
1389 type = gfc_get_function_type (sym);
1390 fndecl = build_decl (input_location,
1391 FUNCTION_DECL, name, type);
1393 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1394 /* If the return type is a pointer, avoid alias issues by setting
1395 DECL_IS_MALLOC to nonzero. This means that the function should be
1396 treated as if it were a malloc, meaning it returns a pointer that
1398 if (POINTER_TYPE_P (type))
1399 DECL_IS_MALLOC (fndecl) = 1;
1401 /* Set the context of this decl. */
1402 if (0 && sym->ns && sym->ns->proc_name)
1404 /* TODO: Add external decls to the appropriate scope. */
1405 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1409 /* Global declaration, e.g. intrinsic subroutine. */
1410 DECL_CONTEXT (fndecl) = NULL_TREE;
1413 DECL_EXTERNAL (fndecl) = 1;
1415 /* This specifies if a function is globally addressable, i.e. it is
1416 the opposite of declaring static in C. */
1417 TREE_PUBLIC (fndecl) = 1;
1419 /* Set attributes for PURE functions. A call to PURE function in the
1420 Fortran 95 sense is both pure and without side effects in the C
1422 if (sym->attr.pure || sym->attr.elemental)
1424 if (sym->attr.function && !gfc_return_by_reference (sym))
1425 DECL_PURE_P (fndecl) = 1;
1426 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1427 parameters and don't use alternate returns (is this
1428 allowed?). In that case, calls to them are meaningless, and
1429 can be optimized away. See also in build_function_decl(). */
1430 TREE_SIDE_EFFECTS (fndecl) = 0;
1433 /* Mark non-returning functions. */
1434 if (sym->attr.noreturn)
1435 TREE_THIS_VOLATILE(fndecl) = 1;
1437 sym->backend_decl = fndecl;
1439 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1440 pushdecl_top_level (fndecl);
1446 /* Create a declaration for a procedure. For external functions (in the C
1447 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1448 a master function with alternate entry points. */
1451 build_function_decl (gfc_symbol * sym)
1454 symbol_attribute attr;
1456 gfc_formal_arglist *f;
1458 gcc_assert (!sym->backend_decl);
1459 gcc_assert (!sym->attr.external);
1461 /* Set the line and filename. sym->declared_at seems to point to the
1462 last statement for subroutines, but it'll do for now. */
1463 gfc_set_backend_locus (&sym->declared_at);
1465 /* Allow only one nesting level. Allow public declarations. */
1466 gcc_assert (current_function_decl == NULL_TREE
1467 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1468 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1471 type = gfc_get_function_type (sym);
1472 fndecl = build_decl (input_location,
1473 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1475 /* Perform name mangling if this is a top level or module procedure. */
1476 if (current_function_decl == NULL_TREE)
1477 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1479 /* Figure out the return type of the declared function, and build a
1480 RESULT_DECL for it. If this is a subroutine with alternate
1481 returns, build a RESULT_DECL for it. */
1484 result_decl = NULL_TREE;
1485 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1488 if (gfc_return_by_reference (sym))
1489 type = void_type_node;
1492 if (sym->result != sym)
1493 result_decl = gfc_sym_identifier (sym->result);
1495 type = TREE_TYPE (TREE_TYPE (fndecl));
1500 /* Look for alternate return placeholders. */
1501 int has_alternate_returns = 0;
1502 for (f = sym->formal; f; f = f->next)
1506 has_alternate_returns = 1;
1511 if (has_alternate_returns)
1512 type = integer_type_node;
1514 type = void_type_node;
1517 result_decl = build_decl (input_location,
1518 RESULT_DECL, result_decl, type);
1519 DECL_ARTIFICIAL (result_decl) = 1;
1520 DECL_IGNORED_P (result_decl) = 1;
1521 DECL_CONTEXT (result_decl) = fndecl;
1522 DECL_RESULT (fndecl) = result_decl;
1524 /* Don't call layout_decl for a RESULT_DECL.
1525 layout_decl (result_decl, 0); */
1527 /* If the return type is a pointer, avoid alias issues by setting
1528 DECL_IS_MALLOC to nonzero. This means that the function should be
1529 treated as if it were a malloc, meaning it returns a pointer that
1531 if (POINTER_TYPE_P (type))
1532 DECL_IS_MALLOC (fndecl) = 1;
1534 /* Set up all attributes for the function. */
1535 DECL_CONTEXT (fndecl) = current_function_decl;
1536 DECL_EXTERNAL (fndecl) = 0;
1538 /* This specifies if a function is globally visible, i.e. it is
1539 the opposite of declaring static in C. */
1540 if (DECL_CONTEXT (fndecl) == NULL_TREE
1541 && !sym->attr.entry_master && !sym->attr.is_main_program)
1542 TREE_PUBLIC (fndecl) = 1;
1544 /* TREE_STATIC means the function body is defined here. */
1545 TREE_STATIC (fndecl) = 1;
1547 /* Set attributes for PURE functions. A call to a PURE function in the
1548 Fortran 95 sense is both pure and without side effects in the C
1550 if (attr.pure || attr.elemental)
1552 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1553 including an alternate return. In that case it can also be
1554 marked as PURE. See also in gfc_get_extern_function_decl(). */
1555 if (attr.function && !gfc_return_by_reference (sym))
1556 DECL_PURE_P (fndecl) = 1;
1557 TREE_SIDE_EFFECTS (fndecl) = 0;
1560 /* Layout the function declaration and put it in the binding level
1561 of the current function. */
1564 sym->backend_decl = fndecl;
1568 /* Create the DECL_ARGUMENTS for a procedure. */
1571 create_function_arglist (gfc_symbol * sym)
1574 gfc_formal_arglist *f;
1575 tree typelist, hidden_typelist;
1576 tree arglist, hidden_arglist;
1580 fndecl = sym->backend_decl;
1582 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1583 the new FUNCTION_DECL node. */
1584 arglist = NULL_TREE;
1585 hidden_arglist = NULL_TREE;
1586 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1588 if (sym->attr.entry_master)
1590 type = TREE_VALUE (typelist);
1591 parm = build_decl (input_location,
1592 PARM_DECL, get_identifier ("__entry"), type);
1594 DECL_CONTEXT (parm) = fndecl;
1595 DECL_ARG_TYPE (parm) = type;
1596 TREE_READONLY (parm) = 1;
1597 gfc_finish_decl (parm);
1598 DECL_ARTIFICIAL (parm) = 1;
1600 arglist = chainon (arglist, parm);
1601 typelist = TREE_CHAIN (typelist);
1604 if (gfc_return_by_reference (sym))
1606 tree type = TREE_VALUE (typelist), length = NULL;
1608 if (sym->ts.type == BT_CHARACTER)
1610 /* Length of character result. */
1611 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1612 gcc_assert (len_type == gfc_charlen_type_node);
1614 length = build_decl (input_location,
1616 get_identifier (".__result"),
1618 if (!sym->ts.cl->length)
1620 sym->ts.cl->backend_decl = length;
1621 TREE_USED (length) = 1;
1623 gcc_assert (TREE_CODE (length) == PARM_DECL);
1624 DECL_CONTEXT (length) = fndecl;
1625 DECL_ARG_TYPE (length) = len_type;
1626 TREE_READONLY (length) = 1;
1627 DECL_ARTIFICIAL (length) = 1;
1628 gfc_finish_decl (length);
1629 if (sym->ts.cl->backend_decl == NULL
1630 || sym->ts.cl->backend_decl == length)
1635 if (sym->ts.cl->backend_decl == NULL)
1637 tree len = build_decl (input_location,
1639 get_identifier ("..__result"),
1640 gfc_charlen_type_node);
1641 DECL_ARTIFICIAL (len) = 1;
1642 TREE_USED (len) = 1;
1643 sym->ts.cl->backend_decl = len;
1646 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1647 arg = sym->result ? sym->result : sym;
1648 backend_decl = arg->backend_decl;
1649 /* Temporary clear it, so that gfc_sym_type creates complete
1651 arg->backend_decl = NULL;
1652 type = gfc_sym_type (arg);
1653 arg->backend_decl = backend_decl;
1654 type = build_reference_type (type);
1658 parm = build_decl (input_location,
1659 PARM_DECL, get_identifier ("__result"), type);
1661 DECL_CONTEXT (parm) = fndecl;
1662 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1663 TREE_READONLY (parm) = 1;
1664 DECL_ARTIFICIAL (parm) = 1;
1665 gfc_finish_decl (parm);
1667 arglist = chainon (arglist, parm);
1668 typelist = TREE_CHAIN (typelist);
1670 if (sym->ts.type == BT_CHARACTER)
1672 gfc_allocate_lang_decl (parm);
1673 arglist = chainon (arglist, length);
1674 typelist = TREE_CHAIN (typelist);
1678 hidden_typelist = typelist;
1679 for (f = sym->formal; f; f = f->next)
1680 if (f->sym != NULL) /* Ignore alternate returns. */
1681 hidden_typelist = TREE_CHAIN (hidden_typelist);
1683 for (f = sym->formal; f; f = f->next)
1685 char name[GFC_MAX_SYMBOL_LEN + 2];
1687 /* Ignore alternate returns. */
1691 type = TREE_VALUE (typelist);
1693 if (f->sym->ts.type == BT_CHARACTER)
1695 tree len_type = TREE_VALUE (hidden_typelist);
1696 tree length = NULL_TREE;
1697 gcc_assert (len_type == gfc_charlen_type_node);
1699 strcpy (&name[1], f->sym->name);
1701 length = build_decl (input_location,
1702 PARM_DECL, get_identifier (name), len_type);
1704 hidden_arglist = chainon (hidden_arglist, length);
1705 DECL_CONTEXT (length) = fndecl;
1706 DECL_ARTIFICIAL (length) = 1;
1707 DECL_ARG_TYPE (length) = len_type;
1708 TREE_READONLY (length) = 1;
1709 gfc_finish_decl (length);
1711 /* Remember the passed value. */
1712 if (f->sym->ts.cl->passed_length != NULL)
1714 /* This can happen if the same type is used for multiple
1715 arguments. We need to copy cl as otherwise
1716 cl->passed_length gets overwritten. */
1717 gfc_charlen *cl, *cl2;
1719 f->sym->ts.cl = gfc_get_charlen();
1720 f->sym->ts.cl->length = cl->length;
1721 f->sym->ts.cl->backend_decl = cl->backend_decl;
1722 f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
1723 f->sym->ts.cl->resolved = cl->resolved;
1724 cl2 = f->sym->ts.cl->next;
1725 f->sym->ts.cl->next = cl;
1728 f->sym->ts.cl->passed_length = length;
1730 /* Use the passed value for assumed length variables. */
1731 if (!f->sym->ts.cl->length)
1733 TREE_USED (length) = 1;
1734 gcc_assert (!f->sym->ts.cl->backend_decl);
1735 f->sym->ts.cl->backend_decl = length;
1738 hidden_typelist = TREE_CHAIN (hidden_typelist);
1740 if (f->sym->ts.cl->backend_decl == NULL
1741 || f->sym->ts.cl->backend_decl == length)
1743 if (f->sym->ts.cl->backend_decl == NULL)
1744 gfc_create_string_length (f->sym);
1746 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1747 if (f->sym->attr.flavor == FL_PROCEDURE)
1748 type = build_pointer_type (gfc_get_function_type (f->sym));
1750 type = gfc_sym_type (f->sym);
1754 /* For non-constant length array arguments, make sure they use
1755 a different type node from TYPE_ARG_TYPES type. */
1756 if (f->sym->attr.dimension
1757 && type == TREE_VALUE (typelist)
1758 && TREE_CODE (type) == POINTER_TYPE
1759 && GFC_ARRAY_TYPE_P (type)
1760 && f->sym->as->type != AS_ASSUMED_SIZE
1761 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1763 if (f->sym->attr.flavor == FL_PROCEDURE)
1764 type = build_pointer_type (gfc_get_function_type (f->sym));
1766 type = gfc_sym_type (f->sym);
1769 if (f->sym->attr.proc_pointer)
1770 type = build_pointer_type (type);
1772 /* Build the argument declaration. */
1773 parm = build_decl (input_location,
1774 PARM_DECL, gfc_sym_identifier (f->sym), type);
1776 /* Fill in arg stuff. */
1777 DECL_CONTEXT (parm) = fndecl;
1778 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1779 /* All implementation args are read-only. */
1780 TREE_READONLY (parm) = 1;
1781 if (POINTER_TYPE_P (type)
1782 && (!f->sym->attr.proc_pointer
1783 && f->sym->attr.flavor != FL_PROCEDURE))
1784 DECL_BY_REFERENCE (parm) = 1;
1786 gfc_finish_decl (parm);
1788 f->sym->backend_decl = parm;
1790 arglist = chainon (arglist, parm);
1791 typelist = TREE_CHAIN (typelist);
1794 /* Add the hidden string length parameters, unless the procedure
1796 if (!sym->attr.is_bind_c)
1797 arglist = chainon (arglist, hidden_arglist);
1799 gcc_assert (hidden_typelist == NULL_TREE
1800 || TREE_VALUE (hidden_typelist) == void_type_node);
1801 DECL_ARGUMENTS (fndecl) = arglist;
1804 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1807 gfc_gimplify_function (tree fndecl)
1809 struct cgraph_node *cgn;
1811 gimplify_function_tree (fndecl);
1812 dump_function (TDI_generic, fndecl);
1814 /* Generate errors for structured block violations. */
1815 /* ??? Could be done as part of resolve_labels. */
1817 diagnose_omp_structured_block_errors (fndecl);
1819 /* Convert all nested functions to GIMPLE now. We do things in this order
1820 so that items like VLA sizes are expanded properly in the context of the
1821 correct function. */
1822 cgn = cgraph_node (fndecl);
1823 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1824 gfc_gimplify_function (cgn->decl);
1828 /* Do the setup necessary before generating the body of a function. */
1831 trans_function_start (gfc_symbol * sym)
1835 fndecl = sym->backend_decl;
1837 /* Let GCC know the current scope is this function. */
1838 current_function_decl = fndecl;
1840 /* Let the world know what we're about to do. */
1841 announce_function (fndecl);
1843 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1845 /* Create RTL for function declaration. */
1846 rest_of_decl_compilation (fndecl, 1, 0);
1849 /* Create RTL for function definition. */
1850 make_decl_rtl (fndecl);
1852 init_function_start (fndecl);
1854 /* Even though we're inside a function body, we still don't want to
1855 call expand_expr to calculate the size of a variable-sized array.
1856 We haven't necessarily assigned RTL to all variables yet, so it's
1857 not safe to try to expand expressions involving them. */
1858 cfun->dont_save_pending_sizes_p = 1;
1860 /* function.c requires a push at the start of the function. */
1864 /* Create thunks for alternate entry points. */
1867 build_entry_thunks (gfc_namespace * ns)
1869 gfc_formal_arglist *formal;
1870 gfc_formal_arglist *thunk_formal;
1872 gfc_symbol *thunk_sym;
1880 /* This should always be a toplevel function. */
1881 gcc_assert (current_function_decl == NULL_TREE);
1883 gfc_get_backend_locus (&old_loc);
1884 for (el = ns->entries; el; el = el->next)
1886 thunk_sym = el->sym;
1888 build_function_decl (thunk_sym);
1889 create_function_arglist (thunk_sym);
1891 trans_function_start (thunk_sym);
1893 thunk_fndecl = thunk_sym->backend_decl;
1895 gfc_init_block (&body);
1897 /* Pass extra parameter identifying this entry point. */
1898 tmp = build_int_cst (gfc_array_index_type, el->id);
1899 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1900 string_args = NULL_TREE;
1902 if (thunk_sym->attr.function)
1904 if (gfc_return_by_reference (ns->proc_name))
1906 tree ref = DECL_ARGUMENTS (current_function_decl);
1907 args = tree_cons (NULL_TREE, ref, args);
1908 if (ns->proc_name->ts.type == BT_CHARACTER)
1909 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1914 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1916 /* Ignore alternate returns. */
1917 if (formal->sym == NULL)
1920 /* We don't have a clever way of identifying arguments, so resort to
1921 a brute-force search. */
1922 for (thunk_formal = thunk_sym->formal;
1924 thunk_formal = thunk_formal->next)
1926 if (thunk_formal->sym == formal->sym)
1932 /* Pass the argument. */
1933 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1934 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1936 if (formal->sym->ts.type == BT_CHARACTER)
1938 tmp = thunk_formal->sym->ts.cl->backend_decl;
1939 string_args = tree_cons (NULL_TREE, tmp, string_args);
1944 /* Pass NULL for a missing argument. */
1945 args = tree_cons (NULL_TREE, null_pointer_node, args);
1946 if (formal->sym->ts.type == BT_CHARACTER)
1948 tmp = build_int_cst (gfc_charlen_type_node, 0);
1949 string_args = tree_cons (NULL_TREE, tmp, string_args);
1954 /* Call the master function. */
1955 args = nreverse (args);
1956 args = chainon (args, nreverse (string_args));
1957 tmp = ns->proc_name->backend_decl;
1958 tmp = build_function_call_expr (tmp, args);
1959 if (ns->proc_name->attr.mixed_entry_master)
1961 tree union_decl, field;
1962 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1964 union_decl = build_decl (input_location,
1965 VAR_DECL, get_identifier ("__result"),
1966 TREE_TYPE (master_type));
1967 DECL_ARTIFICIAL (union_decl) = 1;
1968 DECL_EXTERNAL (union_decl) = 0;
1969 TREE_PUBLIC (union_decl) = 0;
1970 TREE_USED (union_decl) = 1;
1971 layout_decl (union_decl, 0);
1972 pushdecl (union_decl);
1974 DECL_CONTEXT (union_decl) = current_function_decl;
1975 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1977 gfc_add_expr_to_block (&body, tmp);
1979 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1980 field; field = TREE_CHAIN (field))
1981 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1982 thunk_sym->result->name) == 0)
1984 gcc_assert (field != NULL_TREE);
1985 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1986 union_decl, field, NULL_TREE);
1987 tmp = fold_build2 (MODIFY_EXPR,
1988 TREE_TYPE (DECL_RESULT (current_function_decl)),
1989 DECL_RESULT (current_function_decl), tmp);
1990 tmp = build1_v (RETURN_EXPR, tmp);
1992 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1995 tmp = fold_build2 (MODIFY_EXPR,
1996 TREE_TYPE (DECL_RESULT (current_function_decl)),
1997 DECL_RESULT (current_function_decl), tmp);
1998 tmp = build1_v (RETURN_EXPR, tmp);
2000 gfc_add_expr_to_block (&body, tmp);
2002 /* Finish off this function and send it for code generation. */
2003 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2006 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2007 DECL_SAVED_TREE (thunk_fndecl)
2008 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2009 DECL_INITIAL (thunk_fndecl));
2011 /* Output the GENERIC tree. */
2012 dump_function (TDI_original, thunk_fndecl);
2014 /* Store the end of the function, so that we get good line number
2015 info for the epilogue. */
2016 cfun->function_end_locus = input_location;
2018 /* We're leaving the context of this function, so zap cfun.
2019 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2020 tree_rest_of_compilation. */
2023 current_function_decl = NULL_TREE;
2025 gfc_gimplify_function (thunk_fndecl);
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 (gfor_fndecl_set_args, 2, argc, argv);
3980 gfc_add_expr_to_block (&body, tmp);
3982 /* Add a call to set_options to set up the runtime library Fortran
3983 language standard parameters. */
3985 tree array_type, array, var;
3987 /* Passing a new option to the library requires four modifications:
3988 + add it to the tree_cons list below
3989 + change the array size in the call to build_array_type
3990 + change the first argument to the library call
3991 gfor_fndecl_set_options
3992 + modify the library (runtime/compile_options.c)! */
3994 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3995 gfc_option.warn_std), NULL_TREE);
3996 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3997 gfc_option.allow_std), array);
3998 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4000 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4001 gfc_option.flag_dump_core), array);
4002 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4003 gfc_option.flag_backtrace), array);
4004 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4005 gfc_option.flag_sign_zero), array);
4007 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4008 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4010 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4011 gfc_option.flag_range_check), array);
4013 array_type = build_array_type (integer_type_node,
4014 build_index_type (build_int_cst (NULL_TREE, 7)));
4015 array = build_constructor_from_list (array_type, nreverse (array));
4016 TREE_CONSTANT (array) = 1;
4017 TREE_STATIC (array) = 1;
4019 /* Create a static variable to hold the jump table. */
4020 var = gfc_create_var (array_type, "options");
4021 TREE_CONSTANT (var) = 1;
4022 TREE_STATIC (var) = 1;
4023 TREE_READONLY (var) = 1;
4024 DECL_INITIAL (var) = array;
4025 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4027 tmp = build_call_expr (gfor_fndecl_set_options, 2,
4028 build_int_cst (integer_type_node, 8), var);
4029 gfc_add_expr_to_block (&body, tmp);
4032 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4033 the library will raise a FPE when needed. */
4034 if (gfc_option.fpe != 0)
4036 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
4037 build_int_cst (integer_type_node,
4039 gfc_add_expr_to_block (&body, tmp);
4042 /* If this is the main program and an -fconvert option was provided,
4043 add a call to set_convert. */
4045 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4047 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
4048 build_int_cst (integer_type_node,
4049 gfc_option.convert));
4050 gfc_add_expr_to_block (&body, tmp);
4053 /* If this is the main program and an -frecord-marker option was provided,
4054 add a call to set_record_marker. */
4056 if (gfc_option.record_marker != 0)
4058 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
4059 build_int_cst (integer_type_node,
4060 gfc_option.record_marker));
4061 gfc_add_expr_to_block (&body, tmp);
4064 if (gfc_option.max_subrecord_length != 0)
4066 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
4067 build_int_cst (integer_type_node,
4068 gfc_option.max_subrecord_length));
4069 gfc_add_expr_to_block (&body, tmp);
4072 /* Call MAIN__(). */
4073 tmp = build_call_expr (fndecl, 0);
4074 gfc_add_expr_to_block (&body, tmp);
4076 /* Mark MAIN__ as used. */
4077 TREE_USED (fndecl) = 1;
4080 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4081 build_int_cst (integer_type_node, 0));
4082 tmp = build1_v (RETURN_EXPR, tmp);
4083 gfc_add_expr_to_block (&body, tmp);
4086 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4089 /* Finish off this function and send it for code generation. */
4091 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4093 DECL_SAVED_TREE (ftn_main)
4094 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4095 DECL_INITIAL (ftn_main));
4097 /* Output the GENERIC tree. */
4098 dump_function (TDI_original, ftn_main);
4100 gfc_gimplify_function (ftn_main);
4101 cgraph_finalize_function (ftn_main, false);
4105 pop_function_context ();
4106 saved_function_decls = saved_parent_function_decls;
4108 current_function_decl = old_context;
4112 /* Generate code for a function. */
4115 gfc_generate_function_code (gfc_namespace * ns)
4125 tree recurcheckvar = NULL;
4130 sym = ns->proc_name;
4132 /* Check that the frontend isn't still using this. */
4133 gcc_assert (sym->tlink == NULL);
4136 /* Create the declaration for functions with global scope. */
4137 if (!sym->backend_decl)
4138 gfc_create_function_decl (ns);
4140 fndecl = sym->backend_decl;
4141 old_context = current_function_decl;
4145 push_function_context ();
4146 saved_parent_function_decls = saved_function_decls;
4147 saved_function_decls = NULL_TREE;
4150 trans_function_start (sym);
4152 gfc_init_block (&block);
4154 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4156 /* Copy length backend_decls to all entry point result
4161 gfc_conv_const_charlen (ns->proc_name->ts.cl);
4162 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4163 for (el = ns->entries; el; el = el->next)
4164 el->sym->result->ts.cl->backend_decl = backend_decl;
4167 /* Translate COMMON blocks. */
4168 gfc_trans_common (ns);
4170 /* Null the parent fake result declaration if this namespace is
4171 a module function or an external procedures. */
4172 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4173 || ns->parent == NULL)
4174 parent_fake_result_decl = NULL_TREE;
4176 gfc_generate_contained_functions (ns);
4178 nonlocal_dummy_decls = NULL;
4179 nonlocal_dummy_decl_pset = NULL;
4181 generate_local_vars (ns);
4183 /* Keep the parent fake result declaration in module functions
4184 or external procedures. */
4185 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4186 || ns->parent == NULL)
4187 current_fake_result_decl = parent_fake_result_decl;
4189 current_fake_result_decl = NULL_TREE;
4191 current_function_return_label = NULL;
4193 /* Now generate the code for the body of this function. */
4194 gfc_init_block (&body);
4196 is_recursive = sym->attr.recursive
4197 || (sym->attr.entry_master
4198 && sym->ns->entries->sym->attr.recursive);
4199 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4203 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4205 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4206 TREE_STATIC (recurcheckvar) = 1;
4207 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4208 gfc_add_expr_to_block (&block, recurcheckvar);
4209 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4210 &sym->declared_at, msg);
4211 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4215 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4216 && sym->attr.subroutine)
4218 tree alternate_return;
4219 alternate_return = gfc_get_fake_result_decl (sym, 0);
4220 gfc_add_modify (&body, alternate_return, integer_zero_node);
4225 /* Jump to the correct entry point. */
4226 tmp = gfc_trans_entry_master_switch (ns->entries);
4227 gfc_add_expr_to_block (&body, tmp);
4230 /* If bounds-checking is enabled, generate code to check passed in actual
4231 arguments against the expected dummy argument attributes (e.g. string
4233 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4234 add_argument_checking (&body, sym);
4236 tmp = gfc_trans_code (ns->code);
4237 gfc_add_expr_to_block (&body, tmp);
4239 /* Add a return label if needed. */
4240 if (current_function_return_label)
4242 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4243 gfc_add_expr_to_block (&body, tmp);
4246 tmp = gfc_finish_block (&body);
4247 /* Add code to create and cleanup arrays. */
4248 tmp = gfc_trans_deferred_vars (sym, tmp);
4250 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4252 if (sym->attr.subroutine || sym == sym->result)
4254 if (current_fake_result_decl != NULL)
4255 result = TREE_VALUE (current_fake_result_decl);
4258 current_fake_result_decl = NULL_TREE;
4261 result = sym->result->backend_decl;
4263 if (result != NULL_TREE && sym->attr.function
4264 && sym->ts.type == BT_DERIVED
4265 && sym->ts.derived->attr.alloc_comp
4266 && !sym->attr.pointer)
4268 rank = sym->as ? sym->as->rank : 0;
4269 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4270 gfc_add_expr_to_block (&block, tmp2);
4273 gfc_add_expr_to_block (&block, tmp);
4275 /* Reset recursion-check variable. */
4276 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4278 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4279 recurcheckvar = NULL;
4282 if (result == NULL_TREE)
4284 /* TODO: move to the appropriate place in resolve.c. */
4285 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4286 gfc_warning ("Return value of function '%s' at %L not set",
4287 sym->name, &sym->declared_at);
4289 TREE_NO_WARNING(sym->backend_decl) = 1;
4293 /* Set the return value to the dummy result variable. The
4294 types may be different for scalar default REAL functions
4295 with -ff2c, therefore we have to convert. */
4296 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4297 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4298 DECL_RESULT (fndecl), tmp);
4299 tmp = build1_v (RETURN_EXPR, tmp);
4300 gfc_add_expr_to_block (&block, tmp);
4305 gfc_add_expr_to_block (&block, tmp);
4306 /* Reset recursion-check variable. */
4307 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4309 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4310 recurcheckvar = NULL;
4315 /* Add all the decls we created during processing. */
4316 decl = saved_function_decls;
4321 next = TREE_CHAIN (decl);
4322 TREE_CHAIN (decl) = NULL_TREE;
4326 saved_function_decls = NULL_TREE;
4328 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4331 /* Finish off this function and send it for code generation. */
4333 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4335 DECL_SAVED_TREE (fndecl)
4336 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4337 DECL_INITIAL (fndecl));
4339 if (nonlocal_dummy_decls)
4341 BLOCK_VARS (DECL_INITIAL (fndecl))
4342 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4343 pointer_set_destroy (nonlocal_dummy_decl_pset);
4344 nonlocal_dummy_decls = NULL;
4345 nonlocal_dummy_decl_pset = NULL;
4348 /* Output the GENERIC tree. */
4349 dump_function (TDI_original, fndecl);
4351 /* Store the end of the function, so that we get good line number
4352 info for the epilogue. */
4353 cfun->function_end_locus = input_location;
4355 /* We're leaving the context of this function, so zap cfun.
4356 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4357 tree_rest_of_compilation. */
4362 pop_function_context ();
4363 saved_function_decls = saved_parent_function_decls;
4365 current_function_decl = old_context;
4367 if (decl_function_context (fndecl))
4368 /* Register this function with cgraph just far enough to get it
4369 added to our parent's nested function list. */
4370 (void) cgraph_node (fndecl);
4373 gfc_gimplify_function (fndecl);
4374 cgraph_finalize_function (fndecl, false);
4377 gfc_trans_use_stmts (ns);
4378 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4380 if (sym->attr.is_main_program)
4381 create_main_function (fndecl);
4386 gfc_generate_constructors (void)
4388 gcc_assert (gfc_static_ctors == NULL_TREE);
4396 if (gfc_static_ctors == NULL_TREE)
4399 fnname = get_file_function_name ("I");
4400 type = build_function_type (void_type_node,
4401 gfc_chainon_list (NULL_TREE, void_type_node));
4403 fndecl = build_decl (input_location,
4404 FUNCTION_DECL, fnname, type);
4405 TREE_PUBLIC (fndecl) = 1;
4407 decl = build_decl (input_location,
4408 RESULT_DECL, NULL_TREE, void_type_node);
4409 DECL_ARTIFICIAL (decl) = 1;
4410 DECL_IGNORED_P (decl) = 1;
4411 DECL_CONTEXT (decl) = fndecl;
4412 DECL_RESULT (fndecl) = decl;
4416 current_function_decl = fndecl;
4418 rest_of_decl_compilation (fndecl, 1, 0);
4420 make_decl_rtl (fndecl);
4422 init_function_start (fndecl);
4426 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4428 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4429 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4435 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4436 DECL_SAVED_TREE (fndecl)
4437 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4438 DECL_INITIAL (fndecl));
4440 free_after_parsing (cfun);
4441 free_after_compilation (cfun);
4443 tree_rest_of_compilation (fndecl);
4445 current_function_decl = NULL_TREE;
4449 /* Translates a BLOCK DATA program unit. This means emitting the
4450 commons contained therein plus their initializations. We also emit
4451 a globally visible symbol to make sure that each BLOCK DATA program
4452 unit remains unique. */
4455 gfc_generate_block_data (gfc_namespace * ns)
4460 /* Tell the backend the source location of the block data. */
4462 gfc_set_backend_locus (&ns->proc_name->declared_at);
4464 gfc_set_backend_locus (&gfc_current_locus);
4466 /* Process the DATA statements. */
4467 gfc_trans_common (ns);
4469 /* Create a global symbol with the mane of the block data. This is to
4470 generate linker errors if the same name is used twice. It is never
4473 id = gfc_sym_mangled_function_id (ns->proc_name);
4475 id = get_identifier ("__BLOCK_DATA__");
4477 decl = build_decl (input_location,
4478 VAR_DECL, id, gfc_array_index_type);
4479 TREE_PUBLIC (decl) = 1;
4480 TREE_STATIC (decl) = 1;
4481 DECL_IGNORED_P (decl) = 1;
4484 rest_of_decl_compilation (decl, 1, 0);
4488 #include "gt-fortran-trans-decl.h"