1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-decl.c -- Handling of backend function and variable decls, etc */
27 #include "coretypes.h"
30 #include "tree-dump.h"
31 #include "gimple.h" /* For create_tmp_var_raw. */
33 #include "diagnostic-core.h" /* For internal_error. */
34 #include "toplev.h" /* For announce_function. */
35 #include "output.h" /* For decl_default_tls_model. */
42 #include "pointer-set.h"
43 #include "constructor.h"
45 #include "trans-types.h"
46 #include "trans-array.h"
47 #include "trans-const.h"
48 /* Only for gfc_trans_code. Shouldn't need to include this. */
49 #include "trans-stmt.h"
51 #define MAX_LABEL_VALUE 99999
54 /* Holds the result of the function if no result variable specified. */
56 static GTY(()) tree current_fake_result_decl;
57 static GTY(()) tree parent_fake_result_decl;
60 /* Holds the variable DECLs for the current function. */
62 static GTY(()) tree saved_function_decls;
63 static GTY(()) tree saved_parent_function_decls;
65 static struct pointer_set_t *nonlocal_dummy_decl_pset;
66 static GTY(()) tree nonlocal_dummy_decls;
68 /* Holds the variable DECLs that are locals. */
70 static GTY(()) tree saved_local_decls;
72 /* The namespace of the module we're currently generating. Only used while
73 outputting decls for module variables. Do not rely on this being set. */
75 static gfc_namespace *module_namespace;
77 /* The currently processed procedure symbol. */
78 static gfc_symbol* current_procedure_symbol = NULL;
81 /* List of static constructor functions. */
83 tree gfc_static_ctors;
86 /* Function declarations for builtin library functions. */
88 tree gfor_fndecl_pause_numeric;
89 tree gfor_fndecl_pause_string;
90 tree gfor_fndecl_stop_numeric;
91 tree gfor_fndecl_stop_numeric_f08;
92 tree gfor_fndecl_stop_string;
93 tree gfor_fndecl_error_stop_numeric;
94 tree gfor_fndecl_error_stop_string;
95 tree gfor_fndecl_runtime_error;
96 tree gfor_fndecl_runtime_error_at;
97 tree gfor_fndecl_runtime_warning_at;
98 tree gfor_fndecl_os_error;
99 tree gfor_fndecl_generate_error;
100 tree gfor_fndecl_set_args;
101 tree gfor_fndecl_set_fpe;
102 tree gfor_fndecl_set_options;
103 tree gfor_fndecl_set_convert;
104 tree gfor_fndecl_set_record_marker;
105 tree gfor_fndecl_set_max_subrecord_length;
106 tree gfor_fndecl_ctime;
107 tree gfor_fndecl_fdate;
108 tree gfor_fndecl_ttynam;
109 tree gfor_fndecl_in_pack;
110 tree gfor_fndecl_in_unpack;
111 tree gfor_fndecl_associated;
114 /* Coarray run-time library function decls. */
115 tree gfor_fndecl_caf_init;
116 tree gfor_fndecl_caf_finalize;
117 tree gfor_fndecl_caf_critical;
118 tree gfor_fndecl_caf_end_critical;
119 tree gfor_fndecl_caf_sync_all;
120 tree gfor_fndecl_caf_sync_images;
121 tree gfor_fndecl_caf_error_stop;
122 tree gfor_fndecl_caf_error_stop_str;
124 /* Coarray global variables for num_images/this_image. */
126 tree gfort_gvar_caf_num_images;
127 tree gfort_gvar_caf_this_image;
130 /* Math functions. Many other math functions are handled in
131 trans-intrinsic.c. */
133 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
134 tree gfor_fndecl_math_ishftc4;
135 tree gfor_fndecl_math_ishftc8;
136 tree gfor_fndecl_math_ishftc16;
139 /* String functions. */
141 tree gfor_fndecl_compare_string;
142 tree gfor_fndecl_concat_string;
143 tree gfor_fndecl_string_len_trim;
144 tree gfor_fndecl_string_index;
145 tree gfor_fndecl_string_scan;
146 tree gfor_fndecl_string_verify;
147 tree gfor_fndecl_string_trim;
148 tree gfor_fndecl_string_minmax;
149 tree gfor_fndecl_adjustl;
150 tree gfor_fndecl_adjustr;
151 tree gfor_fndecl_select_string;
152 tree gfor_fndecl_compare_string_char4;
153 tree gfor_fndecl_concat_string_char4;
154 tree gfor_fndecl_string_len_trim_char4;
155 tree gfor_fndecl_string_index_char4;
156 tree gfor_fndecl_string_scan_char4;
157 tree gfor_fndecl_string_verify_char4;
158 tree gfor_fndecl_string_trim_char4;
159 tree gfor_fndecl_string_minmax_char4;
160 tree gfor_fndecl_adjustl_char4;
161 tree gfor_fndecl_adjustr_char4;
162 tree gfor_fndecl_select_string_char4;
165 /* Conversion between character kinds. */
166 tree gfor_fndecl_convert_char1_to_char4;
167 tree gfor_fndecl_convert_char4_to_char1;
170 /* Other misc. runtime library functions. */
171 tree gfor_fndecl_size0;
172 tree gfor_fndecl_size1;
173 tree gfor_fndecl_iargc;
175 /* Intrinsic functions implemented in Fortran. */
176 tree gfor_fndecl_sc_kind;
177 tree gfor_fndecl_si_kind;
178 tree gfor_fndecl_sr_kind;
180 /* BLAS gemm functions. */
181 tree gfor_fndecl_sgemm;
182 tree gfor_fndecl_dgemm;
183 tree gfor_fndecl_cgemm;
184 tree gfor_fndecl_zgemm;
188 gfc_add_decl_to_parent_function (tree decl)
191 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
192 DECL_NONLOCAL (decl) = 1;
193 DECL_CHAIN (decl) = saved_parent_function_decls;
194 saved_parent_function_decls = decl;
198 gfc_add_decl_to_function (tree decl)
201 TREE_USED (decl) = 1;
202 DECL_CONTEXT (decl) = current_function_decl;
203 DECL_CHAIN (decl) = saved_function_decls;
204 saved_function_decls = decl;
208 add_decl_as_local (tree decl)
211 TREE_USED (decl) = 1;
212 DECL_CONTEXT (decl) = current_function_decl;
213 DECL_CHAIN (decl) = saved_local_decls;
214 saved_local_decls = decl;
218 /* Build a backend label declaration. Set TREE_USED for named labels.
219 The context of the label is always the current_function_decl. All
220 labels are marked artificial. */
223 gfc_build_label_decl (tree label_id)
225 /* 2^32 temporaries should be enough. */
226 static unsigned int tmp_num = 1;
230 if (label_id == NULL_TREE)
232 /* Build an internal label name. */
233 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
234 label_id = get_identifier (label_name);
239 /* Build the LABEL_DECL node. Labels have no type. */
240 label_decl = build_decl (input_location,
241 LABEL_DECL, label_id, void_type_node);
242 DECL_CONTEXT (label_decl) = current_function_decl;
243 DECL_MODE (label_decl) = VOIDmode;
245 /* We always define the label as used, even if the original source
246 file never references the label. We don't want all kinds of
247 spurious warnings for old-style Fortran code with too many
249 TREE_USED (label_decl) = 1;
251 DECL_ARTIFICIAL (label_decl) = 1;
256 /* Set the backend source location of a decl. */
259 gfc_set_decl_location (tree decl, locus * loc)
261 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
265 /* Return the backend label declaration for a given label structure,
266 or create it if it doesn't exist yet. */
269 gfc_get_label_decl (gfc_st_label * lp)
271 if (lp->backend_decl)
272 return lp->backend_decl;
275 char label_name[GFC_MAX_SYMBOL_LEN + 1];
278 /* Validate the label declaration from the front end. */
279 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
281 /* Build a mangled name for the label. */
282 sprintf (label_name, "__label_%.6d", lp->value);
284 /* Build the LABEL_DECL node. */
285 label_decl = gfc_build_label_decl (get_identifier (label_name));
287 /* Tell the debugger where the label came from. */
288 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
289 gfc_set_decl_location (label_decl, &lp->where);
291 DECL_ARTIFICIAL (label_decl) = 1;
293 /* Store the label in the label list and return the LABEL_DECL. */
294 lp->backend_decl = label_decl;
300 /* Convert a gfc_symbol to an identifier of the same name. */
303 gfc_sym_identifier (gfc_symbol * sym)
305 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
306 return (get_identifier ("MAIN__"));
308 return (get_identifier (sym->name));
312 /* Construct mangled name from symbol name. */
315 gfc_sym_mangled_identifier (gfc_symbol * sym)
317 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
319 /* Prevent the mangling of identifiers that have an assigned
320 binding label (mainly those that are bind(c)). */
321 if (sym->attr.is_bind_c == 1
322 && sym->binding_label[0] != '\0')
323 return get_identifier(sym->binding_label);
325 if (sym->module == NULL)
326 return gfc_sym_identifier (sym);
329 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
330 return get_identifier (name);
335 /* Construct mangled function name from symbol name. */
338 gfc_sym_mangled_function_id (gfc_symbol * sym)
341 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
343 /* It may be possible to simply use the binding label if it's
344 provided, and remove the other checks. Then we could use it
345 for other things if we wished. */
346 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
347 sym->binding_label[0] != '\0')
348 /* use the binding label rather than the mangled name */
349 return get_identifier (sym->binding_label);
351 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
352 || (sym->module != NULL && (sym->attr.external
353 || sym->attr.if_source == IFSRC_IFBODY)))
355 /* Main program is mangled into MAIN__. */
356 if (sym->attr.is_main_program)
357 return get_identifier ("MAIN__");
359 /* Intrinsic procedures are never mangled. */
360 if (sym->attr.proc == PROC_INTRINSIC)
361 return get_identifier (sym->name);
363 if (gfc_option.flag_underscoring)
365 has_underscore = strchr (sym->name, '_') != 0;
366 if (gfc_option.flag_second_underscore && has_underscore)
367 snprintf (name, sizeof name, "%s__", sym->name);
369 snprintf (name, sizeof name, "%s_", sym->name);
370 return get_identifier (name);
373 return get_identifier (sym->name);
377 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
378 return get_identifier (name);
384 gfc_set_decl_assembler_name (tree decl, tree name)
386 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
387 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
391 /* Returns true if a variable of specified size should go on the stack. */
394 gfc_can_put_var_on_stack (tree size)
396 unsigned HOST_WIDE_INT low;
398 if (!INTEGER_CST_P (size))
401 if (gfc_option.flag_max_stack_var_size < 0)
404 if (TREE_INT_CST_HIGH (size) != 0)
407 low = TREE_INT_CST_LOW (size);
408 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
411 /* TODO: Set a per-function stack size limit. */
417 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
418 an expression involving its corresponding pointer. There are
419 2 cases; one for variable size arrays, and one for everything else,
420 because variable-sized arrays require one fewer level of
424 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
426 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
429 /* Parameters need to be dereferenced. */
430 if (sym->cp_pointer->attr.dummy)
431 ptr_decl = build_fold_indirect_ref_loc (input_location,
434 /* Check to see if we're dealing with a variable-sized array. */
435 if (sym->attr.dimension
436 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
438 /* These decls will be dereferenced later, so we don't dereference
440 value = convert (TREE_TYPE (decl), ptr_decl);
444 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
446 value = build_fold_indirect_ref_loc (input_location,
450 SET_DECL_VALUE_EXPR (decl, value);
451 DECL_HAS_VALUE_EXPR_P (decl) = 1;
452 GFC_DECL_CRAY_POINTEE (decl) = 1;
453 /* This is a fake variable just for debugging purposes. */
454 TREE_ASM_WRITTEN (decl) = 1;
458 /* Finish processing of a declaration without an initial value. */
461 gfc_finish_decl (tree decl)
463 gcc_assert (TREE_CODE (decl) == PARM_DECL
464 || DECL_INITIAL (decl) == NULL_TREE);
466 if (TREE_CODE (decl) != VAR_DECL)
469 if (DECL_SIZE (decl) == NULL_TREE
470 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
471 layout_decl (decl, 0);
473 /* A few consistency checks. */
474 /* A static variable with an incomplete type is an error if it is
475 initialized. Also if it is not file scope. Otherwise, let it
476 through, but if it is not `extern' then it may cause an error
478 /* An automatic variable with an incomplete type is an error. */
480 /* We should know the storage size. */
481 gcc_assert (DECL_SIZE (decl) != NULL_TREE
482 || (TREE_STATIC (decl)
483 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
484 : DECL_EXTERNAL (decl)));
486 /* The storage size should be constant. */
487 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
489 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
493 /* Apply symbol attributes to a variable, and add it to the function scope. */
496 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
499 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
500 This is the equivalent of the TARGET variables.
501 We also need to set this if the variable is passed by reference in a
504 /* Set DECL_VALUE_EXPR for Cray Pointees. */
505 if (sym->attr.cray_pointee)
506 gfc_finish_cray_pointee (decl, sym);
508 if (sym->attr.target)
509 TREE_ADDRESSABLE (decl) = 1;
510 /* If it wasn't used we wouldn't be getting it. */
511 TREE_USED (decl) = 1;
513 /* Chain this decl to the pending declarations. Don't do pushdecl()
514 because this would add them to the current scope rather than the
516 if (current_function_decl != NULL_TREE)
518 if (sym->ns->proc_name->backend_decl == current_function_decl
519 || sym->result == sym)
520 gfc_add_decl_to_function (decl);
521 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
522 /* This is a BLOCK construct. */
523 add_decl_as_local (decl);
525 gfc_add_decl_to_parent_function (decl);
528 if (sym->attr.cray_pointee)
531 if(sym->attr.is_bind_c == 1)
533 /* We need to put variables that are bind(c) into the common
534 segment of the object file, because this is what C would do.
535 gfortran would typically put them in either the BSS or
536 initialized data segments, and only mark them as common if
537 they were part of common blocks. However, if they are not put
538 into common space, then C cannot initialize global Fortran
539 variables that it interoperates with and the draft says that
540 either Fortran or C should be able to initialize it (but not
541 both, of course.) (J3/04-007, section 15.3). */
542 TREE_PUBLIC(decl) = 1;
543 DECL_COMMON(decl) = 1;
546 /* If a variable is USE associated, it's always external. */
547 if (sym->attr.use_assoc)
549 DECL_EXTERNAL (decl) = 1;
550 TREE_PUBLIC (decl) = 1;
552 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
554 /* TODO: Don't set sym->module for result or dummy variables. */
555 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
556 /* This is the declaration of a module variable. */
557 TREE_PUBLIC (decl) = 1;
558 TREE_STATIC (decl) = 1;
561 /* Derived types are a bit peculiar because of the possibility of
562 a default initializer; this must be applied each time the variable
563 comes into scope it therefore need not be static. These variables
564 are SAVE_NONE but have an initializer. Otherwise explicitly
565 initialized variables are SAVE_IMPLICIT and explicitly saved are
567 if (!sym->attr.use_assoc
568 && (sym->attr.save != SAVE_NONE || sym->attr.data
569 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
570 TREE_STATIC (decl) = 1;
572 if (sym->attr.volatile_)
574 TREE_THIS_VOLATILE (decl) = 1;
575 TREE_SIDE_EFFECTS (decl) = 1;
576 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
577 TREE_TYPE (decl) = new_type;
580 /* Keep variables larger than max-stack-var-size off stack. */
581 if (!sym->ns->proc_name->attr.recursive
582 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
583 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
584 /* Put variable length auto array pointers always into stack. */
585 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
586 || sym->attr.dimension == 0
587 || sym->as->type != AS_EXPLICIT
589 || sym->attr.allocatable)
590 && !DECL_ARTIFICIAL (decl))
591 TREE_STATIC (decl) = 1;
593 /* Handle threadprivate variables. */
594 if (sym->attr.threadprivate
595 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
596 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
598 if (!sym->attr.target
599 && !sym->attr.pointer
600 && !sym->attr.cray_pointee
601 && !sym->attr.proc_pointer)
602 DECL_RESTRICTED_P (decl) = 1;
606 /* Allocate the lang-specific part of a decl. */
609 gfc_allocate_lang_decl (tree decl)
611 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
615 /* Remember a symbol to generate initialization/cleanup code at function
619 gfc_defer_symbol_init (gfc_symbol * sym)
625 /* Don't add a symbol twice. */
629 last = head = sym->ns->proc_name;
632 /* Make sure that setup code for dummy variables which are used in the
633 setup of other variables is generated first. */
636 /* Find the first dummy arg seen after us, or the first non-dummy arg.
637 This is a circular list, so don't go past the head. */
639 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
645 /* Insert in between last and p. */
651 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
652 backend_decl for a module symbol, if it all ready exists. If the
653 module gsymbol does not exist, it is created. If the symbol does
654 not exist, it is added to the gsymbol namespace. Returns true if
655 an existing backend_decl is found. */
658 gfc_get_module_backend_decl (gfc_symbol *sym)
664 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
666 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
672 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
678 gsym = gfc_get_gsymbol (sym->module);
679 gsym->type = GSYM_MODULE;
680 gsym->ns = gfc_get_namespace (NULL, 0);
683 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
687 else if (sym->attr.flavor == FL_DERIVED)
689 if (!s->backend_decl)
690 s->backend_decl = gfc_get_derived_type (s);
691 gfc_copy_dt_decls_ifequal (s, sym, true);
694 else if (s->backend_decl)
696 if (sym->ts.type == BT_DERIVED)
697 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
699 else if (sym->ts.type == BT_CHARACTER)
700 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
701 sym->backend_decl = s->backend_decl;
709 /* Create an array index type variable with function scope. */
712 create_index_var (const char * pfx, int nest)
716 decl = gfc_create_var_np (gfc_array_index_type, pfx);
718 gfc_add_decl_to_parent_function (decl);
720 gfc_add_decl_to_function (decl);
725 /* Create variables to hold all the non-constant bits of info for a
726 descriptorless array. Remember these in the lang-specific part of the
730 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
735 gfc_namespace* procns;
737 type = TREE_TYPE (decl);
739 /* We just use the descriptor, if there is one. */
740 if (GFC_DESCRIPTOR_TYPE_P (type))
743 gcc_assert (GFC_ARRAY_TYPE_P (type));
744 procns = gfc_find_proc_namespace (sym->ns);
745 nest = (procns->proc_name->backend_decl != current_function_decl)
746 && !sym->attr.contained;
748 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
750 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
752 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
753 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
755 /* Don't try to use the unknown bound for assumed shape arrays. */
756 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
757 && (sym->as->type != AS_ASSUMED_SIZE
758 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
760 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
761 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
764 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
766 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
767 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
770 for (dim = GFC_TYPE_ARRAY_RANK (type);
771 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
773 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
775 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
776 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
778 /* Don't try to use the unknown ubound for the last coarray dimension. */
779 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
780 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
782 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
783 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
786 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
788 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
790 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
793 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
795 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
798 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
799 && sym->as->type != AS_ASSUMED_SIZE)
801 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
802 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
805 if (POINTER_TYPE_P (type))
807 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
808 gcc_assert (TYPE_LANG_SPECIFIC (type)
809 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
810 type = TREE_TYPE (type);
813 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
817 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
818 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
819 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
821 TYPE_DOMAIN (type) = range;
825 if (TYPE_NAME (type) != NULL_TREE
826 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
827 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
829 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
831 for (dim = 0; dim < sym->as->rank - 1; dim++)
833 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
834 gtype = TREE_TYPE (gtype);
836 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
837 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
838 TYPE_NAME (type) = NULL_TREE;
841 if (TYPE_NAME (type) == NULL_TREE)
843 tree gtype = TREE_TYPE (type), rtype, type_decl;
845 for (dim = sym->as->rank - 1; dim >= 0; dim--)
848 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
849 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
850 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
851 gtype = build_array_type (gtype, rtype);
852 /* Ensure the bound variables aren't optimized out at -O0.
853 For -O1 and above they often will be optimized out, but
854 can be tracked by VTA. Also set DECL_NAMELESS, so that
855 the artificial lbound.N or ubound.N DECL_NAME doesn't
856 end up in debug info. */
857 if (lbound && TREE_CODE (lbound) == VAR_DECL
858 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
860 if (DECL_NAME (lbound)
861 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
863 DECL_NAMELESS (lbound) = 1;
864 DECL_IGNORED_P (lbound) = 0;
866 if (ubound && TREE_CODE (ubound) == VAR_DECL
867 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
869 if (DECL_NAME (ubound)
870 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
872 DECL_NAMELESS (ubound) = 1;
873 DECL_IGNORED_P (ubound) = 0;
876 TYPE_NAME (type) = type_decl = build_decl (input_location,
877 TYPE_DECL, NULL, gtype);
878 DECL_ORIGINAL_TYPE (type_decl) = gtype;
883 /* For some dummy arguments we don't use the actual argument directly.
884 Instead we create a local decl and use that. This allows us to perform
885 initialization, and construct full type information. */
888 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
898 if (sym->attr.pointer || sym->attr.allocatable)
901 /* Add to list of variables if not a fake result variable. */
902 if (sym->attr.result || sym->attr.dummy)
903 gfc_defer_symbol_init (sym);
905 type = TREE_TYPE (dummy);
906 gcc_assert (TREE_CODE (dummy) == PARM_DECL
907 && POINTER_TYPE_P (type));
909 /* Do we know the element size? */
910 known_size = sym->ts.type != BT_CHARACTER
911 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
913 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
915 /* For descriptorless arrays with known element size the actual
916 argument is sufficient. */
917 gcc_assert (GFC_ARRAY_TYPE_P (type));
918 gfc_build_qualified_array (dummy, sym);
922 type = TREE_TYPE (type);
923 if (GFC_DESCRIPTOR_TYPE_P (type))
925 /* Create a descriptorless array pointer. */
929 /* Even when -frepack-arrays is used, symbols with TARGET attribute
931 if (!gfc_option.flag_repack_arrays || sym->attr.target)
933 if (as->type == AS_ASSUMED_SIZE)
934 packed = PACKED_FULL;
938 if (as->type == AS_EXPLICIT)
940 packed = PACKED_FULL;
941 for (n = 0; n < as->rank; n++)
945 && as->upper[n]->expr_type == EXPR_CONSTANT
946 && as->lower[n]->expr_type == EXPR_CONSTANT))
947 packed = PACKED_PARTIAL;
951 packed = PACKED_PARTIAL;
954 type = gfc_typenode_for_spec (&sym->ts);
955 type = gfc_get_nodesc_array_type (type, sym->as, packed,
960 /* We now have an expression for the element size, so create a fully
961 qualified type. Reset sym->backend decl or this will just return the
963 DECL_ARTIFICIAL (sym->backend_decl) = 1;
964 sym->backend_decl = NULL_TREE;
965 type = gfc_sym_type (sym);
966 packed = PACKED_FULL;
969 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
970 decl = build_decl (input_location,
971 VAR_DECL, get_identifier (name), type);
973 DECL_ARTIFICIAL (decl) = 1;
974 DECL_NAMELESS (decl) = 1;
975 TREE_PUBLIC (decl) = 0;
976 TREE_STATIC (decl) = 0;
977 DECL_EXTERNAL (decl) = 0;
979 /* We should never get deferred shape arrays here. We used to because of
981 gcc_assert (sym->as->type != AS_DEFERRED);
983 if (packed == PACKED_PARTIAL)
984 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
985 else if (packed == PACKED_FULL)
986 GFC_DECL_PACKED_ARRAY (decl) = 1;
988 gfc_build_qualified_array (decl, sym);
990 if (DECL_LANG_SPECIFIC (dummy))
991 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
993 gfc_allocate_lang_decl (decl);
995 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
997 if (sym->ns->proc_name->backend_decl == current_function_decl
998 || sym->attr.contained)
999 gfc_add_decl_to_function (decl);
1001 gfc_add_decl_to_parent_function (decl);
1006 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1007 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1008 pointing to the artificial variable for debug info purposes. */
1011 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1015 if (! nonlocal_dummy_decl_pset)
1016 nonlocal_dummy_decl_pset = pointer_set_create ();
1018 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1021 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1022 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1023 TREE_TYPE (sym->backend_decl));
1024 DECL_ARTIFICIAL (decl) = 0;
1025 TREE_USED (decl) = 1;
1026 TREE_PUBLIC (decl) = 0;
1027 TREE_STATIC (decl) = 0;
1028 DECL_EXTERNAL (decl) = 0;
1029 if (DECL_BY_REFERENCE (dummy))
1030 DECL_BY_REFERENCE (decl) = 1;
1031 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1032 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1033 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1034 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1035 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1036 nonlocal_dummy_decls = decl;
1039 /* Return a constant or a variable to use as a string length. Does not
1040 add the decl to the current scope. */
1043 gfc_create_string_length (gfc_symbol * sym)
1045 gcc_assert (sym->ts.u.cl);
1046 gfc_conv_const_charlen (sym->ts.u.cl);
1048 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1051 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1053 /* Also prefix the mangled name. */
1054 strcpy (&name[1], sym->name);
1056 length = build_decl (input_location,
1057 VAR_DECL, get_identifier (name),
1058 gfc_charlen_type_node);
1059 DECL_ARTIFICIAL (length) = 1;
1060 TREE_USED (length) = 1;
1061 if (sym->ns->proc_name->tlink != NULL)
1062 gfc_defer_symbol_init (sym);
1064 sym->ts.u.cl->backend_decl = length;
1067 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1068 return sym->ts.u.cl->backend_decl;
1071 /* If a variable is assigned a label, we add another two auxiliary
1075 gfc_add_assign_aux_vars (gfc_symbol * sym)
1081 gcc_assert (sym->backend_decl);
1083 decl = sym->backend_decl;
1084 gfc_allocate_lang_decl (decl);
1085 GFC_DECL_ASSIGN (decl) = 1;
1086 length = build_decl (input_location,
1087 VAR_DECL, create_tmp_var_name (sym->name),
1088 gfc_charlen_type_node);
1089 addr = build_decl (input_location,
1090 VAR_DECL, create_tmp_var_name (sym->name),
1092 gfc_finish_var_decl (length, sym);
1093 gfc_finish_var_decl (addr, sym);
1094 /* STRING_LENGTH is also used as flag. Less than -1 means that
1095 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1096 target label's address. Otherwise, value is the length of a format string
1097 and ASSIGN_ADDR is its address. */
1098 if (TREE_STATIC (length))
1099 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1101 gfc_defer_symbol_init (sym);
1103 GFC_DECL_STRING_LEN (decl) = length;
1104 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1109 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1114 for (id = 0; id < EXT_ATTR_NUM; id++)
1115 if (sym_attr.ext_attr & (1 << id))
1117 attr = build_tree_list (
1118 get_identifier (ext_attr_list[id].middle_end_name),
1120 list = chainon (list, attr);
1127 static void build_function_decl (gfc_symbol * sym, bool global);
1130 /* Return the decl for a gfc_symbol, create it if it doesn't already
1134 gfc_get_symbol_decl (gfc_symbol * sym)
1137 tree length = NULL_TREE;
1140 bool intrinsic_array_parameter = false;
1142 gcc_assert (sym->attr.referenced
1143 || sym->attr.use_assoc
1144 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1145 || (sym->module && sym->attr.if_source != IFSRC_DECL
1146 && sym->backend_decl));
1148 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1149 byref = gfc_return_by_reference (sym->ns->proc_name);
1153 /* Make sure that the vtab for the declared type is completed. */
1154 if (sym->ts.type == BT_CLASS)
1156 gfc_component *c = CLASS_DATA (sym);
1157 if (!c->ts.u.derived->backend_decl)
1158 gfc_find_derived_vtab (c->ts.u.derived);
1161 /* All deferred character length procedures need to retain the backend
1162 decl, which is a pointer to the character length in the caller's
1163 namespace and to declare a local character length. */
1164 if (!byref && sym->attr.function
1165 && sym->ts.type == BT_CHARACTER
1167 && sym->ts.u.cl->passed_length == NULL
1168 && sym->ts.u.cl->backend_decl
1169 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1171 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1172 sym->ts.u.cl->backend_decl = NULL_TREE;
1173 length = gfc_create_string_length (sym);
1176 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1178 /* Return via extra parameter. */
1179 if (sym->attr.result && byref
1180 && !sym->backend_decl)
1183 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1184 /* For entry master function skip over the __entry
1186 if (sym->ns->proc_name->attr.entry_master)
1187 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1190 /* Dummy variables should already have been created. */
1191 gcc_assert (sym->backend_decl);
1193 /* Create a character length variable. */
1194 if (sym->ts.type == BT_CHARACTER)
1196 /* For a deferred dummy, make a new string length variable. */
1197 if (sym->ts.deferred
1199 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1200 sym->ts.u.cl->backend_decl = NULL_TREE;
1202 if (sym->ts.deferred && sym->attr.result
1203 && sym->ts.u.cl->passed_length == NULL
1204 && sym->ts.u.cl->backend_decl)
1206 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1207 sym->ts.u.cl->backend_decl = NULL_TREE;
1210 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1211 length = gfc_create_string_length (sym);
1213 length = sym->ts.u.cl->backend_decl;
1214 if (TREE_CODE (length) == VAR_DECL
1215 && DECL_FILE_SCOPE_P (length))
1217 /* Add the string length to the same context as the symbol. */
1218 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1219 gfc_add_decl_to_function (length);
1221 gfc_add_decl_to_parent_function (length);
1223 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1224 DECL_CONTEXT (length));
1226 gfc_defer_symbol_init (sym);
1230 /* Use a copy of the descriptor for dummy arrays. */
1231 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1233 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1234 /* Prevent the dummy from being detected as unused if it is copied. */
1235 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1236 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1237 sym->backend_decl = decl;
1240 TREE_USED (sym->backend_decl) = 1;
1241 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1243 gfc_add_assign_aux_vars (sym);
1246 if (sym->attr.dimension
1247 && DECL_LANG_SPECIFIC (sym->backend_decl)
1248 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1249 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1250 gfc_nonlocal_dummy_array_decl (sym);
1252 return sym->backend_decl;
1255 if (sym->backend_decl)
1256 return sym->backend_decl;
1258 /* Special case for array-valued named constants from intrinsic
1259 procedures; those are inlined. */
1260 if (sym->attr.use_assoc && sym->from_intmod
1261 && sym->attr.flavor == FL_PARAMETER)
1262 intrinsic_array_parameter = true;
1264 /* If use associated and whole file compilation, use the module
1266 if (gfc_option.flag_whole_file
1267 && (sym->attr.flavor == FL_VARIABLE
1268 || sym->attr.flavor == FL_PARAMETER)
1269 && sym->attr.use_assoc
1270 && !intrinsic_array_parameter
1272 && gfc_get_module_backend_decl (sym))
1273 return sym->backend_decl;
1275 if (sym->attr.flavor == FL_PROCEDURE)
1277 /* Catch function declarations. Only used for actual parameters,
1278 procedure pointers and procptr initialization targets. */
1279 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1281 decl = gfc_get_extern_function_decl (sym);
1282 gfc_set_decl_location (decl, &sym->declared_at);
1286 if (!sym->backend_decl)
1287 build_function_decl (sym, false);
1288 decl = sym->backend_decl;
1293 if (sym->attr.intrinsic)
1294 internal_error ("intrinsic variable which isn't a procedure");
1296 /* Create string length decl first so that they can be used in the
1297 type declaration. */
1298 if (sym->ts.type == BT_CHARACTER)
1299 length = gfc_create_string_length (sym);
1301 /* Create the decl for the variable. */
1302 decl = build_decl (sym->declared_at.lb->location,
1303 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1305 /* Add attributes to variables. Functions are handled elsewhere. */
1306 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1307 decl_attributes (&decl, attributes, 0);
1309 /* Symbols from modules should have their assembler names mangled.
1310 This is done here rather than in gfc_finish_var_decl because it
1311 is different for string length variables. */
1314 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1315 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1316 DECL_IGNORED_P (decl) = 1;
1319 if (sym->attr.dimension)
1321 /* Create variables to hold the non-constant bits of array info. */
1322 gfc_build_qualified_array (decl, sym);
1324 if (sym->attr.contiguous
1325 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1326 GFC_DECL_PACKED_ARRAY (decl) = 1;
1329 /* Remember this variable for allocation/cleanup. */
1330 if (sym->attr.dimension || sym->attr.allocatable
1331 || (sym->ts.type == BT_CLASS &&
1332 (CLASS_DATA (sym)->attr.dimension
1333 || CLASS_DATA (sym)->attr.allocatable))
1334 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1335 /* This applies a derived type default initializer. */
1336 || (sym->ts.type == BT_DERIVED
1337 && sym->attr.save == SAVE_NONE
1339 && !sym->attr.allocatable
1340 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1341 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1342 gfc_defer_symbol_init (sym);
1344 gfc_finish_var_decl (decl, sym);
1346 if (sym->ts.type == BT_CHARACTER)
1348 /* Character variables need special handling. */
1349 gfc_allocate_lang_decl (decl);
1351 if (TREE_CODE (length) != INTEGER_CST)
1353 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1357 /* Also prefix the mangled name for symbols from modules. */
1358 strcpy (&name[1], sym->name);
1361 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1362 gfc_set_decl_assembler_name (decl, get_identifier (name));
1364 gfc_finish_var_decl (length, sym);
1365 gcc_assert (!sym->value);
1368 else if (sym->attr.subref_array_pointer)
1370 /* We need the span for these beasts. */
1371 gfc_allocate_lang_decl (decl);
1374 if (sym->attr.subref_array_pointer)
1377 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1378 span = build_decl (input_location,
1379 VAR_DECL, create_tmp_var_name ("span"),
1380 gfc_array_index_type);
1381 gfc_finish_var_decl (span, sym);
1382 TREE_STATIC (span) = TREE_STATIC (decl);
1383 DECL_ARTIFICIAL (span) = 1;
1384 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1386 GFC_DECL_SPAN (decl) = span;
1387 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1390 sym->backend_decl = decl;
1392 if (sym->attr.assign)
1393 gfc_add_assign_aux_vars (sym);
1395 if (intrinsic_array_parameter)
1397 TREE_STATIC (decl) = 1;
1398 DECL_EXTERNAL (decl) = 0;
1401 if (TREE_STATIC (decl)
1402 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1403 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1404 || gfc_option.flag_max_stack_var_size == 0
1405 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1407 /* Add static initializer. For procedures, it is only needed if
1408 SAVE is specified otherwise they need to be reinitialized
1409 every time the procedure is entered. The TREE_STATIC is
1410 in this case due to -fmax-stack-var-size=. */
1411 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1413 sym->attr.dimension,
1415 || sym->attr.allocatable,
1416 sym->attr.proc_pointer);
1419 if (!TREE_STATIC (decl)
1420 && POINTER_TYPE_P (TREE_TYPE (decl))
1421 && !sym->attr.pointer
1422 && !sym->attr.allocatable
1423 && !sym->attr.proc_pointer)
1424 DECL_BY_REFERENCE (decl) = 1;
1430 /* Substitute a temporary variable in place of the real one. */
1433 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1435 save->attr = sym->attr;
1436 save->decl = sym->backend_decl;
1438 gfc_clear_attr (&sym->attr);
1439 sym->attr.referenced = 1;
1440 sym->attr.flavor = FL_VARIABLE;
1442 sym->backend_decl = decl;
1446 /* Restore the original variable. */
1449 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1451 sym->attr = save->attr;
1452 sym->backend_decl = save->decl;
1456 /* Declare a procedure pointer. */
1459 get_proc_pointer_decl (gfc_symbol *sym)
1464 decl = sym->backend_decl;
1468 decl = build_decl (input_location,
1469 VAR_DECL, get_identifier (sym->name),
1470 build_pointer_type (gfc_get_function_type (sym)));
1472 if ((sym->ns->proc_name
1473 && sym->ns->proc_name->backend_decl == current_function_decl)
1474 || sym->attr.contained)
1475 gfc_add_decl_to_function (decl);
1476 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1477 gfc_add_decl_to_parent_function (decl);
1479 sym->backend_decl = decl;
1481 /* If a variable is USE associated, it's always external. */
1482 if (sym->attr.use_assoc)
1484 DECL_EXTERNAL (decl) = 1;
1485 TREE_PUBLIC (decl) = 1;
1487 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1489 /* This is the declaration of a module variable. */
1490 TREE_PUBLIC (decl) = 1;
1491 TREE_STATIC (decl) = 1;
1494 if (!sym->attr.use_assoc
1495 && (sym->attr.save != SAVE_NONE || sym->attr.data
1496 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1497 TREE_STATIC (decl) = 1;
1499 if (TREE_STATIC (decl) && sym->value)
1501 /* Add static initializer. */
1502 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1504 sym->attr.dimension,
1508 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1509 decl_attributes (&decl, attributes, 0);
1515 /* Get a basic decl for an external function. */
1518 gfc_get_extern_function_decl (gfc_symbol * sym)
1524 gfc_intrinsic_sym *isym;
1526 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1531 if (sym->backend_decl)
1532 return sym->backend_decl;
1534 /* We should never be creating external decls for alternate entry points.
1535 The procedure may be an alternate entry point, but we don't want/need
1537 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1539 if (sym->attr.proc_pointer)
1540 return get_proc_pointer_decl (sym);
1542 /* See if this is an external procedure from the same file. If so,
1543 return the backend_decl. */
1544 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1546 if (gfc_option.flag_whole_file
1547 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1548 && !sym->backend_decl
1550 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1551 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1553 if (!gsym->ns->proc_name->backend_decl)
1555 /* By construction, the external function cannot be
1556 a contained procedure. */
1558 tree save_fn_decl = current_function_decl;
1560 current_function_decl = NULL_TREE;
1561 gfc_save_backend_locus (&old_loc);
1564 gfc_create_function_decl (gsym->ns, true);
1567 gfc_restore_backend_locus (&old_loc);
1568 current_function_decl = save_fn_decl;
1571 /* If the namespace has entries, the proc_name is the
1572 entry master. Find the entry and use its backend_decl.
1573 otherwise, use the proc_name backend_decl. */
1574 if (gsym->ns->entries)
1576 gfc_entry_list *entry = gsym->ns->entries;
1578 for (; entry; entry = entry->next)
1580 if (strcmp (gsym->name, entry->sym->name) == 0)
1582 sym->backend_decl = entry->sym->backend_decl;
1588 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1590 if (sym->backend_decl)
1592 /* Avoid problems of double deallocation of the backend declaration
1593 later in gfc_trans_use_stmts; cf. PR 45087. */
1594 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1595 sym->attr.use_assoc = 0;
1597 return sym->backend_decl;
1601 /* See if this is a module procedure from the same file. If so,
1602 return the backend_decl. */
1604 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1606 if (gfc_option.flag_whole_file
1608 && gsym->type == GSYM_MODULE)
1613 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1614 if (s && s->backend_decl)
1616 sym->backend_decl = s->backend_decl;
1617 return sym->backend_decl;
1621 if (sym->attr.intrinsic)
1623 /* Call the resolution function to get the actual name. This is
1624 a nasty hack which relies on the resolution functions only looking
1625 at the first argument. We pass NULL for the second argument
1626 otherwise things like AINT get confused. */
1627 isym = gfc_find_function (sym->name);
1628 gcc_assert (isym->resolve.f0 != NULL);
1630 memset (&e, 0, sizeof (e));
1631 e.expr_type = EXPR_FUNCTION;
1633 memset (&argexpr, 0, sizeof (argexpr));
1634 gcc_assert (isym->formal);
1635 argexpr.ts = isym->formal->ts;
1637 if (isym->formal->next == NULL)
1638 isym->resolve.f1 (&e, &argexpr);
1641 if (isym->formal->next->next == NULL)
1642 isym->resolve.f2 (&e, &argexpr, NULL);
1645 if (isym->formal->next->next->next == NULL)
1646 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1649 /* All specific intrinsics take less than 5 arguments. */
1650 gcc_assert (isym->formal->next->next->next->next == NULL);
1651 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1656 if (gfc_option.flag_f2c
1657 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1658 || e.ts.type == BT_COMPLEX))
1660 /* Specific which needs a different implementation if f2c
1661 calling conventions are used. */
1662 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1665 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1667 name = get_identifier (s);
1668 mangled_name = name;
1672 name = gfc_sym_identifier (sym);
1673 mangled_name = gfc_sym_mangled_function_id (sym);
1676 type = gfc_get_function_type (sym);
1677 fndecl = build_decl (input_location,
1678 FUNCTION_DECL, name, type);
1680 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1681 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1682 the opposite of declaring a function as static in C). */
1683 DECL_EXTERNAL (fndecl) = 1;
1684 TREE_PUBLIC (fndecl) = 1;
1686 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1687 decl_attributes (&fndecl, attributes, 0);
1689 gfc_set_decl_assembler_name (fndecl, mangled_name);
1691 /* Set the context of this decl. */
1692 if (0 && sym->ns && sym->ns->proc_name)
1694 /* TODO: Add external decls to the appropriate scope. */
1695 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1699 /* Global declaration, e.g. intrinsic subroutine. */
1700 DECL_CONTEXT (fndecl) = NULL_TREE;
1703 /* Set attributes for PURE functions. A call to PURE function in the
1704 Fortran 95 sense is both pure and without side effects in the C
1706 if (sym->attr.pure || sym->attr.elemental)
1708 if (sym->attr.function && !gfc_return_by_reference (sym))
1709 DECL_PURE_P (fndecl) = 1;
1710 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1711 parameters and don't use alternate returns (is this
1712 allowed?). In that case, calls to them are meaningless, and
1713 can be optimized away. See also in build_function_decl(). */
1714 TREE_SIDE_EFFECTS (fndecl) = 0;
1717 /* Mark non-returning functions. */
1718 if (sym->attr.noreturn)
1719 TREE_THIS_VOLATILE(fndecl) = 1;
1721 sym->backend_decl = fndecl;
1723 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1724 pushdecl_top_level (fndecl);
1730 /* Create a declaration for a procedure. For external functions (in the C
1731 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1732 a master function with alternate entry points. */
1735 build_function_decl (gfc_symbol * sym, bool global)
1737 tree fndecl, type, attributes;
1738 symbol_attribute attr;
1740 gfc_formal_arglist *f;
1742 gcc_assert (!sym->attr.external);
1744 if (sym->backend_decl)
1747 /* Set the line and filename. sym->declared_at seems to point to the
1748 last statement for subroutines, but it'll do for now. */
1749 gfc_set_backend_locus (&sym->declared_at);
1751 /* Allow only one nesting level. Allow public declarations. */
1752 gcc_assert (current_function_decl == NULL_TREE
1753 || DECL_FILE_SCOPE_P (current_function_decl)
1754 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1755 == NAMESPACE_DECL));
1757 type = gfc_get_function_type (sym);
1758 fndecl = build_decl (input_location,
1759 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1763 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1764 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1765 the opposite of declaring a function as static in C). */
1766 DECL_EXTERNAL (fndecl) = 0;
1768 if (!current_function_decl
1769 && !sym->attr.entry_master && !sym->attr.is_main_program)
1770 TREE_PUBLIC (fndecl) = 1;
1772 attributes = add_attributes_to_decl (attr, NULL_TREE);
1773 decl_attributes (&fndecl, attributes, 0);
1775 /* Figure out the return type of the declared function, and build a
1776 RESULT_DECL for it. If this is a subroutine with alternate
1777 returns, build a RESULT_DECL for it. */
1778 result_decl = NULL_TREE;
1779 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1782 if (gfc_return_by_reference (sym))
1783 type = void_type_node;
1786 if (sym->result != sym)
1787 result_decl = gfc_sym_identifier (sym->result);
1789 type = TREE_TYPE (TREE_TYPE (fndecl));
1794 /* Look for alternate return placeholders. */
1795 int has_alternate_returns = 0;
1796 for (f = sym->formal; f; f = f->next)
1800 has_alternate_returns = 1;
1805 if (has_alternate_returns)
1806 type = integer_type_node;
1808 type = void_type_node;
1811 result_decl = build_decl (input_location,
1812 RESULT_DECL, result_decl, type);
1813 DECL_ARTIFICIAL (result_decl) = 1;
1814 DECL_IGNORED_P (result_decl) = 1;
1815 DECL_CONTEXT (result_decl) = fndecl;
1816 DECL_RESULT (fndecl) = result_decl;
1818 /* Don't call layout_decl for a RESULT_DECL.
1819 layout_decl (result_decl, 0); */
1821 /* TREE_STATIC means the function body is defined here. */
1822 TREE_STATIC (fndecl) = 1;
1824 /* Set attributes for PURE functions. A call to a PURE function in the
1825 Fortran 95 sense is both pure and without side effects in the C
1827 if (attr.pure || attr.elemental)
1829 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1830 including an alternate return. In that case it can also be
1831 marked as PURE. See also in gfc_get_extern_function_decl(). */
1832 if (attr.function && !gfc_return_by_reference (sym))
1833 DECL_PURE_P (fndecl) = 1;
1834 TREE_SIDE_EFFECTS (fndecl) = 0;
1838 /* Layout the function declaration and put it in the binding level
1839 of the current function. */
1842 pushdecl_top_level (fndecl);
1846 /* Perform name mangling if this is a top level or module procedure. */
1847 if (current_function_decl == NULL_TREE)
1848 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1850 sym->backend_decl = fndecl;
1854 /* Create the DECL_ARGUMENTS for a procedure. */
1857 create_function_arglist (gfc_symbol * sym)
1860 gfc_formal_arglist *f;
1861 tree typelist, hidden_typelist;
1862 tree arglist, hidden_arglist;
1866 fndecl = sym->backend_decl;
1868 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1869 the new FUNCTION_DECL node. */
1870 arglist = NULL_TREE;
1871 hidden_arglist = NULL_TREE;
1872 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1874 if (sym->attr.entry_master)
1876 type = TREE_VALUE (typelist);
1877 parm = build_decl (input_location,
1878 PARM_DECL, get_identifier ("__entry"), type);
1880 DECL_CONTEXT (parm) = fndecl;
1881 DECL_ARG_TYPE (parm) = type;
1882 TREE_READONLY (parm) = 1;
1883 gfc_finish_decl (parm);
1884 DECL_ARTIFICIAL (parm) = 1;
1886 arglist = chainon (arglist, parm);
1887 typelist = TREE_CHAIN (typelist);
1890 if (gfc_return_by_reference (sym))
1892 tree type = TREE_VALUE (typelist), length = NULL;
1894 if (sym->ts.type == BT_CHARACTER)
1896 /* Length of character result. */
1897 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1899 length = build_decl (input_location,
1901 get_identifier (".__result"),
1903 if (!sym->ts.u.cl->length)
1905 sym->ts.u.cl->backend_decl = length;
1906 TREE_USED (length) = 1;
1908 gcc_assert (TREE_CODE (length) == PARM_DECL);
1909 DECL_CONTEXT (length) = fndecl;
1910 DECL_ARG_TYPE (length) = len_type;
1911 TREE_READONLY (length) = 1;
1912 DECL_ARTIFICIAL (length) = 1;
1913 gfc_finish_decl (length);
1914 if (sym->ts.u.cl->backend_decl == NULL
1915 || sym->ts.u.cl->backend_decl == length)
1920 if (sym->ts.u.cl->backend_decl == NULL)
1922 tree len = build_decl (input_location,
1924 get_identifier ("..__result"),
1925 gfc_charlen_type_node);
1926 DECL_ARTIFICIAL (len) = 1;
1927 TREE_USED (len) = 1;
1928 sym->ts.u.cl->backend_decl = len;
1931 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1932 arg = sym->result ? sym->result : sym;
1933 backend_decl = arg->backend_decl;
1934 /* Temporary clear it, so that gfc_sym_type creates complete
1936 arg->backend_decl = NULL;
1937 type = gfc_sym_type (arg);
1938 arg->backend_decl = backend_decl;
1939 type = build_reference_type (type);
1943 parm = build_decl (input_location,
1944 PARM_DECL, get_identifier ("__result"), type);
1946 DECL_CONTEXT (parm) = fndecl;
1947 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1948 TREE_READONLY (parm) = 1;
1949 DECL_ARTIFICIAL (parm) = 1;
1950 gfc_finish_decl (parm);
1952 arglist = chainon (arglist, parm);
1953 typelist = TREE_CHAIN (typelist);
1955 if (sym->ts.type == BT_CHARACTER)
1957 gfc_allocate_lang_decl (parm);
1958 arglist = chainon (arglist, length);
1959 typelist = TREE_CHAIN (typelist);
1963 hidden_typelist = typelist;
1964 for (f = sym->formal; f; f = f->next)
1965 if (f->sym != NULL) /* Ignore alternate returns. */
1966 hidden_typelist = TREE_CHAIN (hidden_typelist);
1968 for (f = sym->formal; f; f = f->next)
1970 char name[GFC_MAX_SYMBOL_LEN + 2];
1972 /* Ignore alternate returns. */
1976 type = TREE_VALUE (typelist);
1978 if (f->sym->ts.type == BT_CHARACTER
1979 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1981 tree len_type = TREE_VALUE (hidden_typelist);
1982 tree length = NULL_TREE;
1983 if (!f->sym->ts.deferred)
1984 gcc_assert (len_type == gfc_charlen_type_node);
1986 gcc_assert (POINTER_TYPE_P (len_type));
1988 strcpy (&name[1], f->sym->name);
1990 length = build_decl (input_location,
1991 PARM_DECL, get_identifier (name), len_type);
1993 hidden_arglist = chainon (hidden_arglist, length);
1994 DECL_CONTEXT (length) = fndecl;
1995 DECL_ARTIFICIAL (length) = 1;
1996 DECL_ARG_TYPE (length) = len_type;
1997 TREE_READONLY (length) = 1;
1998 gfc_finish_decl (length);
2000 /* Remember the passed value. */
2001 if (f->sym->ts.u.cl->passed_length != NULL)
2003 /* This can happen if the same type is used for multiple
2004 arguments. We need to copy cl as otherwise
2005 cl->passed_length gets overwritten. */
2006 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2008 f->sym->ts.u.cl->passed_length = length;
2010 /* Use the passed value for assumed length variables. */
2011 if (!f->sym->ts.u.cl->length)
2013 TREE_USED (length) = 1;
2014 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2015 f->sym->ts.u.cl->backend_decl = length;
2018 hidden_typelist = TREE_CHAIN (hidden_typelist);
2020 if (f->sym->ts.u.cl->backend_decl == NULL
2021 || f->sym->ts.u.cl->backend_decl == length)
2023 if (f->sym->ts.u.cl->backend_decl == NULL)
2024 gfc_create_string_length (f->sym);
2026 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2027 if (f->sym->attr.flavor == FL_PROCEDURE)
2028 type = build_pointer_type (gfc_get_function_type (f->sym));
2030 type = gfc_sym_type (f->sym);
2034 /* For non-constant length array arguments, make sure they use
2035 a different type node from TYPE_ARG_TYPES type. */
2036 if (f->sym->attr.dimension
2037 && type == TREE_VALUE (typelist)
2038 && TREE_CODE (type) == POINTER_TYPE
2039 && GFC_ARRAY_TYPE_P (type)
2040 && f->sym->as->type != AS_ASSUMED_SIZE
2041 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2043 if (f->sym->attr.flavor == FL_PROCEDURE)
2044 type = build_pointer_type (gfc_get_function_type (f->sym));
2046 type = gfc_sym_type (f->sym);
2049 if (f->sym->attr.proc_pointer)
2050 type = build_pointer_type (type);
2052 if (f->sym->attr.volatile_)
2053 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2055 /* Build the argument declaration. */
2056 parm = build_decl (input_location,
2057 PARM_DECL, gfc_sym_identifier (f->sym), type);
2059 if (f->sym->attr.volatile_)
2061 TREE_THIS_VOLATILE (parm) = 1;
2062 TREE_SIDE_EFFECTS (parm) = 1;
2065 /* Fill in arg stuff. */
2066 DECL_CONTEXT (parm) = fndecl;
2067 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2068 /* All implementation args are read-only. */
2069 TREE_READONLY (parm) = 1;
2070 if (POINTER_TYPE_P (type)
2071 && (!f->sym->attr.proc_pointer
2072 && f->sym->attr.flavor != FL_PROCEDURE))
2073 DECL_BY_REFERENCE (parm) = 1;
2075 gfc_finish_decl (parm);
2077 f->sym->backend_decl = parm;
2079 arglist = chainon (arglist, parm);
2080 typelist = TREE_CHAIN (typelist);
2083 /* Add the hidden string length parameters, unless the procedure
2085 if (!sym->attr.is_bind_c)
2086 arglist = chainon (arglist, hidden_arglist);
2088 gcc_assert (hidden_typelist == NULL_TREE
2089 || TREE_VALUE (hidden_typelist) == void_type_node);
2090 DECL_ARGUMENTS (fndecl) = arglist;
2093 /* Do the setup necessary before generating the body of a function. */
2096 trans_function_start (gfc_symbol * sym)
2100 fndecl = sym->backend_decl;
2102 /* Let GCC know the current scope is this function. */
2103 current_function_decl = fndecl;
2105 /* Let the world know what we're about to do. */
2106 announce_function (fndecl);
2108 if (DECL_FILE_SCOPE_P (fndecl))
2110 /* Create RTL for function declaration. */
2111 rest_of_decl_compilation (fndecl, 1, 0);
2114 /* Create RTL for function definition. */
2115 make_decl_rtl (fndecl);
2117 init_function_start (fndecl);
2119 /* function.c requires a push at the start of the function. */
2123 /* Create thunks for alternate entry points. */
2126 build_entry_thunks (gfc_namespace * ns, bool global)
2128 gfc_formal_arglist *formal;
2129 gfc_formal_arglist *thunk_formal;
2131 gfc_symbol *thunk_sym;
2137 /* This should always be a toplevel function. */
2138 gcc_assert (current_function_decl == NULL_TREE);
2140 gfc_save_backend_locus (&old_loc);
2141 for (el = ns->entries; el; el = el->next)
2143 VEC(tree,gc) *args = NULL;
2144 VEC(tree,gc) *string_args = NULL;
2146 thunk_sym = el->sym;
2148 build_function_decl (thunk_sym, global);
2149 create_function_arglist (thunk_sym);
2151 trans_function_start (thunk_sym);
2153 thunk_fndecl = thunk_sym->backend_decl;
2155 gfc_init_block (&body);
2157 /* Pass extra parameter identifying this entry point. */
2158 tmp = build_int_cst (gfc_array_index_type, el->id);
2159 VEC_safe_push (tree, gc, args, tmp);
2161 if (thunk_sym->attr.function)
2163 if (gfc_return_by_reference (ns->proc_name))
2165 tree ref = DECL_ARGUMENTS (current_function_decl);
2166 VEC_safe_push (tree, gc, args, ref);
2167 if (ns->proc_name->ts.type == BT_CHARACTER)
2168 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2172 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2174 /* Ignore alternate returns. */
2175 if (formal->sym == NULL)
2178 /* We don't have a clever way of identifying arguments, so resort to
2179 a brute-force search. */
2180 for (thunk_formal = thunk_sym->formal;
2182 thunk_formal = thunk_formal->next)
2184 if (thunk_formal->sym == formal->sym)
2190 /* Pass the argument. */
2191 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2192 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2193 if (formal->sym->ts.type == BT_CHARACTER)
2195 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2196 VEC_safe_push (tree, gc, string_args, tmp);
2201 /* Pass NULL for a missing argument. */
2202 VEC_safe_push (tree, gc, args, null_pointer_node);
2203 if (formal->sym->ts.type == BT_CHARACTER)
2205 tmp = build_int_cst (gfc_charlen_type_node, 0);
2206 VEC_safe_push (tree, gc, string_args, tmp);
2211 /* Call the master function. */
2212 VEC_safe_splice (tree, gc, args, string_args);
2213 tmp = ns->proc_name->backend_decl;
2214 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2215 if (ns->proc_name->attr.mixed_entry_master)
2217 tree union_decl, field;
2218 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2220 union_decl = build_decl (input_location,
2221 VAR_DECL, get_identifier ("__result"),
2222 TREE_TYPE (master_type));
2223 DECL_ARTIFICIAL (union_decl) = 1;
2224 DECL_EXTERNAL (union_decl) = 0;
2225 TREE_PUBLIC (union_decl) = 0;
2226 TREE_USED (union_decl) = 1;
2227 layout_decl (union_decl, 0);
2228 pushdecl (union_decl);
2230 DECL_CONTEXT (union_decl) = current_function_decl;
2231 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2232 TREE_TYPE (union_decl), union_decl, tmp);
2233 gfc_add_expr_to_block (&body, tmp);
2235 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2236 field; field = DECL_CHAIN (field))
2237 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2238 thunk_sym->result->name) == 0)
2240 gcc_assert (field != NULL_TREE);
2241 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2242 TREE_TYPE (field), union_decl, field,
2244 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2245 TREE_TYPE (DECL_RESULT (current_function_decl)),
2246 DECL_RESULT (current_function_decl), tmp);
2247 tmp = build1_v (RETURN_EXPR, tmp);
2249 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2252 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2253 TREE_TYPE (DECL_RESULT (current_function_decl)),
2254 DECL_RESULT (current_function_decl), tmp);
2255 tmp = build1_v (RETURN_EXPR, tmp);
2257 gfc_add_expr_to_block (&body, tmp);
2259 /* Finish off this function and send it for code generation. */
2260 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2263 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2264 DECL_SAVED_TREE (thunk_fndecl)
2265 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2266 DECL_INITIAL (thunk_fndecl));
2268 /* Output the GENERIC tree. */
2269 dump_function (TDI_original, thunk_fndecl);
2271 /* Store the end of the function, so that we get good line number
2272 info for the epilogue. */
2273 cfun->function_end_locus = input_location;
2275 /* We're leaving the context of this function, so zap cfun.
2276 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2277 tree_rest_of_compilation. */
2280 current_function_decl = NULL_TREE;
2282 cgraph_finalize_function (thunk_fndecl, true);
2284 /* We share the symbols in the formal argument list with other entry
2285 points and the master function. Clear them so that they are
2286 recreated for each function. */
2287 for (formal = thunk_sym->formal; formal; formal = formal->next)
2288 if (formal->sym != NULL) /* Ignore alternate returns. */
2290 formal->sym->backend_decl = NULL_TREE;
2291 if (formal->sym->ts.type == BT_CHARACTER)
2292 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2295 if (thunk_sym->attr.function)
2297 if (thunk_sym->ts.type == BT_CHARACTER)
2298 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2299 if (thunk_sym->result->ts.type == BT_CHARACTER)
2300 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2304 gfc_restore_backend_locus (&old_loc);
2308 /* Create a decl for a function, and create any thunks for alternate entry
2309 points. If global is true, generate the function in the global binding
2310 level, otherwise in the current binding level (which can be global). */
2313 gfc_create_function_decl (gfc_namespace * ns, bool global)
2315 /* Create a declaration for the master function. */
2316 build_function_decl (ns->proc_name, global);
2318 /* Compile the entry thunks. */
2320 build_entry_thunks (ns, global);
2322 /* Now create the read argument list. */
2323 create_function_arglist (ns->proc_name);
2326 /* Return the decl used to hold the function return value. If
2327 parent_flag is set, the context is the parent_scope. */
2330 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2334 tree this_fake_result_decl;
2335 tree this_function_decl;
2337 char name[GFC_MAX_SYMBOL_LEN + 10];
2341 this_fake_result_decl = parent_fake_result_decl;
2342 this_function_decl = DECL_CONTEXT (current_function_decl);
2346 this_fake_result_decl = current_fake_result_decl;
2347 this_function_decl = current_function_decl;
2351 && sym->ns->proc_name->backend_decl == this_function_decl
2352 && sym->ns->proc_name->attr.entry_master
2353 && sym != sym->ns->proc_name)
2356 if (this_fake_result_decl != NULL)
2357 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2358 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2361 return TREE_VALUE (t);
2362 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2365 this_fake_result_decl = parent_fake_result_decl;
2367 this_fake_result_decl = current_fake_result_decl;
2369 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2373 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2374 field; field = DECL_CHAIN (field))
2375 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2379 gcc_assert (field != NULL_TREE);
2380 decl = fold_build3_loc (input_location, COMPONENT_REF,
2381 TREE_TYPE (field), decl, field, NULL_TREE);
2384 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2386 gfc_add_decl_to_parent_function (var);
2388 gfc_add_decl_to_function (var);
2390 SET_DECL_VALUE_EXPR (var, decl);
2391 DECL_HAS_VALUE_EXPR_P (var) = 1;
2392 GFC_DECL_RESULT (var) = 1;
2394 TREE_CHAIN (this_fake_result_decl)
2395 = tree_cons (get_identifier (sym->name), var,
2396 TREE_CHAIN (this_fake_result_decl));
2400 if (this_fake_result_decl != NULL_TREE)
2401 return TREE_VALUE (this_fake_result_decl);
2403 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2408 if (sym->ts.type == BT_CHARACTER)
2410 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2411 length = gfc_create_string_length (sym);
2413 length = sym->ts.u.cl->backend_decl;
2414 if (TREE_CODE (length) == VAR_DECL
2415 && DECL_CONTEXT (length) == NULL_TREE)
2416 gfc_add_decl_to_function (length);
2419 if (gfc_return_by_reference (sym))
2421 decl = DECL_ARGUMENTS (this_function_decl);
2423 if (sym->ns->proc_name->backend_decl == this_function_decl
2424 && sym->ns->proc_name->attr.entry_master)
2425 decl = DECL_CHAIN (decl);
2427 TREE_USED (decl) = 1;
2429 decl = gfc_build_dummy_array_decl (sym, decl);
2433 sprintf (name, "__result_%.20s",
2434 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2436 if (!sym->attr.mixed_entry_master && sym->attr.function)
2437 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2438 VAR_DECL, get_identifier (name),
2439 gfc_sym_type (sym));
2441 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2442 VAR_DECL, get_identifier (name),
2443 TREE_TYPE (TREE_TYPE (this_function_decl)));
2444 DECL_ARTIFICIAL (decl) = 1;
2445 DECL_EXTERNAL (decl) = 0;
2446 TREE_PUBLIC (decl) = 0;
2447 TREE_USED (decl) = 1;
2448 GFC_DECL_RESULT (decl) = 1;
2449 TREE_ADDRESSABLE (decl) = 1;
2451 layout_decl (decl, 0);
2454 gfc_add_decl_to_parent_function (decl);
2456 gfc_add_decl_to_function (decl);
2460 parent_fake_result_decl = build_tree_list (NULL, decl);
2462 current_fake_result_decl = build_tree_list (NULL, decl);
2468 /* Builds a function decl. The remaining parameters are the types of the
2469 function arguments. Negative nargs indicates a varargs function. */
2472 build_library_function_decl_1 (tree name, const char *spec,
2473 tree rettype, int nargs, va_list p)
2475 VEC(tree,gc) *arglist;
2480 /* Library functions must be declared with global scope. */
2481 gcc_assert (current_function_decl == NULL_TREE);
2483 /* Create a list of the argument types. */
2484 arglist = VEC_alloc (tree, gc, abs (nargs));
2485 for (n = abs (nargs); n > 0; n--)
2487 tree argtype = va_arg (p, tree);
2488 VEC_quick_push (tree, arglist, argtype);
2491 /* Build the function type and decl. */
2493 fntype = build_function_type_vec (rettype, arglist);
2495 fntype = build_varargs_function_type_vec (rettype, arglist);
2498 tree attr_args = build_tree_list (NULL_TREE,
2499 build_string (strlen (spec), spec));
2500 tree attrs = tree_cons (get_identifier ("fn spec"),
2501 attr_args, TYPE_ATTRIBUTES (fntype));
2502 fntype = build_type_attribute_variant (fntype, attrs);
2504 fndecl = build_decl (input_location,
2505 FUNCTION_DECL, name, fntype);
2507 /* Mark this decl as external. */
2508 DECL_EXTERNAL (fndecl) = 1;
2509 TREE_PUBLIC (fndecl) = 1;
2513 rest_of_decl_compilation (fndecl, 1, 0);
2518 /* Builds a function decl. The remaining parameters are the types of the
2519 function arguments. Negative nargs indicates a varargs function. */
2522 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2526 va_start (args, nargs);
2527 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2532 /* Builds a function decl. The remaining parameters are the types of the
2533 function arguments. Negative nargs indicates a varargs function.
2534 The SPEC parameter specifies the function argument and return type
2535 specification according to the fnspec function type attribute. */
2538 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2539 tree rettype, int nargs, ...)
2543 va_start (args, nargs);
2544 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2550 gfc_build_intrinsic_function_decls (void)
2552 tree gfc_int4_type_node = gfc_get_int_type (4);
2553 tree gfc_int8_type_node = gfc_get_int_type (8);
2554 tree gfc_int16_type_node = gfc_get_int_type (16);
2555 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2556 tree pchar1_type_node = gfc_get_pchar_type (1);
2557 tree pchar4_type_node = gfc_get_pchar_type (4);
2559 /* String functions. */
2560 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2561 get_identifier (PREFIX("compare_string")), "..R.R",
2562 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2563 gfc_charlen_type_node, pchar1_type_node);
2564 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2565 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2567 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2568 get_identifier (PREFIX("concat_string")), "..W.R.R",
2569 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2570 gfc_charlen_type_node, pchar1_type_node,
2571 gfc_charlen_type_node, pchar1_type_node);
2572 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2574 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2575 get_identifier (PREFIX("string_len_trim")), "..R",
2576 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2577 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2578 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2580 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2581 get_identifier (PREFIX("string_index")), "..R.R.",
2582 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2583 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2584 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2585 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2587 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2588 get_identifier (PREFIX("string_scan")), "..R.R.",
2589 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2590 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2591 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2592 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2594 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2595 get_identifier (PREFIX("string_verify")), "..R.R.",
2596 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2597 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2598 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2599 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2601 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2602 get_identifier (PREFIX("string_trim")), ".Ww.R",
2603 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2604 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2607 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2608 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2609 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2610 build_pointer_type (pchar1_type_node), integer_type_node,
2613 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2614 get_identifier (PREFIX("adjustl")), ".W.R",
2615 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2617 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2619 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2620 get_identifier (PREFIX("adjustr")), ".W.R",
2621 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2623 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2625 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2626 get_identifier (PREFIX("select_string")), ".R.R.",
2627 integer_type_node, 4, pvoid_type_node, integer_type_node,
2628 pchar1_type_node, gfc_charlen_type_node);
2629 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2630 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2632 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2633 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2634 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2635 gfc_charlen_type_node, pchar4_type_node);
2636 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2637 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2639 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2640 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2641 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2642 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2644 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2646 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2647 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2648 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2649 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2650 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2652 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2653 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2654 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2655 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2656 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2657 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2659 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2660 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2661 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2662 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2663 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2664 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2666 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2667 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2668 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2669 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2670 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2671 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2673 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2674 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2675 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2676 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2679 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2680 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2681 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2682 build_pointer_type (pchar4_type_node), integer_type_node,
2685 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2686 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2687 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2689 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2691 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2692 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2693 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2695 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2697 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2698 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2699 integer_type_node, 4, pvoid_type_node, integer_type_node,
2700 pvoid_type_node, gfc_charlen_type_node);
2701 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2702 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2705 /* Conversion between character kinds. */
2707 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2708 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2709 void_type_node, 3, build_pointer_type (pchar4_type_node),
2710 gfc_charlen_type_node, pchar1_type_node);
2712 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2713 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2714 void_type_node, 3, build_pointer_type (pchar1_type_node),
2715 gfc_charlen_type_node, pchar4_type_node);
2717 /* Misc. functions. */
2719 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2720 get_identifier (PREFIX("ttynam")), ".W",
2721 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2724 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2725 get_identifier (PREFIX("fdate")), ".W",
2726 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2728 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2729 get_identifier (PREFIX("ctime")), ".W",
2730 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2731 gfc_int8_type_node);
2733 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2734 get_identifier (PREFIX("selected_char_kind")), "..R",
2735 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2736 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2737 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2739 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2740 get_identifier (PREFIX("selected_int_kind")), ".R",
2741 gfc_int4_type_node, 1, pvoid_type_node);
2742 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2743 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2745 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2746 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2747 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2749 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2750 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2752 /* Power functions. */
2754 tree ctype, rtype, itype, jtype;
2755 int rkind, ikind, jkind;
2758 static int ikinds[NIKINDS] = {4, 8, 16};
2759 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2760 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2762 for (ikind=0; ikind < NIKINDS; ikind++)
2764 itype = gfc_get_int_type (ikinds[ikind]);
2766 for (jkind=0; jkind < NIKINDS; jkind++)
2768 jtype = gfc_get_int_type (ikinds[jkind]);
2771 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2773 gfor_fndecl_math_powi[jkind][ikind].integer =
2774 gfc_build_library_function_decl (get_identifier (name),
2775 jtype, 2, jtype, itype);
2776 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2777 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2781 for (rkind = 0; rkind < NRKINDS; rkind ++)
2783 rtype = gfc_get_real_type (rkinds[rkind]);
2786 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2788 gfor_fndecl_math_powi[rkind][ikind].real =
2789 gfc_build_library_function_decl (get_identifier (name),
2790 rtype, 2, rtype, itype);
2791 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2792 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2795 ctype = gfc_get_complex_type (rkinds[rkind]);
2798 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2800 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2801 gfc_build_library_function_decl (get_identifier (name),
2802 ctype, 2,ctype, itype);
2803 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2804 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2812 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2813 get_identifier (PREFIX("ishftc4")),
2814 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2815 gfc_int4_type_node);
2816 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2817 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2819 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2820 get_identifier (PREFIX("ishftc8")),
2821 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2822 gfc_int4_type_node);
2823 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2824 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2826 if (gfc_int16_type_node)
2828 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2829 get_identifier (PREFIX("ishftc16")),
2830 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2831 gfc_int4_type_node);
2832 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2833 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2836 /* BLAS functions. */
2838 tree pint = build_pointer_type (integer_type_node);
2839 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2840 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2841 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2842 tree pz = build_pointer_type
2843 (gfc_get_complex_type (gfc_default_double_kind));
2845 gfor_fndecl_sgemm = gfc_build_library_function_decl
2847 (gfc_option.flag_underscoring ? "sgemm_"
2849 void_type_node, 15, pchar_type_node,
2850 pchar_type_node, pint, pint, pint, ps, ps, pint,
2851 ps, pint, ps, ps, pint, integer_type_node,
2853 gfor_fndecl_dgemm = gfc_build_library_function_decl
2855 (gfc_option.flag_underscoring ? "dgemm_"
2857 void_type_node, 15, pchar_type_node,
2858 pchar_type_node, pint, pint, pint, pd, pd, pint,
2859 pd, pint, pd, pd, pint, integer_type_node,
2861 gfor_fndecl_cgemm = gfc_build_library_function_decl
2863 (gfc_option.flag_underscoring ? "cgemm_"
2865 void_type_node, 15, pchar_type_node,
2866 pchar_type_node, pint, pint, pint, pc, pc, pint,
2867 pc, pint, pc, pc, pint, integer_type_node,
2869 gfor_fndecl_zgemm = gfc_build_library_function_decl
2871 (gfc_option.flag_underscoring ? "zgemm_"
2873 void_type_node, 15, pchar_type_node,
2874 pchar_type_node, pint, pint, pint, pz, pz, pint,
2875 pz, pint, pz, pz, pint, integer_type_node,
2879 /* Other functions. */
2880 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2881 get_identifier (PREFIX("size0")), ".R",
2882 gfc_array_index_type, 1, pvoid_type_node);
2883 DECL_PURE_P (gfor_fndecl_size0) = 1;
2884 TREE_NOTHROW (gfor_fndecl_size0) = 1;
2886 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2887 get_identifier (PREFIX("size1")), ".R",
2888 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2889 DECL_PURE_P (gfor_fndecl_size1) = 1;
2890 TREE_NOTHROW (gfor_fndecl_size1) = 1;
2892 gfor_fndecl_iargc = gfc_build_library_function_decl (
2893 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2894 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
2898 /* Make prototypes for runtime library functions. */
2901 gfc_build_builtin_function_decls (void)
2903 tree gfc_int4_type_node = gfc_get_int_type (4);
2905 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2906 get_identifier (PREFIX("stop_numeric")),
2907 void_type_node, 1, gfc_int4_type_node);
2908 /* STOP doesn't return. */
2909 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2911 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
2912 get_identifier (PREFIX("stop_numeric_f08")),
2913 void_type_node, 1, gfc_int4_type_node);
2914 /* STOP doesn't return. */
2915 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
2917 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2918 get_identifier (PREFIX("stop_string")), ".R.",
2919 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2920 /* STOP doesn't return. */
2921 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2923 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2924 get_identifier (PREFIX("error_stop_numeric")),
2925 void_type_node, 1, gfc_int4_type_node);
2926 /* ERROR STOP doesn't return. */
2927 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2929 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2930 get_identifier (PREFIX("error_stop_string")), ".R.",
2931 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2932 /* ERROR STOP doesn't return. */
2933 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2935 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2936 get_identifier (PREFIX("pause_numeric")),
2937 void_type_node, 1, gfc_int4_type_node);
2939 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2940 get_identifier (PREFIX("pause_string")), ".R.",
2941 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2943 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2944 get_identifier (PREFIX("runtime_error")), ".R",
2945 void_type_node, -1, pchar_type_node);
2946 /* The runtime_error function does not return. */
2947 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2949 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2950 get_identifier (PREFIX("runtime_error_at")), ".RR",
2951 void_type_node, -2, pchar_type_node, pchar_type_node);
2952 /* The runtime_error_at function does not return. */
2953 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2955 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2956 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2957 void_type_node, -2, pchar_type_node, pchar_type_node);
2959 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2960 get_identifier (PREFIX("generate_error")), ".R.R",
2961 void_type_node, 3, pvoid_type_node, integer_type_node,
2964 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2965 get_identifier (PREFIX("os_error")), ".R",
2966 void_type_node, 1, pchar_type_node);
2967 /* The runtime_error function does not return. */
2968 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2970 gfor_fndecl_set_args = gfc_build_library_function_decl (
2971 get_identifier (PREFIX("set_args")),
2972 void_type_node, 2, integer_type_node,
2973 build_pointer_type (pchar_type_node));
2975 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2976 get_identifier (PREFIX("set_fpe")),
2977 void_type_node, 1, integer_type_node);
2979 /* Keep the array dimension in sync with the call, later in this file. */
2980 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2981 get_identifier (PREFIX("set_options")), "..R",
2982 void_type_node, 2, integer_type_node,
2983 build_pointer_type (integer_type_node));
2985 gfor_fndecl_set_convert = gfc_build_library_function_decl (
2986 get_identifier (PREFIX("set_convert")),
2987 void_type_node, 1, integer_type_node);
2989 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2990 get_identifier (PREFIX("set_record_marker")),
2991 void_type_node, 1, integer_type_node);
2993 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
2994 get_identifier (PREFIX("set_max_subrecord_length")),
2995 void_type_node, 1, integer_type_node);
2997 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2998 get_identifier (PREFIX("internal_pack")), ".r",
2999 pvoid_type_node, 1, pvoid_type_node);
3001 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3002 get_identifier (PREFIX("internal_unpack")), ".wR",
3003 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3005 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3006 get_identifier (PREFIX("associated")), ".RR",
3007 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3008 DECL_PURE_P (gfor_fndecl_associated) = 1;
3009 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3011 /* Coarray library calls. */
3012 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3014 tree pint_type, pppchar_type;
3016 pint_type = build_pointer_type (integer_type_node);
3018 = build_pointer_type (build_pointer_type (pchar_type_node));
3020 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3021 get_identifier (PREFIX("caf_init")), void_type_node,
3022 4, pint_type, pppchar_type, pint_type, pint_type);
3024 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3025 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3027 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3028 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3030 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3031 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3033 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3034 get_identifier (PREFIX("caf_sync_all")), ".W", integer_type_node,
3035 2, build_pointer_type (pchar_type_node), integer_type_node);
3037 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3038 get_identifier (PREFIX("caf_sync_images")), ".RRW", integer_type_node,
3039 4, integer_type_node, pint_type, build_pointer_type (pchar_type_node),
3042 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3043 get_identifier (PREFIX("caf_error_stop")),
3044 void_type_node, 1, gfc_int4_type_node);
3045 /* CAF's ERROR STOP doesn't return. */
3046 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3048 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3049 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3050 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3051 /* CAF's ERROR STOP doesn't return. */
3052 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3055 gfc_build_intrinsic_function_decls ();
3056 gfc_build_intrinsic_lib_fndecls ();
3057 gfc_build_io_library_fndecls ();
3061 /* Evaluate the length of dummy character variables. */
3064 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3065 gfc_wrapped_block *block)
3069 gfc_finish_decl (cl->backend_decl);
3071 gfc_start_block (&init);
3073 /* Evaluate the string length expression. */
3074 gfc_conv_string_length (cl, NULL, &init);
3076 gfc_trans_vla_type_sizes (sym, &init);
3078 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3082 /* Allocate and cleanup an automatic character variable. */
3085 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3091 gcc_assert (sym->backend_decl);
3092 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3094 gfc_init_block (&init);
3096 /* Evaluate the string length expression. */
3097 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3099 gfc_trans_vla_type_sizes (sym, &init);
3101 decl = sym->backend_decl;
3103 /* Emit a DECL_EXPR for this variable, which will cause the
3104 gimplifier to allocate storage, and all that good stuff. */
3105 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3106 gfc_add_expr_to_block (&init, tmp);
3108 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3111 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3114 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3118 gcc_assert (sym->backend_decl);
3119 gfc_start_block (&init);
3121 /* Set the initial value to length. See the comments in
3122 function gfc_add_assign_aux_vars in this file. */
3123 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3124 build_int_cst (gfc_charlen_type_node, -2));
3126 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3130 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3132 tree t = *tp, var, val;
3134 if (t == NULL || t == error_mark_node)
3136 if (TREE_CONSTANT (t) || DECL_P (t))
3139 if (TREE_CODE (t) == SAVE_EXPR)
3141 if (SAVE_EXPR_RESOLVED_P (t))
3143 *tp = TREE_OPERAND (t, 0);
3146 val = TREE_OPERAND (t, 0);
3151 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3152 gfc_add_decl_to_function (var);
3153 gfc_add_modify (body, var, val);
3154 if (TREE_CODE (t) == SAVE_EXPR)
3155 TREE_OPERAND (t, 0) = var;
3160 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3164 if (type == NULL || type == error_mark_node)
3167 type = TYPE_MAIN_VARIANT (type);
3169 if (TREE_CODE (type) == INTEGER_TYPE)
3171 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3172 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3174 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3176 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3177 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3180 else if (TREE_CODE (type) == ARRAY_TYPE)
3182 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3183 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3184 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3185 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3187 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3189 TYPE_SIZE (t) = TYPE_SIZE (type);
3190 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3195 /* Make sure all type sizes and array domains are either constant,
3196 or variable or parameter decls. This is a simplified variant
3197 of gimplify_type_sizes, but we can't use it here, as none of the
3198 variables in the expressions have been gimplified yet.
3199 As type sizes and domains for various variable length arrays
3200 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3201 time, without this routine gimplify_type_sizes in the middle-end
3202 could result in the type sizes being gimplified earlier than where
3203 those variables are initialized. */
3206 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3208 tree type = TREE_TYPE (sym->backend_decl);
3210 if (TREE_CODE (type) == FUNCTION_TYPE
3211 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3213 if (! current_fake_result_decl)
3216 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3219 while (POINTER_TYPE_P (type))
3220 type = TREE_TYPE (type);
3222 if (GFC_DESCRIPTOR_TYPE_P (type))
3224 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3226 while (POINTER_TYPE_P (etype))
3227 etype = TREE_TYPE (etype);
3229 gfc_trans_vla_type_sizes_1 (etype, body);
3232 gfc_trans_vla_type_sizes_1 (type, body);
3236 /* Initialize a derived type by building an lvalue from the symbol
3237 and using trans_assignment to do the work. Set dealloc to false
3238 if no deallocation prior the assignment is needed. */
3240 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3248 gcc_assert (!sym->attr.allocatable);
3249 gfc_set_sym_referenced (sym);
3250 e = gfc_lval_expr_from_sym (sym);
3251 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3252 if (sym->attr.dummy && (sym->attr.optional
3253 || sym->ns->proc_name->attr.entry_master))
3255 present = gfc_conv_expr_present (sym);
3256 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3257 tmp, build_empty_stmt (input_location));
3259 gfc_add_expr_to_block (block, tmp);
3264 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3265 them their default initializer, if they do not have allocatable
3266 components, they have their allocatable components deallocated. */
3269 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3272 gfc_formal_arglist *f;
3276 gfc_init_block (&init);
3277 for (f = proc_sym->formal; f; f = f->next)
3278 if (f->sym && f->sym->attr.intent == INTENT_OUT
3279 && !f->sym->attr.pointer
3280 && f->sym->ts.type == BT_DERIVED)
3282 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3284 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3285 f->sym->backend_decl,
3286 f->sym->as ? f->sym->as->rank : 0);
3288 if (f->sym->attr.optional
3289 || f->sym->ns->proc_name->attr.entry_master)
3291 present = gfc_conv_expr_present (f->sym);
3292 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3294 build_empty_stmt (input_location));
3297 gfc_add_expr_to_block (&init, tmp);
3299 else if (f->sym->value)
3300 gfc_init_default_dt (f->sym, &init, true);
3302 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3303 && f->sym->ts.type == BT_CLASS
3304 && !CLASS_DATA (f->sym)->attr.class_pointer
3305 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3307 tree decl = build_fold_indirect_ref_loc (input_location,
3308 f->sym->backend_decl);
3309 tmp = CLASS_DATA (f->sym)->backend_decl;
3310 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3311 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3312 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3313 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3315 CLASS_DATA (f->sym)->as ?
3316 CLASS_DATA (f->sym)->as->rank : 0);
3318 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3320 present = gfc_conv_expr_present (f->sym);
3321 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3323 build_empty_stmt (input_location));
3326 gfc_add_expr_to_block (&init, tmp);
3329 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3333 /* Generate function entry and exit code, and add it to the function body.
3335 Allocation and initialization of array variables.
3336 Allocation of character string variables.
3337 Initialization and possibly repacking of dummy arrays.
3338 Initialization of ASSIGN statement auxiliary variable.
3339 Initialization of ASSOCIATE names.
3340 Automatic deallocation. */
3343 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3347 gfc_formal_arglist *f;
3348 stmtblock_t tmpblock;
3349 bool seen_trans_deferred_array = false;
3355 /* Deal with implicit return variables. Explicit return variables will
3356 already have been added. */
3357 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3359 if (!current_fake_result_decl)
3361 gfc_entry_list *el = NULL;
3362 if (proc_sym->attr.entry_master)
3364 for (el = proc_sym->ns->entries; el; el = el->next)
3365 if (el->sym != el->sym->result)
3368 /* TODO: move to the appropriate place in resolve.c. */
3369 if (warn_return_type && el == NULL)
3370 gfc_warning ("Return value of function '%s' at %L not set",
3371 proc_sym->name, &proc_sym->declared_at);
3373 else if (proc_sym->as)
3375 tree result = TREE_VALUE (current_fake_result_decl);
3376 gfc_trans_dummy_array_bias (proc_sym, result, block);
3378 /* An automatic character length, pointer array result. */
3379 if (proc_sym->ts.type == BT_CHARACTER
3380 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3381 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3383 else if (proc_sym->ts.type == BT_CHARACTER)
3385 if (proc_sym->ts.deferred)
3388 gfc_save_backend_locus (&loc);
3389 gfc_set_backend_locus (&proc_sym->declared_at);
3390 gfc_start_block (&init);
3391 /* Zero the string length on entry. */
3392 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3393 build_int_cst (gfc_charlen_type_node, 0));
3394 /* Null the pointer. */
3395 e = gfc_lval_expr_from_sym (proc_sym);
3396 gfc_init_se (&se, NULL);
3397 se.want_pointer = 1;
3398 gfc_conv_expr (&se, e);
3401 gfc_add_modify (&init, tmp,
3402 fold_convert (TREE_TYPE (se.expr),
3403 null_pointer_node));
3404 gfc_restore_backend_locus (&loc);
3406 /* Pass back the string length on exit. */
3407 tmp = proc_sym->ts.u.cl->passed_length;
3408 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3409 tmp = fold_convert (gfc_charlen_type_node, tmp);
3410 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3411 gfc_charlen_type_node, tmp,
3412 proc_sym->ts.u.cl->backend_decl);
3413 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3415 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3416 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3419 gcc_assert (gfc_option.flag_f2c
3420 && proc_sym->ts.type == BT_COMPLEX);
3423 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3424 should be done here so that the offsets and lbounds of arrays
3426 gfc_save_backend_locus (&loc);
3427 gfc_set_backend_locus (&proc_sym->declared_at);
3428 init_intent_out_dt (proc_sym, block);
3429 gfc_restore_backend_locus (&loc);
3431 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3433 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3434 && sym->ts.u.derived->attr.alloc_comp;
3438 if (sym->attr.dimension)
3440 switch (sym->as->type)
3443 if (sym->attr.dummy || sym->attr.result)
3444 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3445 else if (sym->attr.pointer || sym->attr.allocatable)
3447 if (TREE_STATIC (sym->backend_decl))
3449 gfc_save_backend_locus (&loc);
3450 gfc_set_backend_locus (&sym->declared_at);
3451 gfc_trans_static_array_pointer (sym);
3452 gfc_restore_backend_locus (&loc);
3456 seen_trans_deferred_array = true;
3457 gfc_trans_deferred_array (sym, block);
3462 gfc_save_backend_locus (&loc);
3463 gfc_set_backend_locus (&sym->declared_at);
3465 if (sym_has_alloc_comp)
3467 seen_trans_deferred_array = true;
3468 gfc_trans_deferred_array (sym, block);
3470 else if (sym->ts.type == BT_DERIVED
3473 && sym->attr.save == SAVE_NONE)
3475 gfc_start_block (&tmpblock);
3476 gfc_init_default_dt (sym, &tmpblock, false);
3477 gfc_add_init_cleanup (block,
3478 gfc_finish_block (&tmpblock),
3482 gfc_trans_auto_array_allocation (sym->backend_decl,
3484 gfc_restore_backend_locus (&loc);
3488 case AS_ASSUMED_SIZE:
3489 /* Must be a dummy parameter. */
3490 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3492 /* We should always pass assumed size arrays the g77 way. */
3493 if (sym->attr.dummy)
3494 gfc_trans_g77_array (sym, block);
3497 case AS_ASSUMED_SHAPE:
3498 /* Must be a dummy parameter. */
3499 gcc_assert (sym->attr.dummy);
3501 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3505 seen_trans_deferred_array = true;
3506 gfc_trans_deferred_array (sym, block);
3512 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3513 gfc_trans_deferred_array (sym, block);
3515 else if ((!sym->attr.dummy || sym->ts.deferred)
3516 && (sym->attr.allocatable
3517 || (sym->ts.type == BT_CLASS
3518 && CLASS_DATA (sym)->attr.allocatable)))
3520 if (!sym->attr.save)
3522 /* Nullify and automatic deallocation of allocatable
3524 e = gfc_lval_expr_from_sym (sym);
3525 if (sym->ts.type == BT_CLASS)
3526 gfc_add_data_component (e);
3528 gfc_init_se (&se, NULL);
3529 se.want_pointer = 1;
3530 gfc_conv_expr (&se, e);
3533 gfc_save_backend_locus (&loc);
3534 gfc_set_backend_locus (&sym->declared_at);
3535 gfc_start_block (&init);
3537 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3539 /* Nullify when entering the scope. */
3540 gfc_add_modify (&init, se.expr,
3541 fold_convert (TREE_TYPE (se.expr),
3542 null_pointer_node));
3545 if ((sym->attr.dummy ||sym->attr.result)
3546 && sym->ts.type == BT_CHARACTER
3547 && sym->ts.deferred)
3549 /* Character length passed by reference. */
3550 tmp = sym->ts.u.cl->passed_length;
3551 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3552 tmp = fold_convert (gfc_charlen_type_node, tmp);
3554 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3555 /* Zero the string length when entering the scope. */
3556 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3557 build_int_cst (gfc_charlen_type_node, 0));
3559 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3561 gfc_restore_backend_locus (&loc);
3563 /* Pass the final character length back. */
3564 if (sym->attr.intent != INTENT_IN)
3565 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3566 gfc_charlen_type_node, tmp,
3567 sym->ts.u.cl->backend_decl);
3572 gfc_restore_backend_locus (&loc);
3574 /* Deallocate when leaving the scope. Nullifying is not
3576 if (!sym->attr.result && !sym->attr.dummy)
3577 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3580 if (sym->ts.type == BT_CLASS)
3582 /* Initialize _vptr to declared type. */
3583 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3586 gfc_save_backend_locus (&loc);
3587 gfc_set_backend_locus (&sym->declared_at);
3588 e = gfc_lval_expr_from_sym (sym);
3589 gfc_add_vptr_component (e);
3590 gfc_init_se (&se, NULL);
3591 se.want_pointer = 1;
3592 gfc_conv_expr (&se, e);
3594 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3595 gfc_get_symbol_decl (vtab));
3596 gfc_add_modify (&init, se.expr, rhs);
3597 gfc_restore_backend_locus (&loc);
3600 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3603 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3608 /* If we get to here, all that should be left are pointers. */
3609 gcc_assert (sym->attr.pointer);
3611 if (sym->attr.dummy)
3613 gfc_start_block (&init);
3615 /* Character length passed by reference. */
3616 tmp = sym->ts.u.cl->passed_length;
3617 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3618 tmp = fold_convert (gfc_charlen_type_node, tmp);
3619 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3620 /* Pass the final character length back. */
3621 if (sym->attr.intent != INTENT_IN)
3622 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3623 gfc_charlen_type_node, tmp,
3624 sym->ts.u.cl->backend_decl);
3627 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3630 else if (sym->ts.deferred)
3631 gfc_fatal_error ("Deferred type parameter not yet supported");
3632 else if (sym_has_alloc_comp)
3633 gfc_trans_deferred_array (sym, block);
3634 else if (sym->ts.type == BT_CHARACTER)
3636 gfc_save_backend_locus (&loc);
3637 gfc_set_backend_locus (&sym->declared_at);
3638 if (sym->attr.dummy || sym->attr.result)
3639 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3641 gfc_trans_auto_character_variable (sym, block);
3642 gfc_restore_backend_locus (&loc);
3644 else if (sym->attr.assign)
3646 gfc_save_backend_locus (&loc);
3647 gfc_set_backend_locus (&sym->declared_at);
3648 gfc_trans_assign_aux_var (sym, block);
3649 gfc_restore_backend_locus (&loc);
3651 else if (sym->ts.type == BT_DERIVED
3654 && sym->attr.save == SAVE_NONE)
3656 gfc_start_block (&tmpblock);
3657 gfc_init_default_dt (sym, &tmpblock, false);
3658 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3665 gfc_init_block (&tmpblock);
3667 for (f = proc_sym->formal; f; f = f->next)
3669 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3671 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3672 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3673 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3677 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3678 && current_fake_result_decl != NULL)
3680 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3681 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3682 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3685 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3688 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3690 /* Hash and equality functions for module_htab. */
3693 module_htab_do_hash (const void *x)
3695 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3699 module_htab_eq (const void *x1, const void *x2)
3701 return strcmp ((((const struct module_htab_entry *)x1)->name),
3702 (const char *)x2) == 0;
3705 /* Hash and equality functions for module_htab's decls. */
3708 module_htab_decls_hash (const void *x)
3710 const_tree t = (const_tree) x;
3711 const_tree n = DECL_NAME (t);
3713 n = TYPE_NAME (TREE_TYPE (t));
3714 return htab_hash_string (IDENTIFIER_POINTER (n));
3718 module_htab_decls_eq (const void *x1, const void *x2)
3720 const_tree t1 = (const_tree) x1;
3721 const_tree n1 = DECL_NAME (t1);
3722 if (n1 == NULL_TREE)
3723 n1 = TYPE_NAME (TREE_TYPE (t1));
3724 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3727 struct module_htab_entry *
3728 gfc_find_module (const char *name)
3733 module_htab = htab_create_ggc (10, module_htab_do_hash,
3734 module_htab_eq, NULL);
3736 slot = htab_find_slot_with_hash (module_htab, name,
3737 htab_hash_string (name), INSERT);
3740 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3742 entry->name = gfc_get_string (name);
3743 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3744 module_htab_decls_eq, NULL);
3745 *slot = (void *) entry;
3747 return (struct module_htab_entry *) *slot;
3751 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3756 if (DECL_NAME (decl))
3757 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3760 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3761 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3763 slot = htab_find_slot_with_hash (entry->decls, name,
3764 htab_hash_string (name), INSERT);
3766 *slot = (void *) decl;
3769 static struct module_htab_entry *cur_module;
3771 /* Output an initialized decl for a module variable. */
3774 gfc_create_module_variable (gfc_symbol * sym)
3778 /* Module functions with alternate entries are dealt with later and
3779 would get caught by the next condition. */
3780 if (sym->attr.entry)
3783 /* Make sure we convert the types of the derived types from iso_c_binding
3785 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3786 && sym->ts.type == BT_DERIVED)
3787 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3789 if (sym->attr.flavor == FL_DERIVED
3790 && sym->backend_decl
3791 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3793 decl = sym->backend_decl;
3794 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3796 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3797 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3799 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3800 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3801 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3802 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3803 == sym->ns->proc_name->backend_decl);
3805 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3806 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3807 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3810 /* Only output variables, procedure pointers and array valued,
3811 or derived type, parameters. */
3812 if (sym->attr.flavor != FL_VARIABLE
3813 && !(sym->attr.flavor == FL_PARAMETER
3814 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3815 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3818 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3820 decl = sym->backend_decl;
3821 gcc_assert (DECL_FILE_SCOPE_P (decl));
3822 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3823 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3824 gfc_module_add_decl (cur_module, decl);
3827 /* Don't generate variables from other modules. Variables from
3828 COMMONs will already have been generated. */
3829 if (sym->attr.use_assoc || sym->attr.in_common)
3832 /* Equivalenced variables arrive here after creation. */
3833 if (sym->backend_decl
3834 && (sym->equiv_built || sym->attr.in_equivalence))
3837 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
3838 internal_error ("backend decl for module variable %s already exists",
3841 /* We always want module variables to be created. */
3842 sym->attr.referenced = 1;
3843 /* Create the decl. */
3844 decl = gfc_get_symbol_decl (sym);
3846 /* Create the variable. */
3848 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3849 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3850 rest_of_decl_compilation (decl, 1, 0);
3851 gfc_module_add_decl (cur_module, decl);
3853 /* Also add length of strings. */
3854 if (sym->ts.type == BT_CHARACTER)
3858 length = sym->ts.u.cl->backend_decl;
3859 gcc_assert (length || sym->attr.proc_pointer);
3860 if (length && !INTEGER_CST_P (length))
3863 rest_of_decl_compilation (length, 1, 0);
3868 /* Emit debug information for USE statements. */
3871 gfc_trans_use_stmts (gfc_namespace * ns)
3873 gfc_use_list *use_stmt;
3874 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3876 struct module_htab_entry *entry
3877 = gfc_find_module (use_stmt->module_name);
3878 gfc_use_rename *rent;
3880 if (entry->namespace_decl == NULL)
3882 entry->namespace_decl
3883 = build_decl (input_location,
3885 get_identifier (use_stmt->module_name),
3887 DECL_EXTERNAL (entry->namespace_decl) = 1;
3889 gfc_set_backend_locus (&use_stmt->where);
3890 if (!use_stmt->only_flag)
3891 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3893 ns->proc_name->backend_decl,
3895 for (rent = use_stmt->rename; rent; rent = rent->next)
3897 tree decl, local_name;
3900 if (rent->op != INTRINSIC_NONE)
3903 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3904 htab_hash_string (rent->use_name),
3910 st = gfc_find_symtree (ns->sym_root,
3912 ? rent->local_name : rent->use_name);
3915 /* Sometimes, generic interfaces wind up being over-ruled by a
3916 local symbol (see PR41062). */
3917 if (!st->n.sym->attr.use_assoc)
3920 if (st->n.sym->backend_decl
3921 && DECL_P (st->n.sym->backend_decl)
3922 && st->n.sym->module
3923 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3925 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3926 || (TREE_CODE (st->n.sym->backend_decl)
3928 decl = copy_node (st->n.sym->backend_decl);
3929 DECL_CONTEXT (decl) = entry->namespace_decl;
3930 DECL_EXTERNAL (decl) = 1;
3931 DECL_IGNORED_P (decl) = 0;
3932 DECL_INITIAL (decl) = NULL_TREE;
3936 *slot = error_mark_node;
3937 htab_clear_slot (entry->decls, slot);
3942 decl = (tree) *slot;
3943 if (rent->local_name[0])
3944 local_name = get_identifier (rent->local_name);
3946 local_name = NULL_TREE;
3947 gfc_set_backend_locus (&rent->where);
3948 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3949 ns->proc_name->backend_decl,
3950 !use_stmt->only_flag);
3956 /* Return true if expr is a constant initializer that gfc_conv_initializer
3960 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3970 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3972 else if (expr->expr_type == EXPR_STRUCTURE)
3973 return check_constant_initializer (expr, ts, false, false);
3974 else if (expr->expr_type != EXPR_ARRAY)
3976 for (c = gfc_constructor_first (expr->value.constructor);
3977 c; c = gfc_constructor_next (c))
3981 if (c->expr->expr_type == EXPR_STRUCTURE)
3983 if (!check_constant_initializer (c->expr, ts, false, false))
3986 else if (c->expr->expr_type != EXPR_CONSTANT)
3991 else switch (ts->type)
3994 if (expr->expr_type != EXPR_STRUCTURE)
3996 cm = expr->ts.u.derived->components;
3997 for (c = gfc_constructor_first (expr->value.constructor);
3998 c; c = gfc_constructor_next (c), cm = cm->next)
4000 if (!c->expr || cm->attr.allocatable)
4002 if (!check_constant_initializer (c->expr, &cm->ts,
4009 return expr->expr_type == EXPR_CONSTANT;
4013 /* Emit debug info for parameters and unreferenced variables with
4017 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4021 if (sym->attr.flavor != FL_PARAMETER
4022 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4025 if (sym->backend_decl != NULL
4026 || sym->value == NULL
4027 || sym->attr.use_assoc
4030 || sym->attr.function
4031 || sym->attr.intrinsic
4032 || sym->attr.pointer
4033 || sym->attr.allocatable
4034 || sym->attr.cray_pointee
4035 || sym->attr.threadprivate
4036 || sym->attr.is_bind_c
4037 || sym->attr.subref_array_pointer
4038 || sym->attr.assign)
4041 if (sym->ts.type == BT_CHARACTER)
4043 gfc_conv_const_charlen (sym->ts.u.cl);
4044 if (sym->ts.u.cl->backend_decl == NULL
4045 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4048 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4055 if (sym->as->type != AS_EXPLICIT)
4057 for (n = 0; n < sym->as->rank; n++)
4058 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4059 || sym->as->upper[n] == NULL
4060 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4064 if (!check_constant_initializer (sym->value, &sym->ts,
4065 sym->attr.dimension, false))
4068 /* Create the decl for the variable or constant. */
4069 decl = build_decl (input_location,
4070 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4071 gfc_sym_identifier (sym), gfc_sym_type (sym));
4072 if (sym->attr.flavor == FL_PARAMETER)
4073 TREE_READONLY (decl) = 1;
4074 gfc_set_decl_location (decl, &sym->declared_at);
4075 if (sym->attr.dimension)
4076 GFC_DECL_PACKED_ARRAY (decl) = 1;
4077 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4078 TREE_STATIC (decl) = 1;
4079 TREE_USED (decl) = 1;
4080 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4081 TREE_PUBLIC (decl) = 1;
4082 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4084 sym->attr.dimension,
4086 debug_hooks->global_decl (decl);
4089 /* Generate all the required code for module variables. */
4092 gfc_generate_module_vars (gfc_namespace * ns)
4094 module_namespace = ns;
4095 cur_module = gfc_find_module (ns->proc_name->name);
4097 /* Check if the frontend left the namespace in a reasonable state. */
4098 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4100 /* Generate COMMON blocks. */
4101 gfc_trans_common (ns);
4103 /* Create decls for all the module variables. */
4104 gfc_traverse_ns (ns, gfc_create_module_variable);
4108 gfc_trans_use_stmts (ns);
4109 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4114 gfc_generate_contained_functions (gfc_namespace * parent)
4118 /* We create all the prototypes before generating any code. */
4119 for (ns = parent->contained; ns; ns = ns->sibling)
4121 /* Skip namespaces from used modules. */
4122 if (ns->parent != parent)
4125 gfc_create_function_decl (ns, false);
4128 for (ns = parent->contained; ns; ns = ns->sibling)
4130 /* Skip namespaces from used modules. */
4131 if (ns->parent != parent)
4134 gfc_generate_function_code (ns);
4139 /* Drill down through expressions for the array specification bounds and
4140 character length calling generate_local_decl for all those variables
4141 that have not already been declared. */
4144 generate_local_decl (gfc_symbol *);
4146 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4149 expr_decls (gfc_expr *e, gfc_symbol *sym,
4150 int *f ATTRIBUTE_UNUSED)
4152 if (e->expr_type != EXPR_VARIABLE
4153 || sym == e->symtree->n.sym
4154 || e->symtree->n.sym->mark
4155 || e->symtree->n.sym->ns != sym->ns)
4158 generate_local_decl (e->symtree->n.sym);
4163 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4165 gfc_traverse_expr (e, sym, expr_decls, 0);
4169 /* Check for dependencies in the character length and array spec. */
4172 generate_dependency_declarations (gfc_symbol *sym)
4176 if (sym->ts.type == BT_CHARACTER
4178 && sym->ts.u.cl->length
4179 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4180 generate_expr_decls (sym, sym->ts.u.cl->length);
4182 if (sym->as && sym->as->rank)
4184 for (i = 0; i < sym->as->rank; i++)
4186 generate_expr_decls (sym, sym->as->lower[i]);
4187 generate_expr_decls (sym, sym->as->upper[i]);
4193 /* Generate decls for all local variables. We do this to ensure correct
4194 handling of expressions which only appear in the specification of
4198 generate_local_decl (gfc_symbol * sym)
4200 if (sym->attr.flavor == FL_VARIABLE)
4202 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4203 generate_dependency_declarations (sym);
4205 if (sym->attr.referenced)
4206 gfc_get_symbol_decl (sym);
4208 /* Warnings for unused dummy arguments. */
4209 else if (sym->attr.dummy)
4211 /* INTENT(out) dummy arguments are likely meant to be set. */
4212 if (gfc_option.warn_unused_dummy_argument
4213 && sym->attr.intent == INTENT_OUT)
4215 if (sym->ts.type != BT_DERIVED)
4216 gfc_warning ("Dummy argument '%s' at %L was declared "
4217 "INTENT(OUT) but was not set", sym->name,
4219 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4220 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4221 "declared INTENT(OUT) but was not set and "
4222 "does not have a default initializer",
4223 sym->name, &sym->declared_at);
4225 else if (gfc_option.warn_unused_dummy_argument)
4226 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4230 /* Warn for unused variables, but not if they're inside a common
4231 block, a namelist, or are use-associated. */
4232 else if (warn_unused_variable
4233 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4234 || sym->attr.in_namelist))
4235 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4238 /* For variable length CHARACTER parameters, the PARM_DECL already
4239 references the length variable, so force gfc_get_symbol_decl
4240 even when not referenced. If optimize > 0, it will be optimized
4241 away anyway. But do this only after emitting -Wunused-parameter
4242 warning if requested. */
4243 if (sym->attr.dummy && !sym->attr.referenced
4244 && sym->ts.type == BT_CHARACTER
4245 && sym->ts.u.cl->backend_decl != NULL
4246 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4248 sym->attr.referenced = 1;
4249 gfc_get_symbol_decl (sym);
4252 /* INTENT(out) dummy arguments and result variables with allocatable
4253 components are reset by default and need to be set referenced to
4254 generate the code for nullification and automatic lengths. */
4255 if (!sym->attr.referenced
4256 && sym->ts.type == BT_DERIVED
4257 && sym->ts.u.derived->attr.alloc_comp
4258 && !sym->attr.pointer
4259 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4261 (sym->attr.result && sym != sym->result)))
4263 sym->attr.referenced = 1;
4264 gfc_get_symbol_decl (sym);
4267 /* Check for dependencies in the array specification and string
4268 length, adding the necessary declarations to the function. We
4269 mark the symbol now, as well as in traverse_ns, to prevent
4270 getting stuck in a circular dependency. */
4273 /* We do not want the middle-end to warn about unused parameters
4274 as this was already done above. */
4275 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4276 TREE_NO_WARNING(sym->backend_decl) = 1;
4278 else if (sym->attr.flavor == FL_PARAMETER)
4280 if (warn_unused_parameter
4281 && !sym->attr.referenced
4282 && !sym->attr.use_assoc)
4283 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4286 else if (sym->attr.flavor == FL_PROCEDURE)
4288 /* TODO: move to the appropriate place in resolve.c. */
4289 if (warn_return_type
4290 && sym->attr.function
4292 && sym != sym->result
4293 && !sym->result->attr.referenced
4294 && !sym->attr.use_assoc
4295 && sym->attr.if_source != IFSRC_IFBODY)
4297 gfc_warning ("Return value '%s' of function '%s' declared at "
4298 "%L not set", sym->result->name, sym->name,
4299 &sym->result->declared_at);
4301 /* Prevents "Unused variable" warning for RESULT variables. */
4302 sym->result->mark = 1;
4306 if (sym->attr.dummy == 1)
4308 /* Modify the tree type for scalar character dummy arguments of bind(c)
4309 procedures if they are passed by value. The tree type for them will
4310 be promoted to INTEGER_TYPE for the middle end, which appears to be
4311 what C would do with characters passed by-value. The value attribute
4312 implies the dummy is a scalar. */
4313 if (sym->attr.value == 1 && sym->backend_decl != NULL
4314 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4315 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4316 gfc_conv_scalar_char_value (sym, NULL, NULL);
4319 /* Make sure we convert the types of the derived types from iso_c_binding
4321 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4322 && sym->ts.type == BT_DERIVED)
4323 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4327 generate_local_vars (gfc_namespace * ns)
4329 gfc_traverse_ns (ns, generate_local_decl);
4333 /* Generate a switch statement to jump to the correct entry point. Also
4334 creates the label decls for the entry points. */
4337 gfc_trans_entry_master_switch (gfc_entry_list * el)
4344 gfc_init_block (&block);
4345 for (; el; el = el->next)
4347 /* Add the case label. */
4348 label = gfc_build_label_decl (NULL_TREE);
4349 val = build_int_cst (gfc_array_index_type, el->id);
4350 tmp = build_case_label (val, NULL_TREE, label);
4351 gfc_add_expr_to_block (&block, tmp);
4353 /* And jump to the actual entry point. */
4354 label = gfc_build_label_decl (NULL_TREE);
4355 tmp = build1_v (GOTO_EXPR, label);
4356 gfc_add_expr_to_block (&block, tmp);
4358 /* Save the label decl. */
4361 tmp = gfc_finish_block (&block);
4362 /* The first argument selects the entry point. */
4363 val = DECL_ARGUMENTS (current_function_decl);
4364 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4369 /* Add code to string lengths of actual arguments passed to a function against
4370 the expected lengths of the dummy arguments. */
4373 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4375 gfc_formal_arglist *formal;
4377 for (formal = sym->formal; formal; formal = formal->next)
4378 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4380 enum tree_code comparison;
4385 const char *message;
4391 gcc_assert (cl->passed_length != NULL_TREE);
4392 gcc_assert (cl->backend_decl != NULL_TREE);
4394 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4395 string lengths must match exactly. Otherwise, it is only required
4396 that the actual string length is *at least* the expected one.
4397 Sequence association allows for a mismatch of the string length
4398 if the actual argument is (part of) an array, but only if the
4399 dummy argument is an array. (See "Sequence association" in
4400 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4401 if (fsym->attr.pointer || fsym->attr.allocatable
4402 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4404 comparison = NE_EXPR;
4405 message = _("Actual string length does not match the declared one"
4406 " for dummy argument '%s' (%ld/%ld)");
4408 else if (fsym->as && fsym->as->rank != 0)
4412 comparison = LT_EXPR;
4413 message = _("Actual string length is shorter than the declared one"
4414 " for dummy argument '%s' (%ld/%ld)");
4417 /* Build the condition. For optional arguments, an actual length
4418 of 0 is also acceptable if the associated string is NULL, which
4419 means the argument was not passed. */
4420 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4421 cl->passed_length, cl->backend_decl);
4422 if (fsym->attr.optional)
4428 not_0length = fold_build2_loc (input_location, NE_EXPR,
4431 build_zero_cst (gfc_charlen_type_node));
4432 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4433 fsym->attr.referenced = 1;
4434 not_absent = gfc_conv_expr_present (fsym);
4436 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4437 boolean_type_node, not_0length,
4440 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4441 boolean_type_node, cond, absent_failed);
4444 /* Build the runtime check. */
4445 argname = gfc_build_cstring_const (fsym->name);
4446 argname = gfc_build_addr_expr (pchar_type_node, argname);
4447 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4449 fold_convert (long_integer_type_node,
4451 fold_convert (long_integer_type_node,
4457 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4458 global variables for -fcoarray=lib. They are placed into the translation
4459 unit of the main program. Make sure that in one TU (the one of the main
4460 program), the first call to gfc_init_coarray_decl is done with true.
4461 Otherwise, expect link errors. */
4464 gfc_init_coarray_decl (bool main_tu)
4468 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4471 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4474 save_fn_decl = current_function_decl;
4475 current_function_decl = NULL_TREE;
4478 gfort_gvar_caf_this_image
4479 = build_decl (input_location, VAR_DECL,
4480 get_identifier (PREFIX("caf_this_image")),
4482 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4483 TREE_USED (gfort_gvar_caf_this_image) = 1;
4484 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4485 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4488 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4490 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4492 pushdecl_top_level (gfort_gvar_caf_this_image);
4494 gfort_gvar_caf_num_images
4495 = build_decl (input_location, VAR_DECL,
4496 get_identifier (PREFIX("caf_num_images")),
4498 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4499 TREE_USED (gfort_gvar_caf_num_images) = 1;
4500 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4501 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4504 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4506 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4508 pushdecl_top_level (gfort_gvar_caf_num_images);
4511 current_function_decl = save_fn_decl;
4516 create_main_function (tree fndecl)
4520 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4523 old_context = current_function_decl;
4527 push_function_context ();
4528 saved_parent_function_decls = saved_function_decls;
4529 saved_function_decls = NULL_TREE;
4532 /* main() function must be declared with global scope. */
4533 gcc_assert (current_function_decl == NULL_TREE);
4535 /* Declare the function. */
4536 tmp = build_function_type_list (integer_type_node, integer_type_node,
4537 build_pointer_type (pchar_type_node),
4539 main_identifier_node = get_identifier ("main");
4540 ftn_main = build_decl (input_location, FUNCTION_DECL,
4541 main_identifier_node, tmp);
4542 DECL_EXTERNAL (ftn_main) = 0;
4543 TREE_PUBLIC (ftn_main) = 1;
4544 TREE_STATIC (ftn_main) = 1;
4545 DECL_ATTRIBUTES (ftn_main)
4546 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4548 /* Setup the result declaration (for "return 0"). */
4549 result_decl = build_decl (input_location,
4550 RESULT_DECL, NULL_TREE, integer_type_node);
4551 DECL_ARTIFICIAL (result_decl) = 1;
4552 DECL_IGNORED_P (result_decl) = 1;
4553 DECL_CONTEXT (result_decl) = ftn_main;
4554 DECL_RESULT (ftn_main) = result_decl;
4556 pushdecl (ftn_main);
4558 /* Get the arguments. */
4560 arglist = NULL_TREE;
4561 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4563 tmp = TREE_VALUE (typelist);
4564 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4565 DECL_CONTEXT (argc) = ftn_main;
4566 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4567 TREE_READONLY (argc) = 1;
4568 gfc_finish_decl (argc);
4569 arglist = chainon (arglist, argc);
4571 typelist = TREE_CHAIN (typelist);
4572 tmp = TREE_VALUE (typelist);
4573 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4574 DECL_CONTEXT (argv) = ftn_main;
4575 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4576 TREE_READONLY (argv) = 1;
4577 DECL_BY_REFERENCE (argv) = 1;
4578 gfc_finish_decl (argv);
4579 arglist = chainon (arglist, argv);
4581 DECL_ARGUMENTS (ftn_main) = arglist;
4582 current_function_decl = ftn_main;
4583 announce_function (ftn_main);
4585 rest_of_decl_compilation (ftn_main, 1, 0);
4586 make_decl_rtl (ftn_main);
4587 init_function_start (ftn_main);
4590 gfc_init_block (&body);
4592 /* Call some libgfortran initialization routines, call then MAIN__(). */
4594 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4595 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4597 tree pint_type, pppchar_type;
4598 pint_type = build_pointer_type (integer_type_node);
4600 = build_pointer_type (build_pointer_type (pchar_type_node));
4602 gfc_init_coarray_decl (true);
4603 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4604 gfc_build_addr_expr (pint_type, argc),
4605 gfc_build_addr_expr (pppchar_type, argv),
4606 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4607 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4608 gfc_add_expr_to_block (&body, tmp);
4611 /* Call _gfortran_set_args (argc, argv). */
4612 TREE_USED (argc) = 1;
4613 TREE_USED (argv) = 1;
4614 tmp = build_call_expr_loc (input_location,
4615 gfor_fndecl_set_args, 2, argc, argv);
4616 gfc_add_expr_to_block (&body, tmp);
4618 /* Add a call to set_options to set up the runtime library Fortran
4619 language standard parameters. */
4621 tree array_type, array, var;
4622 VEC(constructor_elt,gc) *v = NULL;
4624 /* Passing a new option to the library requires four modifications:
4625 + add it to the tree_cons list below
4626 + change the array size in the call to build_array_type
4627 + change the first argument to the library call
4628 gfor_fndecl_set_options
4629 + modify the library (runtime/compile_options.c)! */
4631 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4632 build_int_cst (integer_type_node,
4633 gfc_option.warn_std));
4634 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4635 build_int_cst (integer_type_node,
4636 gfc_option.allow_std));
4637 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4638 build_int_cst (integer_type_node, pedantic));
4639 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4640 build_int_cst (integer_type_node,
4641 gfc_option.flag_dump_core));
4642 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4643 build_int_cst (integer_type_node,
4644 gfc_option.flag_backtrace));
4645 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4646 build_int_cst (integer_type_node,
4647 gfc_option.flag_sign_zero));
4648 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4649 build_int_cst (integer_type_node,
4651 & GFC_RTCHECK_BOUNDS)));
4652 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4653 build_int_cst (integer_type_node,
4654 gfc_option.flag_range_check));
4656 array_type = build_array_type (integer_type_node,
4657 build_index_type (size_int (7)));
4658 array = build_constructor (array_type, v);
4659 TREE_CONSTANT (array) = 1;
4660 TREE_STATIC (array) = 1;
4662 /* Create a static variable to hold the jump table. */
4663 var = gfc_create_var (array_type, "options");
4664 TREE_CONSTANT (var) = 1;
4665 TREE_STATIC (var) = 1;
4666 TREE_READONLY (var) = 1;
4667 DECL_INITIAL (var) = array;
4668 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4670 tmp = build_call_expr_loc (input_location,
4671 gfor_fndecl_set_options, 2,
4672 build_int_cst (integer_type_node, 8), var);
4673 gfc_add_expr_to_block (&body, tmp);
4676 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4677 the library will raise a FPE when needed. */
4678 if (gfc_option.fpe != 0)
4680 tmp = build_call_expr_loc (input_location,
4681 gfor_fndecl_set_fpe, 1,
4682 build_int_cst (integer_type_node,
4684 gfc_add_expr_to_block (&body, tmp);
4687 /* If this is the main program and an -fconvert option was provided,
4688 add a call to set_convert. */
4690 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4692 tmp = build_call_expr_loc (input_location,
4693 gfor_fndecl_set_convert, 1,
4694 build_int_cst (integer_type_node,
4695 gfc_option.convert));
4696 gfc_add_expr_to_block (&body, tmp);
4699 /* If this is the main program and an -frecord-marker option was provided,
4700 add a call to set_record_marker. */
4702 if (gfc_option.record_marker != 0)
4704 tmp = build_call_expr_loc (input_location,
4705 gfor_fndecl_set_record_marker, 1,
4706 build_int_cst (integer_type_node,
4707 gfc_option.record_marker));
4708 gfc_add_expr_to_block (&body, tmp);
4711 if (gfc_option.max_subrecord_length != 0)
4713 tmp = build_call_expr_loc (input_location,
4714 gfor_fndecl_set_max_subrecord_length, 1,
4715 build_int_cst (integer_type_node,
4716 gfc_option.max_subrecord_length));
4717 gfc_add_expr_to_block (&body, tmp);
4720 /* Call MAIN__(). */
4721 tmp = build_call_expr_loc (input_location,
4723 gfc_add_expr_to_block (&body, tmp);
4725 /* Mark MAIN__ as used. */
4726 TREE_USED (fndecl) = 1;
4728 /* Coarray: Call _gfortran_caf_finalize(void). */
4729 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4731 /* Per F2008, 8.5.1 END of the main program implies a
4733 tmp = built_in_decls [BUILT_IN_SYNCHRONIZE];
4734 tmp = build_call_expr_loc (input_location, tmp, 0);
4735 gfc_add_expr_to_block (&body, tmp);
4737 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
4738 gfc_add_expr_to_block (&body, tmp);
4742 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4743 DECL_RESULT (ftn_main),
4744 build_int_cst (integer_type_node, 0));
4745 tmp = build1_v (RETURN_EXPR, tmp);
4746 gfc_add_expr_to_block (&body, tmp);
4749 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4752 /* Finish off this function and send it for code generation. */
4754 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4756 DECL_SAVED_TREE (ftn_main)
4757 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4758 DECL_INITIAL (ftn_main));
4760 /* Output the GENERIC tree. */
4761 dump_function (TDI_original, ftn_main);
4763 cgraph_finalize_function (ftn_main, true);
4767 pop_function_context ();
4768 saved_function_decls = saved_parent_function_decls;
4770 current_function_decl = old_context;
4774 /* Get the result expression for a procedure. */
4777 get_proc_result (gfc_symbol* sym)
4779 if (sym->attr.subroutine || sym == sym->result)
4781 if (current_fake_result_decl != NULL)
4782 return TREE_VALUE (current_fake_result_decl);
4787 return sym->result->backend_decl;
4791 /* Generate an appropriate return-statement for a procedure. */
4794 gfc_generate_return (void)
4800 sym = current_procedure_symbol;
4801 fndecl = sym->backend_decl;
4803 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4807 result = get_proc_result (sym);
4809 /* Set the return value to the dummy result variable. The
4810 types may be different for scalar default REAL functions
4811 with -ff2c, therefore we have to convert. */
4812 if (result != NULL_TREE)
4814 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4815 result = fold_build2_loc (input_location, MODIFY_EXPR,
4816 TREE_TYPE (result), DECL_RESULT (fndecl),
4821 return build1_v (RETURN_EXPR, result);
4825 /* Generate code for a function. */
4828 gfc_generate_function_code (gfc_namespace * ns)
4834 stmtblock_t init, cleanup;
4836 gfc_wrapped_block try_block;
4837 tree recurcheckvar = NULL_TREE;
4839 gfc_symbol *previous_procedure_symbol;
4843 sym = ns->proc_name;
4844 previous_procedure_symbol = current_procedure_symbol;
4845 current_procedure_symbol = sym;
4847 /* Check that the frontend isn't still using this. */
4848 gcc_assert (sym->tlink == NULL);
4851 /* Create the declaration for functions with global scope. */
4852 if (!sym->backend_decl)
4853 gfc_create_function_decl (ns, false);
4855 fndecl = sym->backend_decl;
4856 old_context = current_function_decl;
4860 push_function_context ();
4861 saved_parent_function_decls = saved_function_decls;
4862 saved_function_decls = NULL_TREE;
4865 trans_function_start (sym);
4867 gfc_init_block (&init);
4869 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4871 /* Copy length backend_decls to all entry point result
4876 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4877 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4878 for (el = ns->entries; el; el = el->next)
4879 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4882 /* Translate COMMON blocks. */
4883 gfc_trans_common (ns);
4885 /* Null the parent fake result declaration if this namespace is
4886 a module function or an external procedures. */
4887 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4888 || ns->parent == NULL)
4889 parent_fake_result_decl = NULL_TREE;
4891 gfc_generate_contained_functions (ns);
4893 nonlocal_dummy_decls = NULL;
4894 nonlocal_dummy_decl_pset = NULL;
4896 generate_local_vars (ns);
4898 /* Keep the parent fake result declaration in module functions
4899 or external procedures. */
4900 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4901 || ns->parent == NULL)
4902 current_fake_result_decl = parent_fake_result_decl;
4904 current_fake_result_decl = NULL_TREE;
4906 is_recursive = sym->attr.recursive
4907 || (sym->attr.entry_master
4908 && sym->ns->entries->sym->attr.recursive);
4909 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4911 && !gfc_option.flag_recursive)
4915 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4917 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4918 TREE_STATIC (recurcheckvar) = 1;
4919 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4920 gfc_add_expr_to_block (&init, recurcheckvar);
4921 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4922 &sym->declared_at, msg);
4923 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
4927 /* Now generate the code for the body of this function. */
4928 gfc_init_block (&body);
4930 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4931 && sym->attr.subroutine)
4933 tree alternate_return;
4934 alternate_return = gfc_get_fake_result_decl (sym, 0);
4935 gfc_add_modify (&body, alternate_return, integer_zero_node);
4940 /* Jump to the correct entry point. */
4941 tmp = gfc_trans_entry_master_switch (ns->entries);
4942 gfc_add_expr_to_block (&body, tmp);
4945 /* If bounds-checking is enabled, generate code to check passed in actual
4946 arguments against the expected dummy argument attributes (e.g. string
4948 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4949 add_argument_checking (&body, sym);
4951 tmp = gfc_trans_code (ns->code);
4952 gfc_add_expr_to_block (&body, tmp);
4954 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4956 tree result = get_proc_result (sym);
4958 if (result != NULL_TREE
4959 && sym->attr.function
4960 && !sym->attr.pointer)
4962 if (sym->attr.allocatable && sym->attr.dimension == 0
4963 && sym->result == sym)
4964 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4965 null_pointer_node));
4966 else if (sym->ts.type == BT_DERIVED
4967 && sym->ts.u.derived->attr.alloc_comp
4968 && !sym->attr.allocatable)
4970 rank = sym->as ? sym->as->rank : 0;
4971 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4972 gfc_add_expr_to_block (&init, tmp);
4976 if (result == NULL_TREE)
4978 /* TODO: move to the appropriate place in resolve.c. */
4979 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4980 gfc_warning ("Return value of function '%s' at %L not set",
4981 sym->name, &sym->declared_at);
4983 TREE_NO_WARNING(sym->backend_decl) = 1;
4986 gfc_add_expr_to_block (&body, gfc_generate_return ());
4989 gfc_init_block (&cleanup);
4991 /* Reset recursion-check variable. */
4992 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4994 && !gfc_option.gfc_flag_openmp
4995 && recurcheckvar != NULL_TREE)
4997 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4998 recurcheckvar = NULL;
5001 /* Finish the function body and add init and cleanup code. */
5002 tmp = gfc_finish_block (&body);
5003 gfc_start_wrapped_block (&try_block, tmp);
5004 /* Add code to create and cleanup arrays. */
5005 gfc_trans_deferred_vars (sym, &try_block);
5006 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5007 gfc_finish_block (&cleanup));
5009 /* Add all the decls we created during processing. */
5010 decl = saved_function_decls;
5015 next = DECL_CHAIN (decl);
5016 DECL_CHAIN (decl) = NULL_TREE;
5020 saved_function_decls = NULL_TREE;
5022 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5025 /* Finish off this function and send it for code generation. */
5027 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5029 DECL_SAVED_TREE (fndecl)
5030 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5031 DECL_INITIAL (fndecl));
5033 if (nonlocal_dummy_decls)
5035 BLOCK_VARS (DECL_INITIAL (fndecl))
5036 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5037 pointer_set_destroy (nonlocal_dummy_decl_pset);
5038 nonlocal_dummy_decls = NULL;
5039 nonlocal_dummy_decl_pset = NULL;
5042 /* Output the GENERIC tree. */
5043 dump_function (TDI_original, fndecl);
5045 /* Store the end of the function, so that we get good line number
5046 info for the epilogue. */
5047 cfun->function_end_locus = input_location;
5049 /* We're leaving the context of this function, so zap cfun.
5050 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5051 tree_rest_of_compilation. */
5056 pop_function_context ();
5057 saved_function_decls = saved_parent_function_decls;
5059 current_function_decl = old_context;
5061 if (decl_function_context (fndecl))
5062 /* Register this function with cgraph just far enough to get it
5063 added to our parent's nested function list. */
5064 (void) cgraph_create_node (fndecl);
5066 cgraph_finalize_function (fndecl, true);
5068 gfc_trans_use_stmts (ns);
5069 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5071 if (sym->attr.is_main_program)
5072 create_main_function (fndecl);
5074 current_procedure_symbol = previous_procedure_symbol;
5079 gfc_generate_constructors (void)
5081 gcc_assert (gfc_static_ctors == NULL_TREE);
5089 if (gfc_static_ctors == NULL_TREE)
5092 fnname = get_file_function_name ("I");
5093 type = build_function_type_list (void_type_node, NULL_TREE);
5095 fndecl = build_decl (input_location,
5096 FUNCTION_DECL, fnname, type);
5097 TREE_PUBLIC (fndecl) = 1;
5099 decl = build_decl (input_location,
5100 RESULT_DECL, NULL_TREE, void_type_node);
5101 DECL_ARTIFICIAL (decl) = 1;
5102 DECL_IGNORED_P (decl) = 1;
5103 DECL_CONTEXT (decl) = fndecl;
5104 DECL_RESULT (fndecl) = decl;
5108 current_function_decl = fndecl;
5110 rest_of_decl_compilation (fndecl, 1, 0);
5112 make_decl_rtl (fndecl);
5114 init_function_start (fndecl);
5118 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5120 tmp = build_call_expr_loc (input_location,
5121 TREE_VALUE (gfc_static_ctors), 0);
5122 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5128 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5129 DECL_SAVED_TREE (fndecl)
5130 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5131 DECL_INITIAL (fndecl));
5133 free_after_parsing (cfun);
5134 free_after_compilation (cfun);
5136 tree_rest_of_compilation (fndecl);
5138 current_function_decl = NULL_TREE;
5142 /* Translates a BLOCK DATA program unit. This means emitting the
5143 commons contained therein plus their initializations. We also emit
5144 a globally visible symbol to make sure that each BLOCK DATA program
5145 unit remains unique. */
5148 gfc_generate_block_data (gfc_namespace * ns)
5153 /* Tell the backend the source location of the block data. */
5155 gfc_set_backend_locus (&ns->proc_name->declared_at);
5157 gfc_set_backend_locus (&gfc_current_locus);
5159 /* Process the DATA statements. */
5160 gfc_trans_common (ns);
5162 /* Create a global symbol with the mane of the block data. This is to
5163 generate linker errors if the same name is used twice. It is never
5166 id = gfc_sym_mangled_function_id (ns->proc_name);
5168 id = get_identifier ("__BLOCK_DATA__");
5170 decl = build_decl (input_location,
5171 VAR_DECL, id, gfc_array_index_type);
5172 TREE_PUBLIC (decl) = 1;
5173 TREE_STATIC (decl) = 1;
5174 DECL_IGNORED_P (decl) = 1;
5177 rest_of_decl_compilation (decl, 1, 0);
5181 /* Process the local variables of a BLOCK construct. */
5184 gfc_process_block_locals (gfc_namespace* ns)
5188 gcc_assert (saved_local_decls == NULL_TREE);
5189 generate_local_vars (ns);
5191 decl = saved_local_decls;
5196 next = DECL_CHAIN (decl);
5197 DECL_CHAIN (decl) = NULL_TREE;
5201 saved_local_decls = NULL_TREE;
5205 #include "gt-fortran-trans-decl.h"