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 /* With -fcoarray=lib: For generating the registering call
82 of static coarrays. */
83 static bool has_coarray_vars;
84 static stmtblock_t caf_init_block;
87 /* List of static constructor functions. */
89 tree gfc_static_ctors;
92 /* Function declarations for builtin library functions. */
94 tree gfor_fndecl_pause_numeric;
95 tree gfor_fndecl_pause_string;
96 tree gfor_fndecl_stop_numeric;
97 tree gfor_fndecl_stop_numeric_f08;
98 tree gfor_fndecl_stop_string;
99 tree gfor_fndecl_error_stop_numeric;
100 tree gfor_fndecl_error_stop_string;
101 tree gfor_fndecl_runtime_error;
102 tree gfor_fndecl_runtime_error_at;
103 tree gfor_fndecl_runtime_warning_at;
104 tree gfor_fndecl_os_error;
105 tree gfor_fndecl_generate_error;
106 tree gfor_fndecl_set_args;
107 tree gfor_fndecl_set_fpe;
108 tree gfor_fndecl_set_options;
109 tree gfor_fndecl_set_convert;
110 tree gfor_fndecl_set_record_marker;
111 tree gfor_fndecl_set_max_subrecord_length;
112 tree gfor_fndecl_ctime;
113 tree gfor_fndecl_fdate;
114 tree gfor_fndecl_ttynam;
115 tree gfor_fndecl_in_pack;
116 tree gfor_fndecl_in_unpack;
117 tree gfor_fndecl_associated;
120 /* Coarray run-time library function decls. */
121 tree gfor_fndecl_caf_init;
122 tree gfor_fndecl_caf_finalize;
123 tree gfor_fndecl_caf_register;
124 tree gfor_fndecl_caf_deregister;
125 tree gfor_fndecl_caf_critical;
126 tree gfor_fndecl_caf_end_critical;
127 tree gfor_fndecl_caf_sync_all;
128 tree gfor_fndecl_caf_sync_images;
129 tree gfor_fndecl_caf_error_stop;
130 tree gfor_fndecl_caf_error_stop_str;
132 /* Coarray global variables for num_images/this_image. */
134 tree gfort_gvar_caf_num_images;
135 tree gfort_gvar_caf_this_image;
138 /* Math functions. Many other math functions are handled in
139 trans-intrinsic.c. */
141 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
142 tree gfor_fndecl_math_ishftc4;
143 tree gfor_fndecl_math_ishftc8;
144 tree gfor_fndecl_math_ishftc16;
147 /* String functions. */
149 tree gfor_fndecl_compare_string;
150 tree gfor_fndecl_concat_string;
151 tree gfor_fndecl_string_len_trim;
152 tree gfor_fndecl_string_index;
153 tree gfor_fndecl_string_scan;
154 tree gfor_fndecl_string_verify;
155 tree gfor_fndecl_string_trim;
156 tree gfor_fndecl_string_minmax;
157 tree gfor_fndecl_adjustl;
158 tree gfor_fndecl_adjustr;
159 tree gfor_fndecl_select_string;
160 tree gfor_fndecl_compare_string_char4;
161 tree gfor_fndecl_concat_string_char4;
162 tree gfor_fndecl_string_len_trim_char4;
163 tree gfor_fndecl_string_index_char4;
164 tree gfor_fndecl_string_scan_char4;
165 tree gfor_fndecl_string_verify_char4;
166 tree gfor_fndecl_string_trim_char4;
167 tree gfor_fndecl_string_minmax_char4;
168 tree gfor_fndecl_adjustl_char4;
169 tree gfor_fndecl_adjustr_char4;
170 tree gfor_fndecl_select_string_char4;
173 /* Conversion between character kinds. */
174 tree gfor_fndecl_convert_char1_to_char4;
175 tree gfor_fndecl_convert_char4_to_char1;
178 /* Other misc. runtime library functions. */
179 tree gfor_fndecl_size0;
180 tree gfor_fndecl_size1;
181 tree gfor_fndecl_iargc;
183 /* Intrinsic functions implemented in Fortran. */
184 tree gfor_fndecl_sc_kind;
185 tree gfor_fndecl_si_kind;
186 tree gfor_fndecl_sr_kind;
188 /* BLAS gemm functions. */
189 tree gfor_fndecl_sgemm;
190 tree gfor_fndecl_dgemm;
191 tree gfor_fndecl_cgemm;
192 tree gfor_fndecl_zgemm;
196 gfc_add_decl_to_parent_function (tree decl)
199 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
200 DECL_NONLOCAL (decl) = 1;
201 DECL_CHAIN (decl) = saved_parent_function_decls;
202 saved_parent_function_decls = decl;
206 gfc_add_decl_to_function (tree decl)
209 TREE_USED (decl) = 1;
210 DECL_CONTEXT (decl) = current_function_decl;
211 DECL_CHAIN (decl) = saved_function_decls;
212 saved_function_decls = decl;
216 add_decl_as_local (tree decl)
219 TREE_USED (decl) = 1;
220 DECL_CONTEXT (decl) = current_function_decl;
221 DECL_CHAIN (decl) = saved_local_decls;
222 saved_local_decls = decl;
226 /* Build a backend label declaration. Set TREE_USED for named labels.
227 The context of the label is always the current_function_decl. All
228 labels are marked artificial. */
231 gfc_build_label_decl (tree label_id)
233 /* 2^32 temporaries should be enough. */
234 static unsigned int tmp_num = 1;
238 if (label_id == NULL_TREE)
240 /* Build an internal label name. */
241 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
242 label_id = get_identifier (label_name);
247 /* Build the LABEL_DECL node. Labels have no type. */
248 label_decl = build_decl (input_location,
249 LABEL_DECL, label_id, void_type_node);
250 DECL_CONTEXT (label_decl) = current_function_decl;
251 DECL_MODE (label_decl) = VOIDmode;
253 /* We always define the label as used, even if the original source
254 file never references the label. We don't want all kinds of
255 spurious warnings for old-style Fortran code with too many
257 TREE_USED (label_decl) = 1;
259 DECL_ARTIFICIAL (label_decl) = 1;
264 /* Set the backend source location of a decl. */
267 gfc_set_decl_location (tree decl, locus * loc)
269 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
273 /* Return the backend label declaration for a given label structure,
274 or create it if it doesn't exist yet. */
277 gfc_get_label_decl (gfc_st_label * lp)
279 if (lp->backend_decl)
280 return lp->backend_decl;
283 char label_name[GFC_MAX_SYMBOL_LEN + 1];
286 /* Validate the label declaration from the front end. */
287 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
289 /* Build a mangled name for the label. */
290 sprintf (label_name, "__label_%.6d", lp->value);
292 /* Build the LABEL_DECL node. */
293 label_decl = gfc_build_label_decl (get_identifier (label_name));
295 /* Tell the debugger where the label came from. */
296 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
297 gfc_set_decl_location (label_decl, &lp->where);
299 DECL_ARTIFICIAL (label_decl) = 1;
301 /* Store the label in the label list and return the LABEL_DECL. */
302 lp->backend_decl = label_decl;
308 /* Convert a gfc_symbol to an identifier of the same name. */
311 gfc_sym_identifier (gfc_symbol * sym)
313 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
314 return (get_identifier ("MAIN__"));
316 return (get_identifier (sym->name));
320 /* Construct mangled name from symbol name. */
323 gfc_sym_mangled_identifier (gfc_symbol * sym)
325 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
327 /* Prevent the mangling of identifiers that have an assigned
328 binding label (mainly those that are bind(c)). */
329 if (sym->attr.is_bind_c == 1
330 && sym->binding_label[0] != '\0')
331 return get_identifier(sym->binding_label);
333 if (sym->module == NULL)
334 return gfc_sym_identifier (sym);
337 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
338 return get_identifier (name);
343 /* Construct mangled function name from symbol name. */
346 gfc_sym_mangled_function_id (gfc_symbol * sym)
349 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
351 /* It may be possible to simply use the binding label if it's
352 provided, and remove the other checks. Then we could use it
353 for other things if we wished. */
354 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
355 sym->binding_label[0] != '\0')
356 /* use the binding label rather than the mangled name */
357 return get_identifier (sym->binding_label);
359 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
360 || (sym->module != NULL && (sym->attr.external
361 || sym->attr.if_source == IFSRC_IFBODY)))
363 /* Main program is mangled into MAIN__. */
364 if (sym->attr.is_main_program)
365 return get_identifier ("MAIN__");
367 /* Intrinsic procedures are never mangled. */
368 if (sym->attr.proc == PROC_INTRINSIC)
369 return get_identifier (sym->name);
371 if (gfc_option.flag_underscoring)
373 has_underscore = strchr (sym->name, '_') != 0;
374 if (gfc_option.flag_second_underscore && has_underscore)
375 snprintf (name, sizeof name, "%s__", sym->name);
377 snprintf (name, sizeof name, "%s_", sym->name);
378 return get_identifier (name);
381 return get_identifier (sym->name);
385 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
386 return get_identifier (name);
392 gfc_set_decl_assembler_name (tree decl, tree name)
394 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
395 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
399 /* Returns true if a variable of specified size should go on the stack. */
402 gfc_can_put_var_on_stack (tree size)
404 unsigned HOST_WIDE_INT low;
406 if (!INTEGER_CST_P (size))
409 if (gfc_option.flag_max_stack_var_size < 0)
412 if (TREE_INT_CST_HIGH (size) != 0)
415 low = TREE_INT_CST_LOW (size);
416 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
419 /* TODO: Set a per-function stack size limit. */
425 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
426 an expression involving its corresponding pointer. There are
427 2 cases; one for variable size arrays, and one for everything else,
428 because variable-sized arrays require one fewer level of
432 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
434 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
437 /* Parameters need to be dereferenced. */
438 if (sym->cp_pointer->attr.dummy)
439 ptr_decl = build_fold_indirect_ref_loc (input_location,
442 /* Check to see if we're dealing with a variable-sized array. */
443 if (sym->attr.dimension
444 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
446 /* These decls will be dereferenced later, so we don't dereference
448 value = convert (TREE_TYPE (decl), ptr_decl);
452 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
454 value = build_fold_indirect_ref_loc (input_location,
458 SET_DECL_VALUE_EXPR (decl, value);
459 DECL_HAS_VALUE_EXPR_P (decl) = 1;
460 GFC_DECL_CRAY_POINTEE (decl) = 1;
461 /* This is a fake variable just for debugging purposes. */
462 TREE_ASM_WRITTEN (decl) = 1;
466 /* Finish processing of a declaration without an initial value. */
469 gfc_finish_decl (tree decl)
471 gcc_assert (TREE_CODE (decl) == PARM_DECL
472 || DECL_INITIAL (decl) == NULL_TREE);
474 if (TREE_CODE (decl) != VAR_DECL)
477 if (DECL_SIZE (decl) == NULL_TREE
478 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
479 layout_decl (decl, 0);
481 /* A few consistency checks. */
482 /* A static variable with an incomplete type is an error if it is
483 initialized. Also if it is not file scope. Otherwise, let it
484 through, but if it is not `extern' then it may cause an error
486 /* An automatic variable with an incomplete type is an error. */
488 /* We should know the storage size. */
489 gcc_assert (DECL_SIZE (decl) != NULL_TREE
490 || (TREE_STATIC (decl)
491 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
492 : DECL_EXTERNAL (decl)));
494 /* The storage size should be constant. */
495 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
497 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
501 /* Apply symbol attributes to a variable, and add it to the function scope. */
504 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
507 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
508 This is the equivalent of the TARGET variables.
509 We also need to set this if the variable is passed by reference in a
512 /* Set DECL_VALUE_EXPR for Cray Pointees. */
513 if (sym->attr.cray_pointee)
514 gfc_finish_cray_pointee (decl, sym);
516 if (sym->attr.target)
517 TREE_ADDRESSABLE (decl) = 1;
518 /* If it wasn't used we wouldn't be getting it. */
519 TREE_USED (decl) = 1;
521 if (sym->attr.flavor == FL_PARAMETER
522 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
523 TREE_READONLY (decl) = 1;
525 /* Chain this decl to the pending declarations. Don't do pushdecl()
526 because this would add them to the current scope rather than the
528 if (current_function_decl != NULL_TREE)
530 if (sym->ns->proc_name->backend_decl == current_function_decl
531 || sym->result == sym)
532 gfc_add_decl_to_function (decl);
533 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
534 /* This is a BLOCK construct. */
535 add_decl_as_local (decl);
537 gfc_add_decl_to_parent_function (decl);
540 if (sym->attr.cray_pointee)
543 if(sym->attr.is_bind_c == 1)
545 /* We need to put variables that are bind(c) into the common
546 segment of the object file, because this is what C would do.
547 gfortran would typically put them in either the BSS or
548 initialized data segments, and only mark them as common if
549 they were part of common blocks. However, if they are not put
550 into common space, then C cannot initialize global Fortran
551 variables that it interoperates with and the draft says that
552 either Fortran or C should be able to initialize it (but not
553 both, of course.) (J3/04-007, section 15.3). */
554 TREE_PUBLIC(decl) = 1;
555 DECL_COMMON(decl) = 1;
558 /* If a variable is USE associated, it's always external. */
559 if (sym->attr.use_assoc)
561 DECL_EXTERNAL (decl) = 1;
562 TREE_PUBLIC (decl) = 1;
564 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
566 /* TODO: Don't set sym->module for result or dummy variables. */
567 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
568 /* This is the declaration of a module variable. */
569 TREE_PUBLIC (decl) = 1;
570 TREE_STATIC (decl) = 1;
573 /* Derived types are a bit peculiar because of the possibility of
574 a default initializer; this must be applied each time the variable
575 comes into scope it therefore need not be static. These variables
576 are SAVE_NONE but have an initializer. Otherwise explicitly
577 initialized variables are SAVE_IMPLICIT and explicitly saved are
579 if (!sym->attr.use_assoc
580 && (sym->attr.save != SAVE_NONE || sym->attr.data
581 || (sym->value && sym->ns->proc_name->attr.is_main_program)
582 || (gfc_option.coarray == GFC_FCOARRAY_LIB
583 && sym->attr.codimension && !sym->attr.allocatable)))
584 TREE_STATIC (decl) = 1;
586 if (sym->attr.volatile_)
588 TREE_THIS_VOLATILE (decl) = 1;
589 TREE_SIDE_EFFECTS (decl) = 1;
590 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
591 TREE_TYPE (decl) = new_type;
594 /* Keep variables larger than max-stack-var-size off stack. */
595 if (!sym->ns->proc_name->attr.recursive
596 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
597 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
598 /* Put variable length auto array pointers always into stack. */
599 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
600 || sym->attr.dimension == 0
601 || sym->as->type != AS_EXPLICIT
603 || sym->attr.allocatable)
604 && !DECL_ARTIFICIAL (decl))
605 TREE_STATIC (decl) = 1;
607 /* Handle threadprivate variables. */
608 if (sym->attr.threadprivate
609 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
610 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
612 if (!sym->attr.target
613 && !sym->attr.pointer
614 && !sym->attr.cray_pointee
615 && !sym->attr.proc_pointer)
616 DECL_RESTRICTED_P (decl) = 1;
620 /* Allocate the lang-specific part of a decl. */
623 gfc_allocate_lang_decl (tree decl)
625 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
629 /* Remember a symbol to generate initialization/cleanup code at function
633 gfc_defer_symbol_init (gfc_symbol * sym)
639 /* Don't add a symbol twice. */
643 last = head = sym->ns->proc_name;
646 /* Make sure that setup code for dummy variables which are used in the
647 setup of other variables is generated first. */
650 /* Find the first dummy arg seen after us, or the first non-dummy arg.
651 This is a circular list, so don't go past the head. */
653 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
659 /* Insert in between last and p. */
665 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
666 backend_decl for a module symbol, if it all ready exists. If the
667 module gsymbol does not exist, it is created. If the symbol does
668 not exist, it is added to the gsymbol namespace. Returns true if
669 an existing backend_decl is found. */
672 gfc_get_module_backend_decl (gfc_symbol *sym)
678 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
680 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
686 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
692 gsym = gfc_get_gsymbol (sym->module);
693 gsym->type = GSYM_MODULE;
694 gsym->ns = gfc_get_namespace (NULL, 0);
697 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
701 else if (sym->attr.flavor == FL_DERIVED)
703 if (s && s->attr.flavor == FL_PROCEDURE)
706 gcc_assert (s->attr.generic);
707 for (intr = s->generic; intr; intr = intr->next)
708 if (intr->sym->attr.flavor == FL_DERIVED)
715 if (!s->backend_decl)
716 s->backend_decl = gfc_get_derived_type (s);
717 gfc_copy_dt_decls_ifequal (s, sym, true);
720 else if (s->backend_decl)
722 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
723 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
725 else if (sym->ts.type == BT_CHARACTER)
726 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
727 sym->backend_decl = s->backend_decl;
735 /* Create an array index type variable with function scope. */
738 create_index_var (const char * pfx, int nest)
742 decl = gfc_create_var_np (gfc_array_index_type, pfx);
744 gfc_add_decl_to_parent_function (decl);
746 gfc_add_decl_to_function (decl);
751 /* Create variables to hold all the non-constant bits of info for a
752 descriptorless array. Remember these in the lang-specific part of the
756 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
761 gfc_namespace* procns;
763 type = TREE_TYPE (decl);
765 /* We just use the descriptor, if there is one. */
766 if (GFC_DESCRIPTOR_TYPE_P (type))
769 gcc_assert (GFC_ARRAY_TYPE_P (type));
770 procns = gfc_find_proc_namespace (sym->ns);
771 nest = (procns->proc_name->backend_decl != current_function_decl)
772 && !sym->attr.contained;
774 if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
775 && sym->as->type != AS_ASSUMED_SHAPE
776 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
780 token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
783 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
784 DECL_ARTIFICIAL (token) = 1;
785 TREE_STATIC (token) = 1;
786 gfc_add_decl_to_function (token);
789 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
791 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
793 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
794 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
796 /* Don't try to use the unknown bound for assumed shape arrays. */
797 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
798 && (sym->as->type != AS_ASSUMED_SIZE
799 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
801 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
802 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
805 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
807 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
808 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
811 for (dim = GFC_TYPE_ARRAY_RANK (type);
812 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
814 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
816 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
817 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
819 /* Don't try to use the unknown ubound for the last coarray dimension. */
820 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
821 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
823 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
824 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
827 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
829 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
831 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
834 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
836 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
839 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
840 && sym->as->type != AS_ASSUMED_SIZE)
842 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
843 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
846 if (POINTER_TYPE_P (type))
848 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
849 gcc_assert (TYPE_LANG_SPECIFIC (type)
850 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
851 type = TREE_TYPE (type);
854 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
858 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
859 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
860 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
862 TYPE_DOMAIN (type) = range;
866 if (TYPE_NAME (type) != NULL_TREE
867 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
868 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
870 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
872 for (dim = 0; dim < sym->as->rank - 1; dim++)
874 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
875 gtype = TREE_TYPE (gtype);
877 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
878 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
879 TYPE_NAME (type) = NULL_TREE;
882 if (TYPE_NAME (type) == NULL_TREE)
884 tree gtype = TREE_TYPE (type), rtype, type_decl;
886 for (dim = sym->as->rank - 1; dim >= 0; dim--)
889 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
890 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
891 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
892 gtype = build_array_type (gtype, rtype);
893 /* Ensure the bound variables aren't optimized out at -O0.
894 For -O1 and above they often will be optimized out, but
895 can be tracked by VTA. Also set DECL_NAMELESS, so that
896 the artificial lbound.N or ubound.N DECL_NAME doesn't
897 end up in debug info. */
898 if (lbound && TREE_CODE (lbound) == VAR_DECL
899 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
901 if (DECL_NAME (lbound)
902 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
904 DECL_NAMELESS (lbound) = 1;
905 DECL_IGNORED_P (lbound) = 0;
907 if (ubound && TREE_CODE (ubound) == VAR_DECL
908 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
910 if (DECL_NAME (ubound)
911 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
913 DECL_NAMELESS (ubound) = 1;
914 DECL_IGNORED_P (ubound) = 0;
917 TYPE_NAME (type) = type_decl = build_decl (input_location,
918 TYPE_DECL, NULL, gtype);
919 DECL_ORIGINAL_TYPE (type_decl) = gtype;
924 /* For some dummy arguments we don't use the actual argument directly.
925 Instead we create a local decl and use that. This allows us to perform
926 initialization, and construct full type information. */
929 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
939 if (sym->attr.pointer || sym->attr.allocatable)
942 /* Add to list of variables if not a fake result variable. */
943 if (sym->attr.result || sym->attr.dummy)
944 gfc_defer_symbol_init (sym);
946 type = TREE_TYPE (dummy);
947 gcc_assert (TREE_CODE (dummy) == PARM_DECL
948 && POINTER_TYPE_P (type));
950 /* Do we know the element size? */
951 known_size = sym->ts.type != BT_CHARACTER
952 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
954 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
956 /* For descriptorless arrays with known element size the actual
957 argument is sufficient. */
958 gcc_assert (GFC_ARRAY_TYPE_P (type));
959 gfc_build_qualified_array (dummy, sym);
963 type = TREE_TYPE (type);
964 if (GFC_DESCRIPTOR_TYPE_P (type))
966 /* Create a descriptorless array pointer. */
970 /* Even when -frepack-arrays is used, symbols with TARGET attribute
972 if (!gfc_option.flag_repack_arrays || sym->attr.target)
974 if (as->type == AS_ASSUMED_SIZE)
975 packed = PACKED_FULL;
979 if (as->type == AS_EXPLICIT)
981 packed = PACKED_FULL;
982 for (n = 0; n < as->rank; n++)
986 && as->upper[n]->expr_type == EXPR_CONSTANT
987 && as->lower[n]->expr_type == EXPR_CONSTANT))
988 packed = PACKED_PARTIAL;
992 packed = PACKED_PARTIAL;
995 type = gfc_typenode_for_spec (&sym->ts);
996 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1001 /* We now have an expression for the element size, so create a fully
1002 qualified type. Reset sym->backend decl or this will just return the
1004 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1005 sym->backend_decl = NULL_TREE;
1006 type = gfc_sym_type (sym);
1007 packed = PACKED_FULL;
1010 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1011 decl = build_decl (input_location,
1012 VAR_DECL, get_identifier (name), type);
1014 DECL_ARTIFICIAL (decl) = 1;
1015 DECL_NAMELESS (decl) = 1;
1016 TREE_PUBLIC (decl) = 0;
1017 TREE_STATIC (decl) = 0;
1018 DECL_EXTERNAL (decl) = 0;
1020 /* We should never get deferred shape arrays here. We used to because of
1022 gcc_assert (sym->as->type != AS_DEFERRED);
1024 if (packed == PACKED_PARTIAL)
1025 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1026 else if (packed == PACKED_FULL)
1027 GFC_DECL_PACKED_ARRAY (decl) = 1;
1029 gfc_build_qualified_array (decl, sym);
1031 if (DECL_LANG_SPECIFIC (dummy))
1032 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1034 gfc_allocate_lang_decl (decl);
1036 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1038 if (sym->ns->proc_name->backend_decl == current_function_decl
1039 || sym->attr.contained)
1040 gfc_add_decl_to_function (decl);
1042 gfc_add_decl_to_parent_function (decl);
1047 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1048 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1049 pointing to the artificial variable for debug info purposes. */
1052 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1056 if (! nonlocal_dummy_decl_pset)
1057 nonlocal_dummy_decl_pset = pointer_set_create ();
1059 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1062 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1063 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1064 TREE_TYPE (sym->backend_decl));
1065 DECL_ARTIFICIAL (decl) = 0;
1066 TREE_USED (decl) = 1;
1067 TREE_PUBLIC (decl) = 0;
1068 TREE_STATIC (decl) = 0;
1069 DECL_EXTERNAL (decl) = 0;
1070 if (DECL_BY_REFERENCE (dummy))
1071 DECL_BY_REFERENCE (decl) = 1;
1072 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1073 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1074 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1075 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1076 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1077 nonlocal_dummy_decls = decl;
1080 /* Return a constant or a variable to use as a string length. Does not
1081 add the decl to the current scope. */
1084 gfc_create_string_length (gfc_symbol * sym)
1086 gcc_assert (sym->ts.u.cl);
1087 gfc_conv_const_charlen (sym->ts.u.cl);
1089 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1092 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1094 /* Also prefix the mangled name. */
1095 strcpy (&name[1], sym->name);
1097 length = build_decl (input_location,
1098 VAR_DECL, get_identifier (name),
1099 gfc_charlen_type_node);
1100 DECL_ARTIFICIAL (length) = 1;
1101 TREE_USED (length) = 1;
1102 if (sym->ns->proc_name->tlink != NULL)
1103 gfc_defer_symbol_init (sym);
1105 sym->ts.u.cl->backend_decl = length;
1108 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1109 return sym->ts.u.cl->backend_decl;
1112 /* If a variable is assigned a label, we add another two auxiliary
1116 gfc_add_assign_aux_vars (gfc_symbol * sym)
1122 gcc_assert (sym->backend_decl);
1124 decl = sym->backend_decl;
1125 gfc_allocate_lang_decl (decl);
1126 GFC_DECL_ASSIGN (decl) = 1;
1127 length = build_decl (input_location,
1128 VAR_DECL, create_tmp_var_name (sym->name),
1129 gfc_charlen_type_node);
1130 addr = build_decl (input_location,
1131 VAR_DECL, create_tmp_var_name (sym->name),
1133 gfc_finish_var_decl (length, sym);
1134 gfc_finish_var_decl (addr, sym);
1135 /* STRING_LENGTH is also used as flag. Less than -1 means that
1136 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1137 target label's address. Otherwise, value is the length of a format string
1138 and ASSIGN_ADDR is its address. */
1139 if (TREE_STATIC (length))
1140 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1142 gfc_defer_symbol_init (sym);
1144 GFC_DECL_STRING_LEN (decl) = length;
1145 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1150 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1155 for (id = 0; id < EXT_ATTR_NUM; id++)
1156 if (sym_attr.ext_attr & (1 << id))
1158 attr = build_tree_list (
1159 get_identifier (ext_attr_list[id].middle_end_name),
1161 list = chainon (list, attr);
1168 static void build_function_decl (gfc_symbol * sym, bool global);
1171 /* Return the decl for a gfc_symbol, create it if it doesn't already
1175 gfc_get_symbol_decl (gfc_symbol * sym)
1178 tree length = NULL_TREE;
1181 bool intrinsic_array_parameter = false;
1183 gcc_assert (sym->attr.referenced
1184 || sym->attr.use_assoc
1185 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1186 || (sym->module && sym->attr.if_source != IFSRC_DECL
1187 && sym->backend_decl));
1189 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1190 byref = gfc_return_by_reference (sym->ns->proc_name);
1194 /* Make sure that the vtab for the declared type is completed. */
1195 if (sym->ts.type == BT_CLASS)
1197 gfc_component *c = CLASS_DATA (sym);
1198 if (!c->ts.u.derived->backend_decl)
1200 gfc_find_derived_vtab (c->ts.u.derived);
1201 gfc_get_derived_type (sym->ts.u.derived);
1205 /* All deferred character length procedures need to retain the backend
1206 decl, which is a pointer to the character length in the caller's
1207 namespace and to declare a local character length. */
1208 if (!byref && sym->attr.function
1209 && sym->ts.type == BT_CHARACTER
1211 && sym->ts.u.cl->passed_length == NULL
1212 && sym->ts.u.cl->backend_decl
1213 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1215 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1216 sym->ts.u.cl->backend_decl = NULL_TREE;
1217 length = gfc_create_string_length (sym);
1220 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1222 /* Return via extra parameter. */
1223 if (sym->attr.result && byref
1224 && !sym->backend_decl)
1227 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1228 /* For entry master function skip over the __entry
1230 if (sym->ns->proc_name->attr.entry_master)
1231 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1234 /* Dummy variables should already have been created. */
1235 gcc_assert (sym->backend_decl);
1237 /* Create a character length variable. */
1238 if (sym->ts.type == BT_CHARACTER)
1240 /* For a deferred dummy, make a new string length variable. */
1241 if (sym->ts.deferred
1243 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1244 sym->ts.u.cl->backend_decl = NULL_TREE;
1246 if (sym->ts.deferred && sym->attr.result
1247 && sym->ts.u.cl->passed_length == NULL
1248 && sym->ts.u.cl->backend_decl)
1250 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1251 sym->ts.u.cl->backend_decl = NULL_TREE;
1254 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1255 length = gfc_create_string_length (sym);
1257 length = sym->ts.u.cl->backend_decl;
1258 if (TREE_CODE (length) == VAR_DECL
1259 && DECL_FILE_SCOPE_P (length))
1261 /* Add the string length to the same context as the symbol. */
1262 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1263 gfc_add_decl_to_function (length);
1265 gfc_add_decl_to_parent_function (length);
1267 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1268 DECL_CONTEXT (length));
1270 gfc_defer_symbol_init (sym);
1274 /* Use a copy of the descriptor for dummy arrays. */
1275 if ((sym->attr.dimension || sym->attr.codimension)
1276 && !TREE_USED (sym->backend_decl))
1278 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1279 /* Prevent the dummy from being detected as unused if it is copied. */
1280 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1281 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1282 sym->backend_decl = decl;
1285 TREE_USED (sym->backend_decl) = 1;
1286 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1288 gfc_add_assign_aux_vars (sym);
1291 if (sym->attr.dimension
1292 && DECL_LANG_SPECIFIC (sym->backend_decl)
1293 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1294 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1295 gfc_nonlocal_dummy_array_decl (sym);
1297 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1298 GFC_DECL_CLASS(sym->backend_decl) = 1;
1300 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1301 GFC_DECL_CLASS(sym->backend_decl) = 1;
1302 return sym->backend_decl;
1305 if (sym->backend_decl)
1306 return sym->backend_decl;
1308 /* Special case for array-valued named constants from intrinsic
1309 procedures; those are inlined. */
1310 if (sym->attr.use_assoc && sym->from_intmod
1311 && sym->attr.flavor == FL_PARAMETER)
1312 intrinsic_array_parameter = true;
1314 /* If use associated and whole file compilation, use the module
1316 if (gfc_option.flag_whole_file
1317 && (sym->attr.flavor == FL_VARIABLE
1318 || sym->attr.flavor == FL_PARAMETER)
1319 && sym->attr.use_assoc
1320 && !intrinsic_array_parameter
1322 && gfc_get_module_backend_decl (sym))
1324 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1325 GFC_DECL_CLASS(sym->backend_decl) = 1;
1326 return sym->backend_decl;
1329 if (sym->attr.flavor == FL_PROCEDURE)
1331 /* Catch function declarations. Only used for actual parameters,
1332 procedure pointers and procptr initialization targets. */
1333 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1335 decl = gfc_get_extern_function_decl (sym);
1336 gfc_set_decl_location (decl, &sym->declared_at);
1340 if (!sym->backend_decl)
1341 build_function_decl (sym, false);
1342 decl = sym->backend_decl;
1347 if (sym->attr.intrinsic)
1348 internal_error ("intrinsic variable which isn't a procedure");
1350 /* Create string length decl first so that they can be used in the
1351 type declaration. */
1352 if (sym->ts.type == BT_CHARACTER)
1353 length = gfc_create_string_length (sym);
1355 /* Create the decl for the variable. */
1356 decl = build_decl (sym->declared_at.lb->location,
1357 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1359 /* Add attributes to variables. Functions are handled elsewhere. */
1360 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1361 decl_attributes (&decl, attributes, 0);
1363 /* Symbols from modules should have their assembler names mangled.
1364 This is done here rather than in gfc_finish_var_decl because it
1365 is different for string length variables. */
1368 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1369 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1370 DECL_IGNORED_P (decl) = 1;
1373 if (sym->attr.dimension || sym->attr.codimension)
1375 /* Create variables to hold the non-constant bits of array info. */
1376 gfc_build_qualified_array (decl, sym);
1378 if (sym->attr.contiguous
1379 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1380 GFC_DECL_PACKED_ARRAY (decl) = 1;
1383 /* Remember this variable for allocation/cleanup. */
1384 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1385 || (sym->ts.type == BT_CLASS &&
1386 (CLASS_DATA (sym)->attr.dimension
1387 || CLASS_DATA (sym)->attr.allocatable))
1388 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1389 /* This applies a derived type default initializer. */
1390 || (sym->ts.type == BT_DERIVED
1391 && sym->attr.save == SAVE_NONE
1393 && !sym->attr.allocatable
1394 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1395 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1396 gfc_defer_symbol_init (sym);
1398 gfc_finish_var_decl (decl, sym);
1400 if (sym->ts.type == BT_CHARACTER)
1402 /* Character variables need special handling. */
1403 gfc_allocate_lang_decl (decl);
1405 if (TREE_CODE (length) != INTEGER_CST)
1407 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1411 /* Also prefix the mangled name for symbols from modules. */
1412 strcpy (&name[1], sym->name);
1415 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1416 gfc_set_decl_assembler_name (decl, get_identifier (name));
1418 gfc_finish_var_decl (length, sym);
1419 gcc_assert (!sym->value);
1422 else if (sym->attr.subref_array_pointer)
1424 /* We need the span for these beasts. */
1425 gfc_allocate_lang_decl (decl);
1428 if (sym->attr.subref_array_pointer)
1431 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1432 span = build_decl (input_location,
1433 VAR_DECL, create_tmp_var_name ("span"),
1434 gfc_array_index_type);
1435 gfc_finish_var_decl (span, sym);
1436 TREE_STATIC (span) = TREE_STATIC (decl);
1437 DECL_ARTIFICIAL (span) = 1;
1439 GFC_DECL_SPAN (decl) = span;
1440 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1443 if (sym->ts.type == BT_CLASS)
1444 GFC_DECL_CLASS(decl) = 1;
1446 sym->backend_decl = decl;
1448 if (sym->attr.assign)
1449 gfc_add_assign_aux_vars (sym);
1451 if (intrinsic_array_parameter)
1453 TREE_STATIC (decl) = 1;
1454 DECL_EXTERNAL (decl) = 0;
1457 if (TREE_STATIC (decl)
1458 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1459 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1460 || gfc_option.flag_max_stack_var_size == 0
1461 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1462 && (gfc_option.coarray != GFC_FCOARRAY_LIB
1463 || !sym->attr.codimension || sym->attr.allocatable))
1465 /* Add static initializer. For procedures, it is only needed if
1466 SAVE is specified otherwise they need to be reinitialized
1467 every time the procedure is entered. The TREE_STATIC is
1468 in this case due to -fmax-stack-var-size=. */
1469 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1472 || (sym->attr.codimension
1473 && sym->attr.allocatable),
1475 || sym->attr.allocatable,
1476 sym->attr.proc_pointer);
1479 if (!TREE_STATIC (decl)
1480 && POINTER_TYPE_P (TREE_TYPE (decl))
1481 && !sym->attr.pointer
1482 && !sym->attr.allocatable
1483 && !sym->attr.proc_pointer)
1484 DECL_BY_REFERENCE (decl) = 1;
1487 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1489 TREE_READONLY (decl) = 1;
1490 GFC_DECL_PUSH_TOPLEVEL (decl) = 1;
1497 /* Substitute a temporary variable in place of the real one. */
1500 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1502 save->attr = sym->attr;
1503 save->decl = sym->backend_decl;
1505 gfc_clear_attr (&sym->attr);
1506 sym->attr.referenced = 1;
1507 sym->attr.flavor = FL_VARIABLE;
1509 sym->backend_decl = decl;
1513 /* Restore the original variable. */
1516 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1518 sym->attr = save->attr;
1519 sym->backend_decl = save->decl;
1523 /* Declare a procedure pointer. */
1526 get_proc_pointer_decl (gfc_symbol *sym)
1531 decl = sym->backend_decl;
1535 decl = build_decl (input_location,
1536 VAR_DECL, get_identifier (sym->name),
1537 build_pointer_type (gfc_get_function_type (sym)));
1539 if ((sym->ns->proc_name
1540 && sym->ns->proc_name->backend_decl == current_function_decl)
1541 || sym->attr.contained)
1542 gfc_add_decl_to_function (decl);
1543 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1544 gfc_add_decl_to_parent_function (decl);
1546 sym->backend_decl = decl;
1548 /* If a variable is USE associated, it's always external. */
1549 if (sym->attr.use_assoc)
1551 DECL_EXTERNAL (decl) = 1;
1552 TREE_PUBLIC (decl) = 1;
1554 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1556 /* This is the declaration of a module variable. */
1557 TREE_PUBLIC (decl) = 1;
1558 TREE_STATIC (decl) = 1;
1561 if (!sym->attr.use_assoc
1562 && (sym->attr.save != SAVE_NONE || sym->attr.data
1563 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1564 TREE_STATIC (decl) = 1;
1566 if (TREE_STATIC (decl) && sym->value)
1568 /* Add static initializer. */
1569 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1571 sym->attr.dimension,
1575 /* Handle threadprivate procedure pointers. */
1576 if (sym->attr.threadprivate
1577 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1578 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1580 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1581 decl_attributes (&decl, attributes, 0);
1587 /* Get a basic decl for an external function. */
1590 gfc_get_extern_function_decl (gfc_symbol * sym)
1596 gfc_intrinsic_sym *isym;
1598 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1603 if (sym->backend_decl)
1604 return sym->backend_decl;
1606 /* We should never be creating external decls for alternate entry points.
1607 The procedure may be an alternate entry point, but we don't want/need
1609 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1611 if (sym->attr.proc_pointer)
1612 return get_proc_pointer_decl (sym);
1614 /* See if this is an external procedure from the same file. If so,
1615 return the backend_decl. */
1616 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1618 if (gfc_option.flag_whole_file
1619 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1620 && !sym->backend_decl
1622 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1623 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1625 if (!gsym->ns->proc_name->backend_decl)
1627 /* By construction, the external function cannot be
1628 a contained procedure. */
1630 tree save_fn_decl = current_function_decl;
1632 current_function_decl = NULL_TREE;
1633 gfc_save_backend_locus (&old_loc);
1636 gfc_create_function_decl (gsym->ns, true);
1639 gfc_restore_backend_locus (&old_loc);
1640 current_function_decl = save_fn_decl;
1643 /* If the namespace has entries, the proc_name is the
1644 entry master. Find the entry and use its backend_decl.
1645 otherwise, use the proc_name backend_decl. */
1646 if (gsym->ns->entries)
1648 gfc_entry_list *entry = gsym->ns->entries;
1650 for (; entry; entry = entry->next)
1652 if (strcmp (gsym->name, entry->sym->name) == 0)
1654 sym->backend_decl = entry->sym->backend_decl;
1660 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1662 if (sym->backend_decl)
1664 /* Avoid problems of double deallocation of the backend declaration
1665 later in gfc_trans_use_stmts; cf. PR 45087. */
1666 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1667 sym->attr.use_assoc = 0;
1669 return sym->backend_decl;
1673 /* See if this is a module procedure from the same file. If so,
1674 return the backend_decl. */
1676 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1678 if (gfc_option.flag_whole_file
1680 && gsym->type == GSYM_MODULE)
1685 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1686 if (s && s->backend_decl)
1688 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1689 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1691 else if (sym->ts.type == BT_CHARACTER)
1692 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1693 sym->backend_decl = s->backend_decl;
1694 return sym->backend_decl;
1698 if (sym->attr.intrinsic)
1700 /* Call the resolution function to get the actual name. This is
1701 a nasty hack which relies on the resolution functions only looking
1702 at the first argument. We pass NULL for the second argument
1703 otherwise things like AINT get confused. */
1704 isym = gfc_find_function (sym->name);
1705 gcc_assert (isym->resolve.f0 != NULL);
1707 memset (&e, 0, sizeof (e));
1708 e.expr_type = EXPR_FUNCTION;
1710 memset (&argexpr, 0, sizeof (argexpr));
1711 gcc_assert (isym->formal);
1712 argexpr.ts = isym->formal->ts;
1714 if (isym->formal->next == NULL)
1715 isym->resolve.f1 (&e, &argexpr);
1718 if (isym->formal->next->next == NULL)
1719 isym->resolve.f2 (&e, &argexpr, NULL);
1722 if (isym->formal->next->next->next == NULL)
1723 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1726 /* All specific intrinsics take less than 5 arguments. */
1727 gcc_assert (isym->formal->next->next->next->next == NULL);
1728 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1733 if (gfc_option.flag_f2c
1734 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1735 || e.ts.type == BT_COMPLEX))
1737 /* Specific which needs a different implementation if f2c
1738 calling conventions are used. */
1739 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1742 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1744 name = get_identifier (s);
1745 mangled_name = name;
1749 name = gfc_sym_identifier (sym);
1750 mangled_name = gfc_sym_mangled_function_id (sym);
1753 type = gfc_get_function_type (sym);
1754 fndecl = build_decl (input_location,
1755 FUNCTION_DECL, name, type);
1757 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1758 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1759 the opposite of declaring a function as static in C). */
1760 DECL_EXTERNAL (fndecl) = 1;
1761 TREE_PUBLIC (fndecl) = 1;
1763 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1764 decl_attributes (&fndecl, attributes, 0);
1766 gfc_set_decl_assembler_name (fndecl, mangled_name);
1768 /* Set the context of this decl. */
1769 if (0 && sym->ns && sym->ns->proc_name)
1771 /* TODO: Add external decls to the appropriate scope. */
1772 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1776 /* Global declaration, e.g. intrinsic subroutine. */
1777 DECL_CONTEXT (fndecl) = NULL_TREE;
1780 /* Set attributes for PURE functions. A call to PURE function in the
1781 Fortran 95 sense is both pure and without side effects in the C
1783 if (sym->attr.pure || sym->attr.elemental)
1785 if (sym->attr.function && !gfc_return_by_reference (sym))
1786 DECL_PURE_P (fndecl) = 1;
1787 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1788 parameters and don't use alternate returns (is this
1789 allowed?). In that case, calls to them are meaningless, and
1790 can be optimized away. See also in build_function_decl(). */
1791 TREE_SIDE_EFFECTS (fndecl) = 0;
1794 /* Mark non-returning functions. */
1795 if (sym->attr.noreturn)
1796 TREE_THIS_VOLATILE(fndecl) = 1;
1798 sym->backend_decl = fndecl;
1800 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1801 pushdecl_top_level (fndecl);
1807 /* Create a declaration for a procedure. For external functions (in the C
1808 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1809 a master function with alternate entry points. */
1812 build_function_decl (gfc_symbol * sym, bool global)
1814 tree fndecl, type, attributes;
1815 symbol_attribute attr;
1817 gfc_formal_arglist *f;
1819 gcc_assert (!sym->attr.external);
1821 if (sym->backend_decl)
1824 /* Set the line and filename. sym->declared_at seems to point to the
1825 last statement for subroutines, but it'll do for now. */
1826 gfc_set_backend_locus (&sym->declared_at);
1828 /* Allow only one nesting level. Allow public declarations. */
1829 gcc_assert (current_function_decl == NULL_TREE
1830 || DECL_FILE_SCOPE_P (current_function_decl)
1831 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1832 == NAMESPACE_DECL));
1834 type = gfc_get_function_type (sym);
1835 fndecl = build_decl (input_location,
1836 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1840 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1841 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1842 the opposite of declaring a function as static in C). */
1843 DECL_EXTERNAL (fndecl) = 0;
1845 if (!current_function_decl
1846 && !sym->attr.entry_master && !sym->attr.is_main_program)
1847 TREE_PUBLIC (fndecl) = 1;
1849 attributes = add_attributes_to_decl (attr, NULL_TREE);
1850 decl_attributes (&fndecl, attributes, 0);
1852 /* Figure out the return type of the declared function, and build a
1853 RESULT_DECL for it. If this is a subroutine with alternate
1854 returns, build a RESULT_DECL for it. */
1855 result_decl = NULL_TREE;
1856 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1859 if (gfc_return_by_reference (sym))
1860 type = void_type_node;
1863 if (sym->result != sym)
1864 result_decl = gfc_sym_identifier (sym->result);
1866 type = TREE_TYPE (TREE_TYPE (fndecl));
1871 /* Look for alternate return placeholders. */
1872 int has_alternate_returns = 0;
1873 for (f = sym->formal; f; f = f->next)
1877 has_alternate_returns = 1;
1882 if (has_alternate_returns)
1883 type = integer_type_node;
1885 type = void_type_node;
1888 result_decl = build_decl (input_location,
1889 RESULT_DECL, result_decl, type);
1890 DECL_ARTIFICIAL (result_decl) = 1;
1891 DECL_IGNORED_P (result_decl) = 1;
1892 DECL_CONTEXT (result_decl) = fndecl;
1893 DECL_RESULT (fndecl) = result_decl;
1895 /* Don't call layout_decl for a RESULT_DECL.
1896 layout_decl (result_decl, 0); */
1898 /* TREE_STATIC means the function body is defined here. */
1899 TREE_STATIC (fndecl) = 1;
1901 /* Set attributes for PURE functions. A call to a PURE function in the
1902 Fortran 95 sense is both pure and without side effects in the C
1904 if (attr.pure || attr.elemental)
1906 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1907 including an alternate return. In that case it can also be
1908 marked as PURE. See also in gfc_get_extern_function_decl(). */
1909 if (attr.function && !gfc_return_by_reference (sym))
1910 DECL_PURE_P (fndecl) = 1;
1911 TREE_SIDE_EFFECTS (fndecl) = 0;
1915 /* Layout the function declaration and put it in the binding level
1916 of the current function. */
1919 || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0))
1920 pushdecl_top_level (fndecl);
1924 /* Perform name mangling if this is a top level or module procedure. */
1925 if (current_function_decl == NULL_TREE)
1926 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1928 sym->backend_decl = fndecl;
1932 /* Create the DECL_ARGUMENTS for a procedure. */
1935 create_function_arglist (gfc_symbol * sym)
1938 gfc_formal_arglist *f;
1939 tree typelist, hidden_typelist;
1940 tree arglist, hidden_arglist;
1944 fndecl = sym->backend_decl;
1946 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1947 the new FUNCTION_DECL node. */
1948 arglist = NULL_TREE;
1949 hidden_arglist = NULL_TREE;
1950 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1952 if (sym->attr.entry_master)
1954 type = TREE_VALUE (typelist);
1955 parm = build_decl (input_location,
1956 PARM_DECL, get_identifier ("__entry"), type);
1958 DECL_CONTEXT (parm) = fndecl;
1959 DECL_ARG_TYPE (parm) = type;
1960 TREE_READONLY (parm) = 1;
1961 gfc_finish_decl (parm);
1962 DECL_ARTIFICIAL (parm) = 1;
1964 arglist = chainon (arglist, parm);
1965 typelist = TREE_CHAIN (typelist);
1968 if (gfc_return_by_reference (sym))
1970 tree type = TREE_VALUE (typelist), length = NULL;
1972 if (sym->ts.type == BT_CHARACTER)
1974 /* Length of character result. */
1975 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1977 length = build_decl (input_location,
1979 get_identifier (".__result"),
1981 if (!sym->ts.u.cl->length)
1983 sym->ts.u.cl->backend_decl = length;
1984 TREE_USED (length) = 1;
1986 gcc_assert (TREE_CODE (length) == PARM_DECL);
1987 DECL_CONTEXT (length) = fndecl;
1988 DECL_ARG_TYPE (length) = len_type;
1989 TREE_READONLY (length) = 1;
1990 DECL_ARTIFICIAL (length) = 1;
1991 gfc_finish_decl (length);
1992 if (sym->ts.u.cl->backend_decl == NULL
1993 || sym->ts.u.cl->backend_decl == length)
1998 if (sym->ts.u.cl->backend_decl == NULL)
2000 tree len = build_decl (input_location,
2002 get_identifier ("..__result"),
2003 gfc_charlen_type_node);
2004 DECL_ARTIFICIAL (len) = 1;
2005 TREE_USED (len) = 1;
2006 sym->ts.u.cl->backend_decl = len;
2009 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2010 arg = sym->result ? sym->result : sym;
2011 backend_decl = arg->backend_decl;
2012 /* Temporary clear it, so that gfc_sym_type creates complete
2014 arg->backend_decl = NULL;
2015 type = gfc_sym_type (arg);
2016 arg->backend_decl = backend_decl;
2017 type = build_reference_type (type);
2021 parm = build_decl (input_location,
2022 PARM_DECL, get_identifier ("__result"), type);
2024 DECL_CONTEXT (parm) = fndecl;
2025 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2026 TREE_READONLY (parm) = 1;
2027 DECL_ARTIFICIAL (parm) = 1;
2028 gfc_finish_decl (parm);
2030 arglist = chainon (arglist, parm);
2031 typelist = TREE_CHAIN (typelist);
2033 if (sym->ts.type == BT_CHARACTER)
2035 gfc_allocate_lang_decl (parm);
2036 arglist = chainon (arglist, length);
2037 typelist = TREE_CHAIN (typelist);
2041 hidden_typelist = typelist;
2042 for (f = sym->formal; f; f = f->next)
2043 if (f->sym != NULL) /* Ignore alternate returns. */
2044 hidden_typelist = TREE_CHAIN (hidden_typelist);
2046 for (f = sym->formal; f; f = f->next)
2048 char name[GFC_MAX_SYMBOL_LEN + 2];
2050 /* Ignore alternate returns. */
2054 type = TREE_VALUE (typelist);
2056 if (f->sym->ts.type == BT_CHARACTER
2057 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2059 tree len_type = TREE_VALUE (hidden_typelist);
2060 tree length = NULL_TREE;
2061 if (!f->sym->ts.deferred)
2062 gcc_assert (len_type == gfc_charlen_type_node);
2064 gcc_assert (POINTER_TYPE_P (len_type));
2066 strcpy (&name[1], f->sym->name);
2068 length = build_decl (input_location,
2069 PARM_DECL, get_identifier (name), len_type);
2071 hidden_arglist = chainon (hidden_arglist, length);
2072 DECL_CONTEXT (length) = fndecl;
2073 DECL_ARTIFICIAL (length) = 1;
2074 DECL_ARG_TYPE (length) = len_type;
2075 TREE_READONLY (length) = 1;
2076 gfc_finish_decl (length);
2078 /* Remember the passed value. */
2079 if (f->sym->ts.u.cl->passed_length != NULL)
2081 /* This can happen if the same type is used for multiple
2082 arguments. We need to copy cl as otherwise
2083 cl->passed_length gets overwritten. */
2084 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2086 f->sym->ts.u.cl->passed_length = length;
2088 /* Use the passed value for assumed length variables. */
2089 if (!f->sym->ts.u.cl->length)
2091 TREE_USED (length) = 1;
2092 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2093 f->sym->ts.u.cl->backend_decl = length;
2096 hidden_typelist = TREE_CHAIN (hidden_typelist);
2098 if (f->sym->ts.u.cl->backend_decl == NULL
2099 || f->sym->ts.u.cl->backend_decl == length)
2101 if (f->sym->ts.u.cl->backend_decl == NULL)
2102 gfc_create_string_length (f->sym);
2104 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2105 if (f->sym->attr.flavor == FL_PROCEDURE)
2106 type = build_pointer_type (gfc_get_function_type (f->sym));
2108 type = gfc_sym_type (f->sym);
2112 /* For non-constant length array arguments, make sure they use
2113 a different type node from TYPE_ARG_TYPES type. */
2114 if (f->sym->attr.dimension
2115 && type == TREE_VALUE (typelist)
2116 && TREE_CODE (type) == POINTER_TYPE
2117 && GFC_ARRAY_TYPE_P (type)
2118 && f->sym->as->type != AS_ASSUMED_SIZE
2119 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2121 if (f->sym->attr.flavor == FL_PROCEDURE)
2122 type = build_pointer_type (gfc_get_function_type (f->sym));
2124 type = gfc_sym_type (f->sym);
2127 if (f->sym->attr.proc_pointer)
2128 type = build_pointer_type (type);
2130 if (f->sym->attr.volatile_)
2131 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2133 /* Build the argument declaration. */
2134 parm = build_decl (input_location,
2135 PARM_DECL, gfc_sym_identifier (f->sym), type);
2137 if (f->sym->attr.volatile_)
2139 TREE_THIS_VOLATILE (parm) = 1;
2140 TREE_SIDE_EFFECTS (parm) = 1;
2143 /* Fill in arg stuff. */
2144 DECL_CONTEXT (parm) = fndecl;
2145 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2146 /* All implementation args are read-only. */
2147 TREE_READONLY (parm) = 1;
2148 if (POINTER_TYPE_P (type)
2149 && (!f->sym->attr.proc_pointer
2150 && f->sym->attr.flavor != FL_PROCEDURE))
2151 DECL_BY_REFERENCE (parm) = 1;
2153 gfc_finish_decl (parm);
2155 f->sym->backend_decl = parm;
2157 /* Coarrays which are descriptorless or assumed-shape pass with
2158 -fcoarray=lib the token and the offset as hidden arguments. */
2159 if (f->sym->attr.codimension
2160 && gfc_option.coarray == GFC_FCOARRAY_LIB
2161 && !f->sym->attr.allocatable)
2167 gcc_assert (f->sym->backend_decl != NULL_TREE
2168 && !sym->attr.is_bind_c);
2169 caf_type = TREE_TYPE (f->sym->backend_decl);
2171 token = build_decl (input_location, PARM_DECL,
2172 create_tmp_var_name ("caf_token"),
2173 build_qualified_type (pvoid_type_node,
2174 TYPE_QUAL_RESTRICT));
2175 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2177 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2178 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2179 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2180 gfc_allocate_lang_decl (f->sym->backend_decl);
2181 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2185 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2186 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2189 DECL_CONTEXT (token) = fndecl;
2190 DECL_ARTIFICIAL (token) = 1;
2191 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2192 TREE_READONLY (token) = 1;
2193 hidden_arglist = chainon (hidden_arglist, token);
2194 gfc_finish_decl (token);
2196 offset = build_decl (input_location, PARM_DECL,
2197 create_tmp_var_name ("caf_offset"),
2198 gfc_array_index_type);
2200 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2202 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2204 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2208 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2209 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2211 DECL_CONTEXT (offset) = fndecl;
2212 DECL_ARTIFICIAL (offset) = 1;
2213 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2214 TREE_READONLY (offset) = 1;
2215 hidden_arglist = chainon (hidden_arglist, offset);
2216 gfc_finish_decl (offset);
2219 arglist = chainon (arglist, parm);
2220 typelist = TREE_CHAIN (typelist);
2223 /* Add the hidden string length parameters, unless the procedure
2225 if (!sym->attr.is_bind_c)
2226 arglist = chainon (arglist, hidden_arglist);
2228 gcc_assert (hidden_typelist == NULL_TREE
2229 || TREE_VALUE (hidden_typelist) == void_type_node);
2230 DECL_ARGUMENTS (fndecl) = arglist;
2233 /* Do the setup necessary before generating the body of a function. */
2236 trans_function_start (gfc_symbol * sym)
2240 fndecl = sym->backend_decl;
2242 /* Let GCC know the current scope is this function. */
2243 current_function_decl = fndecl;
2245 /* Let the world know what we're about to do. */
2246 announce_function (fndecl);
2248 if (DECL_FILE_SCOPE_P (fndecl))
2250 /* Create RTL for function declaration. */
2251 rest_of_decl_compilation (fndecl, 1, 0);
2254 /* Create RTL for function definition. */
2255 make_decl_rtl (fndecl);
2257 init_function_start (fndecl);
2259 /* function.c requires a push at the start of the function. */
2263 /* Create thunks for alternate entry points. */
2266 build_entry_thunks (gfc_namespace * ns, bool global)
2268 gfc_formal_arglist *formal;
2269 gfc_formal_arglist *thunk_formal;
2271 gfc_symbol *thunk_sym;
2277 /* This should always be a toplevel function. */
2278 gcc_assert (current_function_decl == NULL_TREE);
2280 gfc_save_backend_locus (&old_loc);
2281 for (el = ns->entries; el; el = el->next)
2283 VEC(tree,gc) *args = NULL;
2284 VEC(tree,gc) *string_args = NULL;
2286 thunk_sym = el->sym;
2288 build_function_decl (thunk_sym, global);
2289 create_function_arglist (thunk_sym);
2291 trans_function_start (thunk_sym);
2293 thunk_fndecl = thunk_sym->backend_decl;
2295 gfc_init_block (&body);
2297 /* Pass extra parameter identifying this entry point. */
2298 tmp = build_int_cst (gfc_array_index_type, el->id);
2299 VEC_safe_push (tree, gc, args, tmp);
2301 if (thunk_sym->attr.function)
2303 if (gfc_return_by_reference (ns->proc_name))
2305 tree ref = DECL_ARGUMENTS (current_function_decl);
2306 VEC_safe_push (tree, gc, args, ref);
2307 if (ns->proc_name->ts.type == BT_CHARACTER)
2308 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2312 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2314 /* Ignore alternate returns. */
2315 if (formal->sym == NULL)
2318 /* We don't have a clever way of identifying arguments, so resort to
2319 a brute-force search. */
2320 for (thunk_formal = thunk_sym->formal;
2322 thunk_formal = thunk_formal->next)
2324 if (thunk_formal->sym == formal->sym)
2330 /* Pass the argument. */
2331 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2332 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2333 if (formal->sym->ts.type == BT_CHARACTER)
2335 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2336 VEC_safe_push (tree, gc, string_args, tmp);
2341 /* Pass NULL for a missing argument. */
2342 VEC_safe_push (tree, gc, args, null_pointer_node);
2343 if (formal->sym->ts.type == BT_CHARACTER)
2345 tmp = build_int_cst (gfc_charlen_type_node, 0);
2346 VEC_safe_push (tree, gc, string_args, tmp);
2351 /* Call the master function. */
2352 VEC_safe_splice (tree, gc, args, string_args);
2353 tmp = ns->proc_name->backend_decl;
2354 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2355 if (ns->proc_name->attr.mixed_entry_master)
2357 tree union_decl, field;
2358 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2360 union_decl = build_decl (input_location,
2361 VAR_DECL, get_identifier ("__result"),
2362 TREE_TYPE (master_type));
2363 DECL_ARTIFICIAL (union_decl) = 1;
2364 DECL_EXTERNAL (union_decl) = 0;
2365 TREE_PUBLIC (union_decl) = 0;
2366 TREE_USED (union_decl) = 1;
2367 layout_decl (union_decl, 0);
2368 pushdecl (union_decl);
2370 DECL_CONTEXT (union_decl) = current_function_decl;
2371 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2372 TREE_TYPE (union_decl), union_decl, tmp);
2373 gfc_add_expr_to_block (&body, tmp);
2375 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2376 field; field = DECL_CHAIN (field))
2377 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2378 thunk_sym->result->name) == 0)
2380 gcc_assert (field != NULL_TREE);
2381 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2382 TREE_TYPE (field), union_decl, field,
2384 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2385 TREE_TYPE (DECL_RESULT (current_function_decl)),
2386 DECL_RESULT (current_function_decl), tmp);
2387 tmp = build1_v (RETURN_EXPR, tmp);
2389 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2392 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2393 TREE_TYPE (DECL_RESULT (current_function_decl)),
2394 DECL_RESULT (current_function_decl), tmp);
2395 tmp = build1_v (RETURN_EXPR, tmp);
2397 gfc_add_expr_to_block (&body, tmp);
2399 /* Finish off this function and send it for code generation. */
2400 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2403 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2404 DECL_SAVED_TREE (thunk_fndecl)
2405 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2406 DECL_INITIAL (thunk_fndecl));
2408 /* Output the GENERIC tree. */
2409 dump_function (TDI_original, thunk_fndecl);
2411 /* Store the end of the function, so that we get good line number
2412 info for the epilogue. */
2413 cfun->function_end_locus = input_location;
2415 /* We're leaving the context of this function, so zap cfun.
2416 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2417 tree_rest_of_compilation. */
2420 current_function_decl = NULL_TREE;
2422 cgraph_finalize_function (thunk_fndecl, true);
2424 /* We share the symbols in the formal argument list with other entry
2425 points and the master function. Clear them so that they are
2426 recreated for each function. */
2427 for (formal = thunk_sym->formal; formal; formal = formal->next)
2428 if (formal->sym != NULL) /* Ignore alternate returns. */
2430 formal->sym->backend_decl = NULL_TREE;
2431 if (formal->sym->ts.type == BT_CHARACTER)
2432 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2435 if (thunk_sym->attr.function)
2437 if (thunk_sym->ts.type == BT_CHARACTER)
2438 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2439 if (thunk_sym->result->ts.type == BT_CHARACTER)
2440 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2444 gfc_restore_backend_locus (&old_loc);
2448 /* Create a decl for a function, and create any thunks for alternate entry
2449 points. If global is true, generate the function in the global binding
2450 level, otherwise in the current binding level (which can be global). */
2453 gfc_create_function_decl (gfc_namespace * ns, bool global)
2455 /* Create a declaration for the master function. */
2456 build_function_decl (ns->proc_name, global);
2458 /* Compile the entry thunks. */
2460 build_entry_thunks (ns, global);
2462 /* Now create the read argument list. */
2463 create_function_arglist (ns->proc_name);
2466 /* Return the decl used to hold the function return value. If
2467 parent_flag is set, the context is the parent_scope. */
2470 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2474 tree this_fake_result_decl;
2475 tree this_function_decl;
2477 char name[GFC_MAX_SYMBOL_LEN + 10];
2481 this_fake_result_decl = parent_fake_result_decl;
2482 this_function_decl = DECL_CONTEXT (current_function_decl);
2486 this_fake_result_decl = current_fake_result_decl;
2487 this_function_decl = current_function_decl;
2491 && sym->ns->proc_name->backend_decl == this_function_decl
2492 && sym->ns->proc_name->attr.entry_master
2493 && sym != sym->ns->proc_name)
2496 if (this_fake_result_decl != NULL)
2497 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2498 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2501 return TREE_VALUE (t);
2502 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2505 this_fake_result_decl = parent_fake_result_decl;
2507 this_fake_result_decl = current_fake_result_decl;
2509 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2513 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2514 field; field = DECL_CHAIN (field))
2515 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2519 gcc_assert (field != NULL_TREE);
2520 decl = fold_build3_loc (input_location, COMPONENT_REF,
2521 TREE_TYPE (field), decl, field, NULL_TREE);
2524 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2526 gfc_add_decl_to_parent_function (var);
2528 gfc_add_decl_to_function (var);
2530 SET_DECL_VALUE_EXPR (var, decl);
2531 DECL_HAS_VALUE_EXPR_P (var) = 1;
2532 GFC_DECL_RESULT (var) = 1;
2534 TREE_CHAIN (this_fake_result_decl)
2535 = tree_cons (get_identifier (sym->name), var,
2536 TREE_CHAIN (this_fake_result_decl));
2540 if (this_fake_result_decl != NULL_TREE)
2541 return TREE_VALUE (this_fake_result_decl);
2543 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2548 if (sym->ts.type == BT_CHARACTER)
2550 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2551 length = gfc_create_string_length (sym);
2553 length = sym->ts.u.cl->backend_decl;
2554 if (TREE_CODE (length) == VAR_DECL
2555 && DECL_CONTEXT (length) == NULL_TREE)
2556 gfc_add_decl_to_function (length);
2559 if (gfc_return_by_reference (sym))
2561 decl = DECL_ARGUMENTS (this_function_decl);
2563 if (sym->ns->proc_name->backend_decl == this_function_decl
2564 && sym->ns->proc_name->attr.entry_master)
2565 decl = DECL_CHAIN (decl);
2567 TREE_USED (decl) = 1;
2569 decl = gfc_build_dummy_array_decl (sym, decl);
2573 sprintf (name, "__result_%.20s",
2574 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2576 if (!sym->attr.mixed_entry_master && sym->attr.function)
2577 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2578 VAR_DECL, get_identifier (name),
2579 gfc_sym_type (sym));
2581 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2582 VAR_DECL, get_identifier (name),
2583 TREE_TYPE (TREE_TYPE (this_function_decl)));
2584 DECL_ARTIFICIAL (decl) = 1;
2585 DECL_EXTERNAL (decl) = 0;
2586 TREE_PUBLIC (decl) = 0;
2587 TREE_USED (decl) = 1;
2588 GFC_DECL_RESULT (decl) = 1;
2589 TREE_ADDRESSABLE (decl) = 1;
2591 layout_decl (decl, 0);
2594 gfc_add_decl_to_parent_function (decl);
2596 gfc_add_decl_to_function (decl);
2600 parent_fake_result_decl = build_tree_list (NULL, decl);
2602 current_fake_result_decl = build_tree_list (NULL, decl);
2608 /* Builds a function decl. The remaining parameters are the types of the
2609 function arguments. Negative nargs indicates a varargs function. */
2612 build_library_function_decl_1 (tree name, const char *spec,
2613 tree rettype, int nargs, va_list p)
2615 VEC(tree,gc) *arglist;
2620 /* Library functions must be declared with global scope. */
2621 gcc_assert (current_function_decl == NULL_TREE);
2623 /* Create a list of the argument types. */
2624 arglist = VEC_alloc (tree, gc, abs (nargs));
2625 for (n = abs (nargs); n > 0; n--)
2627 tree argtype = va_arg (p, tree);
2628 VEC_quick_push (tree, arglist, argtype);
2631 /* Build the function type and decl. */
2633 fntype = build_function_type_vec (rettype, arglist);
2635 fntype = build_varargs_function_type_vec (rettype, arglist);
2638 tree attr_args = build_tree_list (NULL_TREE,
2639 build_string (strlen (spec), spec));
2640 tree attrs = tree_cons (get_identifier ("fn spec"),
2641 attr_args, TYPE_ATTRIBUTES (fntype));
2642 fntype = build_type_attribute_variant (fntype, attrs);
2644 fndecl = build_decl (input_location,
2645 FUNCTION_DECL, name, fntype);
2647 /* Mark this decl as external. */
2648 DECL_EXTERNAL (fndecl) = 1;
2649 TREE_PUBLIC (fndecl) = 1;
2653 rest_of_decl_compilation (fndecl, 1, 0);
2658 /* Builds a function decl. The remaining parameters are the types of the
2659 function arguments. Negative nargs indicates a varargs function. */
2662 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2666 va_start (args, nargs);
2667 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2672 /* Builds a function decl. The remaining parameters are the types of the
2673 function arguments. Negative nargs indicates a varargs function.
2674 The SPEC parameter specifies the function argument and return type
2675 specification according to the fnspec function type attribute. */
2678 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2679 tree rettype, int nargs, ...)
2683 va_start (args, nargs);
2684 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2690 gfc_build_intrinsic_function_decls (void)
2692 tree gfc_int4_type_node = gfc_get_int_type (4);
2693 tree gfc_int8_type_node = gfc_get_int_type (8);
2694 tree gfc_int16_type_node = gfc_get_int_type (16);
2695 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2696 tree pchar1_type_node = gfc_get_pchar_type (1);
2697 tree pchar4_type_node = gfc_get_pchar_type (4);
2699 /* String functions. */
2700 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2701 get_identifier (PREFIX("compare_string")), "..R.R",
2702 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2703 gfc_charlen_type_node, pchar1_type_node);
2704 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2705 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2707 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2708 get_identifier (PREFIX("concat_string")), "..W.R.R",
2709 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2710 gfc_charlen_type_node, pchar1_type_node,
2711 gfc_charlen_type_node, pchar1_type_node);
2712 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2714 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2715 get_identifier (PREFIX("string_len_trim")), "..R",
2716 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2717 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2718 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2720 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2721 get_identifier (PREFIX("string_index")), "..R.R.",
2722 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2723 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2724 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2725 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2727 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2728 get_identifier (PREFIX("string_scan")), "..R.R.",
2729 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2730 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2731 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2732 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2734 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2735 get_identifier (PREFIX("string_verify")), "..R.R.",
2736 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2737 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2738 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2739 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2741 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2742 get_identifier (PREFIX("string_trim")), ".Ww.R",
2743 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2744 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2747 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2748 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2749 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2750 build_pointer_type (pchar1_type_node), integer_type_node,
2753 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2754 get_identifier (PREFIX("adjustl")), ".W.R",
2755 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2757 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2759 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2760 get_identifier (PREFIX("adjustr")), ".W.R",
2761 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2763 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2765 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2766 get_identifier (PREFIX("select_string")), ".R.R.",
2767 integer_type_node, 4, pvoid_type_node, integer_type_node,
2768 pchar1_type_node, gfc_charlen_type_node);
2769 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2770 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2772 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2773 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2774 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2775 gfc_charlen_type_node, pchar4_type_node);
2776 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2777 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2779 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2780 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2781 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2782 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2784 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2786 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2787 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2788 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2789 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2790 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2792 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2793 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2794 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2795 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2796 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2797 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2799 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2800 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2801 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2802 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2803 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2804 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2806 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2807 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2808 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2809 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2810 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2811 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2813 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2814 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2815 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2816 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2819 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2820 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2821 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2822 build_pointer_type (pchar4_type_node), integer_type_node,
2825 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2826 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2827 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2829 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2831 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2832 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2833 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2835 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2837 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2838 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2839 integer_type_node, 4, pvoid_type_node, integer_type_node,
2840 pvoid_type_node, gfc_charlen_type_node);
2841 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2842 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2845 /* Conversion between character kinds. */
2847 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2848 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2849 void_type_node, 3, build_pointer_type (pchar4_type_node),
2850 gfc_charlen_type_node, pchar1_type_node);
2852 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2853 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2854 void_type_node, 3, build_pointer_type (pchar1_type_node),
2855 gfc_charlen_type_node, pchar4_type_node);
2857 /* Misc. functions. */
2859 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2860 get_identifier (PREFIX("ttynam")), ".W",
2861 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2864 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2865 get_identifier (PREFIX("fdate")), ".W",
2866 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2868 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2869 get_identifier (PREFIX("ctime")), ".W",
2870 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2871 gfc_int8_type_node);
2873 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2874 get_identifier (PREFIX("selected_char_kind")), "..R",
2875 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2876 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2877 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2879 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2880 get_identifier (PREFIX("selected_int_kind")), ".R",
2881 gfc_int4_type_node, 1, pvoid_type_node);
2882 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2883 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2885 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2886 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2887 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2889 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2890 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2892 /* Power functions. */
2894 tree ctype, rtype, itype, jtype;
2895 int rkind, ikind, jkind;
2898 static int ikinds[NIKINDS] = {4, 8, 16};
2899 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2900 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2902 for (ikind=0; ikind < NIKINDS; ikind++)
2904 itype = gfc_get_int_type (ikinds[ikind]);
2906 for (jkind=0; jkind < NIKINDS; jkind++)
2908 jtype = gfc_get_int_type (ikinds[jkind]);
2911 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2913 gfor_fndecl_math_powi[jkind][ikind].integer =
2914 gfc_build_library_function_decl (get_identifier (name),
2915 jtype, 2, jtype, itype);
2916 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2917 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2921 for (rkind = 0; rkind < NRKINDS; rkind ++)
2923 rtype = gfc_get_real_type (rkinds[rkind]);
2926 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2928 gfor_fndecl_math_powi[rkind][ikind].real =
2929 gfc_build_library_function_decl (get_identifier (name),
2930 rtype, 2, rtype, itype);
2931 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2932 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2935 ctype = gfc_get_complex_type (rkinds[rkind]);
2938 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2940 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2941 gfc_build_library_function_decl (get_identifier (name),
2942 ctype, 2,ctype, itype);
2943 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2944 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2952 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2953 get_identifier (PREFIX("ishftc4")),
2954 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2955 gfc_int4_type_node);
2956 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2957 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2959 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2960 get_identifier (PREFIX("ishftc8")),
2961 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2962 gfc_int4_type_node);
2963 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2964 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2966 if (gfc_int16_type_node)
2968 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2969 get_identifier (PREFIX("ishftc16")),
2970 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2971 gfc_int4_type_node);
2972 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2973 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2976 /* BLAS functions. */
2978 tree pint = build_pointer_type (integer_type_node);
2979 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2980 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2981 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2982 tree pz = build_pointer_type
2983 (gfc_get_complex_type (gfc_default_double_kind));
2985 gfor_fndecl_sgemm = gfc_build_library_function_decl
2987 (gfc_option.flag_underscoring ? "sgemm_"
2989 void_type_node, 15, pchar_type_node,
2990 pchar_type_node, pint, pint, pint, ps, ps, pint,
2991 ps, pint, ps, ps, pint, integer_type_node,
2993 gfor_fndecl_dgemm = gfc_build_library_function_decl
2995 (gfc_option.flag_underscoring ? "dgemm_"
2997 void_type_node, 15, pchar_type_node,
2998 pchar_type_node, pint, pint, pint, pd, pd, pint,
2999 pd, pint, pd, pd, pint, integer_type_node,
3001 gfor_fndecl_cgemm = gfc_build_library_function_decl
3003 (gfc_option.flag_underscoring ? "cgemm_"
3005 void_type_node, 15, pchar_type_node,
3006 pchar_type_node, pint, pint, pint, pc, pc, pint,
3007 pc, pint, pc, pc, pint, integer_type_node,
3009 gfor_fndecl_zgemm = gfc_build_library_function_decl
3011 (gfc_option.flag_underscoring ? "zgemm_"
3013 void_type_node, 15, pchar_type_node,
3014 pchar_type_node, pint, pint, pint, pz, pz, pint,
3015 pz, pint, pz, pz, pint, integer_type_node,
3019 /* Other functions. */
3020 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3021 get_identifier (PREFIX("size0")), ".R",
3022 gfc_array_index_type, 1, pvoid_type_node);
3023 DECL_PURE_P (gfor_fndecl_size0) = 1;
3024 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3026 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3027 get_identifier (PREFIX("size1")), ".R",
3028 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3029 DECL_PURE_P (gfor_fndecl_size1) = 1;
3030 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3032 gfor_fndecl_iargc = gfc_build_library_function_decl (
3033 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3034 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3038 /* Make prototypes for runtime library functions. */
3041 gfc_build_builtin_function_decls (void)
3043 tree gfc_int4_type_node = gfc_get_int_type (4);
3045 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3046 get_identifier (PREFIX("stop_numeric")),
3047 void_type_node, 1, gfc_int4_type_node);
3048 /* STOP doesn't return. */
3049 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3051 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
3052 get_identifier (PREFIX("stop_numeric_f08")),
3053 void_type_node, 1, gfc_int4_type_node);
3054 /* STOP doesn't return. */
3055 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
3057 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3058 get_identifier (PREFIX("stop_string")), ".R.",
3059 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3060 /* STOP doesn't return. */
3061 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3063 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3064 get_identifier (PREFIX("error_stop_numeric")),
3065 void_type_node, 1, gfc_int4_type_node);
3066 /* ERROR STOP doesn't return. */
3067 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3069 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3070 get_identifier (PREFIX("error_stop_string")), ".R.",
3071 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3072 /* ERROR STOP doesn't return. */
3073 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3075 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3076 get_identifier (PREFIX("pause_numeric")),
3077 void_type_node, 1, gfc_int4_type_node);
3079 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3080 get_identifier (PREFIX("pause_string")), ".R.",
3081 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3083 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3084 get_identifier (PREFIX("runtime_error")), ".R",
3085 void_type_node, -1, pchar_type_node);
3086 /* The runtime_error function does not return. */
3087 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3089 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3090 get_identifier (PREFIX("runtime_error_at")), ".RR",
3091 void_type_node, -2, pchar_type_node, pchar_type_node);
3092 /* The runtime_error_at function does not return. */
3093 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3095 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3096 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3097 void_type_node, -2, pchar_type_node, pchar_type_node);
3099 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3100 get_identifier (PREFIX("generate_error")), ".R.R",
3101 void_type_node, 3, pvoid_type_node, integer_type_node,
3104 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3105 get_identifier (PREFIX("os_error")), ".R",
3106 void_type_node, 1, pchar_type_node);
3107 /* The runtime_error function does not return. */
3108 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3110 gfor_fndecl_set_args = gfc_build_library_function_decl (
3111 get_identifier (PREFIX("set_args")),
3112 void_type_node, 2, integer_type_node,
3113 build_pointer_type (pchar_type_node));
3115 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3116 get_identifier (PREFIX("set_fpe")),
3117 void_type_node, 1, integer_type_node);
3119 /* Keep the array dimension in sync with the call, later in this file. */
3120 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3121 get_identifier (PREFIX("set_options")), "..R",
3122 void_type_node, 2, integer_type_node,
3123 build_pointer_type (integer_type_node));
3125 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3126 get_identifier (PREFIX("set_convert")),
3127 void_type_node, 1, integer_type_node);
3129 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3130 get_identifier (PREFIX("set_record_marker")),
3131 void_type_node, 1, integer_type_node);
3133 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3134 get_identifier (PREFIX("set_max_subrecord_length")),
3135 void_type_node, 1, integer_type_node);
3137 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3138 get_identifier (PREFIX("internal_pack")), ".r",
3139 pvoid_type_node, 1, pvoid_type_node);
3141 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3142 get_identifier (PREFIX("internal_unpack")), ".wR",
3143 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3145 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3146 get_identifier (PREFIX("associated")), ".RR",
3147 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3148 DECL_PURE_P (gfor_fndecl_associated) = 1;
3149 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3151 /* Coarray library calls. */
3152 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3154 tree pint_type, pppchar_type;
3156 pint_type = build_pointer_type (integer_type_node);
3158 = build_pointer_type (build_pointer_type (pchar_type_node));
3160 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3161 get_identifier (PREFIX("caf_init")), void_type_node,
3162 4, pint_type, pppchar_type, pint_type, pint_type);
3164 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3165 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3167 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3168 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3169 size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3170 pchar_type_node, integer_type_node);
3172 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3173 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
3174 ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
3176 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3177 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3179 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3180 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3182 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3183 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3184 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3186 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3187 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3188 5, integer_type_node, pint_type, pint_type,
3189 build_pointer_type (pchar_type_node), integer_type_node);
3191 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3192 get_identifier (PREFIX("caf_error_stop")),
3193 void_type_node, 1, gfc_int4_type_node);
3194 /* CAF's ERROR STOP doesn't return. */
3195 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3197 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3198 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3199 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3200 /* CAF's ERROR STOP doesn't return. */
3201 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3204 gfc_build_intrinsic_function_decls ();
3205 gfc_build_intrinsic_lib_fndecls ();
3206 gfc_build_io_library_fndecls ();
3210 /* Evaluate the length of dummy character variables. */
3213 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3214 gfc_wrapped_block *block)
3218 gfc_finish_decl (cl->backend_decl);
3220 gfc_start_block (&init);
3222 /* Evaluate the string length expression. */
3223 gfc_conv_string_length (cl, NULL, &init);
3225 gfc_trans_vla_type_sizes (sym, &init);
3227 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3231 /* Allocate and cleanup an automatic character variable. */
3234 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3240 gcc_assert (sym->backend_decl);
3241 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3243 gfc_init_block (&init);
3245 /* Evaluate the string length expression. */
3246 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3248 gfc_trans_vla_type_sizes (sym, &init);
3250 decl = sym->backend_decl;
3252 /* Emit a DECL_EXPR for this variable, which will cause the
3253 gimplifier to allocate storage, and all that good stuff. */
3254 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3255 gfc_add_expr_to_block (&init, tmp);
3257 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3260 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3263 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3267 gcc_assert (sym->backend_decl);
3268 gfc_start_block (&init);
3270 /* Set the initial value to length. See the comments in
3271 function gfc_add_assign_aux_vars in this file. */
3272 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3273 build_int_cst (gfc_charlen_type_node, -2));
3275 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3279 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3281 tree t = *tp, var, val;
3283 if (t == NULL || t == error_mark_node)
3285 if (TREE_CONSTANT (t) || DECL_P (t))
3288 if (TREE_CODE (t) == SAVE_EXPR)
3290 if (SAVE_EXPR_RESOLVED_P (t))
3292 *tp = TREE_OPERAND (t, 0);
3295 val = TREE_OPERAND (t, 0);
3300 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3301 gfc_add_decl_to_function (var);
3302 gfc_add_modify (body, var, val);
3303 if (TREE_CODE (t) == SAVE_EXPR)
3304 TREE_OPERAND (t, 0) = var;
3309 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3313 if (type == NULL || type == error_mark_node)
3316 type = TYPE_MAIN_VARIANT (type);
3318 if (TREE_CODE (type) == INTEGER_TYPE)
3320 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3321 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3323 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3325 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3326 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3329 else if (TREE_CODE (type) == ARRAY_TYPE)
3331 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3332 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3333 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3334 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3336 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3338 TYPE_SIZE (t) = TYPE_SIZE (type);
3339 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3344 /* Make sure all type sizes and array domains are either constant,
3345 or variable or parameter decls. This is a simplified variant
3346 of gimplify_type_sizes, but we can't use it here, as none of the
3347 variables in the expressions have been gimplified yet.
3348 As type sizes and domains for various variable length arrays
3349 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3350 time, without this routine gimplify_type_sizes in the middle-end
3351 could result in the type sizes being gimplified earlier than where
3352 those variables are initialized. */
3355 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3357 tree type = TREE_TYPE (sym->backend_decl);
3359 if (TREE_CODE (type) == FUNCTION_TYPE
3360 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3362 if (! current_fake_result_decl)
3365 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3368 while (POINTER_TYPE_P (type))
3369 type = TREE_TYPE (type);
3371 if (GFC_DESCRIPTOR_TYPE_P (type))
3373 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3375 while (POINTER_TYPE_P (etype))
3376 etype = TREE_TYPE (etype);
3378 gfc_trans_vla_type_sizes_1 (etype, body);
3381 gfc_trans_vla_type_sizes_1 (type, body);
3385 /* Initialize a derived type by building an lvalue from the symbol
3386 and using trans_assignment to do the work. Set dealloc to false
3387 if no deallocation prior the assignment is needed. */
3389 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3397 gcc_assert (!sym->attr.allocatable);
3398 gfc_set_sym_referenced (sym);
3399 e = gfc_lval_expr_from_sym (sym);
3400 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3401 if (sym->attr.dummy && (sym->attr.optional
3402 || sym->ns->proc_name->attr.entry_master))
3404 present = gfc_conv_expr_present (sym);
3405 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3406 tmp, build_empty_stmt (input_location));
3408 gfc_add_expr_to_block (block, tmp);
3413 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3414 them their default initializer, if they do not have allocatable
3415 components, they have their allocatable components deallocated. */
3418 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3421 gfc_formal_arglist *f;
3425 gfc_init_block (&init);
3426 for (f = proc_sym->formal; f; f = f->next)
3427 if (f->sym && f->sym->attr.intent == INTENT_OUT
3428 && !f->sym->attr.pointer
3429 && f->sym->ts.type == BT_DERIVED)
3431 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3433 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3434 f->sym->backend_decl,
3435 f->sym->as ? f->sym->as->rank : 0);
3437 if (f->sym->attr.optional
3438 || f->sym->ns->proc_name->attr.entry_master)
3440 present = gfc_conv_expr_present (f->sym);
3441 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3443 build_empty_stmt (input_location));
3446 gfc_add_expr_to_block (&init, tmp);
3448 else if (f->sym->value)
3449 gfc_init_default_dt (f->sym, &init, true);
3451 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3452 && f->sym->ts.type == BT_CLASS
3453 && !CLASS_DATA (f->sym)->attr.class_pointer
3454 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3456 tree decl = build_fold_indirect_ref_loc (input_location,
3457 f->sym->backend_decl);
3458 tmp = CLASS_DATA (f->sym)->backend_decl;
3459 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3460 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3461 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3462 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3464 CLASS_DATA (f->sym)->as ?
3465 CLASS_DATA (f->sym)->as->rank : 0);
3467 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3469 present = gfc_conv_expr_present (f->sym);
3470 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3472 build_empty_stmt (input_location));
3475 gfc_add_expr_to_block (&init, tmp);
3478 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3482 /* Generate function entry and exit code, and add it to the function body.
3484 Allocation and initialization of array variables.
3485 Allocation of character string variables.
3486 Initialization and possibly repacking of dummy arrays.
3487 Initialization of ASSIGN statement auxiliary variable.
3488 Initialization of ASSOCIATE names.
3489 Automatic deallocation. */
3492 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3496 gfc_formal_arglist *f;
3497 stmtblock_t tmpblock;
3498 bool seen_trans_deferred_array = false;
3504 /* Deal with implicit return variables. Explicit return variables will
3505 already have been added. */
3506 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3508 if (!current_fake_result_decl)
3510 gfc_entry_list *el = NULL;
3511 if (proc_sym->attr.entry_master)
3513 for (el = proc_sym->ns->entries; el; el = el->next)
3514 if (el->sym != el->sym->result)
3517 /* TODO: move to the appropriate place in resolve.c. */
3518 if (warn_return_type && el == NULL)
3519 gfc_warning ("Return value of function '%s' at %L not set",
3520 proc_sym->name, &proc_sym->declared_at);
3522 else if (proc_sym->as)
3524 tree result = TREE_VALUE (current_fake_result_decl);
3525 gfc_trans_dummy_array_bias (proc_sym, result, block);
3527 /* An automatic character length, pointer array result. */
3528 if (proc_sym->ts.type == BT_CHARACTER
3529 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3530 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3532 else if (proc_sym->ts.type == BT_CHARACTER)
3534 if (proc_sym->ts.deferred)
3537 gfc_save_backend_locus (&loc);
3538 gfc_set_backend_locus (&proc_sym->declared_at);
3539 gfc_start_block (&init);
3540 /* Zero the string length on entry. */
3541 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3542 build_int_cst (gfc_charlen_type_node, 0));
3543 /* Null the pointer. */
3544 e = gfc_lval_expr_from_sym (proc_sym);
3545 gfc_init_se (&se, NULL);
3546 se.want_pointer = 1;
3547 gfc_conv_expr (&se, e);
3550 gfc_add_modify (&init, tmp,
3551 fold_convert (TREE_TYPE (se.expr),
3552 null_pointer_node));
3553 gfc_restore_backend_locus (&loc);
3555 /* Pass back the string length on exit. */
3556 tmp = proc_sym->ts.u.cl->passed_length;
3557 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3558 tmp = fold_convert (gfc_charlen_type_node, tmp);
3559 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3560 gfc_charlen_type_node, tmp,
3561 proc_sym->ts.u.cl->backend_decl);
3562 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3564 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3565 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3568 gcc_assert (gfc_option.flag_f2c
3569 && proc_sym->ts.type == BT_COMPLEX);
3572 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3573 should be done here so that the offsets and lbounds of arrays
3575 gfc_save_backend_locus (&loc);
3576 gfc_set_backend_locus (&proc_sym->declared_at);
3577 init_intent_out_dt (proc_sym, block);
3578 gfc_restore_backend_locus (&loc);
3580 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3582 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3583 && sym->ts.u.derived->attr.alloc_comp;
3587 if (sym->attr.subref_array_pointer
3588 && GFC_DECL_SPAN (sym->backend_decl)
3589 && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
3591 gfc_init_block (&tmpblock);
3592 gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
3593 build_int_cst (gfc_array_index_type, 0));
3594 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3598 if (sym->attr.dimension || sym->attr.codimension)
3600 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3601 array_type tmp = sym->as->type;
3602 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3607 if (sym->attr.dummy || sym->attr.result)
3608 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3609 else if (sym->attr.pointer || sym->attr.allocatable)
3611 if (TREE_STATIC (sym->backend_decl))
3613 gfc_save_backend_locus (&loc);
3614 gfc_set_backend_locus (&sym->declared_at);
3615 gfc_trans_static_array_pointer (sym);
3616 gfc_restore_backend_locus (&loc);
3620 seen_trans_deferred_array = true;
3621 gfc_trans_deferred_array (sym, block);
3624 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3626 gfc_init_block (&tmpblock);
3627 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3629 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3633 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3635 gfc_save_backend_locus (&loc);
3636 gfc_set_backend_locus (&sym->declared_at);
3638 if (sym_has_alloc_comp)
3640 seen_trans_deferred_array = true;
3641 gfc_trans_deferred_array (sym, block);
3643 else if (sym->ts.type == BT_DERIVED
3646 && sym->attr.save == SAVE_NONE)
3648 gfc_start_block (&tmpblock);
3649 gfc_init_default_dt (sym, &tmpblock, false);
3650 gfc_add_init_cleanup (block,
3651 gfc_finish_block (&tmpblock),
3655 gfc_trans_auto_array_allocation (sym->backend_decl,
3657 gfc_restore_backend_locus (&loc);
3661 case AS_ASSUMED_SIZE:
3662 /* Must be a dummy parameter. */
3663 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3665 /* We should always pass assumed size arrays the g77 way. */
3666 if (sym->attr.dummy)
3667 gfc_trans_g77_array (sym, block);
3670 case AS_ASSUMED_SHAPE:
3671 /* Must be a dummy parameter. */
3672 gcc_assert (sym->attr.dummy);
3674 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3678 seen_trans_deferred_array = true;
3679 gfc_trans_deferred_array (sym, block);
3685 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3686 gfc_trans_deferred_array (sym, block);
3688 else if ((!sym->attr.dummy || sym->ts.deferred)
3689 && (sym->ts.type == BT_CLASS
3690 && CLASS_DATA (sym)->attr.class_pointer))
3692 else if ((!sym->attr.dummy || sym->ts.deferred)
3693 && (sym->attr.allocatable
3694 || (sym->ts.type == BT_CLASS
3695 && CLASS_DATA (sym)->attr.allocatable)))
3697 if (!sym->attr.save)
3699 tree descriptor = NULL_TREE;
3701 /* Nullify and automatic deallocation of allocatable
3703 e = gfc_lval_expr_from_sym (sym);
3704 if (sym->ts.type == BT_CLASS)
3705 gfc_add_data_component (e);
3707 gfc_init_se (&se, NULL);
3708 if (sym->ts.type != BT_CLASS
3709 || sym->ts.u.derived->attr.dimension
3710 || sym->ts.u.derived->attr.codimension)
3712 se.want_pointer = 1;
3713 gfc_conv_expr (&se, e);
3715 else if (sym->ts.type == BT_CLASS
3716 && !CLASS_DATA (sym)->attr.dimension
3717 && !CLASS_DATA (sym)->attr.codimension)
3719 se.want_pointer = 1;
3720 gfc_conv_expr (&se, e);
3724 gfc_conv_expr (&se, e);
3725 descriptor = se.expr;
3726 se.expr = gfc_conv_descriptor_data_addr (se.expr);
3727 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3731 gfc_save_backend_locus (&loc);
3732 gfc_set_backend_locus (&sym->declared_at);
3733 gfc_start_block (&init);
3735 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3737 /* Nullify when entering the scope. */
3738 gfc_add_modify (&init, se.expr,
3739 fold_convert (TREE_TYPE (se.expr),
3740 null_pointer_node));
3743 if ((sym->attr.dummy ||sym->attr.result)
3744 && sym->ts.type == BT_CHARACTER
3745 && sym->ts.deferred)
3747 /* Character length passed by reference. */
3748 tmp = sym->ts.u.cl->passed_length;
3749 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3750 tmp = fold_convert (gfc_charlen_type_node, tmp);
3752 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3753 /* Zero the string length when entering the scope. */
3754 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3755 build_int_cst (gfc_charlen_type_node, 0));
3757 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3759 gfc_restore_backend_locus (&loc);
3761 /* Pass the final character length back. */
3762 if (sym->attr.intent != INTENT_IN)
3763 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3764 gfc_charlen_type_node, tmp,
3765 sym->ts.u.cl->backend_decl);
3770 gfc_restore_backend_locus (&loc);
3772 /* Deallocate when leaving the scope. Nullifying is not
3774 if (!sym->attr.result && !sym->attr.dummy)
3776 if (sym->ts.type == BT_CLASS
3777 && CLASS_DATA (sym)->attr.codimension)
3778 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
3779 NULL_TREE, NULL_TREE,
3780 NULL_TREE, true, NULL,
3783 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
3787 if (sym->ts.type == BT_CLASS)
3789 /* Initialize _vptr to declared type. */
3790 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3793 gfc_save_backend_locus (&loc);
3794 gfc_set_backend_locus (&sym->declared_at);
3795 e = gfc_lval_expr_from_sym (sym);
3796 gfc_add_vptr_component (e);
3797 gfc_init_se (&se, NULL);
3798 se.want_pointer = 1;
3799 gfc_conv_expr (&se, e);
3801 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3802 gfc_get_symbol_decl (vtab));
3803 gfc_add_modify (&init, se.expr, rhs);
3804 gfc_restore_backend_locus (&loc);
3807 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3810 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3815 /* If we get to here, all that should be left are pointers. */
3816 gcc_assert (sym->attr.pointer);
3818 if (sym->attr.dummy)
3820 gfc_start_block (&init);
3822 /* Character length passed by reference. */
3823 tmp = sym->ts.u.cl->passed_length;
3824 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3825 tmp = fold_convert (gfc_charlen_type_node, tmp);
3826 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3827 /* Pass the final character length back. */
3828 if (sym->attr.intent != INTENT_IN)
3829 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3830 gfc_charlen_type_node, tmp,
3831 sym->ts.u.cl->backend_decl);
3834 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3837 else if (sym->ts.deferred)
3838 gfc_fatal_error ("Deferred type parameter not yet supported");
3839 else if (sym_has_alloc_comp)
3840 gfc_trans_deferred_array (sym, block);
3841 else if (sym->ts.type == BT_CHARACTER)
3843 gfc_save_backend_locus (&loc);
3844 gfc_set_backend_locus (&sym->declared_at);
3845 if (sym->attr.dummy || sym->attr.result)
3846 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3848 gfc_trans_auto_character_variable (sym, block);
3849 gfc_restore_backend_locus (&loc);
3851 else if (sym->attr.assign)
3853 gfc_save_backend_locus (&loc);
3854 gfc_set_backend_locus (&sym->declared_at);
3855 gfc_trans_assign_aux_var (sym, block);
3856 gfc_restore_backend_locus (&loc);
3858 else if (sym->ts.type == BT_DERIVED
3861 && sym->attr.save == SAVE_NONE)
3863 gfc_start_block (&tmpblock);
3864 gfc_init_default_dt (sym, &tmpblock, false);
3865 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3872 gfc_init_block (&tmpblock);
3874 for (f = proc_sym->formal; f; f = f->next)
3876 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3878 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3879 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3880 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3884 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3885 && current_fake_result_decl != NULL)
3887 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3888 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3889 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3892 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3895 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3897 /* Hash and equality functions for module_htab. */
3900 module_htab_do_hash (const void *x)
3902 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3906 module_htab_eq (const void *x1, const void *x2)
3908 return strcmp ((((const struct module_htab_entry *)x1)->name),
3909 (const char *)x2) == 0;
3912 /* Hash and equality functions for module_htab's decls. */
3915 module_htab_decls_hash (const void *x)
3917 const_tree t = (const_tree) x;
3918 const_tree n = DECL_NAME (t);
3920 n = TYPE_NAME (TREE_TYPE (t));
3921 return htab_hash_string (IDENTIFIER_POINTER (n));
3925 module_htab_decls_eq (const void *x1, const void *x2)
3927 const_tree t1 = (const_tree) x1;
3928 const_tree n1 = DECL_NAME (t1);
3929 if (n1 == NULL_TREE)
3930 n1 = TYPE_NAME (TREE_TYPE (t1));
3931 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3934 struct module_htab_entry *
3935 gfc_find_module (const char *name)
3940 module_htab = htab_create_ggc (10, module_htab_do_hash,
3941 module_htab_eq, NULL);
3943 slot = htab_find_slot_with_hash (module_htab, name,
3944 htab_hash_string (name), INSERT);
3947 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3949 entry->name = gfc_get_string (name);
3950 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3951 module_htab_decls_eq, NULL);
3952 *slot = (void *) entry;
3954 return (struct module_htab_entry *) *slot;
3958 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3963 if (DECL_NAME (decl))
3964 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3967 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3968 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3970 slot = htab_find_slot_with_hash (entry->decls, name,
3971 htab_hash_string (name), INSERT);
3973 *slot = (void *) decl;
3976 static struct module_htab_entry *cur_module;
3978 /* Output an initialized decl for a module variable. */
3981 gfc_create_module_variable (gfc_symbol * sym)
3985 /* Module functions with alternate entries are dealt with later and
3986 would get caught by the next condition. */
3987 if (sym->attr.entry)
3990 /* Make sure we convert the types of the derived types from iso_c_binding
3992 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3993 && sym->ts.type == BT_DERIVED)
3994 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3996 if (sym->attr.flavor == FL_DERIVED
3997 && sym->backend_decl
3998 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4000 decl = sym->backend_decl;
4001 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4003 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
4004 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
4006 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4007 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4008 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4009 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4010 == sym->ns->proc_name->backend_decl);
4012 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4013 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4014 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4017 /* Only output variables, procedure pointers and array valued,
4018 or derived type, parameters. */
4019 if (sym->attr.flavor != FL_VARIABLE
4020 && !(sym->attr.flavor == FL_PARAMETER
4021 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4022 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4025 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4027 decl = sym->backend_decl;
4028 gcc_assert (DECL_FILE_SCOPE_P (decl));
4029 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4030 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4031 gfc_module_add_decl (cur_module, decl);
4034 /* Don't generate variables from other modules. Variables from
4035 COMMONs will already have been generated. */
4036 if (sym->attr.use_assoc || sym->attr.in_common)
4039 /* Equivalenced variables arrive here after creation. */
4040 if (sym->backend_decl
4041 && (sym->equiv_built || sym->attr.in_equivalence))
4044 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4045 internal_error ("backend decl for module variable %s already exists",
4048 /* We always want module variables to be created. */
4049 sym->attr.referenced = 1;
4050 /* Create the decl. */
4051 decl = gfc_get_symbol_decl (sym);
4053 /* Create the variable. */
4055 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4056 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4057 rest_of_decl_compilation (decl, 1, 0);
4058 gfc_module_add_decl (cur_module, decl);
4060 /* Also add length of strings. */
4061 if (sym->ts.type == BT_CHARACTER)
4065 length = sym->ts.u.cl->backend_decl;
4066 gcc_assert (length || sym->attr.proc_pointer);
4067 if (length && !INTEGER_CST_P (length))
4070 rest_of_decl_compilation (length, 1, 0);
4074 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4075 && sym->attr.referenced && !sym->attr.use_assoc)
4076 has_coarray_vars = true;
4079 /* Emit debug information for USE statements. */
4082 gfc_trans_use_stmts (gfc_namespace * ns)
4084 gfc_use_list *use_stmt;
4085 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4087 struct module_htab_entry *entry
4088 = gfc_find_module (use_stmt->module_name);
4089 gfc_use_rename *rent;
4091 if (entry->namespace_decl == NULL)
4093 entry->namespace_decl
4094 = build_decl (input_location,
4096 get_identifier (use_stmt->module_name),
4098 DECL_EXTERNAL (entry->namespace_decl) = 1;
4100 gfc_set_backend_locus (&use_stmt->where);
4101 if (!use_stmt->only_flag)
4102 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4104 ns->proc_name->backend_decl,
4106 for (rent = use_stmt->rename; rent; rent = rent->next)
4108 tree decl, local_name;
4111 if (rent->op != INTRINSIC_NONE)
4114 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4115 htab_hash_string (rent->use_name),
4121 st = gfc_find_symtree (ns->sym_root,
4123 ? rent->local_name : rent->use_name);
4125 /* The following can happen if a derived type is renamed. */
4129 name = xstrdup (rent->local_name[0]
4130 ? rent->local_name : rent->use_name);
4131 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4132 st = gfc_find_symtree (ns->sym_root, name);
4137 /* Sometimes, generic interfaces wind up being over-ruled by a
4138 local symbol (see PR41062). */
4139 if (!st->n.sym->attr.use_assoc)
4142 if (st->n.sym->backend_decl
4143 && DECL_P (st->n.sym->backend_decl)
4144 && st->n.sym->module
4145 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4147 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4148 || (TREE_CODE (st->n.sym->backend_decl)
4150 decl = copy_node (st->n.sym->backend_decl);
4151 DECL_CONTEXT (decl) = entry->namespace_decl;
4152 DECL_EXTERNAL (decl) = 1;
4153 DECL_IGNORED_P (decl) = 0;
4154 DECL_INITIAL (decl) = NULL_TREE;
4158 *slot = error_mark_node;
4159 htab_clear_slot (entry->decls, slot);
4164 decl = (tree) *slot;
4165 if (rent->local_name[0])
4166 local_name = get_identifier (rent->local_name);
4168 local_name = NULL_TREE;
4169 gfc_set_backend_locus (&rent->where);
4170 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4171 ns->proc_name->backend_decl,
4172 !use_stmt->only_flag);
4178 /* Return true if expr is a constant initializer that gfc_conv_initializer
4182 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4192 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4194 else if (expr->expr_type == EXPR_STRUCTURE)
4195 return check_constant_initializer (expr, ts, false, false);
4196 else if (expr->expr_type != EXPR_ARRAY)
4198 for (c = gfc_constructor_first (expr->value.constructor);
4199 c; c = gfc_constructor_next (c))
4203 if (c->expr->expr_type == EXPR_STRUCTURE)
4205 if (!check_constant_initializer (c->expr, ts, false, false))
4208 else if (c->expr->expr_type != EXPR_CONSTANT)
4213 else switch (ts->type)
4216 if (expr->expr_type != EXPR_STRUCTURE)
4218 cm = expr->ts.u.derived->components;
4219 for (c = gfc_constructor_first (expr->value.constructor);
4220 c; c = gfc_constructor_next (c), cm = cm->next)
4222 if (!c->expr || cm->attr.allocatable)
4224 if (!check_constant_initializer (c->expr, &cm->ts,
4231 return expr->expr_type == EXPR_CONSTANT;
4235 /* Emit debug info for parameters and unreferenced variables with
4239 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4243 if (sym->attr.flavor != FL_PARAMETER
4244 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4247 if (sym->backend_decl != NULL
4248 || sym->value == NULL
4249 || sym->attr.use_assoc
4252 || sym->attr.function
4253 || sym->attr.intrinsic
4254 || sym->attr.pointer
4255 || sym->attr.allocatable
4256 || sym->attr.cray_pointee
4257 || sym->attr.threadprivate
4258 || sym->attr.is_bind_c
4259 || sym->attr.subref_array_pointer
4260 || sym->attr.assign)
4263 if (sym->ts.type == BT_CHARACTER)
4265 gfc_conv_const_charlen (sym->ts.u.cl);
4266 if (sym->ts.u.cl->backend_decl == NULL
4267 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4270 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4277 if (sym->as->type != AS_EXPLICIT)
4279 for (n = 0; n < sym->as->rank; n++)
4280 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4281 || sym->as->upper[n] == NULL
4282 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4286 if (!check_constant_initializer (sym->value, &sym->ts,
4287 sym->attr.dimension, false))
4290 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4293 /* Create the decl for the variable or constant. */
4294 decl = build_decl (input_location,
4295 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4296 gfc_sym_identifier (sym), gfc_sym_type (sym));
4297 if (sym->attr.flavor == FL_PARAMETER)
4298 TREE_READONLY (decl) = 1;
4299 gfc_set_decl_location (decl, &sym->declared_at);
4300 if (sym->attr.dimension)
4301 GFC_DECL_PACKED_ARRAY (decl) = 1;
4302 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4303 TREE_STATIC (decl) = 1;
4304 TREE_USED (decl) = 1;
4305 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4306 TREE_PUBLIC (decl) = 1;
4307 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4309 sym->attr.dimension,
4311 debug_hooks->global_decl (decl);
4316 generate_coarray_sym_init (gfc_symbol *sym)
4318 tree tmp, size, decl, token;
4320 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4321 || sym->attr.use_assoc || !sym->attr.referenced)
4324 decl = sym->backend_decl;
4325 TREE_USED(decl) = 1;
4326 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4328 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4329 to make sure the variable is not optimized away. */
4330 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4332 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4334 /* Ensure that we do not have size=0 for zero-sized arrays. */
4335 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4336 fold_convert (size_type_node, size),
4337 build_int_cst (size_type_node, 1));
4339 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4341 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4342 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4343 fold_convert (size_type_node, tmp), size);
4346 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4347 token = gfc_build_addr_expr (ppvoid_type_node,
4348 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4350 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4351 build_int_cst (integer_type_node,
4352 GFC_CAF_COARRAY_STATIC), /* type. */
4353 token, null_pointer_node, /* token, stat. */
4354 null_pointer_node, /* errgmsg, errmsg_len. */
4355 build_int_cst (integer_type_node, 0));
4357 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4360 /* Handle "static" initializer. */
4363 sym->attr.pointer = 1;
4364 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4366 sym->attr.pointer = 0;
4367 gfc_add_expr_to_block (&caf_init_block, tmp);
4372 /* Generate constructor function to initialize static, nonallocatable
4376 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4378 tree fndecl, tmp, decl, save_fn_decl;
4380 save_fn_decl = current_function_decl;
4381 push_function_context ();
4383 tmp = build_function_type_list (void_type_node, NULL_TREE);
4384 fndecl = build_decl (input_location, FUNCTION_DECL,
4385 create_tmp_var_name ("_caf_init"), tmp);
4387 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4388 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4390 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4391 DECL_ARTIFICIAL (decl) = 1;
4392 DECL_IGNORED_P (decl) = 1;
4393 DECL_CONTEXT (decl) = fndecl;
4394 DECL_RESULT (fndecl) = decl;
4397 current_function_decl = fndecl;
4398 announce_function (fndecl);
4400 rest_of_decl_compilation (fndecl, 0, 0);
4401 make_decl_rtl (fndecl);
4402 init_function_start (fndecl);
4405 gfc_init_block (&caf_init_block);
4407 gfc_traverse_ns (ns, generate_coarray_sym_init);
4409 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4413 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4415 DECL_SAVED_TREE (fndecl)
4416 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4417 DECL_INITIAL (fndecl));
4418 dump_function (TDI_original, fndecl);
4420 cfun->function_end_locus = input_location;
4423 if (decl_function_context (fndecl))
4424 (void) cgraph_create_node (fndecl);
4426 cgraph_finalize_function (fndecl, true);
4428 pop_function_context ();
4429 current_function_decl = save_fn_decl;
4433 /* Generate all the required code for module variables. */
4436 gfc_generate_module_vars (gfc_namespace * ns)
4438 module_namespace = ns;
4439 cur_module = gfc_find_module (ns->proc_name->name);
4441 /* Check if the frontend left the namespace in a reasonable state. */
4442 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4444 /* Generate COMMON blocks. */
4445 gfc_trans_common (ns);
4447 has_coarray_vars = false;
4449 /* Create decls for all the module variables. */
4450 gfc_traverse_ns (ns, gfc_create_module_variable);
4452 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4453 generate_coarray_init (ns);
4457 gfc_trans_use_stmts (ns);
4458 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4463 gfc_generate_contained_functions (gfc_namespace * parent)
4467 /* We create all the prototypes before generating any code. */
4468 for (ns = parent->contained; ns; ns = ns->sibling)
4470 /* Skip namespaces from used modules. */
4471 if (ns->parent != parent)
4474 gfc_create_function_decl (ns, false);
4477 for (ns = parent->contained; ns; ns = ns->sibling)
4479 /* Skip namespaces from used modules. */
4480 if (ns->parent != parent)
4483 gfc_generate_function_code (ns);
4488 /* Drill down through expressions for the array specification bounds and
4489 character length calling generate_local_decl for all those variables
4490 that have not already been declared. */
4493 generate_local_decl (gfc_symbol *);
4495 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4498 expr_decls (gfc_expr *e, gfc_symbol *sym,
4499 int *f ATTRIBUTE_UNUSED)
4501 if (e->expr_type != EXPR_VARIABLE
4502 || sym == e->symtree->n.sym
4503 || e->symtree->n.sym->mark
4504 || e->symtree->n.sym->ns != sym->ns)
4507 generate_local_decl (e->symtree->n.sym);
4512 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4514 gfc_traverse_expr (e, sym, expr_decls, 0);
4518 /* Check for dependencies in the character length and array spec. */
4521 generate_dependency_declarations (gfc_symbol *sym)
4525 if (sym->ts.type == BT_CHARACTER
4527 && sym->ts.u.cl->length
4528 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4529 generate_expr_decls (sym, sym->ts.u.cl->length);
4531 if (sym->as && sym->as->rank)
4533 for (i = 0; i < sym->as->rank; i++)
4535 generate_expr_decls (sym, sym->as->lower[i]);
4536 generate_expr_decls (sym, sym->as->upper[i]);
4542 /* Generate decls for all local variables. We do this to ensure correct
4543 handling of expressions which only appear in the specification of
4547 generate_local_decl (gfc_symbol * sym)
4549 if (sym->attr.flavor == FL_VARIABLE)
4551 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4552 && sym->attr.referenced && !sym->attr.use_assoc)
4553 has_coarray_vars = true;
4555 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4556 generate_dependency_declarations (sym);
4558 if (sym->attr.referenced)
4559 gfc_get_symbol_decl (sym);
4561 /* Warnings for unused dummy arguments. */
4562 else if (sym->attr.dummy)
4564 /* INTENT(out) dummy arguments are likely meant to be set. */
4565 if (gfc_option.warn_unused_dummy_argument
4566 && sym->attr.intent == INTENT_OUT)
4568 if (sym->ts.type != BT_DERIVED)
4569 gfc_warning ("Dummy argument '%s' at %L was declared "
4570 "INTENT(OUT) but was not set", sym->name,
4572 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4573 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4574 "declared INTENT(OUT) but was not set and "
4575 "does not have a default initializer",
4576 sym->name, &sym->declared_at);
4577 if (sym->backend_decl != NULL_TREE)
4578 TREE_NO_WARNING(sym->backend_decl) = 1;
4580 else if (gfc_option.warn_unused_dummy_argument)
4582 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4584 if (sym->backend_decl != NULL_TREE)
4585 TREE_NO_WARNING(sym->backend_decl) = 1;
4589 /* Warn for unused variables, but not if they're inside a common
4590 block, a namelist, or are use-associated. */
4591 else if (warn_unused_variable
4592 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4593 || sym->attr.in_namelist))
4595 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4597 if (sym->backend_decl != NULL_TREE)
4598 TREE_NO_WARNING(sym->backend_decl) = 1;
4600 else if (warn_unused_variable && sym->attr.use_only)
4602 gfc_warning ("Unused module variable '%s' which has been explicitly "
4603 "imported at %L", sym->name, &sym->declared_at);
4604 if (sym->backend_decl != NULL_TREE)
4605 TREE_NO_WARNING(sym->backend_decl) = 1;
4608 /* For variable length CHARACTER parameters, the PARM_DECL already
4609 references the length variable, so force gfc_get_symbol_decl
4610 even when not referenced. If optimize > 0, it will be optimized
4611 away anyway. But do this only after emitting -Wunused-parameter
4612 warning if requested. */
4613 if (sym->attr.dummy && !sym->attr.referenced
4614 && sym->ts.type == BT_CHARACTER
4615 && sym->ts.u.cl->backend_decl != NULL
4616 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4618 sym->attr.referenced = 1;
4619 gfc_get_symbol_decl (sym);
4622 /* INTENT(out) dummy arguments and result variables with allocatable
4623 components are reset by default and need to be set referenced to
4624 generate the code for nullification and automatic lengths. */
4625 if (!sym->attr.referenced
4626 && sym->ts.type == BT_DERIVED
4627 && sym->ts.u.derived->attr.alloc_comp
4628 && !sym->attr.pointer
4629 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4631 (sym->attr.result && sym != sym->result)))
4633 sym->attr.referenced = 1;
4634 gfc_get_symbol_decl (sym);
4637 /* Check for dependencies in the array specification and string
4638 length, adding the necessary declarations to the function. We
4639 mark the symbol now, as well as in traverse_ns, to prevent
4640 getting stuck in a circular dependency. */
4643 else if (sym->attr.flavor == FL_PARAMETER)
4645 if (warn_unused_parameter
4646 && !sym->attr.referenced)
4648 if (!sym->attr.use_assoc)
4649 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4651 else if (sym->attr.use_only)
4652 gfc_warning ("Unused parameter '%s' which has been explicitly "
4653 "imported at %L", sym->name, &sym->declared_at);
4656 else if (sym->attr.flavor == FL_PROCEDURE)
4658 /* TODO: move to the appropriate place in resolve.c. */
4659 if (warn_return_type
4660 && sym->attr.function
4662 && sym != sym->result
4663 && !sym->result->attr.referenced
4664 && !sym->attr.use_assoc
4665 && sym->attr.if_source != IFSRC_IFBODY)
4667 gfc_warning ("Return value '%s' of function '%s' declared at "
4668 "%L not set", sym->result->name, sym->name,
4669 &sym->result->declared_at);
4671 /* Prevents "Unused variable" warning for RESULT variables. */
4672 sym->result->mark = 1;
4676 if (sym->attr.dummy == 1)
4678 /* Modify the tree type for scalar character dummy arguments of bind(c)
4679 procedures if they are passed by value. The tree type for them will
4680 be promoted to INTEGER_TYPE for the middle end, which appears to be
4681 what C would do with characters passed by-value. The value attribute
4682 implies the dummy is a scalar. */
4683 if (sym->attr.value == 1 && sym->backend_decl != NULL
4684 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4685 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4686 gfc_conv_scalar_char_value (sym, NULL, NULL);
4689 /* Make sure we convert the types of the derived types from iso_c_binding
4691 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4692 && sym->ts.type == BT_DERIVED)
4693 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4697 generate_local_vars (gfc_namespace * ns)
4699 gfc_traverse_ns (ns, generate_local_decl);
4703 /* Generate a switch statement to jump to the correct entry point. Also
4704 creates the label decls for the entry points. */
4707 gfc_trans_entry_master_switch (gfc_entry_list * el)
4714 gfc_init_block (&block);
4715 for (; el; el = el->next)
4717 /* Add the case label. */
4718 label = gfc_build_label_decl (NULL_TREE);
4719 val = build_int_cst (gfc_array_index_type, el->id);
4720 tmp = build_case_label (val, NULL_TREE, label);
4721 gfc_add_expr_to_block (&block, tmp);
4723 /* And jump to the actual entry point. */
4724 label = gfc_build_label_decl (NULL_TREE);
4725 tmp = build1_v (GOTO_EXPR, label);
4726 gfc_add_expr_to_block (&block, tmp);
4728 /* Save the label decl. */
4731 tmp = gfc_finish_block (&block);
4732 /* The first argument selects the entry point. */
4733 val = DECL_ARGUMENTS (current_function_decl);
4734 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4739 /* Add code to string lengths of actual arguments passed to a function against
4740 the expected lengths of the dummy arguments. */
4743 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4745 gfc_formal_arglist *formal;
4747 for (formal = sym->formal; formal; formal = formal->next)
4748 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
4749 && !formal->sym->ts.deferred)
4751 enum tree_code comparison;
4756 const char *message;
4762 gcc_assert (cl->passed_length != NULL_TREE);
4763 gcc_assert (cl->backend_decl != NULL_TREE);
4765 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4766 string lengths must match exactly. Otherwise, it is only required
4767 that the actual string length is *at least* the expected one.
4768 Sequence association allows for a mismatch of the string length
4769 if the actual argument is (part of) an array, but only if the
4770 dummy argument is an array. (See "Sequence association" in
4771 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4772 if (fsym->attr.pointer || fsym->attr.allocatable
4773 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4775 comparison = NE_EXPR;
4776 message = _("Actual string length does not match the declared one"
4777 " for dummy argument '%s' (%ld/%ld)");
4779 else if (fsym->as && fsym->as->rank != 0)
4783 comparison = LT_EXPR;
4784 message = _("Actual string length is shorter than the declared one"
4785 " for dummy argument '%s' (%ld/%ld)");
4788 /* Build the condition. For optional arguments, an actual length
4789 of 0 is also acceptable if the associated string is NULL, which
4790 means the argument was not passed. */
4791 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4792 cl->passed_length, cl->backend_decl);
4793 if (fsym->attr.optional)
4799 not_0length = fold_build2_loc (input_location, NE_EXPR,
4802 build_zero_cst (gfc_charlen_type_node));
4803 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4804 fsym->attr.referenced = 1;
4805 not_absent = gfc_conv_expr_present (fsym);
4807 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4808 boolean_type_node, not_0length,
4811 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4812 boolean_type_node, cond, absent_failed);
4815 /* Build the runtime check. */
4816 argname = gfc_build_cstring_const (fsym->name);
4817 argname = gfc_build_addr_expr (pchar_type_node, argname);
4818 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4820 fold_convert (long_integer_type_node,
4822 fold_convert (long_integer_type_node,
4828 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4829 global variables for -fcoarray=lib. They are placed into the translation
4830 unit of the main program. Make sure that in one TU (the one of the main
4831 program), the first call to gfc_init_coarray_decl is done with true.
4832 Otherwise, expect link errors. */
4835 gfc_init_coarray_decl (bool main_tu)
4839 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4842 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4845 save_fn_decl = current_function_decl;
4846 current_function_decl = NULL_TREE;
4849 gfort_gvar_caf_this_image
4850 = build_decl (input_location, VAR_DECL,
4851 get_identifier (PREFIX("caf_this_image")),
4853 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4854 TREE_USED (gfort_gvar_caf_this_image) = 1;
4855 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4856 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4859 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4861 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4863 pushdecl_top_level (gfort_gvar_caf_this_image);
4865 gfort_gvar_caf_num_images
4866 = build_decl (input_location, VAR_DECL,
4867 get_identifier (PREFIX("caf_num_images")),
4869 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4870 TREE_USED (gfort_gvar_caf_num_images) = 1;
4871 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4872 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4875 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4877 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4879 pushdecl_top_level (gfort_gvar_caf_num_images);
4882 current_function_decl = save_fn_decl;
4887 create_main_function (tree fndecl)
4891 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4894 old_context = current_function_decl;
4898 push_function_context ();
4899 saved_parent_function_decls = saved_function_decls;
4900 saved_function_decls = NULL_TREE;
4903 /* main() function must be declared with global scope. */
4904 gcc_assert (current_function_decl == NULL_TREE);
4906 /* Declare the function. */
4907 tmp = build_function_type_list (integer_type_node, integer_type_node,
4908 build_pointer_type (pchar_type_node),
4910 main_identifier_node = get_identifier ("main");
4911 ftn_main = build_decl (input_location, FUNCTION_DECL,
4912 main_identifier_node, tmp);
4913 DECL_EXTERNAL (ftn_main) = 0;
4914 TREE_PUBLIC (ftn_main) = 1;
4915 TREE_STATIC (ftn_main) = 1;
4916 DECL_ATTRIBUTES (ftn_main)
4917 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4919 /* Setup the result declaration (for "return 0"). */
4920 result_decl = build_decl (input_location,
4921 RESULT_DECL, NULL_TREE, integer_type_node);
4922 DECL_ARTIFICIAL (result_decl) = 1;
4923 DECL_IGNORED_P (result_decl) = 1;
4924 DECL_CONTEXT (result_decl) = ftn_main;
4925 DECL_RESULT (ftn_main) = result_decl;
4927 pushdecl (ftn_main);
4929 /* Get the arguments. */
4931 arglist = NULL_TREE;
4932 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4934 tmp = TREE_VALUE (typelist);
4935 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4936 DECL_CONTEXT (argc) = ftn_main;
4937 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4938 TREE_READONLY (argc) = 1;
4939 gfc_finish_decl (argc);
4940 arglist = chainon (arglist, argc);
4942 typelist = TREE_CHAIN (typelist);
4943 tmp = TREE_VALUE (typelist);
4944 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4945 DECL_CONTEXT (argv) = ftn_main;
4946 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4947 TREE_READONLY (argv) = 1;
4948 DECL_BY_REFERENCE (argv) = 1;
4949 gfc_finish_decl (argv);
4950 arglist = chainon (arglist, argv);
4952 DECL_ARGUMENTS (ftn_main) = arglist;
4953 current_function_decl = ftn_main;
4954 announce_function (ftn_main);
4956 rest_of_decl_compilation (ftn_main, 1, 0);
4957 make_decl_rtl (ftn_main);
4958 init_function_start (ftn_main);
4961 gfc_init_block (&body);
4963 /* Call some libgfortran initialization routines, call then MAIN__(). */
4965 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4966 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4968 tree pint_type, pppchar_type;
4969 pint_type = build_pointer_type (integer_type_node);
4971 = build_pointer_type (build_pointer_type (pchar_type_node));
4973 gfc_init_coarray_decl (true);
4974 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4975 gfc_build_addr_expr (pint_type, argc),
4976 gfc_build_addr_expr (pppchar_type, argv),
4977 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4978 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4979 gfc_add_expr_to_block (&body, tmp);
4982 /* Call _gfortran_set_args (argc, argv). */
4983 TREE_USED (argc) = 1;
4984 TREE_USED (argv) = 1;
4985 tmp = build_call_expr_loc (input_location,
4986 gfor_fndecl_set_args, 2, argc, argv);
4987 gfc_add_expr_to_block (&body, tmp);
4989 /* Add a call to set_options to set up the runtime library Fortran
4990 language standard parameters. */
4992 tree array_type, array, var;
4993 VEC(constructor_elt,gc) *v = NULL;
4995 /* Passing a new option to the library requires four modifications:
4996 + add it to the tree_cons list below
4997 + change the array size in the call to build_array_type
4998 + change the first argument to the library call
4999 gfor_fndecl_set_options
5000 + modify the library (runtime/compile_options.c)! */
5002 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5003 build_int_cst (integer_type_node,
5004 gfc_option.warn_std));
5005 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5006 build_int_cst (integer_type_node,
5007 gfc_option.allow_std));
5008 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5009 build_int_cst (integer_type_node, pedantic));
5010 /* TODO: This is the old -fdump-core option, which is unused but
5011 passed due to ABI compatibility; remove when bumping the
5013 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5014 build_int_cst (integer_type_node,
5016 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5017 build_int_cst (integer_type_node,
5018 gfc_option.flag_backtrace));
5019 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5020 build_int_cst (integer_type_node,
5021 gfc_option.flag_sign_zero));
5022 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5023 build_int_cst (integer_type_node,
5025 & GFC_RTCHECK_BOUNDS)));
5026 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5027 build_int_cst (integer_type_node,
5028 gfc_option.flag_range_check));
5030 array_type = build_array_type (integer_type_node,
5031 build_index_type (size_int (7)));
5032 array = build_constructor (array_type, v);
5033 TREE_CONSTANT (array) = 1;
5034 TREE_STATIC (array) = 1;
5036 /* Create a static variable to hold the jump table. */
5037 var = gfc_create_var (array_type, "options");
5038 TREE_CONSTANT (var) = 1;
5039 TREE_STATIC (var) = 1;
5040 TREE_READONLY (var) = 1;
5041 DECL_INITIAL (var) = array;
5042 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5044 tmp = build_call_expr_loc (input_location,
5045 gfor_fndecl_set_options, 2,
5046 build_int_cst (integer_type_node, 8), var);
5047 gfc_add_expr_to_block (&body, tmp);
5050 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5051 the library will raise a FPE when needed. */
5052 if (gfc_option.fpe != 0)
5054 tmp = build_call_expr_loc (input_location,
5055 gfor_fndecl_set_fpe, 1,
5056 build_int_cst (integer_type_node,
5058 gfc_add_expr_to_block (&body, tmp);
5061 /* If this is the main program and an -fconvert option was provided,
5062 add a call to set_convert. */
5064 if (gfc_option.convert != GFC_CONVERT_NATIVE)
5066 tmp = build_call_expr_loc (input_location,
5067 gfor_fndecl_set_convert, 1,
5068 build_int_cst (integer_type_node,
5069 gfc_option.convert));
5070 gfc_add_expr_to_block (&body, tmp);
5073 /* If this is the main program and an -frecord-marker option was provided,
5074 add a call to set_record_marker. */
5076 if (gfc_option.record_marker != 0)
5078 tmp = build_call_expr_loc (input_location,
5079 gfor_fndecl_set_record_marker, 1,
5080 build_int_cst (integer_type_node,
5081 gfc_option.record_marker));
5082 gfc_add_expr_to_block (&body, tmp);
5085 if (gfc_option.max_subrecord_length != 0)
5087 tmp = build_call_expr_loc (input_location,
5088 gfor_fndecl_set_max_subrecord_length, 1,
5089 build_int_cst (integer_type_node,
5090 gfc_option.max_subrecord_length));
5091 gfc_add_expr_to_block (&body, tmp);
5094 /* Call MAIN__(). */
5095 tmp = build_call_expr_loc (input_location,
5097 gfc_add_expr_to_block (&body, tmp);
5099 /* Mark MAIN__ as used. */
5100 TREE_USED (fndecl) = 1;
5102 /* Coarray: Call _gfortran_caf_finalize(void). */
5103 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5105 /* Per F2008, 8.5.1 END of the main program implies a
5107 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5108 tmp = build_call_expr_loc (input_location, tmp, 0);
5109 gfc_add_expr_to_block (&body, tmp);
5111 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5112 gfc_add_expr_to_block (&body, tmp);
5116 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5117 DECL_RESULT (ftn_main),
5118 build_int_cst (integer_type_node, 0));
5119 tmp = build1_v (RETURN_EXPR, tmp);
5120 gfc_add_expr_to_block (&body, tmp);
5123 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5126 /* Finish off this function and send it for code generation. */
5128 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5130 DECL_SAVED_TREE (ftn_main)
5131 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5132 DECL_INITIAL (ftn_main));
5134 /* Output the GENERIC tree. */
5135 dump_function (TDI_original, ftn_main);
5137 cgraph_finalize_function (ftn_main, true);
5141 pop_function_context ();
5142 saved_function_decls = saved_parent_function_decls;
5144 current_function_decl = old_context;
5148 /* Get the result expression for a procedure. */
5151 get_proc_result (gfc_symbol* sym)
5153 if (sym->attr.subroutine || sym == sym->result)
5155 if (current_fake_result_decl != NULL)
5156 return TREE_VALUE (current_fake_result_decl);
5161 return sym->result->backend_decl;
5165 /* Generate an appropriate return-statement for a procedure. */
5168 gfc_generate_return (void)
5174 sym = current_procedure_symbol;
5175 fndecl = sym->backend_decl;
5177 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5181 result = get_proc_result (sym);
5183 /* Set the return value to the dummy result variable. The
5184 types may be different for scalar default REAL functions
5185 with -ff2c, therefore we have to convert. */
5186 if (result != NULL_TREE)
5188 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5189 result = fold_build2_loc (input_location, MODIFY_EXPR,
5190 TREE_TYPE (result), DECL_RESULT (fndecl),
5195 return build1_v (RETURN_EXPR, result);
5199 /* Generate code for a function. */
5202 gfc_generate_function_code (gfc_namespace * ns)
5208 stmtblock_t init, cleanup;
5210 gfc_wrapped_block try_block;
5211 tree recurcheckvar = NULL_TREE;
5213 gfc_symbol *previous_procedure_symbol;
5217 sym = ns->proc_name;
5218 previous_procedure_symbol = current_procedure_symbol;
5219 current_procedure_symbol = sym;
5221 /* Check that the frontend isn't still using this. */
5222 gcc_assert (sym->tlink == NULL);
5225 /* Create the declaration for functions with global scope. */
5226 if (!sym->backend_decl)
5227 gfc_create_function_decl (ns, false);
5229 fndecl = sym->backend_decl;
5230 old_context = current_function_decl;
5234 push_function_context ();
5235 saved_parent_function_decls = saved_function_decls;
5236 saved_function_decls = NULL_TREE;
5239 trans_function_start (sym);
5241 gfc_init_block (&init);
5243 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5245 /* Copy length backend_decls to all entry point result
5250 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5251 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5252 for (el = ns->entries; el; el = el->next)
5253 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5256 /* Translate COMMON blocks. */
5257 gfc_trans_common (ns);
5259 /* Null the parent fake result declaration if this namespace is
5260 a module function or an external procedures. */
5261 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5262 || ns->parent == NULL)
5263 parent_fake_result_decl = NULL_TREE;
5265 gfc_generate_contained_functions (ns);
5267 nonlocal_dummy_decls = NULL;
5268 nonlocal_dummy_decl_pset = NULL;
5270 has_coarray_vars = false;
5271 generate_local_vars (ns);
5273 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5274 generate_coarray_init (ns);
5276 /* Keep the parent fake result declaration in module functions
5277 or external procedures. */
5278 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5279 || ns->parent == NULL)
5280 current_fake_result_decl = parent_fake_result_decl;
5282 current_fake_result_decl = NULL_TREE;
5284 is_recursive = sym->attr.recursive
5285 || (sym->attr.entry_master
5286 && sym->ns->entries->sym->attr.recursive);
5287 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5289 && !gfc_option.flag_recursive)
5293 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5295 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5296 TREE_STATIC (recurcheckvar) = 1;
5297 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5298 gfc_add_expr_to_block (&init, recurcheckvar);
5299 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5300 &sym->declared_at, msg);
5301 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5305 /* Now generate the code for the body of this function. */
5306 gfc_init_block (&body);
5308 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5309 && sym->attr.subroutine)
5311 tree alternate_return;
5312 alternate_return = gfc_get_fake_result_decl (sym, 0);
5313 gfc_add_modify (&body, alternate_return, integer_zero_node);
5318 /* Jump to the correct entry point. */
5319 tmp = gfc_trans_entry_master_switch (ns->entries);
5320 gfc_add_expr_to_block (&body, tmp);
5323 /* If bounds-checking is enabled, generate code to check passed in actual
5324 arguments against the expected dummy argument attributes (e.g. string
5326 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5327 add_argument_checking (&body, sym);
5329 tmp = gfc_trans_code (ns->code);
5330 gfc_add_expr_to_block (&body, tmp);
5332 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5334 tree result = get_proc_result (sym);
5336 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5338 if (sym->attr.allocatable && sym->attr.dimension == 0
5339 && sym->result == sym)
5340 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5341 null_pointer_node));
5342 else if (sym->ts.type == BT_CLASS
5343 && CLASS_DATA (sym)->attr.allocatable
5344 && CLASS_DATA (sym)->attr.dimension == 0
5345 && sym->result == sym)
5347 tmp = CLASS_DATA (sym)->backend_decl;
5348 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5349 TREE_TYPE (tmp), result, tmp, NULL_TREE);
5350 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5351 null_pointer_node));
5353 else if (sym->ts.type == BT_DERIVED
5354 && sym->ts.u.derived->attr.alloc_comp
5355 && !sym->attr.allocatable)
5357 rank = sym->as ? sym->as->rank : 0;
5358 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5359 gfc_add_expr_to_block (&init, tmp);
5363 if (result == NULL_TREE)
5365 /* TODO: move to the appropriate place in resolve.c. */
5366 if (warn_return_type && sym == sym->result)
5367 gfc_warning ("Return value of function '%s' at %L not set",
5368 sym->name, &sym->declared_at);
5369 if (warn_return_type)
5370 TREE_NO_WARNING(sym->backend_decl) = 1;
5373 gfc_add_expr_to_block (&body, gfc_generate_return ());
5376 gfc_init_block (&cleanup);
5378 /* Reset recursion-check variable. */
5379 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5381 && !gfc_option.gfc_flag_openmp
5382 && recurcheckvar != NULL_TREE)
5384 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5385 recurcheckvar = NULL;
5388 /* Finish the function body and add init and cleanup code. */
5389 tmp = gfc_finish_block (&body);
5390 gfc_start_wrapped_block (&try_block, tmp);
5391 /* Add code to create and cleanup arrays. */
5392 gfc_trans_deferred_vars (sym, &try_block);
5393 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5394 gfc_finish_block (&cleanup));
5396 /* Add all the decls we created during processing. */
5397 decl = saved_function_decls;
5402 next = DECL_CHAIN (decl);
5403 DECL_CHAIN (decl) = NULL_TREE;
5404 if (GFC_DECL_PUSH_TOPLEVEL (decl))
5405 pushdecl_top_level (decl);
5410 saved_function_decls = NULL_TREE;
5412 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5415 /* Finish off this function and send it for code generation. */
5417 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5419 DECL_SAVED_TREE (fndecl)
5420 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5421 DECL_INITIAL (fndecl));
5423 if (nonlocal_dummy_decls)
5425 BLOCK_VARS (DECL_INITIAL (fndecl))
5426 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5427 pointer_set_destroy (nonlocal_dummy_decl_pset);
5428 nonlocal_dummy_decls = NULL;
5429 nonlocal_dummy_decl_pset = NULL;
5432 /* Output the GENERIC tree. */
5433 dump_function (TDI_original, fndecl);
5435 /* Store the end of the function, so that we get good line number
5436 info for the epilogue. */
5437 cfun->function_end_locus = input_location;
5439 /* We're leaving the context of this function, so zap cfun.
5440 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5441 tree_rest_of_compilation. */
5446 pop_function_context ();
5447 saved_function_decls = saved_parent_function_decls;
5449 current_function_decl = old_context;
5451 if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
5452 && has_coarray_vars)
5453 /* Register this function with cgraph just far enough to get it
5454 added to our parent's nested function list.
5455 If there are static coarrays in this function, the nested _caf_init
5456 function has already called cgraph_create_node, which also created
5457 the cgraph node for this function. */
5458 (void) cgraph_create_node (fndecl);
5460 cgraph_finalize_function (fndecl, true);
5462 gfc_trans_use_stmts (ns);
5463 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5465 if (sym->attr.is_main_program)
5466 create_main_function (fndecl);
5468 current_procedure_symbol = previous_procedure_symbol;
5473 gfc_generate_constructors (void)
5475 gcc_assert (gfc_static_ctors == NULL_TREE);
5483 if (gfc_static_ctors == NULL_TREE)
5486 fnname = get_file_function_name ("I");
5487 type = build_function_type_list (void_type_node, NULL_TREE);
5489 fndecl = build_decl (input_location,
5490 FUNCTION_DECL, fnname, type);
5491 TREE_PUBLIC (fndecl) = 1;
5493 decl = build_decl (input_location,
5494 RESULT_DECL, NULL_TREE, void_type_node);
5495 DECL_ARTIFICIAL (decl) = 1;
5496 DECL_IGNORED_P (decl) = 1;
5497 DECL_CONTEXT (decl) = fndecl;
5498 DECL_RESULT (fndecl) = decl;
5502 current_function_decl = fndecl;
5504 rest_of_decl_compilation (fndecl, 1, 0);
5506 make_decl_rtl (fndecl);
5508 init_function_start (fndecl);
5512 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5514 tmp = build_call_expr_loc (input_location,
5515 TREE_VALUE (gfc_static_ctors), 0);
5516 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5522 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5523 DECL_SAVED_TREE (fndecl)
5524 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5525 DECL_INITIAL (fndecl));
5527 free_after_parsing (cfun);
5528 free_after_compilation (cfun);
5530 tree_rest_of_compilation (fndecl);
5532 current_function_decl = NULL_TREE;
5536 /* Translates a BLOCK DATA program unit. This means emitting the
5537 commons contained therein plus their initializations. We also emit
5538 a globally visible symbol to make sure that each BLOCK DATA program
5539 unit remains unique. */
5542 gfc_generate_block_data (gfc_namespace * ns)
5547 /* Tell the backend the source location of the block data. */
5549 gfc_set_backend_locus (&ns->proc_name->declared_at);
5551 gfc_set_backend_locus (&gfc_current_locus);
5553 /* Process the DATA statements. */
5554 gfc_trans_common (ns);
5556 /* Create a global symbol with the mane of the block data. This is to
5557 generate linker errors if the same name is used twice. It is never
5560 id = gfc_sym_mangled_function_id (ns->proc_name);
5562 id = get_identifier ("__BLOCK_DATA__");
5564 decl = build_decl (input_location,
5565 VAR_DECL, id, gfc_array_index_type);
5566 TREE_PUBLIC (decl) = 1;
5567 TREE_STATIC (decl) = 1;
5568 DECL_IGNORED_P (decl) = 1;
5571 rest_of_decl_compilation (decl, 1, 0);
5575 /* Process the local variables of a BLOCK construct. */
5578 gfc_process_block_locals (gfc_namespace* ns)
5582 gcc_assert (saved_local_decls == NULL_TREE);
5583 has_coarray_vars = false;
5585 generate_local_vars (ns);
5587 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5588 generate_coarray_init (ns);
5590 decl = saved_local_decls;
5595 next = DECL_CHAIN (decl);
5596 DECL_CHAIN (decl) = NULL_TREE;
5600 saved_local_decls = NULL_TREE;
5604 #include "gt-fortran-trans-decl.h"