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 (NULL_TREE, -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 /* Even though we're inside a function body, we still don't want to
2120 call expand_expr to calculate the size of a variable-sized array.
2121 We haven't necessarily assigned RTL to all variables yet, so it's
2122 not safe to try to expand expressions involving them. */
2123 cfun->dont_save_pending_sizes_p = 1;
2125 /* function.c requires a push at the start of the function. */
2129 /* Create thunks for alternate entry points. */
2132 build_entry_thunks (gfc_namespace * ns, bool global)
2134 gfc_formal_arglist *formal;
2135 gfc_formal_arglist *thunk_formal;
2137 gfc_symbol *thunk_sym;
2143 /* This should always be a toplevel function. */
2144 gcc_assert (current_function_decl == NULL_TREE);
2146 gfc_save_backend_locus (&old_loc);
2147 for (el = ns->entries; el; el = el->next)
2149 VEC(tree,gc) *args = NULL;
2150 VEC(tree,gc) *string_args = NULL;
2152 thunk_sym = el->sym;
2154 build_function_decl (thunk_sym, global);
2155 create_function_arglist (thunk_sym);
2157 trans_function_start (thunk_sym);
2159 thunk_fndecl = thunk_sym->backend_decl;
2161 gfc_init_block (&body);
2163 /* Pass extra parameter identifying this entry point. */
2164 tmp = build_int_cst (gfc_array_index_type, el->id);
2165 VEC_safe_push (tree, gc, args, tmp);
2167 if (thunk_sym->attr.function)
2169 if (gfc_return_by_reference (ns->proc_name))
2171 tree ref = DECL_ARGUMENTS (current_function_decl);
2172 VEC_safe_push (tree, gc, args, ref);
2173 if (ns->proc_name->ts.type == BT_CHARACTER)
2174 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2178 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2180 /* Ignore alternate returns. */
2181 if (formal->sym == NULL)
2184 /* We don't have a clever way of identifying arguments, so resort to
2185 a brute-force search. */
2186 for (thunk_formal = thunk_sym->formal;
2188 thunk_formal = thunk_formal->next)
2190 if (thunk_formal->sym == formal->sym)
2196 /* Pass the argument. */
2197 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2198 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2199 if (formal->sym->ts.type == BT_CHARACTER)
2201 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2202 VEC_safe_push (tree, gc, string_args, tmp);
2207 /* Pass NULL for a missing argument. */
2208 VEC_safe_push (tree, gc, args, null_pointer_node);
2209 if (formal->sym->ts.type == BT_CHARACTER)
2211 tmp = build_int_cst (gfc_charlen_type_node, 0);
2212 VEC_safe_push (tree, gc, string_args, tmp);
2217 /* Call the master function. */
2218 VEC_safe_splice (tree, gc, args, string_args);
2219 tmp = ns->proc_name->backend_decl;
2220 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2221 if (ns->proc_name->attr.mixed_entry_master)
2223 tree union_decl, field;
2224 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2226 union_decl = build_decl (input_location,
2227 VAR_DECL, get_identifier ("__result"),
2228 TREE_TYPE (master_type));
2229 DECL_ARTIFICIAL (union_decl) = 1;
2230 DECL_EXTERNAL (union_decl) = 0;
2231 TREE_PUBLIC (union_decl) = 0;
2232 TREE_USED (union_decl) = 1;
2233 layout_decl (union_decl, 0);
2234 pushdecl (union_decl);
2236 DECL_CONTEXT (union_decl) = current_function_decl;
2237 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2238 TREE_TYPE (union_decl), union_decl, tmp);
2239 gfc_add_expr_to_block (&body, tmp);
2241 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2242 field; field = DECL_CHAIN (field))
2243 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2244 thunk_sym->result->name) == 0)
2246 gcc_assert (field != NULL_TREE);
2247 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2248 TREE_TYPE (field), union_decl, field,
2250 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2251 TREE_TYPE (DECL_RESULT (current_function_decl)),
2252 DECL_RESULT (current_function_decl), tmp);
2253 tmp = build1_v (RETURN_EXPR, tmp);
2255 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2258 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2259 TREE_TYPE (DECL_RESULT (current_function_decl)),
2260 DECL_RESULT (current_function_decl), tmp);
2261 tmp = build1_v (RETURN_EXPR, tmp);
2263 gfc_add_expr_to_block (&body, tmp);
2265 /* Finish off this function and send it for code generation. */
2266 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2269 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2270 DECL_SAVED_TREE (thunk_fndecl)
2271 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2272 DECL_INITIAL (thunk_fndecl));
2274 /* Output the GENERIC tree. */
2275 dump_function (TDI_original, thunk_fndecl);
2277 /* Store the end of the function, so that we get good line number
2278 info for the epilogue. */
2279 cfun->function_end_locus = input_location;
2281 /* We're leaving the context of this function, so zap cfun.
2282 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2283 tree_rest_of_compilation. */
2286 current_function_decl = NULL_TREE;
2288 cgraph_finalize_function (thunk_fndecl, true);
2290 /* We share the symbols in the formal argument list with other entry
2291 points and the master function. Clear them so that they are
2292 recreated for each function. */
2293 for (formal = thunk_sym->formal; formal; formal = formal->next)
2294 if (formal->sym != NULL) /* Ignore alternate returns. */
2296 formal->sym->backend_decl = NULL_TREE;
2297 if (formal->sym->ts.type == BT_CHARACTER)
2298 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2301 if (thunk_sym->attr.function)
2303 if (thunk_sym->ts.type == BT_CHARACTER)
2304 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2305 if (thunk_sym->result->ts.type == BT_CHARACTER)
2306 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2310 gfc_restore_backend_locus (&old_loc);
2314 /* Create a decl for a function, and create any thunks for alternate entry
2315 points. If global is true, generate the function in the global binding
2316 level, otherwise in the current binding level (which can be global). */
2319 gfc_create_function_decl (gfc_namespace * ns, bool global)
2321 /* Create a declaration for the master function. */
2322 build_function_decl (ns->proc_name, global);
2324 /* Compile the entry thunks. */
2326 build_entry_thunks (ns, global);
2328 /* Now create the read argument list. */
2329 create_function_arglist (ns->proc_name);
2332 /* Return the decl used to hold the function return value. If
2333 parent_flag is set, the context is the parent_scope. */
2336 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2340 tree this_fake_result_decl;
2341 tree this_function_decl;
2343 char name[GFC_MAX_SYMBOL_LEN + 10];
2347 this_fake_result_decl = parent_fake_result_decl;
2348 this_function_decl = DECL_CONTEXT (current_function_decl);
2352 this_fake_result_decl = current_fake_result_decl;
2353 this_function_decl = current_function_decl;
2357 && sym->ns->proc_name->backend_decl == this_function_decl
2358 && sym->ns->proc_name->attr.entry_master
2359 && sym != sym->ns->proc_name)
2362 if (this_fake_result_decl != NULL)
2363 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2364 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2367 return TREE_VALUE (t);
2368 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2371 this_fake_result_decl = parent_fake_result_decl;
2373 this_fake_result_decl = current_fake_result_decl;
2375 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2379 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2380 field; field = DECL_CHAIN (field))
2381 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2385 gcc_assert (field != NULL_TREE);
2386 decl = fold_build3_loc (input_location, COMPONENT_REF,
2387 TREE_TYPE (field), decl, field, NULL_TREE);
2390 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2392 gfc_add_decl_to_parent_function (var);
2394 gfc_add_decl_to_function (var);
2396 SET_DECL_VALUE_EXPR (var, decl);
2397 DECL_HAS_VALUE_EXPR_P (var) = 1;
2398 GFC_DECL_RESULT (var) = 1;
2400 TREE_CHAIN (this_fake_result_decl)
2401 = tree_cons (get_identifier (sym->name), var,
2402 TREE_CHAIN (this_fake_result_decl));
2406 if (this_fake_result_decl != NULL_TREE)
2407 return TREE_VALUE (this_fake_result_decl);
2409 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2414 if (sym->ts.type == BT_CHARACTER)
2416 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2417 length = gfc_create_string_length (sym);
2419 length = sym->ts.u.cl->backend_decl;
2420 if (TREE_CODE (length) == VAR_DECL
2421 && DECL_CONTEXT (length) == NULL_TREE)
2422 gfc_add_decl_to_function (length);
2425 if (gfc_return_by_reference (sym))
2427 decl = DECL_ARGUMENTS (this_function_decl);
2429 if (sym->ns->proc_name->backend_decl == this_function_decl
2430 && sym->ns->proc_name->attr.entry_master)
2431 decl = DECL_CHAIN (decl);
2433 TREE_USED (decl) = 1;
2435 decl = gfc_build_dummy_array_decl (sym, decl);
2439 sprintf (name, "__result_%.20s",
2440 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2442 if (!sym->attr.mixed_entry_master && sym->attr.function)
2443 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2444 VAR_DECL, get_identifier (name),
2445 gfc_sym_type (sym));
2447 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2448 VAR_DECL, get_identifier (name),
2449 TREE_TYPE (TREE_TYPE (this_function_decl)));
2450 DECL_ARTIFICIAL (decl) = 1;
2451 DECL_EXTERNAL (decl) = 0;
2452 TREE_PUBLIC (decl) = 0;
2453 TREE_USED (decl) = 1;
2454 GFC_DECL_RESULT (decl) = 1;
2455 TREE_ADDRESSABLE (decl) = 1;
2457 layout_decl (decl, 0);
2460 gfc_add_decl_to_parent_function (decl);
2462 gfc_add_decl_to_function (decl);
2466 parent_fake_result_decl = build_tree_list (NULL, decl);
2468 current_fake_result_decl = build_tree_list (NULL, decl);
2474 /* Builds a function decl. The remaining parameters are the types of the
2475 function arguments. Negative nargs indicates a varargs function. */
2478 build_library_function_decl_1 (tree name, const char *spec,
2479 tree rettype, int nargs, va_list p)
2487 /* Library functions must be declared with global scope. */
2488 gcc_assert (current_function_decl == NULL_TREE);
2490 /* Create a list of the argument types. */
2491 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2493 argtype = va_arg (p, tree);
2494 arglist = gfc_chainon_list (arglist, argtype);
2499 /* Terminate the list. */
2500 arglist = chainon (arglist, void_list_node);
2503 /* Build the function type and decl. */
2504 fntype = build_function_type (rettype, arglist);
2507 tree attr_args = build_tree_list (NULL_TREE,
2508 build_string (strlen (spec), spec));
2509 tree attrs = tree_cons (get_identifier ("fn spec"),
2510 attr_args, TYPE_ATTRIBUTES (fntype));
2511 fntype = build_type_attribute_variant (fntype, attrs);
2513 fndecl = build_decl (input_location,
2514 FUNCTION_DECL, name, fntype);
2516 /* Mark this decl as external. */
2517 DECL_EXTERNAL (fndecl) = 1;
2518 TREE_PUBLIC (fndecl) = 1;
2522 rest_of_decl_compilation (fndecl, 1, 0);
2527 /* Builds a function decl. The remaining parameters are the types of the
2528 function arguments. Negative nargs indicates a varargs function. */
2531 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2535 va_start (args, nargs);
2536 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2541 /* Builds a function decl. The remaining parameters are the types of the
2542 function arguments. Negative nargs indicates a varargs function.
2543 The SPEC parameter specifies the function argument and return type
2544 specification according to the fnspec function type attribute. */
2547 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2548 tree rettype, int nargs, ...)
2552 va_start (args, nargs);
2553 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2559 gfc_build_intrinsic_function_decls (void)
2561 tree gfc_int4_type_node = gfc_get_int_type (4);
2562 tree gfc_int8_type_node = gfc_get_int_type (8);
2563 tree gfc_int16_type_node = gfc_get_int_type (16);
2564 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2565 tree pchar1_type_node = gfc_get_pchar_type (1);
2566 tree pchar4_type_node = gfc_get_pchar_type (4);
2568 /* String functions. */
2569 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2570 get_identifier (PREFIX("compare_string")), "..R.R",
2571 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2572 gfc_charlen_type_node, pchar1_type_node);
2573 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2574 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2576 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2577 get_identifier (PREFIX("concat_string")), "..W.R.R",
2578 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2579 gfc_charlen_type_node, pchar1_type_node,
2580 gfc_charlen_type_node, pchar1_type_node);
2581 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2583 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2584 get_identifier (PREFIX("string_len_trim")), "..R",
2585 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2586 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2587 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2589 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2590 get_identifier (PREFIX("string_index")), "..R.R.",
2591 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2592 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2593 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2594 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2596 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2597 get_identifier (PREFIX("string_scan")), "..R.R.",
2598 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2599 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2600 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2601 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2603 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2604 get_identifier (PREFIX("string_verify")), "..R.R.",
2605 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2606 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2607 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2608 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2610 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2611 get_identifier (PREFIX("string_trim")), ".Ww.R",
2612 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2613 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2616 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2617 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2618 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2619 build_pointer_type (pchar1_type_node), integer_type_node,
2622 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2623 get_identifier (PREFIX("adjustl")), ".W.R",
2624 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2626 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2628 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2629 get_identifier (PREFIX("adjustr")), ".W.R",
2630 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2632 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2634 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2635 get_identifier (PREFIX("select_string")), ".R.R.",
2636 integer_type_node, 4, pvoid_type_node, integer_type_node,
2637 pchar1_type_node, gfc_charlen_type_node);
2638 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2639 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2641 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2642 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2643 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2644 gfc_charlen_type_node, pchar4_type_node);
2645 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2646 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2648 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2649 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2650 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2651 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2653 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2655 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2656 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2657 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2658 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2659 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2661 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2662 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2663 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2664 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2665 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2666 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2668 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2669 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2670 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2671 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2672 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2673 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2675 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2676 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2677 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2678 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2679 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2680 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2682 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2683 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2684 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2685 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2688 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2689 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2690 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2691 build_pointer_type (pchar4_type_node), integer_type_node,
2694 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2695 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2696 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2698 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2700 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2701 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2702 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2704 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2706 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2707 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2708 integer_type_node, 4, pvoid_type_node, integer_type_node,
2709 pvoid_type_node, gfc_charlen_type_node);
2710 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2711 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2714 /* Conversion between character kinds. */
2716 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2717 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2718 void_type_node, 3, build_pointer_type (pchar4_type_node),
2719 gfc_charlen_type_node, pchar1_type_node);
2721 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2722 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2723 void_type_node, 3, build_pointer_type (pchar1_type_node),
2724 gfc_charlen_type_node, pchar4_type_node);
2726 /* Misc. functions. */
2728 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2729 get_identifier (PREFIX("ttynam")), ".W",
2730 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2733 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2734 get_identifier (PREFIX("fdate")), ".W",
2735 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2737 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2738 get_identifier (PREFIX("ctime")), ".W",
2739 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2740 gfc_int8_type_node);
2742 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2743 get_identifier (PREFIX("selected_char_kind")), "..R",
2744 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2745 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2746 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2748 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2749 get_identifier (PREFIX("selected_int_kind")), ".R",
2750 gfc_int4_type_node, 1, pvoid_type_node);
2751 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2752 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2754 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2755 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2756 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2758 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2759 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2761 /* Power functions. */
2763 tree ctype, rtype, itype, jtype;
2764 int rkind, ikind, jkind;
2767 static int ikinds[NIKINDS] = {4, 8, 16};
2768 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2769 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2771 for (ikind=0; ikind < NIKINDS; ikind++)
2773 itype = gfc_get_int_type (ikinds[ikind]);
2775 for (jkind=0; jkind < NIKINDS; jkind++)
2777 jtype = gfc_get_int_type (ikinds[jkind]);
2780 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2782 gfor_fndecl_math_powi[jkind][ikind].integer =
2783 gfc_build_library_function_decl (get_identifier (name),
2784 jtype, 2, jtype, itype);
2785 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2786 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2790 for (rkind = 0; rkind < NRKINDS; rkind ++)
2792 rtype = gfc_get_real_type (rkinds[rkind]);
2795 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2797 gfor_fndecl_math_powi[rkind][ikind].real =
2798 gfc_build_library_function_decl (get_identifier (name),
2799 rtype, 2, rtype, itype);
2800 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2801 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2804 ctype = gfc_get_complex_type (rkinds[rkind]);
2807 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2809 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2810 gfc_build_library_function_decl (get_identifier (name),
2811 ctype, 2,ctype, itype);
2812 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2813 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2821 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2822 get_identifier (PREFIX("ishftc4")),
2823 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2824 gfc_int4_type_node);
2825 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2826 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2828 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2829 get_identifier (PREFIX("ishftc8")),
2830 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2831 gfc_int4_type_node);
2832 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2833 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2835 if (gfc_int16_type_node)
2837 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2838 get_identifier (PREFIX("ishftc16")),
2839 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2840 gfc_int4_type_node);
2841 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2842 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2845 /* BLAS functions. */
2847 tree pint = build_pointer_type (integer_type_node);
2848 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2849 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2850 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2851 tree pz = build_pointer_type
2852 (gfc_get_complex_type (gfc_default_double_kind));
2854 gfor_fndecl_sgemm = gfc_build_library_function_decl
2856 (gfc_option.flag_underscoring ? "sgemm_"
2858 void_type_node, 15, pchar_type_node,
2859 pchar_type_node, pint, pint, pint, ps, ps, pint,
2860 ps, pint, ps, ps, pint, integer_type_node,
2862 gfor_fndecl_dgemm = gfc_build_library_function_decl
2864 (gfc_option.flag_underscoring ? "dgemm_"
2866 void_type_node, 15, pchar_type_node,
2867 pchar_type_node, pint, pint, pint, pd, pd, pint,
2868 pd, pint, pd, pd, pint, integer_type_node,
2870 gfor_fndecl_cgemm = gfc_build_library_function_decl
2872 (gfc_option.flag_underscoring ? "cgemm_"
2874 void_type_node, 15, pchar_type_node,
2875 pchar_type_node, pint, pint, pint, pc, pc, pint,
2876 pc, pint, pc, pc, pint, integer_type_node,
2878 gfor_fndecl_zgemm = gfc_build_library_function_decl
2880 (gfc_option.flag_underscoring ? "zgemm_"
2882 void_type_node, 15, pchar_type_node,
2883 pchar_type_node, pint, pint, pint, pz, pz, pint,
2884 pz, pint, pz, pz, pint, integer_type_node,
2888 /* Other functions. */
2889 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2890 get_identifier (PREFIX("size0")), ".R",
2891 gfc_array_index_type, 1, pvoid_type_node);
2892 DECL_PURE_P (gfor_fndecl_size0) = 1;
2893 TREE_NOTHROW (gfor_fndecl_size0) = 1;
2895 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2896 get_identifier (PREFIX("size1")), ".R",
2897 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2898 DECL_PURE_P (gfor_fndecl_size1) = 1;
2899 TREE_NOTHROW (gfor_fndecl_size1) = 1;
2901 gfor_fndecl_iargc = gfc_build_library_function_decl (
2902 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2903 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
2907 /* Make prototypes for runtime library functions. */
2910 gfc_build_builtin_function_decls (void)
2912 tree gfc_int4_type_node = gfc_get_int_type (4);
2914 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2915 get_identifier (PREFIX("stop_numeric")),
2916 void_type_node, 1, gfc_int4_type_node);
2917 /* STOP doesn't return. */
2918 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2920 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
2921 get_identifier (PREFIX("stop_numeric_f08")),
2922 void_type_node, 1, gfc_int4_type_node);
2923 /* STOP doesn't return. */
2924 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
2926 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2927 get_identifier (PREFIX("stop_string")), ".R.",
2928 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2929 /* STOP doesn't return. */
2930 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2932 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2933 get_identifier (PREFIX("error_stop_numeric")),
2934 void_type_node, 1, gfc_int4_type_node);
2935 /* ERROR STOP doesn't return. */
2936 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2938 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2939 get_identifier (PREFIX("error_stop_string")), ".R.",
2940 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2941 /* ERROR STOP doesn't return. */
2942 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2944 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2945 get_identifier (PREFIX("pause_numeric")),
2946 void_type_node, 1, gfc_int4_type_node);
2948 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2949 get_identifier (PREFIX("pause_string")), ".R.",
2950 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2952 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2953 get_identifier (PREFIX("runtime_error")), ".R",
2954 void_type_node, -1, pchar_type_node);
2955 /* The runtime_error function does not return. */
2956 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2958 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2959 get_identifier (PREFIX("runtime_error_at")), ".RR",
2960 void_type_node, -2, pchar_type_node, pchar_type_node);
2961 /* The runtime_error_at function does not return. */
2962 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2964 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2965 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2966 void_type_node, -2, pchar_type_node, pchar_type_node);
2968 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2969 get_identifier (PREFIX("generate_error")), ".R.R",
2970 void_type_node, 3, pvoid_type_node, integer_type_node,
2973 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2974 get_identifier (PREFIX("os_error")), ".R",
2975 void_type_node, 1, pchar_type_node);
2976 /* The runtime_error function does not return. */
2977 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2979 gfor_fndecl_set_args = gfc_build_library_function_decl (
2980 get_identifier (PREFIX("set_args")),
2981 void_type_node, 2, integer_type_node,
2982 build_pointer_type (pchar_type_node));
2984 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2985 get_identifier (PREFIX("set_fpe")),
2986 void_type_node, 1, integer_type_node);
2988 /* Keep the array dimension in sync with the call, later in this file. */
2989 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2990 get_identifier (PREFIX("set_options")), "..R",
2991 void_type_node, 2, integer_type_node,
2992 build_pointer_type (integer_type_node));
2994 gfor_fndecl_set_convert = gfc_build_library_function_decl (
2995 get_identifier (PREFIX("set_convert")),
2996 void_type_node, 1, integer_type_node);
2998 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2999 get_identifier (PREFIX("set_record_marker")),
3000 void_type_node, 1, integer_type_node);
3002 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3003 get_identifier (PREFIX("set_max_subrecord_length")),
3004 void_type_node, 1, integer_type_node);
3006 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3007 get_identifier (PREFIX("internal_pack")), ".r",
3008 pvoid_type_node, 1, pvoid_type_node);
3010 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3011 get_identifier (PREFIX("internal_unpack")), ".wR",
3012 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3014 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3015 get_identifier (PREFIX("associated")), ".RR",
3016 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3017 DECL_PURE_P (gfor_fndecl_associated) = 1;
3018 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3020 /* Coarray library calls. */
3021 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3023 tree pint_type, pppchar_type;
3025 pint_type = build_pointer_type (integer_type_node);
3027 = build_pointer_type (build_pointer_type (pchar_type_node));
3029 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3030 get_identifier (PREFIX("caf_init")), void_type_node,
3031 4, pint_type, pppchar_type, pint_type, pint_type);
3033 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3034 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3036 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3037 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3039 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3040 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3042 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3043 get_identifier (PREFIX("caf_sync_all")), ".W", integer_type_node,
3044 2, build_pointer_type (pchar_type_node), integer_type_node);
3046 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3047 get_identifier (PREFIX("caf_sync_images")), ".RRW", integer_type_node,
3048 4, integer_type_node, pint_type, build_pointer_type (pchar_type_node),
3051 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3052 get_identifier (PREFIX("caf_error_stop")),
3053 void_type_node, 1, gfc_int4_type_node);
3054 /* CAF's ERROR STOP doesn't return. */
3055 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3057 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3058 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3059 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3060 /* CAF's ERROR STOP doesn't return. */
3061 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3064 gfc_build_intrinsic_function_decls ();
3065 gfc_build_intrinsic_lib_fndecls ();
3066 gfc_build_io_library_fndecls ();
3070 /* Evaluate the length of dummy character variables. */
3073 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3074 gfc_wrapped_block *block)
3078 gfc_finish_decl (cl->backend_decl);
3080 gfc_start_block (&init);
3082 /* Evaluate the string length expression. */
3083 gfc_conv_string_length (cl, NULL, &init);
3085 gfc_trans_vla_type_sizes (sym, &init);
3087 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3091 /* Allocate and cleanup an automatic character variable. */
3094 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3100 gcc_assert (sym->backend_decl);
3101 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3103 gfc_init_block (&init);
3105 /* Evaluate the string length expression. */
3106 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3108 gfc_trans_vla_type_sizes (sym, &init);
3110 decl = sym->backend_decl;
3112 /* Emit a DECL_EXPR for this variable, which will cause the
3113 gimplifier to allocate storage, and all that good stuff. */
3114 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3115 gfc_add_expr_to_block (&init, tmp);
3117 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3120 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3123 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3127 gcc_assert (sym->backend_decl);
3128 gfc_start_block (&init);
3130 /* Set the initial value to length. See the comments in
3131 function gfc_add_assign_aux_vars in this file. */
3132 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3133 build_int_cst (NULL_TREE, -2));
3135 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3139 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3141 tree t = *tp, var, val;
3143 if (t == NULL || t == error_mark_node)
3145 if (TREE_CONSTANT (t) || DECL_P (t))
3148 if (TREE_CODE (t) == SAVE_EXPR)
3150 if (SAVE_EXPR_RESOLVED_P (t))
3152 *tp = TREE_OPERAND (t, 0);
3155 val = TREE_OPERAND (t, 0);
3160 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3161 gfc_add_decl_to_function (var);
3162 gfc_add_modify (body, var, val);
3163 if (TREE_CODE (t) == SAVE_EXPR)
3164 TREE_OPERAND (t, 0) = var;
3169 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3173 if (type == NULL || type == error_mark_node)
3176 type = TYPE_MAIN_VARIANT (type);
3178 if (TREE_CODE (type) == INTEGER_TYPE)
3180 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3181 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3183 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3185 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3186 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3189 else if (TREE_CODE (type) == ARRAY_TYPE)
3191 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3192 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3193 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3194 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3196 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3198 TYPE_SIZE (t) = TYPE_SIZE (type);
3199 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3204 /* Make sure all type sizes and array domains are either constant,
3205 or variable or parameter decls. This is a simplified variant
3206 of gimplify_type_sizes, but we can't use it here, as none of the
3207 variables in the expressions have been gimplified yet.
3208 As type sizes and domains for various variable length arrays
3209 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3210 time, without this routine gimplify_type_sizes in the middle-end
3211 could result in the type sizes being gimplified earlier than where
3212 those variables are initialized. */
3215 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3217 tree type = TREE_TYPE (sym->backend_decl);
3219 if (TREE_CODE (type) == FUNCTION_TYPE
3220 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3222 if (! current_fake_result_decl)
3225 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3228 while (POINTER_TYPE_P (type))
3229 type = TREE_TYPE (type);
3231 if (GFC_DESCRIPTOR_TYPE_P (type))
3233 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3235 while (POINTER_TYPE_P (etype))
3236 etype = TREE_TYPE (etype);
3238 gfc_trans_vla_type_sizes_1 (etype, body);
3241 gfc_trans_vla_type_sizes_1 (type, body);
3245 /* Initialize a derived type by building an lvalue from the symbol
3246 and using trans_assignment to do the work. Set dealloc to false
3247 if no deallocation prior the assignment is needed. */
3249 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3257 gcc_assert (!sym->attr.allocatable);
3258 gfc_set_sym_referenced (sym);
3259 e = gfc_lval_expr_from_sym (sym);
3260 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3261 if (sym->attr.dummy && (sym->attr.optional
3262 || sym->ns->proc_name->attr.entry_master))
3264 present = gfc_conv_expr_present (sym);
3265 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3266 tmp, build_empty_stmt (input_location));
3268 gfc_add_expr_to_block (block, tmp);
3273 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3274 them their default initializer, if they do not have allocatable
3275 components, they have their allocatable components deallocated. */
3278 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3281 gfc_formal_arglist *f;
3285 gfc_init_block (&init);
3286 for (f = proc_sym->formal; f; f = f->next)
3287 if (f->sym && f->sym->attr.intent == INTENT_OUT
3288 && !f->sym->attr.pointer
3289 && f->sym->ts.type == BT_DERIVED)
3291 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3293 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3294 f->sym->backend_decl,
3295 f->sym->as ? f->sym->as->rank : 0);
3297 if (f->sym->attr.optional
3298 || f->sym->ns->proc_name->attr.entry_master)
3300 present = gfc_conv_expr_present (f->sym);
3301 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3303 build_empty_stmt (input_location));
3306 gfc_add_expr_to_block (&init, tmp);
3308 else if (f->sym->value)
3309 gfc_init_default_dt (f->sym, &init, true);
3311 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3312 && f->sym->ts.type == BT_CLASS
3313 && !CLASS_DATA (f->sym)->attr.class_pointer
3314 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3316 tree decl = build_fold_indirect_ref_loc (input_location,
3317 f->sym->backend_decl);
3318 tmp = CLASS_DATA (f->sym)->backend_decl;
3319 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3320 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3321 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3322 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3324 CLASS_DATA (f->sym)->as ?
3325 CLASS_DATA (f->sym)->as->rank : 0);
3327 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3329 present = gfc_conv_expr_present (f->sym);
3330 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3332 build_empty_stmt (input_location));
3335 gfc_add_expr_to_block (&init, tmp);
3338 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3342 /* Generate function entry and exit code, and add it to the function body.
3344 Allocation and initialization of array variables.
3345 Allocation of character string variables.
3346 Initialization and possibly repacking of dummy arrays.
3347 Initialization of ASSIGN statement auxiliary variable.
3348 Initialization of ASSOCIATE names.
3349 Automatic deallocation. */
3352 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3356 gfc_formal_arglist *f;
3357 stmtblock_t tmpblock;
3358 bool seen_trans_deferred_array = false;
3364 /* Deal with implicit return variables. Explicit return variables will
3365 already have been added. */
3366 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3368 if (!current_fake_result_decl)
3370 gfc_entry_list *el = NULL;
3371 if (proc_sym->attr.entry_master)
3373 for (el = proc_sym->ns->entries; el; el = el->next)
3374 if (el->sym != el->sym->result)
3377 /* TODO: move to the appropriate place in resolve.c. */
3378 if (warn_return_type && el == NULL)
3379 gfc_warning ("Return value of function '%s' at %L not set",
3380 proc_sym->name, &proc_sym->declared_at);
3382 else if (proc_sym->as)
3384 tree result = TREE_VALUE (current_fake_result_decl);
3385 gfc_trans_dummy_array_bias (proc_sym, result, block);
3387 /* An automatic character length, pointer array result. */
3388 if (proc_sym->ts.type == BT_CHARACTER
3389 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3390 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3392 else if (proc_sym->ts.type == BT_CHARACTER)
3394 if (proc_sym->ts.deferred)
3397 gfc_save_backend_locus (&loc);
3398 gfc_set_backend_locus (&proc_sym->declared_at);
3399 gfc_start_block (&init);
3400 /* Zero the string length on entry. */
3401 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3402 build_int_cst (gfc_charlen_type_node, 0));
3403 /* Null the pointer. */
3404 e = gfc_lval_expr_from_sym (proc_sym);
3405 gfc_init_se (&se, NULL);
3406 se.want_pointer = 1;
3407 gfc_conv_expr (&se, e);
3410 gfc_add_modify (&init, tmp,
3411 fold_convert (TREE_TYPE (se.expr),
3412 null_pointer_node));
3413 gfc_restore_backend_locus (&loc);
3415 /* Pass back the string length on exit. */
3416 tmp = proc_sym->ts.u.cl->passed_length;
3417 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3418 tmp = fold_convert (gfc_charlen_type_node, tmp);
3419 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3420 gfc_charlen_type_node, tmp,
3421 proc_sym->ts.u.cl->backend_decl);
3422 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3424 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3425 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3428 gcc_assert (gfc_option.flag_f2c
3429 && proc_sym->ts.type == BT_COMPLEX);
3432 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3433 should be done here so that the offsets and lbounds of arrays
3435 gfc_save_backend_locus (&loc);
3436 gfc_set_backend_locus (&proc_sym->declared_at);
3437 init_intent_out_dt (proc_sym, block);
3438 gfc_restore_backend_locus (&loc);
3440 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3442 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3443 && sym->ts.u.derived->attr.alloc_comp;
3447 if (sym->attr.dimension)
3449 switch (sym->as->type)
3452 if (sym->attr.dummy || sym->attr.result)
3453 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3454 else if (sym->attr.pointer || sym->attr.allocatable)
3456 if (TREE_STATIC (sym->backend_decl))
3458 gfc_save_backend_locus (&loc);
3459 gfc_set_backend_locus (&sym->declared_at);
3460 gfc_trans_static_array_pointer (sym);
3461 gfc_restore_backend_locus (&loc);
3465 seen_trans_deferred_array = true;
3466 gfc_trans_deferred_array (sym, block);
3471 gfc_save_backend_locus (&loc);
3472 gfc_set_backend_locus (&sym->declared_at);
3474 if (sym_has_alloc_comp)
3476 seen_trans_deferred_array = true;
3477 gfc_trans_deferred_array (sym, block);
3479 else if (sym->ts.type == BT_DERIVED
3482 && sym->attr.save == SAVE_NONE)
3484 gfc_start_block (&tmpblock);
3485 gfc_init_default_dt (sym, &tmpblock, false);
3486 gfc_add_init_cleanup (block,
3487 gfc_finish_block (&tmpblock),
3491 gfc_trans_auto_array_allocation (sym->backend_decl,
3493 gfc_restore_backend_locus (&loc);
3497 case AS_ASSUMED_SIZE:
3498 /* Must be a dummy parameter. */
3499 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3501 /* We should always pass assumed size arrays the g77 way. */
3502 if (sym->attr.dummy)
3503 gfc_trans_g77_array (sym, block);
3506 case AS_ASSUMED_SHAPE:
3507 /* Must be a dummy parameter. */
3508 gcc_assert (sym->attr.dummy);
3510 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3514 seen_trans_deferred_array = true;
3515 gfc_trans_deferred_array (sym, block);
3521 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3522 gfc_trans_deferred_array (sym, block);
3524 else if ((!sym->attr.dummy || sym->ts.deferred)
3525 && (sym->attr.allocatable
3526 || (sym->ts.type == BT_CLASS
3527 && CLASS_DATA (sym)->attr.allocatable)))
3529 if (!sym->attr.save)
3531 /* Nullify and automatic deallocation of allocatable
3533 e = gfc_lval_expr_from_sym (sym);
3534 if (sym->ts.type == BT_CLASS)
3535 gfc_add_data_component (e);
3537 gfc_init_se (&se, NULL);
3538 se.want_pointer = 1;
3539 gfc_conv_expr (&se, e);
3542 gfc_save_backend_locus (&loc);
3543 gfc_set_backend_locus (&sym->declared_at);
3544 gfc_start_block (&init);
3546 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3548 /* Nullify when entering the scope. */
3549 gfc_add_modify (&init, se.expr,
3550 fold_convert (TREE_TYPE (se.expr),
3551 null_pointer_node));
3554 if ((sym->attr.dummy ||sym->attr.result)
3555 && sym->ts.type == BT_CHARACTER
3556 && sym->ts.deferred)
3558 /* Character length passed by reference. */
3559 tmp = sym->ts.u.cl->passed_length;
3560 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3561 tmp = fold_convert (gfc_charlen_type_node, tmp);
3563 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3564 /* Zero the string length when entering the scope. */
3565 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3566 build_int_cst (gfc_charlen_type_node, 0));
3568 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3570 gfc_restore_backend_locus (&loc);
3572 /* Pass the final character length back. */
3573 if (sym->attr.intent != INTENT_IN)
3574 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3575 gfc_charlen_type_node, tmp,
3576 sym->ts.u.cl->backend_decl);
3581 gfc_restore_backend_locus (&loc);
3583 /* Deallocate when leaving the scope. Nullifying is not
3585 if (!sym->attr.result && !sym->attr.dummy)
3586 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3589 if (sym->ts.type == BT_CLASS)
3591 /* Initialize _vptr to declared type. */
3592 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3595 gfc_save_backend_locus (&loc);
3596 gfc_set_backend_locus (&sym->declared_at);
3597 e = gfc_lval_expr_from_sym (sym);
3598 gfc_add_vptr_component (e);
3599 gfc_init_se (&se, NULL);
3600 se.want_pointer = 1;
3601 gfc_conv_expr (&se, e);
3603 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3604 gfc_get_symbol_decl (vtab));
3605 gfc_add_modify (&init, se.expr, rhs);
3606 gfc_restore_backend_locus (&loc);
3609 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3612 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3617 /* If we get to here, all that should be left are pointers. */
3618 gcc_assert (sym->attr.pointer);
3620 if (sym->attr.dummy)
3622 gfc_start_block (&init);
3624 /* Character length passed by reference. */
3625 tmp = sym->ts.u.cl->passed_length;
3626 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3627 tmp = fold_convert (gfc_charlen_type_node, tmp);
3628 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3629 /* Pass the final character length back. */
3630 if (sym->attr.intent != INTENT_IN)
3631 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3632 gfc_charlen_type_node, tmp,
3633 sym->ts.u.cl->backend_decl);
3636 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3639 else if (sym->ts.deferred)
3640 gfc_fatal_error ("Deferred type parameter not yet supported");
3641 else if (sym_has_alloc_comp)
3642 gfc_trans_deferred_array (sym, block);
3643 else if (sym->ts.type == BT_CHARACTER)
3645 gfc_save_backend_locus (&loc);
3646 gfc_set_backend_locus (&sym->declared_at);
3647 if (sym->attr.dummy || sym->attr.result)
3648 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3650 gfc_trans_auto_character_variable (sym, block);
3651 gfc_restore_backend_locus (&loc);
3653 else if (sym->attr.assign)
3655 gfc_save_backend_locus (&loc);
3656 gfc_set_backend_locus (&sym->declared_at);
3657 gfc_trans_assign_aux_var (sym, block);
3658 gfc_restore_backend_locus (&loc);
3660 else if (sym->ts.type == BT_DERIVED
3663 && sym->attr.save == SAVE_NONE)
3665 gfc_start_block (&tmpblock);
3666 gfc_init_default_dt (sym, &tmpblock, false);
3667 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3674 gfc_init_block (&tmpblock);
3676 for (f = proc_sym->formal; f; f = f->next)
3678 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3680 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3681 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3682 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3686 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3687 && current_fake_result_decl != NULL)
3689 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3690 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3691 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3694 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3697 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3699 /* Hash and equality functions for module_htab. */
3702 module_htab_do_hash (const void *x)
3704 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3708 module_htab_eq (const void *x1, const void *x2)
3710 return strcmp ((((const struct module_htab_entry *)x1)->name),
3711 (const char *)x2) == 0;
3714 /* Hash and equality functions for module_htab's decls. */
3717 module_htab_decls_hash (const void *x)
3719 const_tree t = (const_tree) x;
3720 const_tree n = DECL_NAME (t);
3722 n = TYPE_NAME (TREE_TYPE (t));
3723 return htab_hash_string (IDENTIFIER_POINTER (n));
3727 module_htab_decls_eq (const void *x1, const void *x2)
3729 const_tree t1 = (const_tree) x1;
3730 const_tree n1 = DECL_NAME (t1);
3731 if (n1 == NULL_TREE)
3732 n1 = TYPE_NAME (TREE_TYPE (t1));
3733 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3736 struct module_htab_entry *
3737 gfc_find_module (const char *name)
3742 module_htab = htab_create_ggc (10, module_htab_do_hash,
3743 module_htab_eq, NULL);
3745 slot = htab_find_slot_with_hash (module_htab, name,
3746 htab_hash_string (name), INSERT);
3749 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3751 entry->name = gfc_get_string (name);
3752 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3753 module_htab_decls_eq, NULL);
3754 *slot = (void *) entry;
3756 return (struct module_htab_entry *) *slot;
3760 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3765 if (DECL_NAME (decl))
3766 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3769 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3770 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3772 slot = htab_find_slot_with_hash (entry->decls, name,
3773 htab_hash_string (name), INSERT);
3775 *slot = (void *) decl;
3778 static struct module_htab_entry *cur_module;
3780 /* Output an initialized decl for a module variable. */
3783 gfc_create_module_variable (gfc_symbol * sym)
3787 /* Module functions with alternate entries are dealt with later and
3788 would get caught by the next condition. */
3789 if (sym->attr.entry)
3792 /* Make sure we convert the types of the derived types from iso_c_binding
3794 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3795 && sym->ts.type == BT_DERIVED)
3796 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3798 if (sym->attr.flavor == FL_DERIVED
3799 && sym->backend_decl
3800 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3802 decl = sym->backend_decl;
3803 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3805 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3806 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3808 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3809 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3810 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3811 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3812 == sym->ns->proc_name->backend_decl);
3814 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3815 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3816 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3819 /* Only output variables, procedure pointers and array valued,
3820 or derived type, parameters. */
3821 if (sym->attr.flavor != FL_VARIABLE
3822 && !(sym->attr.flavor == FL_PARAMETER
3823 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3824 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3827 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3829 decl = sym->backend_decl;
3830 gcc_assert (DECL_FILE_SCOPE_P (decl));
3831 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3832 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3833 gfc_module_add_decl (cur_module, decl);
3836 /* Don't generate variables from other modules. Variables from
3837 COMMONs will already have been generated. */
3838 if (sym->attr.use_assoc || sym->attr.in_common)
3841 /* Equivalenced variables arrive here after creation. */
3842 if (sym->backend_decl
3843 && (sym->equiv_built || sym->attr.in_equivalence))
3846 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
3847 internal_error ("backend decl for module variable %s already exists",
3850 /* We always want module variables to be created. */
3851 sym->attr.referenced = 1;
3852 /* Create the decl. */
3853 decl = gfc_get_symbol_decl (sym);
3855 /* Create the variable. */
3857 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3858 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3859 rest_of_decl_compilation (decl, 1, 0);
3860 gfc_module_add_decl (cur_module, decl);
3862 /* Also add length of strings. */
3863 if (sym->ts.type == BT_CHARACTER)
3867 length = sym->ts.u.cl->backend_decl;
3868 gcc_assert (length || sym->attr.proc_pointer);
3869 if (length && !INTEGER_CST_P (length))
3872 rest_of_decl_compilation (length, 1, 0);
3877 /* Emit debug information for USE statements. */
3880 gfc_trans_use_stmts (gfc_namespace * ns)
3882 gfc_use_list *use_stmt;
3883 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3885 struct module_htab_entry *entry
3886 = gfc_find_module (use_stmt->module_name);
3887 gfc_use_rename *rent;
3889 if (entry->namespace_decl == NULL)
3891 entry->namespace_decl
3892 = build_decl (input_location,
3894 get_identifier (use_stmt->module_name),
3896 DECL_EXTERNAL (entry->namespace_decl) = 1;
3898 gfc_set_backend_locus (&use_stmt->where);
3899 if (!use_stmt->only_flag)
3900 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3902 ns->proc_name->backend_decl,
3904 for (rent = use_stmt->rename; rent; rent = rent->next)
3906 tree decl, local_name;
3909 if (rent->op != INTRINSIC_NONE)
3912 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3913 htab_hash_string (rent->use_name),
3919 st = gfc_find_symtree (ns->sym_root,
3921 ? rent->local_name : rent->use_name);
3924 /* Sometimes, generic interfaces wind up being over-ruled by a
3925 local symbol (see PR41062). */
3926 if (!st->n.sym->attr.use_assoc)
3929 if (st->n.sym->backend_decl
3930 && DECL_P (st->n.sym->backend_decl)
3931 && st->n.sym->module
3932 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3934 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3935 || (TREE_CODE (st->n.sym->backend_decl)
3937 decl = copy_node (st->n.sym->backend_decl);
3938 DECL_CONTEXT (decl) = entry->namespace_decl;
3939 DECL_EXTERNAL (decl) = 1;
3940 DECL_IGNORED_P (decl) = 0;
3941 DECL_INITIAL (decl) = NULL_TREE;
3945 *slot = error_mark_node;
3946 htab_clear_slot (entry->decls, slot);
3951 decl = (tree) *slot;
3952 if (rent->local_name[0])
3953 local_name = get_identifier (rent->local_name);
3955 local_name = NULL_TREE;
3956 gfc_set_backend_locus (&rent->where);
3957 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3958 ns->proc_name->backend_decl,
3959 !use_stmt->only_flag);
3965 /* Return true if expr is a constant initializer that gfc_conv_initializer
3969 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3979 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3981 else if (expr->expr_type == EXPR_STRUCTURE)
3982 return check_constant_initializer (expr, ts, false, false);
3983 else if (expr->expr_type != EXPR_ARRAY)
3985 for (c = gfc_constructor_first (expr->value.constructor);
3986 c; c = gfc_constructor_next (c))
3990 if (c->expr->expr_type == EXPR_STRUCTURE)
3992 if (!check_constant_initializer (c->expr, ts, false, false))
3995 else if (c->expr->expr_type != EXPR_CONSTANT)
4000 else switch (ts->type)
4003 if (expr->expr_type != EXPR_STRUCTURE)
4005 cm = expr->ts.u.derived->components;
4006 for (c = gfc_constructor_first (expr->value.constructor);
4007 c; c = gfc_constructor_next (c), cm = cm->next)
4009 if (!c->expr || cm->attr.allocatable)
4011 if (!check_constant_initializer (c->expr, &cm->ts,
4018 return expr->expr_type == EXPR_CONSTANT;
4022 /* Emit debug info for parameters and unreferenced variables with
4026 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4030 if (sym->attr.flavor != FL_PARAMETER
4031 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4034 if (sym->backend_decl != NULL
4035 || sym->value == NULL
4036 || sym->attr.use_assoc
4039 || sym->attr.function
4040 || sym->attr.intrinsic
4041 || sym->attr.pointer
4042 || sym->attr.allocatable
4043 || sym->attr.cray_pointee
4044 || sym->attr.threadprivate
4045 || sym->attr.is_bind_c
4046 || sym->attr.subref_array_pointer
4047 || sym->attr.assign)
4050 if (sym->ts.type == BT_CHARACTER)
4052 gfc_conv_const_charlen (sym->ts.u.cl);
4053 if (sym->ts.u.cl->backend_decl == NULL
4054 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4057 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4064 if (sym->as->type != AS_EXPLICIT)
4066 for (n = 0; n < sym->as->rank; n++)
4067 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4068 || sym->as->upper[n] == NULL
4069 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4073 if (!check_constant_initializer (sym->value, &sym->ts,
4074 sym->attr.dimension, false))
4077 /* Create the decl for the variable or constant. */
4078 decl = build_decl (input_location,
4079 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4080 gfc_sym_identifier (sym), gfc_sym_type (sym));
4081 if (sym->attr.flavor == FL_PARAMETER)
4082 TREE_READONLY (decl) = 1;
4083 gfc_set_decl_location (decl, &sym->declared_at);
4084 if (sym->attr.dimension)
4085 GFC_DECL_PACKED_ARRAY (decl) = 1;
4086 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4087 TREE_STATIC (decl) = 1;
4088 TREE_USED (decl) = 1;
4089 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4090 TREE_PUBLIC (decl) = 1;
4091 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4093 sym->attr.dimension,
4095 debug_hooks->global_decl (decl);
4098 /* Generate all the required code for module variables. */
4101 gfc_generate_module_vars (gfc_namespace * ns)
4103 module_namespace = ns;
4104 cur_module = gfc_find_module (ns->proc_name->name);
4106 /* Check if the frontend left the namespace in a reasonable state. */
4107 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4109 /* Generate COMMON blocks. */
4110 gfc_trans_common (ns);
4112 /* Create decls for all the module variables. */
4113 gfc_traverse_ns (ns, gfc_create_module_variable);
4117 gfc_trans_use_stmts (ns);
4118 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4123 gfc_generate_contained_functions (gfc_namespace * parent)
4127 /* We create all the prototypes before generating any code. */
4128 for (ns = parent->contained; ns; ns = ns->sibling)
4130 /* Skip namespaces from used modules. */
4131 if (ns->parent != parent)
4134 gfc_create_function_decl (ns, false);
4137 for (ns = parent->contained; ns; ns = ns->sibling)
4139 /* Skip namespaces from used modules. */
4140 if (ns->parent != parent)
4143 gfc_generate_function_code (ns);
4148 /* Drill down through expressions for the array specification bounds and
4149 character length calling generate_local_decl for all those variables
4150 that have not already been declared. */
4153 generate_local_decl (gfc_symbol *);
4155 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4158 expr_decls (gfc_expr *e, gfc_symbol *sym,
4159 int *f ATTRIBUTE_UNUSED)
4161 if (e->expr_type != EXPR_VARIABLE
4162 || sym == e->symtree->n.sym
4163 || e->symtree->n.sym->mark
4164 || e->symtree->n.sym->ns != sym->ns)
4167 generate_local_decl (e->symtree->n.sym);
4172 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4174 gfc_traverse_expr (e, sym, expr_decls, 0);
4178 /* Check for dependencies in the character length and array spec. */
4181 generate_dependency_declarations (gfc_symbol *sym)
4185 if (sym->ts.type == BT_CHARACTER
4187 && sym->ts.u.cl->length
4188 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4189 generate_expr_decls (sym, sym->ts.u.cl->length);
4191 if (sym->as && sym->as->rank)
4193 for (i = 0; i < sym->as->rank; i++)
4195 generate_expr_decls (sym, sym->as->lower[i]);
4196 generate_expr_decls (sym, sym->as->upper[i]);
4202 /* Generate decls for all local variables. We do this to ensure correct
4203 handling of expressions which only appear in the specification of
4207 generate_local_decl (gfc_symbol * sym)
4209 if (sym->attr.flavor == FL_VARIABLE)
4211 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4212 generate_dependency_declarations (sym);
4214 if (sym->attr.referenced)
4215 gfc_get_symbol_decl (sym);
4217 /* Warnings for unused dummy arguments. */
4218 else if (sym->attr.dummy)
4220 /* INTENT(out) dummy arguments are likely meant to be set. */
4221 if (gfc_option.warn_unused_dummy_argument
4222 && sym->attr.intent == INTENT_OUT)
4224 if (sym->ts.type != BT_DERIVED)
4225 gfc_warning ("Dummy argument '%s' at %L was declared "
4226 "INTENT(OUT) but was not set", sym->name,
4228 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4229 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4230 "declared INTENT(OUT) but was not set and "
4231 "does not have a default initializer",
4232 sym->name, &sym->declared_at);
4234 else if (gfc_option.warn_unused_dummy_argument)
4235 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4239 /* Warn for unused variables, but not if they're inside a common
4240 block, a namelist, or are use-associated. */
4241 else if (warn_unused_variable
4242 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4243 || sym->attr.in_namelist))
4244 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4247 /* For variable length CHARACTER parameters, the PARM_DECL already
4248 references the length variable, so force gfc_get_symbol_decl
4249 even when not referenced. If optimize > 0, it will be optimized
4250 away anyway. But do this only after emitting -Wunused-parameter
4251 warning if requested. */
4252 if (sym->attr.dummy && !sym->attr.referenced
4253 && sym->ts.type == BT_CHARACTER
4254 && sym->ts.u.cl->backend_decl != NULL
4255 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4257 sym->attr.referenced = 1;
4258 gfc_get_symbol_decl (sym);
4261 /* INTENT(out) dummy arguments and result variables with allocatable
4262 components are reset by default and need to be set referenced to
4263 generate the code for nullification and automatic lengths. */
4264 if (!sym->attr.referenced
4265 && sym->ts.type == BT_DERIVED
4266 && sym->ts.u.derived->attr.alloc_comp
4267 && !sym->attr.pointer
4268 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4270 (sym->attr.result && sym != sym->result)))
4272 sym->attr.referenced = 1;
4273 gfc_get_symbol_decl (sym);
4276 /* Check for dependencies in the array specification and string
4277 length, adding the necessary declarations to the function. We
4278 mark the symbol now, as well as in traverse_ns, to prevent
4279 getting stuck in a circular dependency. */
4282 /* We do not want the middle-end to warn about unused parameters
4283 as this was already done above. */
4284 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4285 TREE_NO_WARNING(sym->backend_decl) = 1;
4287 else if (sym->attr.flavor == FL_PARAMETER)
4289 if (warn_unused_parameter
4290 && !sym->attr.referenced
4291 && !sym->attr.use_assoc)
4292 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4295 else if (sym->attr.flavor == FL_PROCEDURE)
4297 /* TODO: move to the appropriate place in resolve.c. */
4298 if (warn_return_type
4299 && sym->attr.function
4301 && sym != sym->result
4302 && !sym->result->attr.referenced
4303 && !sym->attr.use_assoc
4304 && sym->attr.if_source != IFSRC_IFBODY)
4306 gfc_warning ("Return value '%s' of function '%s' declared at "
4307 "%L not set", sym->result->name, sym->name,
4308 &sym->result->declared_at);
4310 /* Prevents "Unused variable" warning for RESULT variables. */
4311 sym->result->mark = 1;
4315 if (sym->attr.dummy == 1)
4317 /* Modify the tree type for scalar character dummy arguments of bind(c)
4318 procedures if they are passed by value. The tree type for them will
4319 be promoted to INTEGER_TYPE for the middle end, which appears to be
4320 what C would do with characters passed by-value. The value attribute
4321 implies the dummy is a scalar. */
4322 if (sym->attr.value == 1 && sym->backend_decl != NULL
4323 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4324 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4325 gfc_conv_scalar_char_value (sym, NULL, NULL);
4328 /* Make sure we convert the types of the derived types from iso_c_binding
4330 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4331 && sym->ts.type == BT_DERIVED)
4332 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4336 generate_local_vars (gfc_namespace * ns)
4338 gfc_traverse_ns (ns, generate_local_decl);
4342 /* Generate a switch statement to jump to the correct entry point. Also
4343 creates the label decls for the entry points. */
4346 gfc_trans_entry_master_switch (gfc_entry_list * el)
4353 gfc_init_block (&block);
4354 for (; el; el = el->next)
4356 /* Add the case label. */
4357 label = gfc_build_label_decl (NULL_TREE);
4358 val = build_int_cst (gfc_array_index_type, el->id);
4359 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4360 gfc_add_expr_to_block (&block, tmp);
4362 /* And jump to the actual entry point. */
4363 label = gfc_build_label_decl (NULL_TREE);
4364 tmp = build1_v (GOTO_EXPR, label);
4365 gfc_add_expr_to_block (&block, tmp);
4367 /* Save the label decl. */
4370 tmp = gfc_finish_block (&block);
4371 /* The first argument selects the entry point. */
4372 val = DECL_ARGUMENTS (current_function_decl);
4373 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4378 /* Add code to string lengths of actual arguments passed to a function against
4379 the expected lengths of the dummy arguments. */
4382 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4384 gfc_formal_arglist *formal;
4386 for (formal = sym->formal; formal; formal = formal->next)
4387 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4389 enum tree_code comparison;
4394 const char *message;
4400 gcc_assert (cl->passed_length != NULL_TREE);
4401 gcc_assert (cl->backend_decl != NULL_TREE);
4403 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4404 string lengths must match exactly. Otherwise, it is only required
4405 that the actual string length is *at least* the expected one.
4406 Sequence association allows for a mismatch of the string length
4407 if the actual argument is (part of) an array, but only if the
4408 dummy argument is an array. (See "Sequence association" in
4409 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4410 if (fsym->attr.pointer || fsym->attr.allocatable
4411 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4413 comparison = NE_EXPR;
4414 message = _("Actual string length does not match the declared one"
4415 " for dummy argument '%s' (%ld/%ld)");
4417 else if (fsym->as && fsym->as->rank != 0)
4421 comparison = LT_EXPR;
4422 message = _("Actual string length is shorter than the declared one"
4423 " for dummy argument '%s' (%ld/%ld)");
4426 /* Build the condition. For optional arguments, an actual length
4427 of 0 is also acceptable if the associated string is NULL, which
4428 means the argument was not passed. */
4429 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4430 cl->passed_length, cl->backend_decl);
4431 if (fsym->attr.optional)
4437 not_0length = fold_build2_loc (input_location, NE_EXPR,
4440 build_zero_cst (gfc_charlen_type_node));
4441 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4442 fsym->attr.referenced = 1;
4443 not_absent = gfc_conv_expr_present (fsym);
4445 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4446 boolean_type_node, not_0length,
4449 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4450 boolean_type_node, cond, absent_failed);
4453 /* Build the runtime check. */
4454 argname = gfc_build_cstring_const (fsym->name);
4455 argname = gfc_build_addr_expr (pchar_type_node, argname);
4456 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4458 fold_convert (long_integer_type_node,
4460 fold_convert (long_integer_type_node,
4467 gfc_init_coarray_decl (void)
4469 tree save_fn_decl = current_function_decl;
4471 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4474 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4477 save_fn_decl = current_function_decl;
4478 current_function_decl = NULL_TREE;
4481 gfort_gvar_caf_this_image = gfc_create_var (integer_type_node,
4482 PREFIX("caf_this_image"));
4483 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4484 TREE_USED (gfort_gvar_caf_this_image) = 1;
4485 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4486 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4488 gfort_gvar_caf_num_images = gfc_create_var (integer_type_node,
4489 PREFIX("caf_num_images"));
4490 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4491 TREE_USED (gfort_gvar_caf_num_images) = 1;
4492 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4493 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4496 current_function_decl = save_fn_decl;
4501 create_main_function (tree fndecl)
4505 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4508 old_context = current_function_decl;
4512 push_function_context ();
4513 saved_parent_function_decls = saved_function_decls;
4514 saved_function_decls = NULL_TREE;
4517 /* main() function must be declared with global scope. */
4518 gcc_assert (current_function_decl == NULL_TREE);
4520 /* Declare the function. */
4521 tmp = build_function_type_list (integer_type_node, integer_type_node,
4522 build_pointer_type (pchar_type_node),
4524 main_identifier_node = get_identifier ("main");
4525 ftn_main = build_decl (input_location, FUNCTION_DECL,
4526 main_identifier_node, tmp);
4527 DECL_EXTERNAL (ftn_main) = 0;
4528 TREE_PUBLIC (ftn_main) = 1;
4529 TREE_STATIC (ftn_main) = 1;
4530 DECL_ATTRIBUTES (ftn_main)
4531 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4533 /* Setup the result declaration (for "return 0"). */
4534 result_decl = build_decl (input_location,
4535 RESULT_DECL, NULL_TREE, integer_type_node);
4536 DECL_ARTIFICIAL (result_decl) = 1;
4537 DECL_IGNORED_P (result_decl) = 1;
4538 DECL_CONTEXT (result_decl) = ftn_main;
4539 DECL_RESULT (ftn_main) = result_decl;
4541 pushdecl (ftn_main);
4543 /* Get the arguments. */
4545 arglist = NULL_TREE;
4546 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4548 tmp = TREE_VALUE (typelist);
4549 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4550 DECL_CONTEXT (argc) = ftn_main;
4551 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4552 TREE_READONLY (argc) = 1;
4553 gfc_finish_decl (argc);
4554 arglist = chainon (arglist, argc);
4556 typelist = TREE_CHAIN (typelist);
4557 tmp = TREE_VALUE (typelist);
4558 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4559 DECL_CONTEXT (argv) = ftn_main;
4560 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4561 TREE_READONLY (argv) = 1;
4562 DECL_BY_REFERENCE (argv) = 1;
4563 gfc_finish_decl (argv);
4564 arglist = chainon (arglist, argv);
4566 DECL_ARGUMENTS (ftn_main) = arglist;
4567 current_function_decl = ftn_main;
4568 announce_function (ftn_main);
4570 rest_of_decl_compilation (ftn_main, 1, 0);
4571 make_decl_rtl (ftn_main);
4572 init_function_start (ftn_main);
4575 gfc_init_block (&body);
4577 /* Call some libgfortran initialization routines, call then MAIN__(). */
4579 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4580 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4582 tree pint_type, pppchar_type;
4583 pint_type = build_pointer_type (integer_type_node);
4585 = build_pointer_type (build_pointer_type (pchar_type_node));
4587 gfc_init_coarray_decl ();
4588 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4589 gfc_build_addr_expr (pint_type, argc),
4590 gfc_build_addr_expr (pppchar_type, argv),
4591 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4592 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4593 gfc_add_expr_to_block (&body, tmp);
4596 /* Call _gfortran_set_args (argc, argv). */
4597 TREE_USED (argc) = 1;
4598 TREE_USED (argv) = 1;
4599 tmp = build_call_expr_loc (input_location,
4600 gfor_fndecl_set_args, 2, argc, argv);
4601 gfc_add_expr_to_block (&body, tmp);
4603 /* Add a call to set_options to set up the runtime library Fortran
4604 language standard parameters. */
4606 tree array_type, array, var;
4607 VEC(constructor_elt,gc) *v = NULL;
4609 /* Passing a new option to the library requires four modifications:
4610 + add it to the tree_cons list below
4611 + change the array size in the call to build_array_type
4612 + change the first argument to the library call
4613 gfor_fndecl_set_options
4614 + modify the library (runtime/compile_options.c)! */
4616 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4617 build_int_cst (integer_type_node,
4618 gfc_option.warn_std));
4619 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4620 build_int_cst (integer_type_node,
4621 gfc_option.allow_std));
4622 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4623 build_int_cst (integer_type_node, pedantic));
4624 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4625 build_int_cst (integer_type_node,
4626 gfc_option.flag_dump_core));
4627 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4628 build_int_cst (integer_type_node,
4629 gfc_option.flag_backtrace));
4630 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4631 build_int_cst (integer_type_node,
4632 gfc_option.flag_sign_zero));
4633 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4634 build_int_cst (integer_type_node,
4636 & GFC_RTCHECK_BOUNDS)));
4637 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4638 build_int_cst (integer_type_node,
4639 gfc_option.flag_range_check));
4641 array_type = build_array_type (integer_type_node,
4642 build_index_type (build_int_cst (NULL_TREE, 7)));
4643 array = build_constructor (array_type, v);
4644 TREE_CONSTANT (array) = 1;
4645 TREE_STATIC (array) = 1;
4647 /* Create a static variable to hold the jump table. */
4648 var = gfc_create_var (array_type, "options");
4649 TREE_CONSTANT (var) = 1;
4650 TREE_STATIC (var) = 1;
4651 TREE_READONLY (var) = 1;
4652 DECL_INITIAL (var) = array;
4653 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4655 tmp = build_call_expr_loc (input_location,
4656 gfor_fndecl_set_options, 2,
4657 build_int_cst (integer_type_node, 8), var);
4658 gfc_add_expr_to_block (&body, tmp);
4661 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4662 the library will raise a FPE when needed. */
4663 if (gfc_option.fpe != 0)
4665 tmp = build_call_expr_loc (input_location,
4666 gfor_fndecl_set_fpe, 1,
4667 build_int_cst (integer_type_node,
4669 gfc_add_expr_to_block (&body, tmp);
4672 /* If this is the main program and an -fconvert option was provided,
4673 add a call to set_convert. */
4675 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4677 tmp = build_call_expr_loc (input_location,
4678 gfor_fndecl_set_convert, 1,
4679 build_int_cst (integer_type_node,
4680 gfc_option.convert));
4681 gfc_add_expr_to_block (&body, tmp);
4684 /* If this is the main program and an -frecord-marker option was provided,
4685 add a call to set_record_marker. */
4687 if (gfc_option.record_marker != 0)
4689 tmp = build_call_expr_loc (input_location,
4690 gfor_fndecl_set_record_marker, 1,
4691 build_int_cst (integer_type_node,
4692 gfc_option.record_marker));
4693 gfc_add_expr_to_block (&body, tmp);
4696 if (gfc_option.max_subrecord_length != 0)
4698 tmp = build_call_expr_loc (input_location,
4699 gfor_fndecl_set_max_subrecord_length, 1,
4700 build_int_cst (integer_type_node,
4701 gfc_option.max_subrecord_length));
4702 gfc_add_expr_to_block (&body, tmp);
4705 /* Call MAIN__(). */
4706 tmp = build_call_expr_loc (input_location,
4708 gfc_add_expr_to_block (&body, tmp);
4710 /* Mark MAIN__ as used. */
4711 TREE_USED (fndecl) = 1;
4713 /* Coarray: Call _gfortran_caf_finalize(void). */
4714 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4716 /* Per F2008, 8.5.1 END of the main program implies a
4718 tmp = built_in_decls [BUILT_IN_SYNCHRONIZE];
4719 tmp = build_call_expr_loc (input_location, tmp, 0);
4720 gfc_add_expr_to_block (&body, tmp);
4722 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
4723 gfc_add_expr_to_block (&body, tmp);
4727 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4728 DECL_RESULT (ftn_main),
4729 build_int_cst (integer_type_node, 0));
4730 tmp = build1_v (RETURN_EXPR, tmp);
4731 gfc_add_expr_to_block (&body, tmp);
4734 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4737 /* Finish off this function and send it for code generation. */
4739 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4741 DECL_SAVED_TREE (ftn_main)
4742 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4743 DECL_INITIAL (ftn_main));
4745 /* Output the GENERIC tree. */
4746 dump_function (TDI_original, ftn_main);
4748 cgraph_finalize_function (ftn_main, true);
4752 pop_function_context ();
4753 saved_function_decls = saved_parent_function_decls;
4755 current_function_decl = old_context;
4759 /* Get the result expression for a procedure. */
4762 get_proc_result (gfc_symbol* sym)
4764 if (sym->attr.subroutine || sym == sym->result)
4766 if (current_fake_result_decl != NULL)
4767 return TREE_VALUE (current_fake_result_decl);
4772 return sym->result->backend_decl;
4776 /* Generate an appropriate return-statement for a procedure. */
4779 gfc_generate_return (void)
4785 sym = current_procedure_symbol;
4786 fndecl = sym->backend_decl;
4788 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4792 result = get_proc_result (sym);
4794 /* Set the return value to the dummy result variable. The
4795 types may be different for scalar default REAL functions
4796 with -ff2c, therefore we have to convert. */
4797 if (result != NULL_TREE)
4799 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4800 result = fold_build2_loc (input_location, MODIFY_EXPR,
4801 TREE_TYPE (result), DECL_RESULT (fndecl),
4806 return build1_v (RETURN_EXPR, result);
4810 /* Generate code for a function. */
4813 gfc_generate_function_code (gfc_namespace * ns)
4819 stmtblock_t init, cleanup;
4821 gfc_wrapped_block try_block;
4822 tree recurcheckvar = NULL_TREE;
4824 gfc_symbol *previous_procedure_symbol;
4828 sym = ns->proc_name;
4829 previous_procedure_symbol = current_procedure_symbol;
4830 current_procedure_symbol = sym;
4832 /* Check that the frontend isn't still using this. */
4833 gcc_assert (sym->tlink == NULL);
4836 /* Create the declaration for functions with global scope. */
4837 if (!sym->backend_decl)
4838 gfc_create_function_decl (ns, false);
4840 fndecl = sym->backend_decl;
4841 old_context = current_function_decl;
4845 push_function_context ();
4846 saved_parent_function_decls = saved_function_decls;
4847 saved_function_decls = NULL_TREE;
4850 trans_function_start (sym);
4852 gfc_init_block (&init);
4854 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4856 /* Copy length backend_decls to all entry point result
4861 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4862 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4863 for (el = ns->entries; el; el = el->next)
4864 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4867 /* Translate COMMON blocks. */
4868 gfc_trans_common (ns);
4870 /* Null the parent fake result declaration if this namespace is
4871 a module function or an external procedures. */
4872 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4873 || ns->parent == NULL)
4874 parent_fake_result_decl = NULL_TREE;
4876 gfc_generate_contained_functions (ns);
4878 nonlocal_dummy_decls = NULL;
4879 nonlocal_dummy_decl_pset = NULL;
4881 generate_local_vars (ns);
4883 /* Keep the parent fake result declaration in module functions
4884 or external procedures. */
4885 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4886 || ns->parent == NULL)
4887 current_fake_result_decl = parent_fake_result_decl;
4889 current_fake_result_decl = NULL_TREE;
4891 is_recursive = sym->attr.recursive
4892 || (sym->attr.entry_master
4893 && sym->ns->entries->sym->attr.recursive);
4894 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4896 && !gfc_option.flag_recursive)
4900 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4902 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4903 TREE_STATIC (recurcheckvar) = 1;
4904 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4905 gfc_add_expr_to_block (&init, recurcheckvar);
4906 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4907 &sym->declared_at, msg);
4908 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
4912 /* Now generate the code for the body of this function. */
4913 gfc_init_block (&body);
4915 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4916 && sym->attr.subroutine)
4918 tree alternate_return;
4919 alternate_return = gfc_get_fake_result_decl (sym, 0);
4920 gfc_add_modify (&body, alternate_return, integer_zero_node);
4925 /* Jump to the correct entry point. */
4926 tmp = gfc_trans_entry_master_switch (ns->entries);
4927 gfc_add_expr_to_block (&body, tmp);
4930 /* If bounds-checking is enabled, generate code to check passed in actual
4931 arguments against the expected dummy argument attributes (e.g. string
4933 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4934 add_argument_checking (&body, sym);
4936 tmp = gfc_trans_code (ns->code);
4937 gfc_add_expr_to_block (&body, tmp);
4939 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4941 tree result = get_proc_result (sym);
4943 if (result != NULL_TREE
4944 && sym->attr.function
4945 && !sym->attr.pointer)
4947 if (sym->attr.allocatable && sym->attr.dimension == 0
4948 && sym->result == sym)
4949 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4950 null_pointer_node));
4951 else if (sym->ts.type == BT_DERIVED
4952 && sym->ts.u.derived->attr.alloc_comp
4953 && !sym->attr.allocatable)
4955 rank = sym->as ? sym->as->rank : 0;
4956 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4957 gfc_add_expr_to_block (&init, tmp);
4961 if (result == NULL_TREE)
4963 /* TODO: move to the appropriate place in resolve.c. */
4964 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4965 gfc_warning ("Return value of function '%s' at %L not set",
4966 sym->name, &sym->declared_at);
4968 TREE_NO_WARNING(sym->backend_decl) = 1;
4971 gfc_add_expr_to_block (&body, gfc_generate_return ());
4974 gfc_init_block (&cleanup);
4976 /* Reset recursion-check variable. */
4977 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4979 && !gfc_option.gfc_flag_openmp
4980 && recurcheckvar != NULL_TREE)
4982 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4983 recurcheckvar = NULL;
4986 /* Finish the function body and add init and cleanup code. */
4987 tmp = gfc_finish_block (&body);
4988 gfc_start_wrapped_block (&try_block, tmp);
4989 /* Add code to create and cleanup arrays. */
4990 gfc_trans_deferred_vars (sym, &try_block);
4991 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
4992 gfc_finish_block (&cleanup));
4994 /* Add all the decls we created during processing. */
4995 decl = saved_function_decls;
5000 next = DECL_CHAIN (decl);
5001 DECL_CHAIN (decl) = NULL_TREE;
5005 saved_function_decls = NULL_TREE;
5007 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5010 /* Finish off this function and send it for code generation. */
5012 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5014 DECL_SAVED_TREE (fndecl)
5015 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5016 DECL_INITIAL (fndecl));
5018 if (nonlocal_dummy_decls)
5020 BLOCK_VARS (DECL_INITIAL (fndecl))
5021 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5022 pointer_set_destroy (nonlocal_dummy_decl_pset);
5023 nonlocal_dummy_decls = NULL;
5024 nonlocal_dummy_decl_pset = NULL;
5027 /* Output the GENERIC tree. */
5028 dump_function (TDI_original, fndecl);
5030 /* Store the end of the function, so that we get good line number
5031 info for the epilogue. */
5032 cfun->function_end_locus = input_location;
5034 /* We're leaving the context of this function, so zap cfun.
5035 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5036 tree_rest_of_compilation. */
5041 pop_function_context ();
5042 saved_function_decls = saved_parent_function_decls;
5044 current_function_decl = old_context;
5046 if (decl_function_context (fndecl))
5047 /* Register this function with cgraph just far enough to get it
5048 added to our parent's nested function list. */
5049 (void) cgraph_get_create_node (fndecl);
5051 cgraph_finalize_function (fndecl, true);
5053 gfc_trans_use_stmts (ns);
5054 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5056 if (sym->attr.is_main_program)
5057 create_main_function (fndecl);
5059 current_procedure_symbol = previous_procedure_symbol;
5064 gfc_generate_constructors (void)
5066 gcc_assert (gfc_static_ctors == NULL_TREE);
5074 if (gfc_static_ctors == NULL_TREE)
5077 fnname = get_file_function_name ("I");
5078 type = build_function_type_list (void_type_node, NULL_TREE);
5080 fndecl = build_decl (input_location,
5081 FUNCTION_DECL, fnname, type);
5082 TREE_PUBLIC (fndecl) = 1;
5084 decl = build_decl (input_location,
5085 RESULT_DECL, NULL_TREE, void_type_node);
5086 DECL_ARTIFICIAL (decl) = 1;
5087 DECL_IGNORED_P (decl) = 1;
5088 DECL_CONTEXT (decl) = fndecl;
5089 DECL_RESULT (fndecl) = decl;
5093 current_function_decl = fndecl;
5095 rest_of_decl_compilation (fndecl, 1, 0);
5097 make_decl_rtl (fndecl);
5099 init_function_start (fndecl);
5103 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5105 tmp = build_call_expr_loc (input_location,
5106 TREE_VALUE (gfc_static_ctors), 0);
5107 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5113 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5114 DECL_SAVED_TREE (fndecl)
5115 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5116 DECL_INITIAL (fndecl));
5118 free_after_parsing (cfun);
5119 free_after_compilation (cfun);
5121 tree_rest_of_compilation (fndecl);
5123 current_function_decl = NULL_TREE;
5127 /* Translates a BLOCK DATA program unit. This means emitting the
5128 commons contained therein plus their initializations. We also emit
5129 a globally visible symbol to make sure that each BLOCK DATA program
5130 unit remains unique. */
5133 gfc_generate_block_data (gfc_namespace * ns)
5138 /* Tell the backend the source location of the block data. */
5140 gfc_set_backend_locus (&ns->proc_name->declared_at);
5142 gfc_set_backend_locus (&gfc_current_locus);
5144 /* Process the DATA statements. */
5145 gfc_trans_common (ns);
5147 /* Create a global symbol with the mane of the block data. This is to
5148 generate linker errors if the same name is used twice. It is never
5151 id = gfc_sym_mangled_function_id (ns->proc_name);
5153 id = get_identifier ("__BLOCK_DATA__");
5155 decl = build_decl (input_location,
5156 VAR_DECL, id, gfc_array_index_type);
5157 TREE_PUBLIC (decl) = 1;
5158 TREE_STATIC (decl) = 1;
5159 DECL_IGNORED_P (decl) = 1;
5162 rest_of_decl_compilation (decl, 1, 0);
5166 /* Process the local variables of a BLOCK construct. */
5169 gfc_process_block_locals (gfc_namespace* ns)
5173 gcc_assert (saved_local_decls == NULL_TREE);
5174 generate_local_vars (ns);
5176 decl = saved_local_decls;
5181 next = DECL_CHAIN (decl);
5182 DECL_CHAIN (decl) = NULL_TREE;
5186 saved_local_decls = NULL_TREE;
5190 #include "gt-fortran-trans-decl.h"