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_critical;
125 tree gfor_fndecl_caf_end_critical;
126 tree gfor_fndecl_caf_sync_all;
127 tree gfor_fndecl_caf_sync_images;
128 tree gfor_fndecl_caf_error_stop;
129 tree gfor_fndecl_caf_error_stop_str;
131 /* Coarray global variables for num_images/this_image. */
133 tree gfort_gvar_caf_num_images;
134 tree gfort_gvar_caf_this_image;
137 /* Math functions. Many other math functions are handled in
138 trans-intrinsic.c. */
140 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
141 tree gfor_fndecl_math_ishftc4;
142 tree gfor_fndecl_math_ishftc8;
143 tree gfor_fndecl_math_ishftc16;
146 /* String functions. */
148 tree gfor_fndecl_compare_string;
149 tree gfor_fndecl_concat_string;
150 tree gfor_fndecl_string_len_trim;
151 tree gfor_fndecl_string_index;
152 tree gfor_fndecl_string_scan;
153 tree gfor_fndecl_string_verify;
154 tree gfor_fndecl_string_trim;
155 tree gfor_fndecl_string_minmax;
156 tree gfor_fndecl_adjustl;
157 tree gfor_fndecl_adjustr;
158 tree gfor_fndecl_select_string;
159 tree gfor_fndecl_compare_string_char4;
160 tree gfor_fndecl_concat_string_char4;
161 tree gfor_fndecl_string_len_trim_char4;
162 tree gfor_fndecl_string_index_char4;
163 tree gfor_fndecl_string_scan_char4;
164 tree gfor_fndecl_string_verify_char4;
165 tree gfor_fndecl_string_trim_char4;
166 tree gfor_fndecl_string_minmax_char4;
167 tree gfor_fndecl_adjustl_char4;
168 tree gfor_fndecl_adjustr_char4;
169 tree gfor_fndecl_select_string_char4;
172 /* Conversion between character kinds. */
173 tree gfor_fndecl_convert_char1_to_char4;
174 tree gfor_fndecl_convert_char4_to_char1;
177 /* Other misc. runtime library functions. */
178 tree gfor_fndecl_size0;
179 tree gfor_fndecl_size1;
180 tree gfor_fndecl_iargc;
182 /* Intrinsic functions implemented in Fortran. */
183 tree gfor_fndecl_sc_kind;
184 tree gfor_fndecl_si_kind;
185 tree gfor_fndecl_sr_kind;
187 /* BLAS gemm functions. */
188 tree gfor_fndecl_sgemm;
189 tree gfor_fndecl_dgemm;
190 tree gfor_fndecl_cgemm;
191 tree gfor_fndecl_zgemm;
195 gfc_add_decl_to_parent_function (tree decl)
198 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
199 DECL_NONLOCAL (decl) = 1;
200 DECL_CHAIN (decl) = saved_parent_function_decls;
201 saved_parent_function_decls = decl;
205 gfc_add_decl_to_function (tree decl)
208 TREE_USED (decl) = 1;
209 DECL_CONTEXT (decl) = current_function_decl;
210 DECL_CHAIN (decl) = saved_function_decls;
211 saved_function_decls = decl;
215 add_decl_as_local (tree decl)
218 TREE_USED (decl) = 1;
219 DECL_CONTEXT (decl) = current_function_decl;
220 DECL_CHAIN (decl) = saved_local_decls;
221 saved_local_decls = decl;
225 /* Build a backend label declaration. Set TREE_USED for named labels.
226 The context of the label is always the current_function_decl. All
227 labels are marked artificial. */
230 gfc_build_label_decl (tree label_id)
232 /* 2^32 temporaries should be enough. */
233 static unsigned int tmp_num = 1;
237 if (label_id == NULL_TREE)
239 /* Build an internal label name. */
240 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
241 label_id = get_identifier (label_name);
246 /* Build the LABEL_DECL node. Labels have no type. */
247 label_decl = build_decl (input_location,
248 LABEL_DECL, label_id, void_type_node);
249 DECL_CONTEXT (label_decl) = current_function_decl;
250 DECL_MODE (label_decl) = VOIDmode;
252 /* We always define the label as used, even if the original source
253 file never references the label. We don't want all kinds of
254 spurious warnings for old-style Fortran code with too many
256 TREE_USED (label_decl) = 1;
258 DECL_ARTIFICIAL (label_decl) = 1;
263 /* Set the backend source location of a decl. */
266 gfc_set_decl_location (tree decl, locus * loc)
268 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
272 /* Return the backend label declaration for a given label structure,
273 or create it if it doesn't exist yet. */
276 gfc_get_label_decl (gfc_st_label * lp)
278 if (lp->backend_decl)
279 return lp->backend_decl;
282 char label_name[GFC_MAX_SYMBOL_LEN + 1];
285 /* Validate the label declaration from the front end. */
286 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
288 /* Build a mangled name for the label. */
289 sprintf (label_name, "__label_%.6d", lp->value);
291 /* Build the LABEL_DECL node. */
292 label_decl = gfc_build_label_decl (get_identifier (label_name));
294 /* Tell the debugger where the label came from. */
295 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
296 gfc_set_decl_location (label_decl, &lp->where);
298 DECL_ARTIFICIAL (label_decl) = 1;
300 /* Store the label in the label list and return the LABEL_DECL. */
301 lp->backend_decl = label_decl;
307 /* Convert a gfc_symbol to an identifier of the same name. */
310 gfc_sym_identifier (gfc_symbol * sym)
312 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
313 return (get_identifier ("MAIN__"));
315 return (get_identifier (sym->name));
319 /* Construct mangled name from symbol name. */
322 gfc_sym_mangled_identifier (gfc_symbol * sym)
324 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
326 /* Prevent the mangling of identifiers that have an assigned
327 binding label (mainly those that are bind(c)). */
328 if (sym->attr.is_bind_c == 1
329 && sym->binding_label[0] != '\0')
330 return get_identifier(sym->binding_label);
332 if (sym->module == NULL)
333 return gfc_sym_identifier (sym);
336 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
337 return get_identifier (name);
342 /* Construct mangled function name from symbol name. */
345 gfc_sym_mangled_function_id (gfc_symbol * sym)
348 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
350 /* It may be possible to simply use the binding label if it's
351 provided, and remove the other checks. Then we could use it
352 for other things if we wished. */
353 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
354 sym->binding_label[0] != '\0')
355 /* use the binding label rather than the mangled name */
356 return get_identifier (sym->binding_label);
358 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
359 || (sym->module != NULL && (sym->attr.external
360 || sym->attr.if_source == IFSRC_IFBODY)))
362 /* Main program is mangled into MAIN__. */
363 if (sym->attr.is_main_program)
364 return get_identifier ("MAIN__");
366 /* Intrinsic procedures are never mangled. */
367 if (sym->attr.proc == PROC_INTRINSIC)
368 return get_identifier (sym->name);
370 if (gfc_option.flag_underscoring)
372 has_underscore = strchr (sym->name, '_') != 0;
373 if (gfc_option.flag_second_underscore && has_underscore)
374 snprintf (name, sizeof name, "%s__", sym->name);
376 snprintf (name, sizeof name, "%s_", sym->name);
377 return get_identifier (name);
380 return get_identifier (sym->name);
384 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
385 return get_identifier (name);
391 gfc_set_decl_assembler_name (tree decl, tree name)
393 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
394 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
398 /* Returns true if a variable of specified size should go on the stack. */
401 gfc_can_put_var_on_stack (tree size)
403 unsigned HOST_WIDE_INT low;
405 if (!INTEGER_CST_P (size))
408 if (gfc_option.flag_max_stack_var_size < 0)
411 if (TREE_INT_CST_HIGH (size) != 0)
414 low = TREE_INT_CST_LOW (size);
415 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
418 /* TODO: Set a per-function stack size limit. */
424 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
425 an expression involving its corresponding pointer. There are
426 2 cases; one for variable size arrays, and one for everything else,
427 because variable-sized arrays require one fewer level of
431 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
433 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
436 /* Parameters need to be dereferenced. */
437 if (sym->cp_pointer->attr.dummy)
438 ptr_decl = build_fold_indirect_ref_loc (input_location,
441 /* Check to see if we're dealing with a variable-sized array. */
442 if (sym->attr.dimension
443 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
445 /* These decls will be dereferenced later, so we don't dereference
447 value = convert (TREE_TYPE (decl), ptr_decl);
451 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
453 value = build_fold_indirect_ref_loc (input_location,
457 SET_DECL_VALUE_EXPR (decl, value);
458 DECL_HAS_VALUE_EXPR_P (decl) = 1;
459 GFC_DECL_CRAY_POINTEE (decl) = 1;
460 /* This is a fake variable just for debugging purposes. */
461 TREE_ASM_WRITTEN (decl) = 1;
465 /* Finish processing of a declaration without an initial value. */
468 gfc_finish_decl (tree decl)
470 gcc_assert (TREE_CODE (decl) == PARM_DECL
471 || DECL_INITIAL (decl) == NULL_TREE);
473 if (TREE_CODE (decl) != VAR_DECL)
476 if (DECL_SIZE (decl) == NULL_TREE
477 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
478 layout_decl (decl, 0);
480 /* A few consistency checks. */
481 /* A static variable with an incomplete type is an error if it is
482 initialized. Also if it is not file scope. Otherwise, let it
483 through, but if it is not `extern' then it may cause an error
485 /* An automatic variable with an incomplete type is an error. */
487 /* We should know the storage size. */
488 gcc_assert (DECL_SIZE (decl) != NULL_TREE
489 || (TREE_STATIC (decl)
490 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
491 : DECL_EXTERNAL (decl)));
493 /* The storage size should be constant. */
494 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
496 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
500 /* Apply symbol attributes to a variable, and add it to the function scope. */
503 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
506 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
507 This is the equivalent of the TARGET variables.
508 We also need to set this if the variable is passed by reference in a
511 /* Set DECL_VALUE_EXPR for Cray Pointees. */
512 if (sym->attr.cray_pointee)
513 gfc_finish_cray_pointee (decl, sym);
515 if (sym->attr.target)
516 TREE_ADDRESSABLE (decl) = 1;
517 /* If it wasn't used we wouldn't be getting it. */
518 TREE_USED (decl) = 1;
520 /* Chain this decl to the pending declarations. Don't do pushdecl()
521 because this would add them to the current scope rather than the
523 if (current_function_decl != NULL_TREE)
525 if (sym->ns->proc_name->backend_decl == current_function_decl
526 || sym->result == sym)
527 gfc_add_decl_to_function (decl);
528 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
529 /* This is a BLOCK construct. */
530 add_decl_as_local (decl);
532 gfc_add_decl_to_parent_function (decl);
535 if (sym->attr.cray_pointee)
538 if(sym->attr.is_bind_c == 1)
540 /* We need to put variables that are bind(c) into the common
541 segment of the object file, because this is what C would do.
542 gfortran would typically put them in either the BSS or
543 initialized data segments, and only mark them as common if
544 they were part of common blocks. However, if they are not put
545 into common space, then C cannot initialize global Fortran
546 variables that it interoperates with and the draft says that
547 either Fortran or C should be able to initialize it (but not
548 both, of course.) (J3/04-007, section 15.3). */
549 TREE_PUBLIC(decl) = 1;
550 DECL_COMMON(decl) = 1;
553 /* If a variable is USE associated, it's always external. */
554 if (sym->attr.use_assoc)
556 DECL_EXTERNAL (decl) = 1;
557 TREE_PUBLIC (decl) = 1;
559 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
561 /* TODO: Don't set sym->module for result or dummy variables. */
562 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
563 /* This is the declaration of a module variable. */
564 TREE_PUBLIC (decl) = 1;
565 TREE_STATIC (decl) = 1;
568 /* Derived types are a bit peculiar because of the possibility of
569 a default initializer; this must be applied each time the variable
570 comes into scope it therefore need not be static. These variables
571 are SAVE_NONE but have an initializer. Otherwise explicitly
572 initialized variables are SAVE_IMPLICIT and explicitly saved are
574 if (!sym->attr.use_assoc
575 && (sym->attr.save != SAVE_NONE || sym->attr.data
576 || (sym->value && sym->ns->proc_name->attr.is_main_program)
577 || (gfc_option.coarray == GFC_FCOARRAY_LIB
578 && sym->attr.codimension && !sym->attr.allocatable)))
579 TREE_STATIC (decl) = 1;
581 if (sym->attr.volatile_)
583 TREE_THIS_VOLATILE (decl) = 1;
584 TREE_SIDE_EFFECTS (decl) = 1;
585 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
586 TREE_TYPE (decl) = new_type;
589 /* Keep variables larger than max-stack-var-size off stack. */
590 if (!sym->ns->proc_name->attr.recursive
591 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
592 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
593 /* Put variable length auto array pointers always into stack. */
594 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
595 || sym->attr.dimension == 0
596 || sym->as->type != AS_EXPLICIT
598 || sym->attr.allocatable)
599 && !DECL_ARTIFICIAL (decl))
600 TREE_STATIC (decl) = 1;
602 /* Handle threadprivate variables. */
603 if (sym->attr.threadprivate
604 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
605 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
607 if (!sym->attr.target
608 && !sym->attr.pointer
609 && !sym->attr.cray_pointee
610 && !sym->attr.proc_pointer)
611 DECL_RESTRICTED_P (decl) = 1;
615 /* Allocate the lang-specific part of a decl. */
618 gfc_allocate_lang_decl (tree decl)
620 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
624 /* Remember a symbol to generate initialization/cleanup code at function
628 gfc_defer_symbol_init (gfc_symbol * sym)
634 /* Don't add a symbol twice. */
638 last = head = sym->ns->proc_name;
641 /* Make sure that setup code for dummy variables which are used in the
642 setup of other variables is generated first. */
645 /* Find the first dummy arg seen after us, or the first non-dummy arg.
646 This is a circular list, so don't go past the head. */
648 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
654 /* Insert in between last and p. */
660 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
661 backend_decl for a module symbol, if it all ready exists. If the
662 module gsymbol does not exist, it is created. If the symbol does
663 not exist, it is added to the gsymbol namespace. Returns true if
664 an existing backend_decl is found. */
667 gfc_get_module_backend_decl (gfc_symbol *sym)
673 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
675 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
681 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
687 gsym = gfc_get_gsymbol (sym->module);
688 gsym->type = GSYM_MODULE;
689 gsym->ns = gfc_get_namespace (NULL, 0);
692 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
696 else if (sym->attr.flavor == FL_DERIVED)
698 if (!s->backend_decl)
699 s->backend_decl = gfc_get_derived_type (s);
700 gfc_copy_dt_decls_ifequal (s, sym, true);
703 else if (s->backend_decl)
705 if (sym->ts.type == BT_DERIVED)
706 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
708 else if (sym->ts.type == BT_CHARACTER)
709 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
710 sym->backend_decl = s->backend_decl;
718 /* Create an array index type variable with function scope. */
721 create_index_var (const char * pfx, int nest)
725 decl = gfc_create_var_np (gfc_array_index_type, pfx);
727 gfc_add_decl_to_parent_function (decl);
729 gfc_add_decl_to_function (decl);
734 /* Create variables to hold all the non-constant bits of info for a
735 descriptorless array. Remember these in the lang-specific part of the
739 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
744 gfc_namespace* procns;
746 type = TREE_TYPE (decl);
748 /* We just use the descriptor, if there is one. */
749 if (GFC_DESCRIPTOR_TYPE_P (type))
752 gcc_assert (GFC_ARRAY_TYPE_P (type));
753 procns = gfc_find_proc_namespace (sym->ns);
754 nest = (procns->proc_name->backend_decl != current_function_decl)
755 && !sym->attr.contained;
757 if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
758 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
762 token = gfc_create_var_np (pvoid_type_node, "caf_token");
763 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
764 DECL_ARTIFICIAL (token) = 1;
765 TREE_STATIC (token) = 1;
766 gfc_add_decl_to_function (token);
769 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
771 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
773 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
774 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
776 /* Don't try to use the unknown bound for assumed shape arrays. */
777 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
778 && (sym->as->type != AS_ASSUMED_SIZE
779 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
781 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
782 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
785 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
787 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
788 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
791 for (dim = GFC_TYPE_ARRAY_RANK (type);
792 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
794 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
796 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
797 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
799 /* Don't try to use the unknown ubound for the last coarray dimension. */
800 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
801 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
803 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
804 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
807 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
809 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
811 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
814 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
816 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
819 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
820 && sym->as->type != AS_ASSUMED_SIZE)
822 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
823 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
826 if (POINTER_TYPE_P (type))
828 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
829 gcc_assert (TYPE_LANG_SPECIFIC (type)
830 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
831 type = TREE_TYPE (type);
834 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
838 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
839 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
840 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
842 TYPE_DOMAIN (type) = range;
846 if (TYPE_NAME (type) != NULL_TREE
847 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
848 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
850 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
852 for (dim = 0; dim < sym->as->rank - 1; dim++)
854 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
855 gtype = TREE_TYPE (gtype);
857 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
858 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
859 TYPE_NAME (type) = NULL_TREE;
862 if (TYPE_NAME (type) == NULL_TREE)
864 tree gtype = TREE_TYPE (type), rtype, type_decl;
866 for (dim = sym->as->rank - 1; dim >= 0; dim--)
869 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
870 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
871 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
872 gtype = build_array_type (gtype, rtype);
873 /* Ensure the bound variables aren't optimized out at -O0.
874 For -O1 and above they often will be optimized out, but
875 can be tracked by VTA. Also set DECL_NAMELESS, so that
876 the artificial lbound.N or ubound.N DECL_NAME doesn't
877 end up in debug info. */
878 if (lbound && TREE_CODE (lbound) == VAR_DECL
879 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
881 if (DECL_NAME (lbound)
882 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
884 DECL_NAMELESS (lbound) = 1;
885 DECL_IGNORED_P (lbound) = 0;
887 if (ubound && TREE_CODE (ubound) == VAR_DECL
888 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
890 if (DECL_NAME (ubound)
891 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
893 DECL_NAMELESS (ubound) = 1;
894 DECL_IGNORED_P (ubound) = 0;
897 TYPE_NAME (type) = type_decl = build_decl (input_location,
898 TYPE_DECL, NULL, gtype);
899 DECL_ORIGINAL_TYPE (type_decl) = gtype;
904 /* For some dummy arguments we don't use the actual argument directly.
905 Instead we create a local decl and use that. This allows us to perform
906 initialization, and construct full type information. */
909 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
919 if (sym->attr.pointer || sym->attr.allocatable)
922 /* Add to list of variables if not a fake result variable. */
923 if (sym->attr.result || sym->attr.dummy)
924 gfc_defer_symbol_init (sym);
926 type = TREE_TYPE (dummy);
927 gcc_assert (TREE_CODE (dummy) == PARM_DECL
928 && POINTER_TYPE_P (type));
930 /* Do we know the element size? */
931 known_size = sym->ts.type != BT_CHARACTER
932 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
934 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
936 /* For descriptorless arrays with known element size the actual
937 argument is sufficient. */
938 gcc_assert (GFC_ARRAY_TYPE_P (type));
939 gfc_build_qualified_array (dummy, sym);
943 type = TREE_TYPE (type);
944 if (GFC_DESCRIPTOR_TYPE_P (type))
946 /* Create a descriptorless array pointer. */
950 /* Even when -frepack-arrays is used, symbols with TARGET attribute
952 if (!gfc_option.flag_repack_arrays || sym->attr.target)
954 if (as->type == AS_ASSUMED_SIZE)
955 packed = PACKED_FULL;
959 if (as->type == AS_EXPLICIT)
961 packed = PACKED_FULL;
962 for (n = 0; n < as->rank; n++)
966 && as->upper[n]->expr_type == EXPR_CONSTANT
967 && as->lower[n]->expr_type == EXPR_CONSTANT))
968 packed = PACKED_PARTIAL;
972 packed = PACKED_PARTIAL;
975 type = gfc_typenode_for_spec (&sym->ts);
976 type = gfc_get_nodesc_array_type (type, sym->as, packed,
981 /* We now have an expression for the element size, so create a fully
982 qualified type. Reset sym->backend decl or this will just return the
984 DECL_ARTIFICIAL (sym->backend_decl) = 1;
985 sym->backend_decl = NULL_TREE;
986 type = gfc_sym_type (sym);
987 packed = PACKED_FULL;
990 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
991 decl = build_decl (input_location,
992 VAR_DECL, get_identifier (name), type);
994 DECL_ARTIFICIAL (decl) = 1;
995 DECL_NAMELESS (decl) = 1;
996 TREE_PUBLIC (decl) = 0;
997 TREE_STATIC (decl) = 0;
998 DECL_EXTERNAL (decl) = 0;
1000 /* We should never get deferred shape arrays here. We used to because of
1002 gcc_assert (sym->as->type != AS_DEFERRED);
1004 if (packed == PACKED_PARTIAL)
1005 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1006 else if (packed == PACKED_FULL)
1007 GFC_DECL_PACKED_ARRAY (decl) = 1;
1009 gfc_build_qualified_array (decl, sym);
1011 if (DECL_LANG_SPECIFIC (dummy))
1012 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1014 gfc_allocate_lang_decl (decl);
1016 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1018 if (sym->ns->proc_name->backend_decl == current_function_decl
1019 || sym->attr.contained)
1020 gfc_add_decl_to_function (decl);
1022 gfc_add_decl_to_parent_function (decl);
1027 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1028 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1029 pointing to the artificial variable for debug info purposes. */
1032 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1036 if (! nonlocal_dummy_decl_pset)
1037 nonlocal_dummy_decl_pset = pointer_set_create ();
1039 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1042 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1043 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1044 TREE_TYPE (sym->backend_decl));
1045 DECL_ARTIFICIAL (decl) = 0;
1046 TREE_USED (decl) = 1;
1047 TREE_PUBLIC (decl) = 0;
1048 TREE_STATIC (decl) = 0;
1049 DECL_EXTERNAL (decl) = 0;
1050 if (DECL_BY_REFERENCE (dummy))
1051 DECL_BY_REFERENCE (decl) = 1;
1052 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1053 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1054 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1055 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1056 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1057 nonlocal_dummy_decls = decl;
1060 /* Return a constant or a variable to use as a string length. Does not
1061 add the decl to the current scope. */
1064 gfc_create_string_length (gfc_symbol * sym)
1066 gcc_assert (sym->ts.u.cl);
1067 gfc_conv_const_charlen (sym->ts.u.cl);
1069 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1072 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1074 /* Also prefix the mangled name. */
1075 strcpy (&name[1], sym->name);
1077 length = build_decl (input_location,
1078 VAR_DECL, get_identifier (name),
1079 gfc_charlen_type_node);
1080 DECL_ARTIFICIAL (length) = 1;
1081 TREE_USED (length) = 1;
1082 if (sym->ns->proc_name->tlink != NULL)
1083 gfc_defer_symbol_init (sym);
1085 sym->ts.u.cl->backend_decl = length;
1088 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1089 return sym->ts.u.cl->backend_decl;
1092 /* If a variable is assigned a label, we add another two auxiliary
1096 gfc_add_assign_aux_vars (gfc_symbol * sym)
1102 gcc_assert (sym->backend_decl);
1104 decl = sym->backend_decl;
1105 gfc_allocate_lang_decl (decl);
1106 GFC_DECL_ASSIGN (decl) = 1;
1107 length = build_decl (input_location,
1108 VAR_DECL, create_tmp_var_name (sym->name),
1109 gfc_charlen_type_node);
1110 addr = build_decl (input_location,
1111 VAR_DECL, create_tmp_var_name (sym->name),
1113 gfc_finish_var_decl (length, sym);
1114 gfc_finish_var_decl (addr, sym);
1115 /* STRING_LENGTH is also used as flag. Less than -1 means that
1116 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1117 target label's address. Otherwise, value is the length of a format string
1118 and ASSIGN_ADDR is its address. */
1119 if (TREE_STATIC (length))
1120 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1122 gfc_defer_symbol_init (sym);
1124 GFC_DECL_STRING_LEN (decl) = length;
1125 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1130 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1135 for (id = 0; id < EXT_ATTR_NUM; id++)
1136 if (sym_attr.ext_attr & (1 << id))
1138 attr = build_tree_list (
1139 get_identifier (ext_attr_list[id].middle_end_name),
1141 list = chainon (list, attr);
1148 static void build_function_decl (gfc_symbol * sym, bool global);
1151 /* Return the decl for a gfc_symbol, create it if it doesn't already
1155 gfc_get_symbol_decl (gfc_symbol * sym)
1158 tree length = NULL_TREE;
1161 bool intrinsic_array_parameter = false;
1163 gcc_assert (sym->attr.referenced
1164 || sym->attr.use_assoc
1165 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1166 || (sym->module && sym->attr.if_source != IFSRC_DECL
1167 && sym->backend_decl));
1169 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1170 byref = gfc_return_by_reference (sym->ns->proc_name);
1174 /* Make sure that the vtab for the declared type is completed. */
1175 if (sym->ts.type == BT_CLASS)
1177 gfc_component *c = CLASS_DATA (sym);
1178 if (!c->ts.u.derived->backend_decl)
1179 gfc_find_derived_vtab (c->ts.u.derived);
1182 /* All deferred character length procedures need to retain the backend
1183 decl, which is a pointer to the character length in the caller's
1184 namespace and to declare a local character length. */
1185 if (!byref && sym->attr.function
1186 && sym->ts.type == BT_CHARACTER
1188 && sym->ts.u.cl->passed_length == NULL
1189 && sym->ts.u.cl->backend_decl
1190 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1192 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1193 sym->ts.u.cl->backend_decl = NULL_TREE;
1194 length = gfc_create_string_length (sym);
1197 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1199 /* Return via extra parameter. */
1200 if (sym->attr.result && byref
1201 && !sym->backend_decl)
1204 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1205 /* For entry master function skip over the __entry
1207 if (sym->ns->proc_name->attr.entry_master)
1208 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1211 /* Dummy variables should already have been created. */
1212 gcc_assert (sym->backend_decl);
1214 /* Create a character length variable. */
1215 if (sym->ts.type == BT_CHARACTER)
1217 /* For a deferred dummy, make a new string length variable. */
1218 if (sym->ts.deferred
1220 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1221 sym->ts.u.cl->backend_decl = NULL_TREE;
1223 if (sym->ts.deferred && sym->attr.result
1224 && sym->ts.u.cl->passed_length == NULL
1225 && sym->ts.u.cl->backend_decl)
1227 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1228 sym->ts.u.cl->backend_decl = NULL_TREE;
1231 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1232 length = gfc_create_string_length (sym);
1234 length = sym->ts.u.cl->backend_decl;
1235 if (TREE_CODE (length) == VAR_DECL
1236 && DECL_FILE_SCOPE_P (length))
1238 /* Add the string length to the same context as the symbol. */
1239 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1240 gfc_add_decl_to_function (length);
1242 gfc_add_decl_to_parent_function (length);
1244 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1245 DECL_CONTEXT (length));
1247 gfc_defer_symbol_init (sym);
1251 /* Use a copy of the descriptor for dummy arrays. */
1252 if ((sym->attr.dimension || sym->attr.codimension)
1253 && !TREE_USED (sym->backend_decl))
1255 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1256 /* Prevent the dummy from being detected as unused if it is copied. */
1257 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1258 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1259 sym->backend_decl = decl;
1262 TREE_USED (sym->backend_decl) = 1;
1263 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1265 gfc_add_assign_aux_vars (sym);
1268 if (sym->attr.dimension
1269 && DECL_LANG_SPECIFIC (sym->backend_decl)
1270 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1271 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1272 gfc_nonlocal_dummy_array_decl (sym);
1274 return sym->backend_decl;
1277 if (sym->backend_decl)
1278 return sym->backend_decl;
1280 /* Special case for array-valued named constants from intrinsic
1281 procedures; those are inlined. */
1282 if (sym->attr.use_assoc && sym->from_intmod
1283 && sym->attr.flavor == FL_PARAMETER)
1284 intrinsic_array_parameter = true;
1286 /* If use associated and whole file compilation, use the module
1288 if (gfc_option.flag_whole_file
1289 && (sym->attr.flavor == FL_VARIABLE
1290 || sym->attr.flavor == FL_PARAMETER)
1291 && sym->attr.use_assoc
1292 && !intrinsic_array_parameter
1294 && gfc_get_module_backend_decl (sym))
1295 return sym->backend_decl;
1297 if (sym->attr.flavor == FL_PROCEDURE)
1299 /* Catch function declarations. Only used for actual parameters,
1300 procedure pointers and procptr initialization targets. */
1301 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1303 decl = gfc_get_extern_function_decl (sym);
1304 gfc_set_decl_location (decl, &sym->declared_at);
1308 if (!sym->backend_decl)
1309 build_function_decl (sym, false);
1310 decl = sym->backend_decl;
1315 if (sym->attr.intrinsic)
1316 internal_error ("intrinsic variable which isn't a procedure");
1318 /* Create string length decl first so that they can be used in the
1319 type declaration. */
1320 if (sym->ts.type == BT_CHARACTER)
1321 length = gfc_create_string_length (sym);
1323 /* Create the decl for the variable. */
1324 decl = build_decl (sym->declared_at.lb->location,
1325 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1327 /* Add attributes to variables. Functions are handled elsewhere. */
1328 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1329 decl_attributes (&decl, attributes, 0);
1331 /* Symbols from modules should have their assembler names mangled.
1332 This is done here rather than in gfc_finish_var_decl because it
1333 is different for string length variables. */
1336 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1337 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1338 DECL_IGNORED_P (decl) = 1;
1341 if (sym->attr.dimension || sym->attr.codimension)
1343 /* Create variables to hold the non-constant bits of array info. */
1344 gfc_build_qualified_array (decl, sym);
1346 if (sym->attr.contiguous
1347 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1348 GFC_DECL_PACKED_ARRAY (decl) = 1;
1351 /* Remember this variable for allocation/cleanup. */
1352 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1353 || (sym->ts.type == BT_CLASS &&
1354 (CLASS_DATA (sym)->attr.dimension
1355 || CLASS_DATA (sym)->attr.allocatable))
1356 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1357 /* This applies a derived type default initializer. */
1358 || (sym->ts.type == BT_DERIVED
1359 && sym->attr.save == SAVE_NONE
1361 && !sym->attr.allocatable
1362 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1363 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1364 gfc_defer_symbol_init (sym);
1366 gfc_finish_var_decl (decl, sym);
1368 if (sym->ts.type == BT_CHARACTER)
1370 /* Character variables need special handling. */
1371 gfc_allocate_lang_decl (decl);
1373 if (TREE_CODE (length) != INTEGER_CST)
1375 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1379 /* Also prefix the mangled name for symbols from modules. */
1380 strcpy (&name[1], sym->name);
1383 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1384 gfc_set_decl_assembler_name (decl, get_identifier (name));
1386 gfc_finish_var_decl (length, sym);
1387 gcc_assert (!sym->value);
1390 else if (sym->attr.subref_array_pointer)
1392 /* We need the span for these beasts. */
1393 gfc_allocate_lang_decl (decl);
1396 if (sym->attr.subref_array_pointer)
1399 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1400 span = build_decl (input_location,
1401 VAR_DECL, create_tmp_var_name ("span"),
1402 gfc_array_index_type);
1403 gfc_finish_var_decl (span, sym);
1404 TREE_STATIC (span) = TREE_STATIC (decl);
1405 DECL_ARTIFICIAL (span) = 1;
1406 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1408 GFC_DECL_SPAN (decl) = span;
1409 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1412 sym->backend_decl = decl;
1414 if (sym->attr.assign)
1415 gfc_add_assign_aux_vars (sym);
1417 if (intrinsic_array_parameter)
1419 TREE_STATIC (decl) = 1;
1420 DECL_EXTERNAL (decl) = 0;
1423 if (TREE_STATIC (decl)
1424 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1425 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1426 || gfc_option.flag_max_stack_var_size == 0
1427 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1428 && (gfc_option.coarray != GFC_FCOARRAY_LIB || !sym->attr.codimension))
1430 /* Add static initializer. For procedures, it is only needed if
1431 SAVE is specified otherwise they need to be reinitialized
1432 every time the procedure is entered. The TREE_STATIC is
1433 in this case due to -fmax-stack-var-size=. */
1434 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1436 sym->attr.dimension,
1438 || sym->attr.allocatable,
1439 sym->attr.proc_pointer);
1442 if (!TREE_STATIC (decl)
1443 && POINTER_TYPE_P (TREE_TYPE (decl))
1444 && !sym->attr.pointer
1445 && !sym->attr.allocatable
1446 && !sym->attr.proc_pointer)
1447 DECL_BY_REFERENCE (decl) = 1;
1453 /* Substitute a temporary variable in place of the real one. */
1456 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1458 save->attr = sym->attr;
1459 save->decl = sym->backend_decl;
1461 gfc_clear_attr (&sym->attr);
1462 sym->attr.referenced = 1;
1463 sym->attr.flavor = FL_VARIABLE;
1465 sym->backend_decl = decl;
1469 /* Restore the original variable. */
1472 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1474 sym->attr = save->attr;
1475 sym->backend_decl = save->decl;
1479 /* Declare a procedure pointer. */
1482 get_proc_pointer_decl (gfc_symbol *sym)
1487 decl = sym->backend_decl;
1491 decl = build_decl (input_location,
1492 VAR_DECL, get_identifier (sym->name),
1493 build_pointer_type (gfc_get_function_type (sym)));
1495 if ((sym->ns->proc_name
1496 && sym->ns->proc_name->backend_decl == current_function_decl)
1497 || sym->attr.contained)
1498 gfc_add_decl_to_function (decl);
1499 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1500 gfc_add_decl_to_parent_function (decl);
1502 sym->backend_decl = decl;
1504 /* If a variable is USE associated, it's always external. */
1505 if (sym->attr.use_assoc)
1507 DECL_EXTERNAL (decl) = 1;
1508 TREE_PUBLIC (decl) = 1;
1510 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1512 /* This is the declaration of a module variable. */
1513 TREE_PUBLIC (decl) = 1;
1514 TREE_STATIC (decl) = 1;
1517 if (!sym->attr.use_assoc
1518 && (sym->attr.save != SAVE_NONE || sym->attr.data
1519 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1520 TREE_STATIC (decl) = 1;
1522 if (TREE_STATIC (decl) && sym->value)
1524 /* Add static initializer. */
1525 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1527 sym->attr.dimension,
1531 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1532 decl_attributes (&decl, attributes, 0);
1538 /* Get a basic decl for an external function. */
1541 gfc_get_extern_function_decl (gfc_symbol * sym)
1547 gfc_intrinsic_sym *isym;
1549 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1554 if (sym->backend_decl)
1555 return sym->backend_decl;
1557 /* We should never be creating external decls for alternate entry points.
1558 The procedure may be an alternate entry point, but we don't want/need
1560 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1562 if (sym->attr.proc_pointer)
1563 return get_proc_pointer_decl (sym);
1565 /* See if this is an external procedure from the same file. If so,
1566 return the backend_decl. */
1567 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1569 if (gfc_option.flag_whole_file
1570 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1571 && !sym->backend_decl
1573 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1574 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1576 if (!gsym->ns->proc_name->backend_decl)
1578 /* By construction, the external function cannot be
1579 a contained procedure. */
1581 tree save_fn_decl = current_function_decl;
1583 current_function_decl = NULL_TREE;
1584 gfc_save_backend_locus (&old_loc);
1587 gfc_create_function_decl (gsym->ns, true);
1590 gfc_restore_backend_locus (&old_loc);
1591 current_function_decl = save_fn_decl;
1594 /* If the namespace has entries, the proc_name is the
1595 entry master. Find the entry and use its backend_decl.
1596 otherwise, use the proc_name backend_decl. */
1597 if (gsym->ns->entries)
1599 gfc_entry_list *entry = gsym->ns->entries;
1601 for (; entry; entry = entry->next)
1603 if (strcmp (gsym->name, entry->sym->name) == 0)
1605 sym->backend_decl = entry->sym->backend_decl;
1611 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1613 if (sym->backend_decl)
1615 /* Avoid problems of double deallocation of the backend declaration
1616 later in gfc_trans_use_stmts; cf. PR 45087. */
1617 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1618 sym->attr.use_assoc = 0;
1620 return sym->backend_decl;
1624 /* See if this is a module procedure from the same file. If so,
1625 return the backend_decl. */
1627 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1629 if (gfc_option.flag_whole_file
1631 && gsym->type == GSYM_MODULE)
1636 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1637 if (s && s->backend_decl)
1639 sym->backend_decl = s->backend_decl;
1640 return sym->backend_decl;
1644 if (sym->attr.intrinsic)
1646 /* Call the resolution function to get the actual name. This is
1647 a nasty hack which relies on the resolution functions only looking
1648 at the first argument. We pass NULL for the second argument
1649 otherwise things like AINT get confused. */
1650 isym = gfc_find_function (sym->name);
1651 gcc_assert (isym->resolve.f0 != NULL);
1653 memset (&e, 0, sizeof (e));
1654 e.expr_type = EXPR_FUNCTION;
1656 memset (&argexpr, 0, sizeof (argexpr));
1657 gcc_assert (isym->formal);
1658 argexpr.ts = isym->formal->ts;
1660 if (isym->formal->next == NULL)
1661 isym->resolve.f1 (&e, &argexpr);
1664 if (isym->formal->next->next == NULL)
1665 isym->resolve.f2 (&e, &argexpr, NULL);
1668 if (isym->formal->next->next->next == NULL)
1669 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1672 /* All specific intrinsics take less than 5 arguments. */
1673 gcc_assert (isym->formal->next->next->next->next == NULL);
1674 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1679 if (gfc_option.flag_f2c
1680 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1681 || e.ts.type == BT_COMPLEX))
1683 /* Specific which needs a different implementation if f2c
1684 calling conventions are used. */
1685 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1688 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1690 name = get_identifier (s);
1691 mangled_name = name;
1695 name = gfc_sym_identifier (sym);
1696 mangled_name = gfc_sym_mangled_function_id (sym);
1699 type = gfc_get_function_type (sym);
1700 fndecl = build_decl (input_location,
1701 FUNCTION_DECL, name, type);
1703 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1704 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1705 the opposite of declaring a function as static in C). */
1706 DECL_EXTERNAL (fndecl) = 1;
1707 TREE_PUBLIC (fndecl) = 1;
1709 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1710 decl_attributes (&fndecl, attributes, 0);
1712 gfc_set_decl_assembler_name (fndecl, mangled_name);
1714 /* Set the context of this decl. */
1715 if (0 && sym->ns && sym->ns->proc_name)
1717 /* TODO: Add external decls to the appropriate scope. */
1718 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1722 /* Global declaration, e.g. intrinsic subroutine. */
1723 DECL_CONTEXT (fndecl) = NULL_TREE;
1726 /* Set attributes for PURE functions. A call to PURE function in the
1727 Fortran 95 sense is both pure and without side effects in the C
1729 if (sym->attr.pure || sym->attr.elemental)
1731 if (sym->attr.function && !gfc_return_by_reference (sym))
1732 DECL_PURE_P (fndecl) = 1;
1733 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1734 parameters and don't use alternate returns (is this
1735 allowed?). In that case, calls to them are meaningless, and
1736 can be optimized away. See also in build_function_decl(). */
1737 TREE_SIDE_EFFECTS (fndecl) = 0;
1740 /* Mark non-returning functions. */
1741 if (sym->attr.noreturn)
1742 TREE_THIS_VOLATILE(fndecl) = 1;
1744 sym->backend_decl = fndecl;
1746 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1747 pushdecl_top_level (fndecl);
1753 /* Create a declaration for a procedure. For external functions (in the C
1754 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1755 a master function with alternate entry points. */
1758 build_function_decl (gfc_symbol * sym, bool global)
1760 tree fndecl, type, attributes;
1761 symbol_attribute attr;
1763 gfc_formal_arglist *f;
1765 gcc_assert (!sym->attr.external);
1767 if (sym->backend_decl)
1770 /* Set the line and filename. sym->declared_at seems to point to the
1771 last statement for subroutines, but it'll do for now. */
1772 gfc_set_backend_locus (&sym->declared_at);
1774 /* Allow only one nesting level. Allow public declarations. */
1775 gcc_assert (current_function_decl == NULL_TREE
1776 || DECL_FILE_SCOPE_P (current_function_decl)
1777 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1778 == NAMESPACE_DECL));
1780 type = gfc_get_function_type (sym);
1781 fndecl = build_decl (input_location,
1782 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1786 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1787 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1788 the opposite of declaring a function as static in C). */
1789 DECL_EXTERNAL (fndecl) = 0;
1791 if (!current_function_decl
1792 && !sym->attr.entry_master && !sym->attr.is_main_program)
1793 TREE_PUBLIC (fndecl) = 1;
1795 attributes = add_attributes_to_decl (attr, NULL_TREE);
1796 decl_attributes (&fndecl, attributes, 0);
1798 /* Figure out the return type of the declared function, and build a
1799 RESULT_DECL for it. If this is a subroutine with alternate
1800 returns, build a RESULT_DECL for it. */
1801 result_decl = NULL_TREE;
1802 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1805 if (gfc_return_by_reference (sym))
1806 type = void_type_node;
1809 if (sym->result != sym)
1810 result_decl = gfc_sym_identifier (sym->result);
1812 type = TREE_TYPE (TREE_TYPE (fndecl));
1817 /* Look for alternate return placeholders. */
1818 int has_alternate_returns = 0;
1819 for (f = sym->formal; f; f = f->next)
1823 has_alternate_returns = 1;
1828 if (has_alternate_returns)
1829 type = integer_type_node;
1831 type = void_type_node;
1834 result_decl = build_decl (input_location,
1835 RESULT_DECL, result_decl, type);
1836 DECL_ARTIFICIAL (result_decl) = 1;
1837 DECL_IGNORED_P (result_decl) = 1;
1838 DECL_CONTEXT (result_decl) = fndecl;
1839 DECL_RESULT (fndecl) = result_decl;
1841 /* Don't call layout_decl for a RESULT_DECL.
1842 layout_decl (result_decl, 0); */
1844 /* TREE_STATIC means the function body is defined here. */
1845 TREE_STATIC (fndecl) = 1;
1847 /* Set attributes for PURE functions. A call to a PURE function in the
1848 Fortran 95 sense is both pure and without side effects in the C
1850 if (attr.pure || attr.elemental)
1852 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1853 including an alternate return. In that case it can also be
1854 marked as PURE. See also in gfc_get_extern_function_decl(). */
1855 if (attr.function && !gfc_return_by_reference (sym))
1856 DECL_PURE_P (fndecl) = 1;
1857 TREE_SIDE_EFFECTS (fndecl) = 0;
1861 /* Layout the function declaration and put it in the binding level
1862 of the current function. */
1865 pushdecl_top_level (fndecl);
1869 /* Perform name mangling if this is a top level or module procedure. */
1870 if (current_function_decl == NULL_TREE)
1871 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1873 sym->backend_decl = fndecl;
1877 /* Create the DECL_ARGUMENTS for a procedure. */
1880 create_function_arglist (gfc_symbol * sym)
1883 gfc_formal_arglist *f;
1884 tree typelist, hidden_typelist;
1885 tree arglist, hidden_arglist;
1889 fndecl = sym->backend_decl;
1891 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1892 the new FUNCTION_DECL node. */
1893 arglist = NULL_TREE;
1894 hidden_arglist = NULL_TREE;
1895 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1897 if (sym->attr.entry_master)
1899 type = TREE_VALUE (typelist);
1900 parm = build_decl (input_location,
1901 PARM_DECL, get_identifier ("__entry"), type);
1903 DECL_CONTEXT (parm) = fndecl;
1904 DECL_ARG_TYPE (parm) = type;
1905 TREE_READONLY (parm) = 1;
1906 gfc_finish_decl (parm);
1907 DECL_ARTIFICIAL (parm) = 1;
1909 arglist = chainon (arglist, parm);
1910 typelist = TREE_CHAIN (typelist);
1913 if (gfc_return_by_reference (sym))
1915 tree type = TREE_VALUE (typelist), length = NULL;
1917 if (sym->ts.type == BT_CHARACTER)
1919 /* Length of character result. */
1920 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1922 length = build_decl (input_location,
1924 get_identifier (".__result"),
1926 if (!sym->ts.u.cl->length)
1928 sym->ts.u.cl->backend_decl = length;
1929 TREE_USED (length) = 1;
1931 gcc_assert (TREE_CODE (length) == PARM_DECL);
1932 DECL_CONTEXT (length) = fndecl;
1933 DECL_ARG_TYPE (length) = len_type;
1934 TREE_READONLY (length) = 1;
1935 DECL_ARTIFICIAL (length) = 1;
1936 gfc_finish_decl (length);
1937 if (sym->ts.u.cl->backend_decl == NULL
1938 || sym->ts.u.cl->backend_decl == length)
1943 if (sym->ts.u.cl->backend_decl == NULL)
1945 tree len = build_decl (input_location,
1947 get_identifier ("..__result"),
1948 gfc_charlen_type_node);
1949 DECL_ARTIFICIAL (len) = 1;
1950 TREE_USED (len) = 1;
1951 sym->ts.u.cl->backend_decl = len;
1954 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1955 arg = sym->result ? sym->result : sym;
1956 backend_decl = arg->backend_decl;
1957 /* Temporary clear it, so that gfc_sym_type creates complete
1959 arg->backend_decl = NULL;
1960 type = gfc_sym_type (arg);
1961 arg->backend_decl = backend_decl;
1962 type = build_reference_type (type);
1966 parm = build_decl (input_location,
1967 PARM_DECL, get_identifier ("__result"), type);
1969 DECL_CONTEXT (parm) = fndecl;
1970 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1971 TREE_READONLY (parm) = 1;
1972 DECL_ARTIFICIAL (parm) = 1;
1973 gfc_finish_decl (parm);
1975 arglist = chainon (arglist, parm);
1976 typelist = TREE_CHAIN (typelist);
1978 if (sym->ts.type == BT_CHARACTER)
1980 gfc_allocate_lang_decl (parm);
1981 arglist = chainon (arglist, length);
1982 typelist = TREE_CHAIN (typelist);
1986 hidden_typelist = typelist;
1987 for (f = sym->formal; f; f = f->next)
1988 if (f->sym != NULL) /* Ignore alternate returns. */
1989 hidden_typelist = TREE_CHAIN (hidden_typelist);
1991 for (f = sym->formal; f; f = f->next)
1993 char name[GFC_MAX_SYMBOL_LEN + 2];
1995 /* Ignore alternate returns. */
1999 type = TREE_VALUE (typelist);
2001 if (f->sym->ts.type == BT_CHARACTER
2002 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2004 tree len_type = TREE_VALUE (hidden_typelist);
2005 tree length = NULL_TREE;
2006 if (!f->sym->ts.deferred)
2007 gcc_assert (len_type == gfc_charlen_type_node);
2009 gcc_assert (POINTER_TYPE_P (len_type));
2011 strcpy (&name[1], f->sym->name);
2013 length = build_decl (input_location,
2014 PARM_DECL, get_identifier (name), len_type);
2016 hidden_arglist = chainon (hidden_arglist, length);
2017 DECL_CONTEXT (length) = fndecl;
2018 DECL_ARTIFICIAL (length) = 1;
2019 DECL_ARG_TYPE (length) = len_type;
2020 TREE_READONLY (length) = 1;
2021 gfc_finish_decl (length);
2023 /* Remember the passed value. */
2024 if (f->sym->ts.u.cl->passed_length != NULL)
2026 /* This can happen if the same type is used for multiple
2027 arguments. We need to copy cl as otherwise
2028 cl->passed_length gets overwritten. */
2029 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2031 f->sym->ts.u.cl->passed_length = length;
2033 /* Use the passed value for assumed length variables. */
2034 if (!f->sym->ts.u.cl->length)
2036 TREE_USED (length) = 1;
2037 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2038 f->sym->ts.u.cl->backend_decl = length;
2041 hidden_typelist = TREE_CHAIN (hidden_typelist);
2043 if (f->sym->ts.u.cl->backend_decl == NULL
2044 || f->sym->ts.u.cl->backend_decl == length)
2046 if (f->sym->ts.u.cl->backend_decl == NULL)
2047 gfc_create_string_length (f->sym);
2049 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2050 if (f->sym->attr.flavor == FL_PROCEDURE)
2051 type = build_pointer_type (gfc_get_function_type (f->sym));
2053 type = gfc_sym_type (f->sym);
2057 /* For non-constant length array arguments, make sure they use
2058 a different type node from TYPE_ARG_TYPES type. */
2059 if (f->sym->attr.dimension
2060 && type == TREE_VALUE (typelist)
2061 && TREE_CODE (type) == POINTER_TYPE
2062 && GFC_ARRAY_TYPE_P (type)
2063 && f->sym->as->type != AS_ASSUMED_SIZE
2064 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2066 if (f->sym->attr.flavor == FL_PROCEDURE)
2067 type = build_pointer_type (gfc_get_function_type (f->sym));
2069 type = gfc_sym_type (f->sym);
2072 if (f->sym->attr.proc_pointer)
2073 type = build_pointer_type (type);
2075 if (f->sym->attr.volatile_)
2076 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2078 /* Build the argument declaration. */
2079 parm = build_decl (input_location,
2080 PARM_DECL, gfc_sym_identifier (f->sym), type);
2082 if (f->sym->attr.volatile_)
2084 TREE_THIS_VOLATILE (parm) = 1;
2085 TREE_SIDE_EFFECTS (parm) = 1;
2088 /* Fill in arg stuff. */
2089 DECL_CONTEXT (parm) = fndecl;
2090 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2091 /* All implementation args are read-only. */
2092 TREE_READONLY (parm) = 1;
2093 if (POINTER_TYPE_P (type)
2094 && (!f->sym->attr.proc_pointer
2095 && f->sym->attr.flavor != FL_PROCEDURE))
2096 DECL_BY_REFERENCE (parm) = 1;
2098 gfc_finish_decl (parm);
2100 f->sym->backend_decl = parm;
2102 arglist = chainon (arglist, parm);
2103 typelist = TREE_CHAIN (typelist);
2106 /* Add the hidden string length parameters, unless the procedure
2108 if (!sym->attr.is_bind_c)
2109 arglist = chainon (arglist, hidden_arglist);
2111 gcc_assert (hidden_typelist == NULL_TREE
2112 || TREE_VALUE (hidden_typelist) == void_type_node);
2113 DECL_ARGUMENTS (fndecl) = arglist;
2116 /* Do the setup necessary before generating the body of a function. */
2119 trans_function_start (gfc_symbol * sym)
2123 fndecl = sym->backend_decl;
2125 /* Let GCC know the current scope is this function. */
2126 current_function_decl = fndecl;
2128 /* Let the world know what we're about to do. */
2129 announce_function (fndecl);
2131 if (DECL_FILE_SCOPE_P (fndecl))
2133 /* Create RTL for function declaration. */
2134 rest_of_decl_compilation (fndecl, 1, 0);
2137 /* Create RTL for function definition. */
2138 make_decl_rtl (fndecl);
2140 init_function_start (fndecl);
2142 /* function.c requires a push at the start of the function. */
2146 /* Create thunks for alternate entry points. */
2149 build_entry_thunks (gfc_namespace * ns, bool global)
2151 gfc_formal_arglist *formal;
2152 gfc_formal_arglist *thunk_formal;
2154 gfc_symbol *thunk_sym;
2160 /* This should always be a toplevel function. */
2161 gcc_assert (current_function_decl == NULL_TREE);
2163 gfc_save_backend_locus (&old_loc);
2164 for (el = ns->entries; el; el = el->next)
2166 VEC(tree,gc) *args = NULL;
2167 VEC(tree,gc) *string_args = NULL;
2169 thunk_sym = el->sym;
2171 build_function_decl (thunk_sym, global);
2172 create_function_arglist (thunk_sym);
2174 trans_function_start (thunk_sym);
2176 thunk_fndecl = thunk_sym->backend_decl;
2178 gfc_init_block (&body);
2180 /* Pass extra parameter identifying this entry point. */
2181 tmp = build_int_cst (gfc_array_index_type, el->id);
2182 VEC_safe_push (tree, gc, args, tmp);
2184 if (thunk_sym->attr.function)
2186 if (gfc_return_by_reference (ns->proc_name))
2188 tree ref = DECL_ARGUMENTS (current_function_decl);
2189 VEC_safe_push (tree, gc, args, ref);
2190 if (ns->proc_name->ts.type == BT_CHARACTER)
2191 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2195 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2197 /* Ignore alternate returns. */
2198 if (formal->sym == NULL)
2201 /* We don't have a clever way of identifying arguments, so resort to
2202 a brute-force search. */
2203 for (thunk_formal = thunk_sym->formal;
2205 thunk_formal = thunk_formal->next)
2207 if (thunk_formal->sym == formal->sym)
2213 /* Pass the argument. */
2214 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2215 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2216 if (formal->sym->ts.type == BT_CHARACTER)
2218 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2219 VEC_safe_push (tree, gc, string_args, tmp);
2224 /* Pass NULL for a missing argument. */
2225 VEC_safe_push (tree, gc, args, null_pointer_node);
2226 if (formal->sym->ts.type == BT_CHARACTER)
2228 tmp = build_int_cst (gfc_charlen_type_node, 0);
2229 VEC_safe_push (tree, gc, string_args, tmp);
2234 /* Call the master function. */
2235 VEC_safe_splice (tree, gc, args, string_args);
2236 tmp = ns->proc_name->backend_decl;
2237 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2238 if (ns->proc_name->attr.mixed_entry_master)
2240 tree union_decl, field;
2241 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2243 union_decl = build_decl (input_location,
2244 VAR_DECL, get_identifier ("__result"),
2245 TREE_TYPE (master_type));
2246 DECL_ARTIFICIAL (union_decl) = 1;
2247 DECL_EXTERNAL (union_decl) = 0;
2248 TREE_PUBLIC (union_decl) = 0;
2249 TREE_USED (union_decl) = 1;
2250 layout_decl (union_decl, 0);
2251 pushdecl (union_decl);
2253 DECL_CONTEXT (union_decl) = current_function_decl;
2254 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2255 TREE_TYPE (union_decl), union_decl, tmp);
2256 gfc_add_expr_to_block (&body, tmp);
2258 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2259 field; field = DECL_CHAIN (field))
2260 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2261 thunk_sym->result->name) == 0)
2263 gcc_assert (field != NULL_TREE);
2264 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2265 TREE_TYPE (field), union_decl, field,
2267 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2268 TREE_TYPE (DECL_RESULT (current_function_decl)),
2269 DECL_RESULT (current_function_decl), tmp);
2270 tmp = build1_v (RETURN_EXPR, tmp);
2272 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2275 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2276 TREE_TYPE (DECL_RESULT (current_function_decl)),
2277 DECL_RESULT (current_function_decl), tmp);
2278 tmp = build1_v (RETURN_EXPR, tmp);
2280 gfc_add_expr_to_block (&body, tmp);
2282 /* Finish off this function and send it for code generation. */
2283 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2286 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2287 DECL_SAVED_TREE (thunk_fndecl)
2288 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2289 DECL_INITIAL (thunk_fndecl));
2291 /* Output the GENERIC tree. */
2292 dump_function (TDI_original, thunk_fndecl);
2294 /* Store the end of the function, so that we get good line number
2295 info for the epilogue. */
2296 cfun->function_end_locus = input_location;
2298 /* We're leaving the context of this function, so zap cfun.
2299 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2300 tree_rest_of_compilation. */
2303 current_function_decl = NULL_TREE;
2305 cgraph_finalize_function (thunk_fndecl, true);
2307 /* We share the symbols in the formal argument list with other entry
2308 points and the master function. Clear them so that they are
2309 recreated for each function. */
2310 for (formal = thunk_sym->formal; formal; formal = formal->next)
2311 if (formal->sym != NULL) /* Ignore alternate returns. */
2313 formal->sym->backend_decl = NULL_TREE;
2314 if (formal->sym->ts.type == BT_CHARACTER)
2315 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2318 if (thunk_sym->attr.function)
2320 if (thunk_sym->ts.type == BT_CHARACTER)
2321 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2322 if (thunk_sym->result->ts.type == BT_CHARACTER)
2323 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2327 gfc_restore_backend_locus (&old_loc);
2331 /* Create a decl for a function, and create any thunks for alternate entry
2332 points. If global is true, generate the function in the global binding
2333 level, otherwise in the current binding level (which can be global). */
2336 gfc_create_function_decl (gfc_namespace * ns, bool global)
2338 /* Create a declaration for the master function. */
2339 build_function_decl (ns->proc_name, global);
2341 /* Compile the entry thunks. */
2343 build_entry_thunks (ns, global);
2345 /* Now create the read argument list. */
2346 create_function_arglist (ns->proc_name);
2349 /* Return the decl used to hold the function return value. If
2350 parent_flag is set, the context is the parent_scope. */
2353 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2357 tree this_fake_result_decl;
2358 tree this_function_decl;
2360 char name[GFC_MAX_SYMBOL_LEN + 10];
2364 this_fake_result_decl = parent_fake_result_decl;
2365 this_function_decl = DECL_CONTEXT (current_function_decl);
2369 this_fake_result_decl = current_fake_result_decl;
2370 this_function_decl = current_function_decl;
2374 && sym->ns->proc_name->backend_decl == this_function_decl
2375 && sym->ns->proc_name->attr.entry_master
2376 && sym != sym->ns->proc_name)
2379 if (this_fake_result_decl != NULL)
2380 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2381 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2384 return TREE_VALUE (t);
2385 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2388 this_fake_result_decl = parent_fake_result_decl;
2390 this_fake_result_decl = current_fake_result_decl;
2392 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2396 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2397 field; field = DECL_CHAIN (field))
2398 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2402 gcc_assert (field != NULL_TREE);
2403 decl = fold_build3_loc (input_location, COMPONENT_REF,
2404 TREE_TYPE (field), decl, field, NULL_TREE);
2407 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2409 gfc_add_decl_to_parent_function (var);
2411 gfc_add_decl_to_function (var);
2413 SET_DECL_VALUE_EXPR (var, decl);
2414 DECL_HAS_VALUE_EXPR_P (var) = 1;
2415 GFC_DECL_RESULT (var) = 1;
2417 TREE_CHAIN (this_fake_result_decl)
2418 = tree_cons (get_identifier (sym->name), var,
2419 TREE_CHAIN (this_fake_result_decl));
2423 if (this_fake_result_decl != NULL_TREE)
2424 return TREE_VALUE (this_fake_result_decl);
2426 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2431 if (sym->ts.type == BT_CHARACTER)
2433 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2434 length = gfc_create_string_length (sym);
2436 length = sym->ts.u.cl->backend_decl;
2437 if (TREE_CODE (length) == VAR_DECL
2438 && DECL_CONTEXT (length) == NULL_TREE)
2439 gfc_add_decl_to_function (length);
2442 if (gfc_return_by_reference (sym))
2444 decl = DECL_ARGUMENTS (this_function_decl);
2446 if (sym->ns->proc_name->backend_decl == this_function_decl
2447 && sym->ns->proc_name->attr.entry_master)
2448 decl = DECL_CHAIN (decl);
2450 TREE_USED (decl) = 1;
2452 decl = gfc_build_dummy_array_decl (sym, decl);
2456 sprintf (name, "__result_%.20s",
2457 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2459 if (!sym->attr.mixed_entry_master && sym->attr.function)
2460 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2461 VAR_DECL, get_identifier (name),
2462 gfc_sym_type (sym));
2464 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2465 VAR_DECL, get_identifier (name),
2466 TREE_TYPE (TREE_TYPE (this_function_decl)));
2467 DECL_ARTIFICIAL (decl) = 1;
2468 DECL_EXTERNAL (decl) = 0;
2469 TREE_PUBLIC (decl) = 0;
2470 TREE_USED (decl) = 1;
2471 GFC_DECL_RESULT (decl) = 1;
2472 TREE_ADDRESSABLE (decl) = 1;
2474 layout_decl (decl, 0);
2477 gfc_add_decl_to_parent_function (decl);
2479 gfc_add_decl_to_function (decl);
2483 parent_fake_result_decl = build_tree_list (NULL, decl);
2485 current_fake_result_decl = build_tree_list (NULL, decl);
2491 /* Builds a function decl. The remaining parameters are the types of the
2492 function arguments. Negative nargs indicates a varargs function. */
2495 build_library_function_decl_1 (tree name, const char *spec,
2496 tree rettype, int nargs, va_list p)
2498 VEC(tree,gc) *arglist;
2503 /* Library functions must be declared with global scope. */
2504 gcc_assert (current_function_decl == NULL_TREE);
2506 /* Create a list of the argument types. */
2507 arglist = VEC_alloc (tree, gc, abs (nargs));
2508 for (n = abs (nargs); n > 0; n--)
2510 tree argtype = va_arg (p, tree);
2511 VEC_quick_push (tree, arglist, argtype);
2514 /* Build the function type and decl. */
2516 fntype = build_function_type_vec (rettype, arglist);
2518 fntype = build_varargs_function_type_vec (rettype, arglist);
2521 tree attr_args = build_tree_list (NULL_TREE,
2522 build_string (strlen (spec), spec));
2523 tree attrs = tree_cons (get_identifier ("fn spec"),
2524 attr_args, TYPE_ATTRIBUTES (fntype));
2525 fntype = build_type_attribute_variant (fntype, attrs);
2527 fndecl = build_decl (input_location,
2528 FUNCTION_DECL, name, fntype);
2530 /* Mark this decl as external. */
2531 DECL_EXTERNAL (fndecl) = 1;
2532 TREE_PUBLIC (fndecl) = 1;
2536 rest_of_decl_compilation (fndecl, 1, 0);
2541 /* Builds a function decl. The remaining parameters are the types of the
2542 function arguments. Negative nargs indicates a varargs function. */
2545 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2549 va_start (args, nargs);
2550 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2555 /* Builds a function decl. The remaining parameters are the types of the
2556 function arguments. Negative nargs indicates a varargs function.
2557 The SPEC parameter specifies the function argument and return type
2558 specification according to the fnspec function type attribute. */
2561 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2562 tree rettype, int nargs, ...)
2566 va_start (args, nargs);
2567 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2573 gfc_build_intrinsic_function_decls (void)
2575 tree gfc_int4_type_node = gfc_get_int_type (4);
2576 tree gfc_int8_type_node = gfc_get_int_type (8);
2577 tree gfc_int16_type_node = gfc_get_int_type (16);
2578 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2579 tree pchar1_type_node = gfc_get_pchar_type (1);
2580 tree pchar4_type_node = gfc_get_pchar_type (4);
2582 /* String functions. */
2583 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2584 get_identifier (PREFIX("compare_string")), "..R.R",
2585 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2586 gfc_charlen_type_node, pchar1_type_node);
2587 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2588 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2590 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2591 get_identifier (PREFIX("concat_string")), "..W.R.R",
2592 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2593 gfc_charlen_type_node, pchar1_type_node,
2594 gfc_charlen_type_node, pchar1_type_node);
2595 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2597 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2598 get_identifier (PREFIX("string_len_trim")), "..R",
2599 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2600 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2601 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2603 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2604 get_identifier (PREFIX("string_index")), "..R.R.",
2605 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2606 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2607 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2608 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2610 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2611 get_identifier (PREFIX("string_scan")), "..R.R.",
2612 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2613 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2614 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2615 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2617 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2618 get_identifier (PREFIX("string_verify")), "..R.R.",
2619 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2620 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2621 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2622 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2624 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2625 get_identifier (PREFIX("string_trim")), ".Ww.R",
2626 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2627 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2630 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2631 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2632 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2633 build_pointer_type (pchar1_type_node), integer_type_node,
2636 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2637 get_identifier (PREFIX("adjustl")), ".W.R",
2638 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2640 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2642 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2643 get_identifier (PREFIX("adjustr")), ".W.R",
2644 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2646 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2648 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2649 get_identifier (PREFIX("select_string")), ".R.R.",
2650 integer_type_node, 4, pvoid_type_node, integer_type_node,
2651 pchar1_type_node, gfc_charlen_type_node);
2652 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2653 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2655 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2656 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2657 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2658 gfc_charlen_type_node, pchar4_type_node);
2659 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2660 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2662 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2663 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2664 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2665 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2667 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2669 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2670 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2671 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2672 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2673 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2675 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2676 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2677 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2678 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2679 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2680 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2682 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2683 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2684 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2685 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2686 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2687 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2689 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2690 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2691 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2692 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2693 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2694 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2696 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2697 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2698 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2699 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2702 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2703 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2704 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2705 build_pointer_type (pchar4_type_node), integer_type_node,
2708 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2709 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2710 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2712 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2714 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2715 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2716 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2718 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2720 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2721 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2722 integer_type_node, 4, pvoid_type_node, integer_type_node,
2723 pvoid_type_node, gfc_charlen_type_node);
2724 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2725 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2728 /* Conversion between character kinds. */
2730 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2731 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2732 void_type_node, 3, build_pointer_type (pchar4_type_node),
2733 gfc_charlen_type_node, pchar1_type_node);
2735 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2736 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2737 void_type_node, 3, build_pointer_type (pchar1_type_node),
2738 gfc_charlen_type_node, pchar4_type_node);
2740 /* Misc. functions. */
2742 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2743 get_identifier (PREFIX("ttynam")), ".W",
2744 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2747 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2748 get_identifier (PREFIX("fdate")), ".W",
2749 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2751 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2752 get_identifier (PREFIX("ctime")), ".W",
2753 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2754 gfc_int8_type_node);
2756 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2757 get_identifier (PREFIX("selected_char_kind")), "..R",
2758 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2759 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2760 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2762 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2763 get_identifier (PREFIX("selected_int_kind")), ".R",
2764 gfc_int4_type_node, 1, pvoid_type_node);
2765 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2766 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2768 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2769 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2770 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2772 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2773 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2775 /* Power functions. */
2777 tree ctype, rtype, itype, jtype;
2778 int rkind, ikind, jkind;
2781 static int ikinds[NIKINDS] = {4, 8, 16};
2782 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2783 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2785 for (ikind=0; ikind < NIKINDS; ikind++)
2787 itype = gfc_get_int_type (ikinds[ikind]);
2789 for (jkind=0; jkind < NIKINDS; jkind++)
2791 jtype = gfc_get_int_type (ikinds[jkind]);
2794 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2796 gfor_fndecl_math_powi[jkind][ikind].integer =
2797 gfc_build_library_function_decl (get_identifier (name),
2798 jtype, 2, jtype, itype);
2799 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2800 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2804 for (rkind = 0; rkind < NRKINDS; rkind ++)
2806 rtype = gfc_get_real_type (rkinds[rkind]);
2809 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2811 gfor_fndecl_math_powi[rkind][ikind].real =
2812 gfc_build_library_function_decl (get_identifier (name),
2813 rtype, 2, rtype, itype);
2814 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2815 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2818 ctype = gfc_get_complex_type (rkinds[rkind]);
2821 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2823 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2824 gfc_build_library_function_decl (get_identifier (name),
2825 ctype, 2,ctype, itype);
2826 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2827 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2835 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2836 get_identifier (PREFIX("ishftc4")),
2837 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2838 gfc_int4_type_node);
2839 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2840 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2842 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2843 get_identifier (PREFIX("ishftc8")),
2844 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2845 gfc_int4_type_node);
2846 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2847 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2849 if (gfc_int16_type_node)
2851 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2852 get_identifier (PREFIX("ishftc16")),
2853 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2854 gfc_int4_type_node);
2855 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2856 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2859 /* BLAS functions. */
2861 tree pint = build_pointer_type (integer_type_node);
2862 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2863 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2864 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2865 tree pz = build_pointer_type
2866 (gfc_get_complex_type (gfc_default_double_kind));
2868 gfor_fndecl_sgemm = gfc_build_library_function_decl
2870 (gfc_option.flag_underscoring ? "sgemm_"
2872 void_type_node, 15, pchar_type_node,
2873 pchar_type_node, pint, pint, pint, ps, ps, pint,
2874 ps, pint, ps, ps, pint, integer_type_node,
2876 gfor_fndecl_dgemm = gfc_build_library_function_decl
2878 (gfc_option.flag_underscoring ? "dgemm_"
2880 void_type_node, 15, pchar_type_node,
2881 pchar_type_node, pint, pint, pint, pd, pd, pint,
2882 pd, pint, pd, pd, pint, integer_type_node,
2884 gfor_fndecl_cgemm = gfc_build_library_function_decl
2886 (gfc_option.flag_underscoring ? "cgemm_"
2888 void_type_node, 15, pchar_type_node,
2889 pchar_type_node, pint, pint, pint, pc, pc, pint,
2890 pc, pint, pc, pc, pint, integer_type_node,
2892 gfor_fndecl_zgemm = gfc_build_library_function_decl
2894 (gfc_option.flag_underscoring ? "zgemm_"
2896 void_type_node, 15, pchar_type_node,
2897 pchar_type_node, pint, pint, pint, pz, pz, pint,
2898 pz, pint, pz, pz, pint, integer_type_node,
2902 /* Other functions. */
2903 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2904 get_identifier (PREFIX("size0")), ".R",
2905 gfc_array_index_type, 1, pvoid_type_node);
2906 DECL_PURE_P (gfor_fndecl_size0) = 1;
2907 TREE_NOTHROW (gfor_fndecl_size0) = 1;
2909 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2910 get_identifier (PREFIX("size1")), ".R",
2911 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2912 DECL_PURE_P (gfor_fndecl_size1) = 1;
2913 TREE_NOTHROW (gfor_fndecl_size1) = 1;
2915 gfor_fndecl_iargc = gfc_build_library_function_decl (
2916 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2917 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
2921 /* Make prototypes for runtime library functions. */
2924 gfc_build_builtin_function_decls (void)
2926 tree gfc_int4_type_node = gfc_get_int_type (4);
2928 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2929 get_identifier (PREFIX("stop_numeric")),
2930 void_type_node, 1, gfc_int4_type_node);
2931 /* STOP doesn't return. */
2932 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2934 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
2935 get_identifier (PREFIX("stop_numeric_f08")),
2936 void_type_node, 1, gfc_int4_type_node);
2937 /* STOP doesn't return. */
2938 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
2940 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2941 get_identifier (PREFIX("stop_string")), ".R.",
2942 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2943 /* STOP doesn't return. */
2944 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2946 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2947 get_identifier (PREFIX("error_stop_numeric")),
2948 void_type_node, 1, gfc_int4_type_node);
2949 /* ERROR STOP doesn't return. */
2950 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2952 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2953 get_identifier (PREFIX("error_stop_string")), ".R.",
2954 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2955 /* ERROR STOP doesn't return. */
2956 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2958 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2959 get_identifier (PREFIX("pause_numeric")),
2960 void_type_node, 1, gfc_int4_type_node);
2962 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2963 get_identifier (PREFIX("pause_string")), ".R.",
2964 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2966 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2967 get_identifier (PREFIX("runtime_error")), ".R",
2968 void_type_node, -1, pchar_type_node);
2969 /* The runtime_error function does not return. */
2970 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2972 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2973 get_identifier (PREFIX("runtime_error_at")), ".RR",
2974 void_type_node, -2, pchar_type_node, pchar_type_node);
2975 /* The runtime_error_at function does not return. */
2976 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2978 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2979 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2980 void_type_node, -2, pchar_type_node, pchar_type_node);
2982 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2983 get_identifier (PREFIX("generate_error")), ".R.R",
2984 void_type_node, 3, pvoid_type_node, integer_type_node,
2987 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2988 get_identifier (PREFIX("os_error")), ".R",
2989 void_type_node, 1, pchar_type_node);
2990 /* The runtime_error function does not return. */
2991 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2993 gfor_fndecl_set_args = gfc_build_library_function_decl (
2994 get_identifier (PREFIX("set_args")),
2995 void_type_node, 2, integer_type_node,
2996 build_pointer_type (pchar_type_node));
2998 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2999 get_identifier (PREFIX("set_fpe")),
3000 void_type_node, 1, integer_type_node);
3002 /* Keep the array dimension in sync with the call, later in this file. */
3003 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3004 get_identifier (PREFIX("set_options")), "..R",
3005 void_type_node, 2, integer_type_node,
3006 build_pointer_type (integer_type_node));
3008 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3009 get_identifier (PREFIX("set_convert")),
3010 void_type_node, 1, integer_type_node);
3012 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3013 get_identifier (PREFIX("set_record_marker")),
3014 void_type_node, 1, integer_type_node);
3016 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3017 get_identifier (PREFIX("set_max_subrecord_length")),
3018 void_type_node, 1, integer_type_node);
3020 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3021 get_identifier (PREFIX("internal_pack")), ".r",
3022 pvoid_type_node, 1, pvoid_type_node);
3024 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3025 get_identifier (PREFIX("internal_unpack")), ".wR",
3026 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3028 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3029 get_identifier (PREFIX("associated")), ".RR",
3030 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3031 DECL_PURE_P (gfor_fndecl_associated) = 1;
3032 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3034 /* Coarray library calls. */
3035 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3037 tree pint_type, pppchar_type;
3039 pint_type = build_pointer_type (integer_type_node);
3041 = build_pointer_type (build_pointer_type (pchar_type_node));
3043 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3044 get_identifier (PREFIX("caf_init")), void_type_node,
3045 4, pint_type, pppchar_type, pint_type, pint_type);
3047 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3048 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3050 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3051 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3052 size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3053 build_pointer_type (pchar_type_node), integer_type_node);
3055 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3056 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3058 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3059 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3061 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3062 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3063 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3065 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3066 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3067 5, integer_type_node, pint_type, pint_type,
3068 build_pointer_type (pchar_type_node), integer_type_node);
3070 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3071 get_identifier (PREFIX("caf_error_stop")),
3072 void_type_node, 1, gfc_int4_type_node);
3073 /* CAF's ERROR STOP doesn't return. */
3074 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3076 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3077 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3078 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3079 /* CAF's ERROR STOP doesn't return. */
3080 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3083 gfc_build_intrinsic_function_decls ();
3084 gfc_build_intrinsic_lib_fndecls ();
3085 gfc_build_io_library_fndecls ();
3089 /* Evaluate the length of dummy character variables. */
3092 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3093 gfc_wrapped_block *block)
3097 gfc_finish_decl (cl->backend_decl);
3099 gfc_start_block (&init);
3101 /* Evaluate the string length expression. */
3102 gfc_conv_string_length (cl, NULL, &init);
3104 gfc_trans_vla_type_sizes (sym, &init);
3106 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3110 /* Allocate and cleanup an automatic character variable. */
3113 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3119 gcc_assert (sym->backend_decl);
3120 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3122 gfc_init_block (&init);
3124 /* Evaluate the string length expression. */
3125 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3127 gfc_trans_vla_type_sizes (sym, &init);
3129 decl = sym->backend_decl;
3131 /* Emit a DECL_EXPR for this variable, which will cause the
3132 gimplifier to allocate storage, and all that good stuff. */
3133 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3134 gfc_add_expr_to_block (&init, tmp);
3136 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3139 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3142 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3146 gcc_assert (sym->backend_decl);
3147 gfc_start_block (&init);
3149 /* Set the initial value to length. See the comments in
3150 function gfc_add_assign_aux_vars in this file. */
3151 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3152 build_int_cst (gfc_charlen_type_node, -2));
3154 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3158 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3160 tree t = *tp, var, val;
3162 if (t == NULL || t == error_mark_node)
3164 if (TREE_CONSTANT (t) || DECL_P (t))
3167 if (TREE_CODE (t) == SAVE_EXPR)
3169 if (SAVE_EXPR_RESOLVED_P (t))
3171 *tp = TREE_OPERAND (t, 0);
3174 val = TREE_OPERAND (t, 0);
3179 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3180 gfc_add_decl_to_function (var);
3181 gfc_add_modify (body, var, val);
3182 if (TREE_CODE (t) == SAVE_EXPR)
3183 TREE_OPERAND (t, 0) = var;
3188 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3192 if (type == NULL || type == error_mark_node)
3195 type = TYPE_MAIN_VARIANT (type);
3197 if (TREE_CODE (type) == INTEGER_TYPE)
3199 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3200 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3202 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3204 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3205 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3208 else if (TREE_CODE (type) == ARRAY_TYPE)
3210 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3211 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3212 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3213 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3215 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3217 TYPE_SIZE (t) = TYPE_SIZE (type);
3218 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3223 /* Make sure all type sizes and array domains are either constant,
3224 or variable or parameter decls. This is a simplified variant
3225 of gimplify_type_sizes, but we can't use it here, as none of the
3226 variables in the expressions have been gimplified yet.
3227 As type sizes and domains for various variable length arrays
3228 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3229 time, without this routine gimplify_type_sizes in the middle-end
3230 could result in the type sizes being gimplified earlier than where
3231 those variables are initialized. */
3234 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3236 tree type = TREE_TYPE (sym->backend_decl);
3238 if (TREE_CODE (type) == FUNCTION_TYPE
3239 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3241 if (! current_fake_result_decl)
3244 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3247 while (POINTER_TYPE_P (type))
3248 type = TREE_TYPE (type);
3250 if (GFC_DESCRIPTOR_TYPE_P (type))
3252 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3254 while (POINTER_TYPE_P (etype))
3255 etype = TREE_TYPE (etype);
3257 gfc_trans_vla_type_sizes_1 (etype, body);
3260 gfc_trans_vla_type_sizes_1 (type, body);
3264 /* Initialize a derived type by building an lvalue from the symbol
3265 and using trans_assignment to do the work. Set dealloc to false
3266 if no deallocation prior the assignment is needed. */
3268 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3276 gcc_assert (!sym->attr.allocatable);
3277 gfc_set_sym_referenced (sym);
3278 e = gfc_lval_expr_from_sym (sym);
3279 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3280 if (sym->attr.dummy && (sym->attr.optional
3281 || sym->ns->proc_name->attr.entry_master))
3283 present = gfc_conv_expr_present (sym);
3284 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3285 tmp, build_empty_stmt (input_location));
3287 gfc_add_expr_to_block (block, tmp);
3292 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3293 them their default initializer, if they do not have allocatable
3294 components, they have their allocatable components deallocated. */
3297 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3300 gfc_formal_arglist *f;
3304 gfc_init_block (&init);
3305 for (f = proc_sym->formal; f; f = f->next)
3306 if (f->sym && f->sym->attr.intent == INTENT_OUT
3307 && !f->sym->attr.pointer
3308 && f->sym->ts.type == BT_DERIVED)
3310 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3312 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3313 f->sym->backend_decl,
3314 f->sym->as ? f->sym->as->rank : 0);
3316 if (f->sym->attr.optional
3317 || f->sym->ns->proc_name->attr.entry_master)
3319 present = gfc_conv_expr_present (f->sym);
3320 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3322 build_empty_stmt (input_location));
3325 gfc_add_expr_to_block (&init, tmp);
3327 else if (f->sym->value)
3328 gfc_init_default_dt (f->sym, &init, true);
3330 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3331 && f->sym->ts.type == BT_CLASS
3332 && !CLASS_DATA (f->sym)->attr.class_pointer
3333 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3335 tree decl = build_fold_indirect_ref_loc (input_location,
3336 f->sym->backend_decl);
3337 tmp = CLASS_DATA (f->sym)->backend_decl;
3338 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3339 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3340 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3341 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3343 CLASS_DATA (f->sym)->as ?
3344 CLASS_DATA (f->sym)->as->rank : 0);
3346 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3348 present = gfc_conv_expr_present (f->sym);
3349 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3351 build_empty_stmt (input_location));
3354 gfc_add_expr_to_block (&init, tmp);
3357 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3361 /* Generate function entry and exit code, and add it to the function body.
3363 Allocation and initialization of array variables.
3364 Allocation of character string variables.
3365 Initialization and possibly repacking of dummy arrays.
3366 Initialization of ASSIGN statement auxiliary variable.
3367 Initialization of ASSOCIATE names.
3368 Automatic deallocation. */
3371 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3375 gfc_formal_arglist *f;
3376 stmtblock_t tmpblock;
3377 bool seen_trans_deferred_array = false;
3383 /* Deal with implicit return variables. Explicit return variables will
3384 already have been added. */
3385 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3387 if (!current_fake_result_decl)
3389 gfc_entry_list *el = NULL;
3390 if (proc_sym->attr.entry_master)
3392 for (el = proc_sym->ns->entries; el; el = el->next)
3393 if (el->sym != el->sym->result)
3396 /* TODO: move to the appropriate place in resolve.c. */
3397 if (warn_return_type && el == NULL)
3398 gfc_warning ("Return value of function '%s' at %L not set",
3399 proc_sym->name, &proc_sym->declared_at);
3401 else if (proc_sym->as)
3403 tree result = TREE_VALUE (current_fake_result_decl);
3404 gfc_trans_dummy_array_bias (proc_sym, result, block);
3406 /* An automatic character length, pointer array result. */
3407 if (proc_sym->ts.type == BT_CHARACTER
3408 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3409 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3411 else if (proc_sym->ts.type == BT_CHARACTER)
3413 if (proc_sym->ts.deferred)
3416 gfc_save_backend_locus (&loc);
3417 gfc_set_backend_locus (&proc_sym->declared_at);
3418 gfc_start_block (&init);
3419 /* Zero the string length on entry. */
3420 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3421 build_int_cst (gfc_charlen_type_node, 0));
3422 /* Null the pointer. */
3423 e = gfc_lval_expr_from_sym (proc_sym);
3424 gfc_init_se (&se, NULL);
3425 se.want_pointer = 1;
3426 gfc_conv_expr (&se, e);
3429 gfc_add_modify (&init, tmp,
3430 fold_convert (TREE_TYPE (se.expr),
3431 null_pointer_node));
3432 gfc_restore_backend_locus (&loc);
3434 /* Pass back the string length on exit. */
3435 tmp = proc_sym->ts.u.cl->passed_length;
3436 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3437 tmp = fold_convert (gfc_charlen_type_node, tmp);
3438 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3439 gfc_charlen_type_node, tmp,
3440 proc_sym->ts.u.cl->backend_decl);
3441 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3443 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3444 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3447 gcc_assert (gfc_option.flag_f2c
3448 && proc_sym->ts.type == BT_COMPLEX);
3451 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3452 should be done here so that the offsets and lbounds of arrays
3454 gfc_save_backend_locus (&loc);
3455 gfc_set_backend_locus (&proc_sym->declared_at);
3456 init_intent_out_dt (proc_sym, block);
3457 gfc_restore_backend_locus (&loc);
3459 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3461 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3462 && sym->ts.u.derived->attr.alloc_comp;
3466 if (sym->attr.dimension || sym->attr.codimension)
3468 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3469 array_type tmp = sym->as->type;
3470 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3475 if (sym->attr.dummy || sym->attr.result)
3476 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3477 else if (sym->attr.pointer || sym->attr.allocatable)
3479 if (TREE_STATIC (sym->backend_decl))
3481 gfc_save_backend_locus (&loc);
3482 gfc_set_backend_locus (&sym->declared_at);
3483 gfc_trans_static_array_pointer (sym);
3484 gfc_restore_backend_locus (&loc);
3488 seen_trans_deferred_array = true;
3489 gfc_trans_deferred_array (sym, block);
3492 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3494 gfc_init_block (&tmpblock);
3495 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3497 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3501 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3503 gfc_save_backend_locus (&loc);
3504 gfc_set_backend_locus (&sym->declared_at);
3506 if (sym_has_alloc_comp)
3508 seen_trans_deferred_array = true;
3509 gfc_trans_deferred_array (sym, block);
3511 else if (sym->ts.type == BT_DERIVED
3514 && sym->attr.save == SAVE_NONE)
3516 gfc_start_block (&tmpblock);
3517 gfc_init_default_dt (sym, &tmpblock, false);
3518 gfc_add_init_cleanup (block,
3519 gfc_finish_block (&tmpblock),
3523 gfc_trans_auto_array_allocation (sym->backend_decl,
3525 gfc_restore_backend_locus (&loc);
3529 case AS_ASSUMED_SIZE:
3530 /* Must be a dummy parameter. */
3531 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3533 /* We should always pass assumed size arrays the g77 way. */
3534 if (sym->attr.dummy)
3535 gfc_trans_g77_array (sym, block);
3538 case AS_ASSUMED_SHAPE:
3539 /* Must be a dummy parameter. */
3540 gcc_assert (sym->attr.dummy);
3542 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3546 seen_trans_deferred_array = true;
3547 gfc_trans_deferred_array (sym, block);
3553 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3554 gfc_trans_deferred_array (sym, block);
3556 else if ((!sym->attr.dummy || sym->ts.deferred)
3557 && (sym->attr.allocatable
3558 || (sym->ts.type == BT_CLASS
3559 && CLASS_DATA (sym)->attr.allocatable)))
3561 if (!sym->attr.save)
3563 /* Nullify and automatic deallocation of allocatable
3565 e = gfc_lval_expr_from_sym (sym);
3566 if (sym->ts.type == BT_CLASS)
3567 gfc_add_data_component (e);
3569 gfc_init_se (&se, NULL);
3570 se.want_pointer = 1;
3571 gfc_conv_expr (&se, e);
3574 gfc_save_backend_locus (&loc);
3575 gfc_set_backend_locus (&sym->declared_at);
3576 gfc_start_block (&init);
3578 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3580 /* Nullify when entering the scope. */
3581 gfc_add_modify (&init, se.expr,
3582 fold_convert (TREE_TYPE (se.expr),
3583 null_pointer_node));
3586 if ((sym->attr.dummy ||sym->attr.result)
3587 && sym->ts.type == BT_CHARACTER
3588 && sym->ts.deferred)
3590 /* Character length passed by reference. */
3591 tmp = sym->ts.u.cl->passed_length;
3592 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3593 tmp = fold_convert (gfc_charlen_type_node, tmp);
3595 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3596 /* Zero the string length when entering the scope. */
3597 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3598 build_int_cst (gfc_charlen_type_node, 0));
3600 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3602 gfc_restore_backend_locus (&loc);
3604 /* Pass the final character length back. */
3605 if (sym->attr.intent != INTENT_IN)
3606 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3607 gfc_charlen_type_node, tmp,
3608 sym->ts.u.cl->backend_decl);
3613 gfc_restore_backend_locus (&loc);
3615 /* Deallocate when leaving the scope. Nullifying is not
3617 if (!sym->attr.result && !sym->attr.dummy)
3618 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3621 if (sym->ts.type == BT_CLASS)
3623 /* Initialize _vptr to declared type. */
3624 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3627 gfc_save_backend_locus (&loc);
3628 gfc_set_backend_locus (&sym->declared_at);
3629 e = gfc_lval_expr_from_sym (sym);
3630 gfc_add_vptr_component (e);
3631 gfc_init_se (&se, NULL);
3632 se.want_pointer = 1;
3633 gfc_conv_expr (&se, e);
3635 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3636 gfc_get_symbol_decl (vtab));
3637 gfc_add_modify (&init, se.expr, rhs);
3638 gfc_restore_backend_locus (&loc);
3641 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3644 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3649 /* If we get to here, all that should be left are pointers. */
3650 gcc_assert (sym->attr.pointer);
3652 if (sym->attr.dummy)
3654 gfc_start_block (&init);
3656 /* Character length passed by reference. */
3657 tmp = sym->ts.u.cl->passed_length;
3658 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3659 tmp = fold_convert (gfc_charlen_type_node, tmp);
3660 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3661 /* Pass the final character length back. */
3662 if (sym->attr.intent != INTENT_IN)
3663 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3664 gfc_charlen_type_node, tmp,
3665 sym->ts.u.cl->backend_decl);
3668 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3671 else if (sym->ts.deferred)
3672 gfc_fatal_error ("Deferred type parameter not yet supported");
3673 else if (sym_has_alloc_comp)
3674 gfc_trans_deferred_array (sym, block);
3675 else if (sym->ts.type == BT_CHARACTER)
3677 gfc_save_backend_locus (&loc);
3678 gfc_set_backend_locus (&sym->declared_at);
3679 if (sym->attr.dummy || sym->attr.result)
3680 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3682 gfc_trans_auto_character_variable (sym, block);
3683 gfc_restore_backend_locus (&loc);
3685 else if (sym->attr.assign)
3687 gfc_save_backend_locus (&loc);
3688 gfc_set_backend_locus (&sym->declared_at);
3689 gfc_trans_assign_aux_var (sym, block);
3690 gfc_restore_backend_locus (&loc);
3692 else if (sym->ts.type == BT_DERIVED
3695 && sym->attr.save == SAVE_NONE)
3697 gfc_start_block (&tmpblock);
3698 gfc_init_default_dt (sym, &tmpblock, false);
3699 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3706 gfc_init_block (&tmpblock);
3708 for (f = proc_sym->formal; f; f = f->next)
3710 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3712 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3713 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3714 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3718 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3719 && current_fake_result_decl != NULL)
3721 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3722 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3723 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3726 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3729 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3731 /* Hash and equality functions for module_htab. */
3734 module_htab_do_hash (const void *x)
3736 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3740 module_htab_eq (const void *x1, const void *x2)
3742 return strcmp ((((const struct module_htab_entry *)x1)->name),
3743 (const char *)x2) == 0;
3746 /* Hash and equality functions for module_htab's decls. */
3749 module_htab_decls_hash (const void *x)
3751 const_tree t = (const_tree) x;
3752 const_tree n = DECL_NAME (t);
3754 n = TYPE_NAME (TREE_TYPE (t));
3755 return htab_hash_string (IDENTIFIER_POINTER (n));
3759 module_htab_decls_eq (const void *x1, const void *x2)
3761 const_tree t1 = (const_tree) x1;
3762 const_tree n1 = DECL_NAME (t1);
3763 if (n1 == NULL_TREE)
3764 n1 = TYPE_NAME (TREE_TYPE (t1));
3765 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3768 struct module_htab_entry *
3769 gfc_find_module (const char *name)
3774 module_htab = htab_create_ggc (10, module_htab_do_hash,
3775 module_htab_eq, NULL);
3777 slot = htab_find_slot_with_hash (module_htab, name,
3778 htab_hash_string (name), INSERT);
3781 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3783 entry->name = gfc_get_string (name);
3784 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3785 module_htab_decls_eq, NULL);
3786 *slot = (void *) entry;
3788 return (struct module_htab_entry *) *slot;
3792 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3797 if (DECL_NAME (decl))
3798 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3801 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3802 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3804 slot = htab_find_slot_with_hash (entry->decls, name,
3805 htab_hash_string (name), INSERT);
3807 *slot = (void *) decl;
3810 static struct module_htab_entry *cur_module;
3812 /* Output an initialized decl for a module variable. */
3815 gfc_create_module_variable (gfc_symbol * sym)
3819 /* Module functions with alternate entries are dealt with later and
3820 would get caught by the next condition. */
3821 if (sym->attr.entry)
3824 /* Make sure we convert the types of the derived types from iso_c_binding
3826 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3827 && sym->ts.type == BT_DERIVED)
3828 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3830 if (sym->attr.flavor == FL_DERIVED
3831 && sym->backend_decl
3832 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3834 decl = sym->backend_decl;
3835 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3837 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3838 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3840 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3841 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3842 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3843 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3844 == sym->ns->proc_name->backend_decl);
3846 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3847 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3848 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3851 /* Only output variables, procedure pointers and array valued,
3852 or derived type, parameters. */
3853 if (sym->attr.flavor != FL_VARIABLE
3854 && !(sym->attr.flavor == FL_PARAMETER
3855 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3856 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3859 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3861 decl = sym->backend_decl;
3862 gcc_assert (DECL_FILE_SCOPE_P (decl));
3863 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3864 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3865 gfc_module_add_decl (cur_module, decl);
3868 /* Don't generate variables from other modules. Variables from
3869 COMMONs will already have been generated. */
3870 if (sym->attr.use_assoc || sym->attr.in_common)
3873 /* Equivalenced variables arrive here after creation. */
3874 if (sym->backend_decl
3875 && (sym->equiv_built || sym->attr.in_equivalence))
3878 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
3879 internal_error ("backend decl for module variable %s already exists",
3882 /* We always want module variables to be created. */
3883 sym->attr.referenced = 1;
3884 /* Create the decl. */
3885 decl = gfc_get_symbol_decl (sym);
3887 /* Create the variable. */
3889 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3890 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3891 rest_of_decl_compilation (decl, 1, 0);
3892 gfc_module_add_decl (cur_module, decl);
3894 /* Also add length of strings. */
3895 if (sym->ts.type == BT_CHARACTER)
3899 length = sym->ts.u.cl->backend_decl;
3900 gcc_assert (length || sym->attr.proc_pointer);
3901 if (length && !INTEGER_CST_P (length))
3904 rest_of_decl_compilation (length, 1, 0);
3908 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
3909 && sym->attr.referenced && !sym->attr.use_assoc)
3910 has_coarray_vars = true;
3913 /* Emit debug information for USE statements. */
3916 gfc_trans_use_stmts (gfc_namespace * ns)
3918 gfc_use_list *use_stmt;
3919 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3921 struct module_htab_entry *entry
3922 = gfc_find_module (use_stmt->module_name);
3923 gfc_use_rename *rent;
3925 if (entry->namespace_decl == NULL)
3927 entry->namespace_decl
3928 = build_decl (input_location,
3930 get_identifier (use_stmt->module_name),
3932 DECL_EXTERNAL (entry->namespace_decl) = 1;
3934 gfc_set_backend_locus (&use_stmt->where);
3935 if (!use_stmt->only_flag)
3936 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3938 ns->proc_name->backend_decl,
3940 for (rent = use_stmt->rename; rent; rent = rent->next)
3942 tree decl, local_name;
3945 if (rent->op != INTRINSIC_NONE)
3948 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3949 htab_hash_string (rent->use_name),
3955 st = gfc_find_symtree (ns->sym_root,
3957 ? rent->local_name : rent->use_name);
3960 /* Sometimes, generic interfaces wind up being over-ruled by a
3961 local symbol (see PR41062). */
3962 if (!st->n.sym->attr.use_assoc)
3965 if (st->n.sym->backend_decl
3966 && DECL_P (st->n.sym->backend_decl)
3967 && st->n.sym->module
3968 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3970 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3971 || (TREE_CODE (st->n.sym->backend_decl)
3973 decl = copy_node (st->n.sym->backend_decl);
3974 DECL_CONTEXT (decl) = entry->namespace_decl;
3975 DECL_EXTERNAL (decl) = 1;
3976 DECL_IGNORED_P (decl) = 0;
3977 DECL_INITIAL (decl) = NULL_TREE;
3981 *slot = error_mark_node;
3982 htab_clear_slot (entry->decls, slot);
3987 decl = (tree) *slot;
3988 if (rent->local_name[0])
3989 local_name = get_identifier (rent->local_name);
3991 local_name = NULL_TREE;
3992 gfc_set_backend_locus (&rent->where);
3993 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3994 ns->proc_name->backend_decl,
3995 !use_stmt->only_flag);
4001 /* Return true if expr is a constant initializer that gfc_conv_initializer
4005 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4015 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4017 else if (expr->expr_type == EXPR_STRUCTURE)
4018 return check_constant_initializer (expr, ts, false, false);
4019 else if (expr->expr_type != EXPR_ARRAY)
4021 for (c = gfc_constructor_first (expr->value.constructor);
4022 c; c = gfc_constructor_next (c))
4026 if (c->expr->expr_type == EXPR_STRUCTURE)
4028 if (!check_constant_initializer (c->expr, ts, false, false))
4031 else if (c->expr->expr_type != EXPR_CONSTANT)
4036 else switch (ts->type)
4039 if (expr->expr_type != EXPR_STRUCTURE)
4041 cm = expr->ts.u.derived->components;
4042 for (c = gfc_constructor_first (expr->value.constructor);
4043 c; c = gfc_constructor_next (c), cm = cm->next)
4045 if (!c->expr || cm->attr.allocatable)
4047 if (!check_constant_initializer (c->expr, &cm->ts,
4054 return expr->expr_type == EXPR_CONSTANT;
4058 /* Emit debug info for parameters and unreferenced variables with
4062 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4066 if (sym->attr.flavor != FL_PARAMETER
4067 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4070 if (sym->backend_decl != NULL
4071 || sym->value == NULL
4072 || sym->attr.use_assoc
4075 || sym->attr.function
4076 || sym->attr.intrinsic
4077 || sym->attr.pointer
4078 || sym->attr.allocatable
4079 || sym->attr.cray_pointee
4080 || sym->attr.threadprivate
4081 || sym->attr.is_bind_c
4082 || sym->attr.subref_array_pointer
4083 || sym->attr.assign)
4086 if (sym->ts.type == BT_CHARACTER)
4088 gfc_conv_const_charlen (sym->ts.u.cl);
4089 if (sym->ts.u.cl->backend_decl == NULL
4090 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4093 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4100 if (sym->as->type != AS_EXPLICIT)
4102 for (n = 0; n < sym->as->rank; n++)
4103 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4104 || sym->as->upper[n] == NULL
4105 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4109 if (!check_constant_initializer (sym->value, &sym->ts,
4110 sym->attr.dimension, false))
4113 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4116 /* Create the decl for the variable or constant. */
4117 decl = build_decl (input_location,
4118 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4119 gfc_sym_identifier (sym), gfc_sym_type (sym));
4120 if (sym->attr.flavor == FL_PARAMETER)
4121 TREE_READONLY (decl) = 1;
4122 gfc_set_decl_location (decl, &sym->declared_at);
4123 if (sym->attr.dimension)
4124 GFC_DECL_PACKED_ARRAY (decl) = 1;
4125 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4126 TREE_STATIC (decl) = 1;
4127 TREE_USED (decl) = 1;
4128 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4129 TREE_PUBLIC (decl) = 1;
4130 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4132 sym->attr.dimension,
4134 debug_hooks->global_decl (decl);
4139 generate_coarray_sym_init (gfc_symbol *sym)
4141 tree tmp, size, decl, token;
4143 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4144 || sym->attr.use_assoc || !sym->attr.referenced)
4147 decl = sym->backend_decl;
4148 TREE_USED(decl) = 1;
4149 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4151 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4152 to make sure the variable is not optimized away. */
4153 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4155 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4157 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4159 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4160 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4161 fold_convert (size_type_node, tmp),
4162 fold_convert (size_type_node, size));
4165 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4166 token = gfc_build_addr_expr (ppvoid_type_node,
4167 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4169 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4170 build_int_cst (integer_type_node, 0), /* type. */
4171 token, null_pointer_node, /* token, stat. */
4172 null_pointer_node, /* errgmsg, errmsg_len. */
4173 build_int_cst (integer_type_node, 0));
4175 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4178 /* Handle "static" initializer. */
4181 sym->attr.pointer = 1;
4182 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4184 sym->attr.pointer = 0;
4185 gfc_add_expr_to_block (&caf_init_block, tmp);
4190 /* Generate constructor function to initialize static, nonallocatable
4194 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4196 tree fndecl, tmp, decl, save_fn_decl;
4198 save_fn_decl = current_function_decl;
4199 push_function_context ();
4201 tmp = build_function_type_list (void_type_node, NULL_TREE);
4202 fndecl = build_decl (input_location, FUNCTION_DECL,
4203 create_tmp_var_name ("_caf_init"), tmp);
4205 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4206 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4208 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4209 DECL_ARTIFICIAL (decl) = 1;
4210 DECL_IGNORED_P (decl) = 1;
4211 DECL_CONTEXT (decl) = fndecl;
4212 DECL_RESULT (fndecl) = decl;
4215 current_function_decl = fndecl;
4216 announce_function (fndecl);
4218 rest_of_decl_compilation (fndecl, 0, 0);
4219 make_decl_rtl (fndecl);
4220 init_function_start (fndecl);
4223 gfc_init_block (&caf_init_block);
4225 gfc_traverse_ns (ns, generate_coarray_sym_init);
4227 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4231 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4233 DECL_SAVED_TREE (fndecl)
4234 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4235 DECL_INITIAL (fndecl));
4236 dump_function (TDI_original, fndecl);
4238 cfun->function_end_locus = input_location;
4241 if (decl_function_context (fndecl))
4242 (void) cgraph_create_node (fndecl);
4244 cgraph_finalize_function (fndecl, true);
4246 pop_function_context ();
4247 current_function_decl = save_fn_decl;
4251 /* Generate all the required code for module variables. */
4254 gfc_generate_module_vars (gfc_namespace * ns)
4256 module_namespace = ns;
4257 cur_module = gfc_find_module (ns->proc_name->name);
4259 /* Check if the frontend left the namespace in a reasonable state. */
4260 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4262 /* Generate COMMON blocks. */
4263 gfc_trans_common (ns);
4265 has_coarray_vars = false;
4267 /* Create decls for all the module variables. */
4268 gfc_traverse_ns (ns, gfc_create_module_variable);
4270 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4271 generate_coarray_init (ns);
4275 gfc_trans_use_stmts (ns);
4276 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4281 gfc_generate_contained_functions (gfc_namespace * parent)
4285 /* We create all the prototypes before generating any code. */
4286 for (ns = parent->contained; ns; ns = ns->sibling)
4288 /* Skip namespaces from used modules. */
4289 if (ns->parent != parent)
4292 gfc_create_function_decl (ns, false);
4295 for (ns = parent->contained; ns; ns = ns->sibling)
4297 /* Skip namespaces from used modules. */
4298 if (ns->parent != parent)
4301 gfc_generate_function_code (ns);
4306 /* Drill down through expressions for the array specification bounds and
4307 character length calling generate_local_decl for all those variables
4308 that have not already been declared. */
4311 generate_local_decl (gfc_symbol *);
4313 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4316 expr_decls (gfc_expr *e, gfc_symbol *sym,
4317 int *f ATTRIBUTE_UNUSED)
4319 if (e->expr_type != EXPR_VARIABLE
4320 || sym == e->symtree->n.sym
4321 || e->symtree->n.sym->mark
4322 || e->symtree->n.sym->ns != sym->ns)
4325 generate_local_decl (e->symtree->n.sym);
4330 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4332 gfc_traverse_expr (e, sym, expr_decls, 0);
4336 /* Check for dependencies in the character length and array spec. */
4339 generate_dependency_declarations (gfc_symbol *sym)
4343 if (sym->ts.type == BT_CHARACTER
4345 && sym->ts.u.cl->length
4346 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4347 generate_expr_decls (sym, sym->ts.u.cl->length);
4349 if (sym->as && sym->as->rank)
4351 for (i = 0; i < sym->as->rank; i++)
4353 generate_expr_decls (sym, sym->as->lower[i]);
4354 generate_expr_decls (sym, sym->as->upper[i]);
4360 /* Generate decls for all local variables. We do this to ensure correct
4361 handling of expressions which only appear in the specification of
4365 generate_local_decl (gfc_symbol * sym)
4367 if (sym->attr.flavor == FL_VARIABLE)
4369 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4370 && sym->attr.referenced && !sym->attr.use_assoc)
4371 has_coarray_vars = true;
4373 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4374 generate_dependency_declarations (sym);
4376 if (sym->attr.referenced)
4377 gfc_get_symbol_decl (sym);
4379 /* Warnings for unused dummy arguments. */
4380 else if (sym->attr.dummy)
4382 /* INTENT(out) dummy arguments are likely meant to be set. */
4383 if (gfc_option.warn_unused_dummy_argument
4384 && sym->attr.intent == INTENT_OUT)
4386 if (sym->ts.type != BT_DERIVED)
4387 gfc_warning ("Dummy argument '%s' at %L was declared "
4388 "INTENT(OUT) but was not set", sym->name,
4390 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4391 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4392 "declared INTENT(OUT) but was not set and "
4393 "does not have a default initializer",
4394 sym->name, &sym->declared_at);
4396 else if (gfc_option.warn_unused_dummy_argument)
4397 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4401 /* Warn for unused variables, but not if they're inside a common
4402 block, a namelist, or are use-associated. */
4403 else if (warn_unused_variable
4404 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4405 || sym->attr.in_namelist))
4406 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4409 /* For variable length CHARACTER parameters, the PARM_DECL already
4410 references the length variable, so force gfc_get_symbol_decl
4411 even when not referenced. If optimize > 0, it will be optimized
4412 away anyway. But do this only after emitting -Wunused-parameter
4413 warning if requested. */
4414 if (sym->attr.dummy && !sym->attr.referenced
4415 && sym->ts.type == BT_CHARACTER
4416 && sym->ts.u.cl->backend_decl != NULL
4417 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4419 sym->attr.referenced = 1;
4420 gfc_get_symbol_decl (sym);
4423 /* INTENT(out) dummy arguments and result variables with allocatable
4424 components are reset by default and need to be set referenced to
4425 generate the code for nullification and automatic lengths. */
4426 if (!sym->attr.referenced
4427 && sym->ts.type == BT_DERIVED
4428 && sym->ts.u.derived->attr.alloc_comp
4429 && !sym->attr.pointer
4430 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4432 (sym->attr.result && sym != sym->result)))
4434 sym->attr.referenced = 1;
4435 gfc_get_symbol_decl (sym);
4438 /* Check for dependencies in the array specification and string
4439 length, adding the necessary declarations to the function. We
4440 mark the symbol now, as well as in traverse_ns, to prevent
4441 getting stuck in a circular dependency. */
4444 /* We do not want the middle-end to warn about unused parameters
4445 as this was already done above. */
4446 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4447 TREE_NO_WARNING(sym->backend_decl) = 1;
4449 else if (sym->attr.flavor == FL_PARAMETER)
4451 if (warn_unused_parameter
4452 && !sym->attr.referenced
4453 && !sym->attr.use_assoc)
4454 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4457 else if (sym->attr.flavor == FL_PROCEDURE)
4459 /* TODO: move to the appropriate place in resolve.c. */
4460 if (warn_return_type
4461 && sym->attr.function
4463 && sym != sym->result
4464 && !sym->result->attr.referenced
4465 && !sym->attr.use_assoc
4466 && sym->attr.if_source != IFSRC_IFBODY)
4468 gfc_warning ("Return value '%s' of function '%s' declared at "
4469 "%L not set", sym->result->name, sym->name,
4470 &sym->result->declared_at);
4472 /* Prevents "Unused variable" warning for RESULT variables. */
4473 sym->result->mark = 1;
4477 if (sym->attr.dummy == 1)
4479 /* Modify the tree type for scalar character dummy arguments of bind(c)
4480 procedures if they are passed by value. The tree type for them will
4481 be promoted to INTEGER_TYPE for the middle end, which appears to be
4482 what C would do with characters passed by-value. The value attribute
4483 implies the dummy is a scalar. */
4484 if (sym->attr.value == 1 && sym->backend_decl != NULL
4485 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4486 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4487 gfc_conv_scalar_char_value (sym, NULL, NULL);
4490 /* Make sure we convert the types of the derived types from iso_c_binding
4492 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4493 && sym->ts.type == BT_DERIVED)
4494 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4498 generate_local_vars (gfc_namespace * ns)
4500 gfc_traverse_ns (ns, generate_local_decl);
4504 /* Generate a switch statement to jump to the correct entry point. Also
4505 creates the label decls for the entry points. */
4508 gfc_trans_entry_master_switch (gfc_entry_list * el)
4515 gfc_init_block (&block);
4516 for (; el; el = el->next)
4518 /* Add the case label. */
4519 label = gfc_build_label_decl (NULL_TREE);
4520 val = build_int_cst (gfc_array_index_type, el->id);
4521 tmp = build_case_label (val, NULL_TREE, label);
4522 gfc_add_expr_to_block (&block, tmp);
4524 /* And jump to the actual entry point. */
4525 label = gfc_build_label_decl (NULL_TREE);
4526 tmp = build1_v (GOTO_EXPR, label);
4527 gfc_add_expr_to_block (&block, tmp);
4529 /* Save the label decl. */
4532 tmp = gfc_finish_block (&block);
4533 /* The first argument selects the entry point. */
4534 val = DECL_ARGUMENTS (current_function_decl);
4535 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4540 /* Add code to string lengths of actual arguments passed to a function against
4541 the expected lengths of the dummy arguments. */
4544 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4546 gfc_formal_arglist *formal;
4548 for (formal = sym->formal; formal; formal = formal->next)
4549 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4551 enum tree_code comparison;
4556 const char *message;
4562 gcc_assert (cl->passed_length != NULL_TREE);
4563 gcc_assert (cl->backend_decl != NULL_TREE);
4565 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4566 string lengths must match exactly. Otherwise, it is only required
4567 that the actual string length is *at least* the expected one.
4568 Sequence association allows for a mismatch of the string length
4569 if the actual argument is (part of) an array, but only if the
4570 dummy argument is an array. (See "Sequence association" in
4571 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4572 if (fsym->attr.pointer || fsym->attr.allocatable
4573 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4575 comparison = NE_EXPR;
4576 message = _("Actual string length does not match the declared one"
4577 " for dummy argument '%s' (%ld/%ld)");
4579 else if (fsym->as && fsym->as->rank != 0)
4583 comparison = LT_EXPR;
4584 message = _("Actual string length is shorter than the declared one"
4585 " for dummy argument '%s' (%ld/%ld)");
4588 /* Build the condition. For optional arguments, an actual length
4589 of 0 is also acceptable if the associated string is NULL, which
4590 means the argument was not passed. */
4591 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4592 cl->passed_length, cl->backend_decl);
4593 if (fsym->attr.optional)
4599 not_0length = fold_build2_loc (input_location, NE_EXPR,
4602 build_zero_cst (gfc_charlen_type_node));
4603 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4604 fsym->attr.referenced = 1;
4605 not_absent = gfc_conv_expr_present (fsym);
4607 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4608 boolean_type_node, not_0length,
4611 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4612 boolean_type_node, cond, absent_failed);
4615 /* Build the runtime check. */
4616 argname = gfc_build_cstring_const (fsym->name);
4617 argname = gfc_build_addr_expr (pchar_type_node, argname);
4618 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4620 fold_convert (long_integer_type_node,
4622 fold_convert (long_integer_type_node,
4628 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4629 global variables for -fcoarray=lib. They are placed into the translation
4630 unit of the main program. Make sure that in one TU (the one of the main
4631 program), the first call to gfc_init_coarray_decl is done with true.
4632 Otherwise, expect link errors. */
4635 gfc_init_coarray_decl (bool main_tu)
4639 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4642 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4645 save_fn_decl = current_function_decl;
4646 current_function_decl = NULL_TREE;
4649 gfort_gvar_caf_this_image
4650 = build_decl (input_location, VAR_DECL,
4651 get_identifier (PREFIX("caf_this_image")),
4653 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4654 TREE_USED (gfort_gvar_caf_this_image) = 1;
4655 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4656 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4659 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4661 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4663 pushdecl_top_level (gfort_gvar_caf_this_image);
4665 gfort_gvar_caf_num_images
4666 = build_decl (input_location, VAR_DECL,
4667 get_identifier (PREFIX("caf_num_images")),
4669 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4670 TREE_USED (gfort_gvar_caf_num_images) = 1;
4671 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4672 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4675 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4677 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4679 pushdecl_top_level (gfort_gvar_caf_num_images);
4682 current_function_decl = save_fn_decl;
4687 create_main_function (tree fndecl)
4691 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4694 old_context = current_function_decl;
4698 push_function_context ();
4699 saved_parent_function_decls = saved_function_decls;
4700 saved_function_decls = NULL_TREE;
4703 /* main() function must be declared with global scope. */
4704 gcc_assert (current_function_decl == NULL_TREE);
4706 /* Declare the function. */
4707 tmp = build_function_type_list (integer_type_node, integer_type_node,
4708 build_pointer_type (pchar_type_node),
4710 main_identifier_node = get_identifier ("main");
4711 ftn_main = build_decl (input_location, FUNCTION_DECL,
4712 main_identifier_node, tmp);
4713 DECL_EXTERNAL (ftn_main) = 0;
4714 TREE_PUBLIC (ftn_main) = 1;
4715 TREE_STATIC (ftn_main) = 1;
4716 DECL_ATTRIBUTES (ftn_main)
4717 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4719 /* Setup the result declaration (for "return 0"). */
4720 result_decl = build_decl (input_location,
4721 RESULT_DECL, NULL_TREE, integer_type_node);
4722 DECL_ARTIFICIAL (result_decl) = 1;
4723 DECL_IGNORED_P (result_decl) = 1;
4724 DECL_CONTEXT (result_decl) = ftn_main;
4725 DECL_RESULT (ftn_main) = result_decl;
4727 pushdecl (ftn_main);
4729 /* Get the arguments. */
4731 arglist = NULL_TREE;
4732 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4734 tmp = TREE_VALUE (typelist);
4735 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4736 DECL_CONTEXT (argc) = ftn_main;
4737 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4738 TREE_READONLY (argc) = 1;
4739 gfc_finish_decl (argc);
4740 arglist = chainon (arglist, argc);
4742 typelist = TREE_CHAIN (typelist);
4743 tmp = TREE_VALUE (typelist);
4744 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4745 DECL_CONTEXT (argv) = ftn_main;
4746 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4747 TREE_READONLY (argv) = 1;
4748 DECL_BY_REFERENCE (argv) = 1;
4749 gfc_finish_decl (argv);
4750 arglist = chainon (arglist, argv);
4752 DECL_ARGUMENTS (ftn_main) = arglist;
4753 current_function_decl = ftn_main;
4754 announce_function (ftn_main);
4756 rest_of_decl_compilation (ftn_main, 1, 0);
4757 make_decl_rtl (ftn_main);
4758 init_function_start (ftn_main);
4761 gfc_init_block (&body);
4763 /* Call some libgfortran initialization routines, call then MAIN__(). */
4765 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4766 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4768 tree pint_type, pppchar_type;
4769 pint_type = build_pointer_type (integer_type_node);
4771 = build_pointer_type (build_pointer_type (pchar_type_node));
4773 gfc_init_coarray_decl (true);
4774 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4775 gfc_build_addr_expr (pint_type, argc),
4776 gfc_build_addr_expr (pppchar_type, argv),
4777 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4778 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4779 gfc_add_expr_to_block (&body, tmp);
4782 /* Call _gfortran_set_args (argc, argv). */
4783 TREE_USED (argc) = 1;
4784 TREE_USED (argv) = 1;
4785 tmp = build_call_expr_loc (input_location,
4786 gfor_fndecl_set_args, 2, argc, argv);
4787 gfc_add_expr_to_block (&body, tmp);
4789 /* Add a call to set_options to set up the runtime library Fortran
4790 language standard parameters. */
4792 tree array_type, array, var;
4793 VEC(constructor_elt,gc) *v = NULL;
4795 /* Passing a new option to the library requires four modifications:
4796 + add it to the tree_cons list below
4797 + change the array size in the call to build_array_type
4798 + change the first argument to the library call
4799 gfor_fndecl_set_options
4800 + modify the library (runtime/compile_options.c)! */
4802 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4803 build_int_cst (integer_type_node,
4804 gfc_option.warn_std));
4805 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4806 build_int_cst (integer_type_node,
4807 gfc_option.allow_std));
4808 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4809 build_int_cst (integer_type_node, pedantic));
4810 /* TODO: This is the old -fdump-core option, which is unused but
4811 passed due to ABI compatibility; remove when bumping the
4813 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4814 build_int_cst (integer_type_node,
4816 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4817 build_int_cst (integer_type_node,
4818 gfc_option.flag_backtrace));
4819 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4820 build_int_cst (integer_type_node,
4821 gfc_option.flag_sign_zero));
4822 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4823 build_int_cst (integer_type_node,
4825 & GFC_RTCHECK_BOUNDS)));
4826 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4827 build_int_cst (integer_type_node,
4828 gfc_option.flag_range_check));
4830 array_type = build_array_type (integer_type_node,
4831 build_index_type (size_int (7)));
4832 array = build_constructor (array_type, v);
4833 TREE_CONSTANT (array) = 1;
4834 TREE_STATIC (array) = 1;
4836 /* Create a static variable to hold the jump table. */
4837 var = gfc_create_var (array_type, "options");
4838 TREE_CONSTANT (var) = 1;
4839 TREE_STATIC (var) = 1;
4840 TREE_READONLY (var) = 1;
4841 DECL_INITIAL (var) = array;
4842 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4844 tmp = build_call_expr_loc (input_location,
4845 gfor_fndecl_set_options, 2,
4846 build_int_cst (integer_type_node, 8), var);
4847 gfc_add_expr_to_block (&body, tmp);
4850 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4851 the library will raise a FPE when needed. */
4852 if (gfc_option.fpe != 0)
4854 tmp = build_call_expr_loc (input_location,
4855 gfor_fndecl_set_fpe, 1,
4856 build_int_cst (integer_type_node,
4858 gfc_add_expr_to_block (&body, tmp);
4861 /* If this is the main program and an -fconvert option was provided,
4862 add a call to set_convert. */
4864 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4866 tmp = build_call_expr_loc (input_location,
4867 gfor_fndecl_set_convert, 1,
4868 build_int_cst (integer_type_node,
4869 gfc_option.convert));
4870 gfc_add_expr_to_block (&body, tmp);
4873 /* If this is the main program and an -frecord-marker option was provided,
4874 add a call to set_record_marker. */
4876 if (gfc_option.record_marker != 0)
4878 tmp = build_call_expr_loc (input_location,
4879 gfor_fndecl_set_record_marker, 1,
4880 build_int_cst (integer_type_node,
4881 gfc_option.record_marker));
4882 gfc_add_expr_to_block (&body, tmp);
4885 if (gfc_option.max_subrecord_length != 0)
4887 tmp = build_call_expr_loc (input_location,
4888 gfor_fndecl_set_max_subrecord_length, 1,
4889 build_int_cst (integer_type_node,
4890 gfc_option.max_subrecord_length));
4891 gfc_add_expr_to_block (&body, tmp);
4894 /* Call MAIN__(). */
4895 tmp = build_call_expr_loc (input_location,
4897 gfc_add_expr_to_block (&body, tmp);
4899 /* Mark MAIN__ as used. */
4900 TREE_USED (fndecl) = 1;
4902 /* Coarray: Call _gfortran_caf_finalize(void). */
4903 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4905 /* Per F2008, 8.5.1 END of the main program implies a
4907 tmp = built_in_decls [BUILT_IN_SYNC_SYNCHRONIZE];
4908 tmp = build_call_expr_loc (input_location, tmp, 0);
4909 gfc_add_expr_to_block (&body, tmp);
4911 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
4912 gfc_add_expr_to_block (&body, tmp);
4916 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4917 DECL_RESULT (ftn_main),
4918 build_int_cst (integer_type_node, 0));
4919 tmp = build1_v (RETURN_EXPR, tmp);
4920 gfc_add_expr_to_block (&body, tmp);
4923 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4926 /* Finish off this function and send it for code generation. */
4928 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4930 DECL_SAVED_TREE (ftn_main)
4931 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4932 DECL_INITIAL (ftn_main));
4934 /* Output the GENERIC tree. */
4935 dump_function (TDI_original, ftn_main);
4937 cgraph_finalize_function (ftn_main, true);
4941 pop_function_context ();
4942 saved_function_decls = saved_parent_function_decls;
4944 current_function_decl = old_context;
4948 /* Get the result expression for a procedure. */
4951 get_proc_result (gfc_symbol* sym)
4953 if (sym->attr.subroutine || sym == sym->result)
4955 if (current_fake_result_decl != NULL)
4956 return TREE_VALUE (current_fake_result_decl);
4961 return sym->result->backend_decl;
4965 /* Generate an appropriate return-statement for a procedure. */
4968 gfc_generate_return (void)
4974 sym = current_procedure_symbol;
4975 fndecl = sym->backend_decl;
4977 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4981 result = get_proc_result (sym);
4983 /* Set the return value to the dummy result variable. The
4984 types may be different for scalar default REAL functions
4985 with -ff2c, therefore we have to convert. */
4986 if (result != NULL_TREE)
4988 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4989 result = fold_build2_loc (input_location, MODIFY_EXPR,
4990 TREE_TYPE (result), DECL_RESULT (fndecl),
4995 return build1_v (RETURN_EXPR, result);
4999 /* Generate code for a function. */
5002 gfc_generate_function_code (gfc_namespace * ns)
5008 stmtblock_t init, cleanup;
5010 gfc_wrapped_block try_block;
5011 tree recurcheckvar = NULL_TREE;
5013 gfc_symbol *previous_procedure_symbol;
5017 sym = ns->proc_name;
5018 previous_procedure_symbol = current_procedure_symbol;
5019 current_procedure_symbol = sym;
5021 /* Check that the frontend isn't still using this. */
5022 gcc_assert (sym->tlink == NULL);
5025 /* Create the declaration for functions with global scope. */
5026 if (!sym->backend_decl)
5027 gfc_create_function_decl (ns, false);
5029 fndecl = sym->backend_decl;
5030 old_context = current_function_decl;
5034 push_function_context ();
5035 saved_parent_function_decls = saved_function_decls;
5036 saved_function_decls = NULL_TREE;
5039 trans_function_start (sym);
5041 gfc_init_block (&init);
5043 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5045 /* Copy length backend_decls to all entry point result
5050 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5051 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5052 for (el = ns->entries; el; el = el->next)
5053 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5056 /* Translate COMMON blocks. */
5057 gfc_trans_common (ns);
5059 /* Null the parent fake result declaration if this namespace is
5060 a module function or an external procedures. */
5061 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5062 || ns->parent == NULL)
5063 parent_fake_result_decl = NULL_TREE;
5065 gfc_generate_contained_functions (ns);
5067 nonlocal_dummy_decls = NULL;
5068 nonlocal_dummy_decl_pset = NULL;
5070 has_coarray_vars = false;
5071 generate_local_vars (ns);
5073 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5074 generate_coarray_init (ns);
5076 /* Keep the parent fake result declaration in module functions
5077 or external procedures. */
5078 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5079 || ns->parent == NULL)
5080 current_fake_result_decl = parent_fake_result_decl;
5082 current_fake_result_decl = NULL_TREE;
5084 is_recursive = sym->attr.recursive
5085 || (sym->attr.entry_master
5086 && sym->ns->entries->sym->attr.recursive);
5087 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5089 && !gfc_option.flag_recursive)
5093 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5095 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5096 TREE_STATIC (recurcheckvar) = 1;
5097 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5098 gfc_add_expr_to_block (&init, recurcheckvar);
5099 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5100 &sym->declared_at, msg);
5101 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5105 /* Now generate the code for the body of this function. */
5106 gfc_init_block (&body);
5108 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5109 && sym->attr.subroutine)
5111 tree alternate_return;
5112 alternate_return = gfc_get_fake_result_decl (sym, 0);
5113 gfc_add_modify (&body, alternate_return, integer_zero_node);
5118 /* Jump to the correct entry point. */
5119 tmp = gfc_trans_entry_master_switch (ns->entries);
5120 gfc_add_expr_to_block (&body, tmp);
5123 /* If bounds-checking is enabled, generate code to check passed in actual
5124 arguments against the expected dummy argument attributes (e.g. string
5126 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5127 add_argument_checking (&body, sym);
5129 tmp = gfc_trans_code (ns->code);
5130 gfc_add_expr_to_block (&body, tmp);
5132 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5134 tree result = get_proc_result (sym);
5136 if (result != NULL_TREE
5137 && sym->attr.function
5138 && !sym->attr.pointer)
5140 if (sym->attr.allocatable && sym->attr.dimension == 0
5141 && sym->result == sym)
5142 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5143 null_pointer_node));
5144 else if (sym->ts.type == BT_DERIVED
5145 && sym->ts.u.derived->attr.alloc_comp
5146 && !sym->attr.allocatable)
5148 rank = sym->as ? sym->as->rank : 0;
5149 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5150 gfc_add_expr_to_block (&init, tmp);
5154 if (result == NULL_TREE)
5156 /* TODO: move to the appropriate place in resolve.c. */
5157 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
5158 gfc_warning ("Return value of function '%s' at %L not set",
5159 sym->name, &sym->declared_at);
5161 TREE_NO_WARNING(sym->backend_decl) = 1;
5164 gfc_add_expr_to_block (&body, gfc_generate_return ());
5167 gfc_init_block (&cleanup);
5169 /* Reset recursion-check variable. */
5170 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5172 && !gfc_option.gfc_flag_openmp
5173 && recurcheckvar != NULL_TREE)
5175 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5176 recurcheckvar = NULL;
5179 /* Finish the function body and add init and cleanup code. */
5180 tmp = gfc_finish_block (&body);
5181 gfc_start_wrapped_block (&try_block, tmp);
5182 /* Add code to create and cleanup arrays. */
5183 gfc_trans_deferred_vars (sym, &try_block);
5184 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5185 gfc_finish_block (&cleanup));
5187 /* Add all the decls we created during processing. */
5188 decl = saved_function_decls;
5193 next = DECL_CHAIN (decl);
5194 DECL_CHAIN (decl) = NULL_TREE;
5198 saved_function_decls = NULL_TREE;
5200 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5203 /* Finish off this function and send it for code generation. */
5205 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5207 DECL_SAVED_TREE (fndecl)
5208 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5209 DECL_INITIAL (fndecl));
5211 if (nonlocal_dummy_decls)
5213 BLOCK_VARS (DECL_INITIAL (fndecl))
5214 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5215 pointer_set_destroy (nonlocal_dummy_decl_pset);
5216 nonlocal_dummy_decls = NULL;
5217 nonlocal_dummy_decl_pset = NULL;
5220 /* Output the GENERIC tree. */
5221 dump_function (TDI_original, fndecl);
5223 /* Store the end of the function, so that we get good line number
5224 info for the epilogue. */
5225 cfun->function_end_locus = input_location;
5227 /* We're leaving the context of this function, so zap cfun.
5228 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5229 tree_rest_of_compilation. */
5234 pop_function_context ();
5235 saved_function_decls = saved_parent_function_decls;
5237 current_function_decl = old_context;
5239 if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
5240 && has_coarray_vars)
5241 /* Register this function with cgraph just far enough to get it
5242 added to our parent's nested function list.
5243 If there are static coarrays in this function, the nested _caf_init
5244 function has already called cgraph_create_node, which also created
5245 the cgraph node for this function. */
5246 (void) cgraph_create_node (fndecl);
5248 cgraph_finalize_function (fndecl, true);
5250 gfc_trans_use_stmts (ns);
5251 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5253 if (sym->attr.is_main_program)
5254 create_main_function (fndecl);
5256 current_procedure_symbol = previous_procedure_symbol;
5261 gfc_generate_constructors (void)
5263 gcc_assert (gfc_static_ctors == NULL_TREE);
5271 if (gfc_static_ctors == NULL_TREE)
5274 fnname = get_file_function_name ("I");
5275 type = build_function_type_list (void_type_node, NULL_TREE);
5277 fndecl = build_decl (input_location,
5278 FUNCTION_DECL, fnname, type);
5279 TREE_PUBLIC (fndecl) = 1;
5281 decl = build_decl (input_location,
5282 RESULT_DECL, NULL_TREE, void_type_node);
5283 DECL_ARTIFICIAL (decl) = 1;
5284 DECL_IGNORED_P (decl) = 1;
5285 DECL_CONTEXT (decl) = fndecl;
5286 DECL_RESULT (fndecl) = decl;
5290 current_function_decl = fndecl;
5292 rest_of_decl_compilation (fndecl, 1, 0);
5294 make_decl_rtl (fndecl);
5296 init_function_start (fndecl);
5300 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5302 tmp = build_call_expr_loc (input_location,
5303 TREE_VALUE (gfc_static_ctors), 0);
5304 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5310 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5311 DECL_SAVED_TREE (fndecl)
5312 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5313 DECL_INITIAL (fndecl));
5315 free_after_parsing (cfun);
5316 free_after_compilation (cfun);
5318 tree_rest_of_compilation (fndecl);
5320 current_function_decl = NULL_TREE;
5324 /* Translates a BLOCK DATA program unit. This means emitting the
5325 commons contained therein plus their initializations. We also emit
5326 a globally visible symbol to make sure that each BLOCK DATA program
5327 unit remains unique. */
5330 gfc_generate_block_data (gfc_namespace * ns)
5335 /* Tell the backend the source location of the block data. */
5337 gfc_set_backend_locus (&ns->proc_name->declared_at);
5339 gfc_set_backend_locus (&gfc_current_locus);
5341 /* Process the DATA statements. */
5342 gfc_trans_common (ns);
5344 /* Create a global symbol with the mane of the block data. This is to
5345 generate linker errors if the same name is used twice. It is never
5348 id = gfc_sym_mangled_function_id (ns->proc_name);
5350 id = get_identifier ("__BLOCK_DATA__");
5352 decl = build_decl (input_location,
5353 VAR_DECL, id, gfc_array_index_type);
5354 TREE_PUBLIC (decl) = 1;
5355 TREE_STATIC (decl) = 1;
5356 DECL_IGNORED_P (decl) = 1;
5359 rest_of_decl_compilation (decl, 1, 0);
5363 /* Process the local variables of a BLOCK construct. */
5366 gfc_process_block_locals (gfc_namespace* ns)
5370 gcc_assert (saved_local_decls == NULL_TREE);
5371 has_coarray_vars = false;
5373 generate_local_vars (ns);
5375 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5376 generate_coarray_init (ns);
5378 decl = saved_local_decls;
5383 next = DECL_CHAIN (decl);
5384 DECL_CHAIN (decl) = NULL_TREE;
5388 saved_local_decls = NULL_TREE;
5392 #include "gt-fortran-trans-decl.h"