1 /* Backend function setup
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* trans-decl.c -- Handling of backend function and variable decls, etc */
25 #include "coretypes.h"
28 #include "stringpool.h"
29 #include "stor-layout.h"
32 #include "tree-dump.h"
33 #include "gimple-expr.h" /* For create_tmp_var_raw. */
35 #include "diagnostic-core.h" /* For internal_error. */
36 #include "toplev.h" /* For announce_function. */
43 #include "pointer-set.h"
44 #include "constructor.h"
46 #include "trans-types.h"
47 #include "trans-array.h"
48 #include "trans-const.h"
49 /* Only for gfc_trans_code. Shouldn't need to include this. */
50 #include "trans-stmt.h"
52 #define MAX_LABEL_VALUE 99999
55 /* Holds the result of the function if no result variable specified. */
57 static GTY(()) tree current_fake_result_decl;
58 static GTY(()) tree parent_fake_result_decl;
61 /* Holds the variable DECLs for the current function. */
63 static GTY(()) tree saved_function_decls;
64 static GTY(()) tree saved_parent_function_decls;
66 static struct pointer_set_t *nonlocal_dummy_decl_pset;
67 static GTY(()) tree nonlocal_dummy_decls;
69 /* Holds the variable DECLs that are locals. */
71 static GTY(()) tree saved_local_decls;
73 /* The namespace of the module we're currently generating. Only used while
74 outputting decls for module variables. Do not rely on this being set. */
76 static gfc_namespace *module_namespace;
78 /* The currently processed procedure symbol. */
79 static gfc_symbol* current_procedure_symbol = NULL;
82 /* With -fcoarray=lib: For generating the registering call
83 of static coarrays. */
84 static bool has_coarray_vars;
85 static stmtblock_t caf_init_block;
88 /* List of static constructor functions. */
90 tree gfc_static_ctors;
93 /* Function declarations for builtin library functions. */
95 tree gfor_fndecl_pause_numeric;
96 tree gfor_fndecl_pause_string;
97 tree gfor_fndecl_stop_numeric;
98 tree gfor_fndecl_stop_numeric_f08;
99 tree gfor_fndecl_stop_string;
100 tree gfor_fndecl_error_stop_numeric;
101 tree gfor_fndecl_error_stop_string;
102 tree gfor_fndecl_runtime_error;
103 tree gfor_fndecl_runtime_error_at;
104 tree gfor_fndecl_runtime_warning_at;
105 tree gfor_fndecl_os_error;
106 tree gfor_fndecl_generate_error;
107 tree gfor_fndecl_set_args;
108 tree gfor_fndecl_set_fpe;
109 tree gfor_fndecl_set_options;
110 tree gfor_fndecl_set_convert;
111 tree gfor_fndecl_set_record_marker;
112 tree gfor_fndecl_set_max_subrecord_length;
113 tree gfor_fndecl_ctime;
114 tree gfor_fndecl_fdate;
115 tree gfor_fndecl_ttynam;
116 tree gfor_fndecl_in_pack;
117 tree gfor_fndecl_in_unpack;
118 tree gfor_fndecl_associated;
121 /* Coarray run-time library function decls. */
122 tree gfor_fndecl_caf_init;
123 tree gfor_fndecl_caf_finalize;
124 tree gfor_fndecl_caf_this_image;
125 tree gfor_fndecl_caf_num_images;
126 tree gfor_fndecl_caf_register;
127 tree gfor_fndecl_caf_deregister;
128 tree gfor_fndecl_caf_critical;
129 tree gfor_fndecl_caf_end_critical;
130 tree gfor_fndecl_caf_sync_all;
131 tree gfor_fndecl_caf_sync_images;
132 tree gfor_fndecl_caf_error_stop;
133 tree gfor_fndecl_caf_error_stop_str;
134 tree gfor_fndecl_co_max;
135 tree gfor_fndecl_co_min;
136 tree gfor_fndecl_co_sum;
139 /* Math functions. Many other math functions are handled in
140 trans-intrinsic.c. */
142 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
143 tree gfor_fndecl_math_ishftc4;
144 tree gfor_fndecl_math_ishftc8;
145 tree gfor_fndecl_math_ishftc16;
148 /* String functions. */
150 tree gfor_fndecl_compare_string;
151 tree gfor_fndecl_concat_string;
152 tree gfor_fndecl_string_len_trim;
153 tree gfor_fndecl_string_index;
154 tree gfor_fndecl_string_scan;
155 tree gfor_fndecl_string_verify;
156 tree gfor_fndecl_string_trim;
157 tree gfor_fndecl_string_minmax;
158 tree gfor_fndecl_adjustl;
159 tree gfor_fndecl_adjustr;
160 tree gfor_fndecl_select_string;
161 tree gfor_fndecl_compare_string_char4;
162 tree gfor_fndecl_concat_string_char4;
163 tree gfor_fndecl_string_len_trim_char4;
164 tree gfor_fndecl_string_index_char4;
165 tree gfor_fndecl_string_scan_char4;
166 tree gfor_fndecl_string_verify_char4;
167 tree gfor_fndecl_string_trim_char4;
168 tree gfor_fndecl_string_minmax_char4;
169 tree gfor_fndecl_adjustl_char4;
170 tree gfor_fndecl_adjustr_char4;
171 tree gfor_fndecl_select_string_char4;
174 /* Conversion between character kinds. */
175 tree gfor_fndecl_convert_char1_to_char4;
176 tree gfor_fndecl_convert_char4_to_char1;
179 /* Other misc. runtime library functions. */
180 tree gfor_fndecl_size0;
181 tree gfor_fndecl_size1;
182 tree gfor_fndecl_iargc;
184 /* Intrinsic functions implemented in Fortran. */
185 tree gfor_fndecl_sc_kind;
186 tree gfor_fndecl_si_kind;
187 tree gfor_fndecl_sr_kind;
189 /* BLAS gemm functions. */
190 tree gfor_fndecl_sgemm;
191 tree gfor_fndecl_dgemm;
192 tree gfor_fndecl_cgemm;
193 tree gfor_fndecl_zgemm;
197 gfc_add_decl_to_parent_function (tree decl)
200 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
201 DECL_NONLOCAL (decl) = 1;
202 DECL_CHAIN (decl) = saved_parent_function_decls;
203 saved_parent_function_decls = decl;
207 gfc_add_decl_to_function (tree decl)
210 TREE_USED (decl) = 1;
211 DECL_CONTEXT (decl) = current_function_decl;
212 DECL_CHAIN (decl) = saved_function_decls;
213 saved_function_decls = decl;
217 add_decl_as_local (tree decl)
220 TREE_USED (decl) = 1;
221 DECL_CONTEXT (decl) = current_function_decl;
222 DECL_CHAIN (decl) = saved_local_decls;
223 saved_local_decls = decl;
227 /* Build a backend label declaration. Set TREE_USED for named labels.
228 The context of the label is always the current_function_decl. All
229 labels are marked artificial. */
232 gfc_build_label_decl (tree label_id)
234 /* 2^32 temporaries should be enough. */
235 static unsigned int tmp_num = 1;
239 if (label_id == NULL_TREE)
241 /* Build an internal label name. */
242 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
243 label_id = get_identifier (label_name);
248 /* Build the LABEL_DECL node. Labels have no type. */
249 label_decl = build_decl (input_location,
250 LABEL_DECL, label_id, void_type_node);
251 DECL_CONTEXT (label_decl) = current_function_decl;
252 DECL_MODE (label_decl) = VOIDmode;
254 /* We always define the label as used, even if the original source
255 file never references the label. We don't want all kinds of
256 spurious warnings for old-style Fortran code with too many
258 TREE_USED (label_decl) = 1;
260 DECL_ARTIFICIAL (label_decl) = 1;
265 /* Set the backend source location of a decl. */
268 gfc_set_decl_location (tree decl, locus * loc)
270 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
274 /* Return the backend label declaration for a given label structure,
275 or create it if it doesn't exist yet. */
278 gfc_get_label_decl (gfc_st_label * lp)
280 if (lp->backend_decl)
281 return lp->backend_decl;
284 char label_name[GFC_MAX_SYMBOL_LEN + 1];
287 /* Validate the label declaration from the front end. */
288 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
290 /* Build a mangled name for the label. */
291 sprintf (label_name, "__label_%.6d", lp->value);
293 /* Build the LABEL_DECL node. */
294 label_decl = gfc_build_label_decl (get_identifier (label_name));
296 /* Tell the debugger where the label came from. */
297 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
298 gfc_set_decl_location (label_decl, &lp->where);
300 DECL_ARTIFICIAL (label_decl) = 1;
302 /* Store the label in the label list and return the LABEL_DECL. */
303 lp->backend_decl = label_decl;
309 /* Convert a gfc_symbol to an identifier of the same name. */
312 gfc_sym_identifier (gfc_symbol * sym)
314 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
315 return (get_identifier ("MAIN__"));
317 return (get_identifier (sym->name));
321 /* Construct mangled name from symbol name. */
324 gfc_sym_mangled_identifier (gfc_symbol * sym)
326 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
328 /* Prevent the mangling of identifiers that have an assigned
329 binding label (mainly those that are bind(c)). */
330 if (sym->attr.is_bind_c == 1 && sym->binding_label)
331 return get_identifier (sym->binding_label);
333 if (sym->module == NULL)
334 return gfc_sym_identifier (sym);
337 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
338 return get_identifier (name);
343 /* Construct mangled function name from symbol name. */
346 gfc_sym_mangled_function_id (gfc_symbol * sym)
349 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
351 /* It may be possible to simply use the binding label if it's
352 provided, and remove the other checks. Then we could use it
353 for other things if we wished. */
354 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
356 /* use the binding label rather than the mangled name */
357 return get_identifier (sym->binding_label);
359 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
360 || (sym->module != NULL && (sym->attr.external
361 || sym->attr.if_source == IFSRC_IFBODY)))
363 /* Main program is mangled into MAIN__. */
364 if (sym->attr.is_main_program)
365 return get_identifier ("MAIN__");
367 /* Intrinsic procedures are never mangled. */
368 if (sym->attr.proc == PROC_INTRINSIC)
369 return get_identifier (sym->name);
371 if (gfc_option.flag_underscoring)
373 has_underscore = strchr (sym->name, '_') != 0;
374 if (gfc_option.flag_second_underscore && has_underscore)
375 snprintf (name, sizeof name, "%s__", sym->name);
377 snprintf (name, sizeof name, "%s_", sym->name);
378 return get_identifier (name);
381 return get_identifier (sym->name);
385 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
386 return get_identifier (name);
392 gfc_set_decl_assembler_name (tree decl, tree name)
394 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
395 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
399 /* Returns true if a variable of specified size should go on the stack. */
402 gfc_can_put_var_on_stack (tree size)
404 unsigned HOST_WIDE_INT low;
406 if (!INTEGER_CST_P (size))
409 if (gfc_option.flag_max_stack_var_size < 0)
412 if (!tree_fits_uhwi_p (size))
415 low = TREE_INT_CST_LOW (size);
416 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
419 /* TODO: Set a per-function stack size limit. */
425 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
426 an expression involving its corresponding pointer. There are
427 2 cases; one for variable size arrays, and one for everything else,
428 because variable-sized arrays require one fewer level of
432 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
434 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
437 /* Parameters need to be dereferenced. */
438 if (sym->cp_pointer->attr.dummy)
439 ptr_decl = build_fold_indirect_ref_loc (input_location,
442 /* Check to see if we're dealing with a variable-sized array. */
443 if (sym->attr.dimension
444 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
446 /* These decls will be dereferenced later, so we don't dereference
448 value = convert (TREE_TYPE (decl), ptr_decl);
452 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
454 value = build_fold_indirect_ref_loc (input_location,
458 SET_DECL_VALUE_EXPR (decl, value);
459 DECL_HAS_VALUE_EXPR_P (decl) = 1;
460 GFC_DECL_CRAY_POINTEE (decl) = 1;
464 /* Finish processing of a declaration without an initial value. */
467 gfc_finish_decl (tree decl)
469 gcc_assert (TREE_CODE (decl) == PARM_DECL
470 || DECL_INITIAL (decl) == NULL_TREE);
472 if (TREE_CODE (decl) != VAR_DECL)
475 if (DECL_SIZE (decl) == NULL_TREE
476 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
477 layout_decl (decl, 0);
479 /* A few consistency checks. */
480 /* A static variable with an incomplete type is an error if it is
481 initialized. Also if it is not file scope. Otherwise, let it
482 through, but if it is not `extern' then it may cause an error
484 /* An automatic variable with an incomplete type is an error. */
486 /* We should know the storage size. */
487 gcc_assert (DECL_SIZE (decl) != NULL_TREE
488 || (TREE_STATIC (decl)
489 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
490 : DECL_EXTERNAL (decl)));
492 /* The storage size should be constant. */
493 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
495 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
499 /* Handle setting of GFC_DECL_SCALAR* on DECL. */
502 gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
504 if (!attr->dimension && !attr->codimension)
506 /* Handle scalar allocatable variables. */
507 if (attr->allocatable)
509 gfc_allocate_lang_decl (decl);
510 GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
512 /* Handle scalar pointer variables. */
515 gfc_allocate_lang_decl (decl);
516 GFC_DECL_SCALAR_POINTER (decl) = 1;
522 /* Apply symbol attributes to a variable, and add it to the function scope. */
525 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
528 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
529 This is the equivalent of the TARGET variables.
530 We also need to set this if the variable is passed by reference in a
533 /* Set DECL_VALUE_EXPR for Cray Pointees. */
534 if (sym->attr.cray_pointee)
535 gfc_finish_cray_pointee (decl, sym);
537 if (sym->attr.target)
538 TREE_ADDRESSABLE (decl) = 1;
539 /* If it wasn't used we wouldn't be getting it. */
540 TREE_USED (decl) = 1;
542 if (sym->attr.flavor == FL_PARAMETER
543 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
544 TREE_READONLY (decl) = 1;
546 /* Chain this decl to the pending declarations. Don't do pushdecl()
547 because this would add them to the current scope rather than the
549 if (current_function_decl != NULL_TREE)
551 if (sym->ns->proc_name->backend_decl == current_function_decl
552 || sym->result == sym)
553 gfc_add_decl_to_function (decl);
554 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
555 /* This is a BLOCK construct. */
556 add_decl_as_local (decl);
558 gfc_add_decl_to_parent_function (decl);
561 if (sym->attr.cray_pointee)
564 if(sym->attr.is_bind_c == 1 && sym->binding_label)
566 /* We need to put variables that are bind(c) into the common
567 segment of the object file, because this is what C would do.
568 gfortran would typically put them in either the BSS or
569 initialized data segments, and only mark them as common if
570 they were part of common blocks. However, if they are not put
571 into common space, then C cannot initialize global Fortran
572 variables that it interoperates with and the draft says that
573 either Fortran or C should be able to initialize it (but not
574 both, of course.) (J3/04-007, section 15.3). */
575 TREE_PUBLIC(decl) = 1;
576 DECL_COMMON(decl) = 1;
579 /* If a variable is USE associated, it's always external. */
580 if (sym->attr.use_assoc)
582 DECL_EXTERNAL (decl) = 1;
583 TREE_PUBLIC (decl) = 1;
585 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
587 /* TODO: Don't set sym->module for result or dummy variables. */
588 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
590 if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
591 TREE_PUBLIC (decl) = 1;
592 TREE_STATIC (decl) = 1;
595 /* Derived types are a bit peculiar because of the possibility of
596 a default initializer; this must be applied each time the variable
597 comes into scope it therefore need not be static. These variables
598 are SAVE_NONE but have an initializer. Otherwise explicitly
599 initialized variables are SAVE_IMPLICIT and explicitly saved are
601 if (!sym->attr.use_assoc
602 && (sym->attr.save != SAVE_NONE || sym->attr.data
603 || (sym->value && sym->ns->proc_name->attr.is_main_program)
604 || (gfc_option.coarray == GFC_FCOARRAY_LIB
605 && sym->attr.codimension && !sym->attr.allocatable)))
606 TREE_STATIC (decl) = 1;
608 if (sym->attr.volatile_)
610 TREE_THIS_VOLATILE (decl) = 1;
611 TREE_SIDE_EFFECTS (decl) = 1;
612 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
613 TREE_TYPE (decl) = new_type;
616 /* Keep variables larger than max-stack-var-size off stack. */
617 if (!sym->ns->proc_name->attr.recursive
618 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
619 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
620 /* Put variable length auto array pointers always into stack. */
621 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
622 || sym->attr.dimension == 0
623 || sym->as->type != AS_EXPLICIT
625 || sym->attr.allocatable)
626 && !DECL_ARTIFICIAL (decl))
627 TREE_STATIC (decl) = 1;
629 /* Handle threadprivate variables. */
630 if (sym->attr.threadprivate
631 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
632 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
634 gfc_finish_decl_attrs (decl, &sym->attr);
638 /* Allocate the lang-specific part of a decl. */
641 gfc_allocate_lang_decl (tree decl)
643 if (DECL_LANG_SPECIFIC (decl) == NULL)
644 DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
647 /* Remember a symbol to generate initialization/cleanup code at function
651 gfc_defer_symbol_init (gfc_symbol * sym)
657 /* Don't add a symbol twice. */
661 last = head = sym->ns->proc_name;
664 /* Make sure that setup code for dummy variables which are used in the
665 setup of other variables is generated first. */
668 /* Find the first dummy arg seen after us, or the first non-dummy arg.
669 This is a circular list, so don't go past the head. */
671 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
677 /* Insert in between last and p. */
683 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
684 backend_decl for a module symbol, if it all ready exists. If the
685 module gsymbol does not exist, it is created. If the symbol does
686 not exist, it is added to the gsymbol namespace. Returns true if
687 an existing backend_decl is found. */
690 gfc_get_module_backend_decl (gfc_symbol *sym)
696 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
698 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
704 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
710 gsym = gfc_get_gsymbol (sym->module);
711 gsym->type = GSYM_MODULE;
712 gsym->ns = gfc_get_namespace (NULL, 0);
715 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
719 else if (sym->attr.flavor == FL_DERIVED)
721 if (s && s->attr.flavor == FL_PROCEDURE)
724 gcc_assert (s->attr.generic);
725 for (intr = s->generic; intr; intr = intr->next)
726 if (intr->sym->attr.flavor == FL_DERIVED)
733 if (!s->backend_decl)
734 s->backend_decl = gfc_get_derived_type (s);
735 gfc_copy_dt_decls_ifequal (s, sym, true);
738 else if (s->backend_decl)
740 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
741 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
743 else if (sym->ts.type == BT_CHARACTER)
744 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
745 sym->backend_decl = s->backend_decl;
753 /* Create an array index type variable with function scope. */
756 create_index_var (const char * pfx, int nest)
760 decl = gfc_create_var_np (gfc_array_index_type, pfx);
762 gfc_add_decl_to_parent_function (decl);
764 gfc_add_decl_to_function (decl);
769 /* Create variables to hold all the non-constant bits of info for a
770 descriptorless array. Remember these in the lang-specific part of the
774 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
779 gfc_namespace* procns;
781 type = TREE_TYPE (decl);
783 /* We just use the descriptor, if there is one. */
784 if (GFC_DESCRIPTOR_TYPE_P (type))
787 gcc_assert (GFC_ARRAY_TYPE_P (type));
788 procns = gfc_find_proc_namespace (sym->ns);
789 nest = (procns->proc_name->backend_decl != current_function_decl)
790 && !sym->attr.contained;
792 if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
793 && sym->as->type != AS_ASSUMED_SHAPE
794 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
798 token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
801 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
802 DECL_ARTIFICIAL (token) = 1;
803 TREE_STATIC (token) = 1;
804 gfc_add_decl_to_function (token);
807 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
809 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
811 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
812 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
814 /* Don't try to use the unknown bound for assumed shape arrays. */
815 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
816 && (sym->as->type != AS_ASSUMED_SIZE
817 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
819 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
820 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
823 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
825 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
826 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
829 for (dim = GFC_TYPE_ARRAY_RANK (type);
830 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
832 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
834 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
835 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
837 /* Don't try to use the unknown ubound for the last coarray dimension. */
838 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
839 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
841 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
842 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
845 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
847 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
849 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
852 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
854 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
857 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
858 && sym->as->type != AS_ASSUMED_SIZE)
860 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
861 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
864 if (POINTER_TYPE_P (type))
866 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
867 gcc_assert (TYPE_LANG_SPECIFIC (type)
868 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
869 type = TREE_TYPE (type);
872 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
876 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
877 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
878 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
880 TYPE_DOMAIN (type) = range;
884 if (TYPE_NAME (type) != NULL_TREE
885 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
886 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
888 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
890 for (dim = 0; dim < sym->as->rank - 1; dim++)
892 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
893 gtype = TREE_TYPE (gtype);
895 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
896 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
897 TYPE_NAME (type) = NULL_TREE;
900 if (TYPE_NAME (type) == NULL_TREE)
902 tree gtype = TREE_TYPE (type), rtype, type_decl;
904 for (dim = sym->as->rank - 1; dim >= 0; dim--)
907 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
908 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
909 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
910 gtype = build_array_type (gtype, rtype);
911 /* Ensure the bound variables aren't optimized out at -O0.
912 For -O1 and above they often will be optimized out, but
913 can be tracked by VTA. Also set DECL_NAMELESS, so that
914 the artificial lbound.N or ubound.N DECL_NAME doesn't
915 end up in debug info. */
916 if (lbound && TREE_CODE (lbound) == VAR_DECL
917 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
919 if (DECL_NAME (lbound)
920 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
922 DECL_NAMELESS (lbound) = 1;
923 DECL_IGNORED_P (lbound) = 0;
925 if (ubound && TREE_CODE (ubound) == VAR_DECL
926 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
928 if (DECL_NAME (ubound)
929 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
931 DECL_NAMELESS (ubound) = 1;
932 DECL_IGNORED_P (ubound) = 0;
935 TYPE_NAME (type) = type_decl = build_decl (input_location,
936 TYPE_DECL, NULL, gtype);
937 DECL_ORIGINAL_TYPE (type_decl) = gtype;
942 /* For some dummy arguments we don't use the actual argument directly.
943 Instead we create a local decl and use that. This allows us to perform
944 initialization, and construct full type information. */
947 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
957 if (sym->attr.pointer || sym->attr.allocatable
958 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
961 /* Add to list of variables if not a fake result variable. */
962 if (sym->attr.result || sym->attr.dummy)
963 gfc_defer_symbol_init (sym);
965 type = TREE_TYPE (dummy);
966 gcc_assert (TREE_CODE (dummy) == PARM_DECL
967 && POINTER_TYPE_P (type));
969 /* Do we know the element size? */
970 known_size = sym->ts.type != BT_CHARACTER
971 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
973 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
975 /* For descriptorless arrays with known element size the actual
976 argument is sufficient. */
977 gcc_assert (GFC_ARRAY_TYPE_P (type));
978 gfc_build_qualified_array (dummy, sym);
982 type = TREE_TYPE (type);
983 if (GFC_DESCRIPTOR_TYPE_P (type))
985 /* Create a descriptorless array pointer. */
989 /* Even when -frepack-arrays is used, symbols with TARGET attribute
991 if (!gfc_option.flag_repack_arrays || sym->attr.target)
993 if (as->type == AS_ASSUMED_SIZE)
994 packed = PACKED_FULL;
998 if (as->type == AS_EXPLICIT)
1000 packed = PACKED_FULL;
1001 for (n = 0; n < as->rank; n++)
1005 && as->upper[n]->expr_type == EXPR_CONSTANT
1006 && as->lower[n]->expr_type == EXPR_CONSTANT))
1008 packed = PACKED_PARTIAL;
1014 packed = PACKED_PARTIAL;
1017 type = gfc_typenode_for_spec (&sym->ts);
1018 type = gfc_get_nodesc_array_type (type, sym->as, packed,
1023 /* We now have an expression for the element size, so create a fully
1024 qualified type. Reset sym->backend decl or this will just return the
1026 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1027 sym->backend_decl = NULL_TREE;
1028 type = gfc_sym_type (sym);
1029 packed = PACKED_FULL;
1032 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1033 decl = build_decl (input_location,
1034 VAR_DECL, get_identifier (name), type);
1036 DECL_ARTIFICIAL (decl) = 1;
1037 DECL_NAMELESS (decl) = 1;
1038 TREE_PUBLIC (decl) = 0;
1039 TREE_STATIC (decl) = 0;
1040 DECL_EXTERNAL (decl) = 0;
1042 /* Avoid uninitialized warnings for optional dummy arguments. */
1043 if (sym->attr.optional)
1044 TREE_NO_WARNING (decl) = 1;
1046 /* We should never get deferred shape arrays here. We used to because of
1048 gcc_assert (sym->as->type != AS_DEFERRED);
1050 if (packed == PACKED_PARTIAL)
1051 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1052 else if (packed == PACKED_FULL)
1053 GFC_DECL_PACKED_ARRAY (decl) = 1;
1055 gfc_build_qualified_array (decl, sym);
1057 if (DECL_LANG_SPECIFIC (dummy))
1058 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1060 gfc_allocate_lang_decl (decl);
1062 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1064 if (sym->ns->proc_name->backend_decl == current_function_decl
1065 || sym->attr.contained)
1066 gfc_add_decl_to_function (decl);
1068 gfc_add_decl_to_parent_function (decl);
1073 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1074 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1075 pointing to the artificial variable for debug info purposes. */
1078 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1082 if (! nonlocal_dummy_decl_pset)
1083 nonlocal_dummy_decl_pset = pointer_set_create ();
1085 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1088 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1089 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1090 TREE_TYPE (sym->backend_decl));
1091 DECL_ARTIFICIAL (decl) = 0;
1092 TREE_USED (decl) = 1;
1093 TREE_PUBLIC (decl) = 0;
1094 TREE_STATIC (decl) = 0;
1095 DECL_EXTERNAL (decl) = 0;
1096 if (DECL_BY_REFERENCE (dummy))
1097 DECL_BY_REFERENCE (decl) = 1;
1098 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1099 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1100 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1101 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1102 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1103 nonlocal_dummy_decls = decl;
1106 /* Return a constant or a variable to use as a string length. Does not
1107 add the decl to the current scope. */
1110 gfc_create_string_length (gfc_symbol * sym)
1112 gcc_assert (sym->ts.u.cl);
1113 gfc_conv_const_charlen (sym->ts.u.cl);
1115 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1120 /* The string length variable shall be in static memory if it is either
1121 explicitly SAVED, a module variable or with -fno-automatic. Only
1122 relevant is "len=:" - otherwise, it is either a constant length or
1123 it is an automatic variable. */
1124 bool static_length = sym->attr.save
1125 || sym->ns->proc_name->attr.flavor == FL_MODULE
1126 || (gfc_option.flag_max_stack_var_size == 0
1127 && sym->ts.deferred && !sym->attr.dummy
1128 && !sym->attr.result && !sym->attr.function);
1130 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1131 variables as some systems do not support the "." in the assembler name.
1132 For nonstatic variables, the "." does not appear in assembler. */
1136 name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
1139 name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
1141 else if (sym->module)
1142 name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
1144 name = gfc_get_string (".%s", sym->name);
1146 length = build_decl (input_location,
1147 VAR_DECL, get_identifier (name),
1148 gfc_charlen_type_node);
1149 DECL_ARTIFICIAL (length) = 1;
1150 TREE_USED (length) = 1;
1151 if (sym->ns->proc_name->tlink != NULL)
1152 gfc_defer_symbol_init (sym);
1154 sym->ts.u.cl->backend_decl = length;
1157 TREE_STATIC (length) = 1;
1159 if (sym->ns->proc_name->attr.flavor == FL_MODULE
1160 && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
1161 TREE_PUBLIC (length) = 1;
1164 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1165 return sym->ts.u.cl->backend_decl;
1168 /* If a variable is assigned a label, we add another two auxiliary
1172 gfc_add_assign_aux_vars (gfc_symbol * sym)
1178 gcc_assert (sym->backend_decl);
1180 decl = sym->backend_decl;
1181 gfc_allocate_lang_decl (decl);
1182 GFC_DECL_ASSIGN (decl) = 1;
1183 length = build_decl (input_location,
1184 VAR_DECL, create_tmp_var_name (sym->name),
1185 gfc_charlen_type_node);
1186 addr = build_decl (input_location,
1187 VAR_DECL, create_tmp_var_name (sym->name),
1189 gfc_finish_var_decl (length, sym);
1190 gfc_finish_var_decl (addr, sym);
1191 /* STRING_LENGTH is also used as flag. Less than -1 means that
1192 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1193 target label's address. Otherwise, value is the length of a format string
1194 and ASSIGN_ADDR is its address. */
1195 if (TREE_STATIC (length))
1196 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1198 gfc_defer_symbol_init (sym);
1200 GFC_DECL_STRING_LEN (decl) = length;
1201 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1206 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1211 for (id = 0; id < EXT_ATTR_NUM; id++)
1212 if (sym_attr.ext_attr & (1 << id))
1214 attr = build_tree_list (
1215 get_identifier (ext_attr_list[id].middle_end_name),
1217 list = chainon (list, attr);
1224 static void build_function_decl (gfc_symbol * sym, bool global);
1227 /* Return the decl for a gfc_symbol, create it if it doesn't already
1231 gfc_get_symbol_decl (gfc_symbol * sym)
1234 tree length = NULL_TREE;
1237 bool intrinsic_array_parameter = false;
1240 gcc_assert (sym->attr.referenced
1241 || sym->attr.flavor == FL_PROCEDURE
1242 || sym->attr.use_assoc
1243 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1244 || (sym->module && sym->attr.if_source != IFSRC_DECL
1245 && sym->backend_decl));
1247 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1248 byref = gfc_return_by_reference (sym->ns->proc_name);
1252 /* Make sure that the vtab for the declared type is completed. */
1253 if (sym->ts.type == BT_CLASS)
1255 gfc_component *c = CLASS_DATA (sym);
1256 if (!c->ts.u.derived->backend_decl)
1258 gfc_find_derived_vtab (c->ts.u.derived);
1259 gfc_get_derived_type (sym->ts.u.derived);
1263 /* All deferred character length procedures need to retain the backend
1264 decl, which is a pointer to the character length in the caller's
1265 namespace and to declare a local character length. */
1266 if (!byref && sym->attr.function
1267 && sym->ts.type == BT_CHARACTER
1269 && sym->ts.u.cl->passed_length == NULL
1270 && sym->ts.u.cl->backend_decl
1271 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1273 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1274 sym->ts.u.cl->backend_decl = NULL_TREE;
1275 length = gfc_create_string_length (sym);
1278 fun_or_res = byref && (sym->attr.result
1279 || (sym->attr.function && sym->ts.deferred));
1280 if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
1282 /* Return via extra parameter. */
1283 if (sym->attr.result && byref
1284 && !sym->backend_decl)
1287 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1288 /* For entry master function skip over the __entry
1290 if (sym->ns->proc_name->attr.entry_master)
1291 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1294 /* Dummy variables should already have been created. */
1295 gcc_assert (sym->backend_decl);
1297 /* Create a character length variable. */
1298 if (sym->ts.type == BT_CHARACTER)
1300 /* For a deferred dummy, make a new string length variable. */
1301 if (sym->ts.deferred
1303 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1304 sym->ts.u.cl->backend_decl = NULL_TREE;
1306 if (sym->ts.deferred && fun_or_res
1307 && sym->ts.u.cl->passed_length == NULL
1308 && sym->ts.u.cl->backend_decl)
1310 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1311 sym->ts.u.cl->backend_decl = NULL_TREE;
1314 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1315 length = gfc_create_string_length (sym);
1317 length = sym->ts.u.cl->backend_decl;
1318 if (TREE_CODE (length) == VAR_DECL
1319 && DECL_FILE_SCOPE_P (length))
1321 /* Add the string length to the same context as the symbol. */
1322 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1323 gfc_add_decl_to_function (length);
1325 gfc_add_decl_to_parent_function (length);
1327 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1328 DECL_CONTEXT (length));
1330 gfc_defer_symbol_init (sym);
1334 /* Use a copy of the descriptor for dummy arrays. */
1335 if ((sym->attr.dimension || sym->attr.codimension)
1336 && !TREE_USED (sym->backend_decl))
1338 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1339 /* Prevent the dummy from being detected as unused if it is copied. */
1340 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1341 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1342 sym->backend_decl = decl;
1345 TREE_USED (sym->backend_decl) = 1;
1346 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1348 gfc_add_assign_aux_vars (sym);
1351 if (sym->attr.dimension
1352 && DECL_LANG_SPECIFIC (sym->backend_decl)
1353 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1354 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1355 gfc_nonlocal_dummy_array_decl (sym);
1357 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1358 GFC_DECL_CLASS(sym->backend_decl) = 1;
1360 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1361 GFC_DECL_CLASS(sym->backend_decl) = 1;
1362 return sym->backend_decl;
1365 if (sym->backend_decl)
1366 return sym->backend_decl;
1368 /* Special case for array-valued named constants from intrinsic
1369 procedures; those are inlined. */
1370 if (sym->attr.use_assoc && sym->from_intmod
1371 && sym->attr.flavor == FL_PARAMETER)
1372 intrinsic_array_parameter = true;
1374 /* If use associated compilation, use the module
1376 if ((sym->attr.flavor == FL_VARIABLE
1377 || sym->attr.flavor == FL_PARAMETER)
1378 && sym->attr.use_assoc
1379 && !intrinsic_array_parameter
1381 && gfc_get_module_backend_decl (sym))
1383 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1384 GFC_DECL_CLASS(sym->backend_decl) = 1;
1385 return sym->backend_decl;
1388 if (sym->attr.flavor == FL_PROCEDURE)
1390 /* Catch functions. Only used for actual parameters,
1391 procedure pointers and procptr initialization targets. */
1392 if (sym->attr.use_assoc || sym->attr.intrinsic
1393 || sym->attr.if_source != IFSRC_DECL)
1395 decl = gfc_get_extern_function_decl (sym);
1396 gfc_set_decl_location (decl, &sym->declared_at);
1400 if (!sym->backend_decl)
1401 build_function_decl (sym, false);
1402 decl = sym->backend_decl;
1407 if (sym->attr.intrinsic)
1408 internal_error ("intrinsic variable which isn't a procedure");
1410 /* Create string length decl first so that they can be used in the
1411 type declaration. */
1412 if (sym->ts.type == BT_CHARACTER)
1413 length = gfc_create_string_length (sym);
1415 /* Create the decl for the variable. */
1416 decl = build_decl (sym->declared_at.lb->location,
1417 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1419 /* Add attributes to variables. Functions are handled elsewhere. */
1420 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1421 decl_attributes (&decl, attributes, 0);
1423 /* Symbols from modules should have their assembler names mangled.
1424 This is done here rather than in gfc_finish_var_decl because it
1425 is different for string length variables. */
1428 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1429 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1430 DECL_IGNORED_P (decl) = 1;
1433 if (sym->attr.select_type_temporary)
1435 DECL_ARTIFICIAL (decl) = 1;
1436 DECL_IGNORED_P (decl) = 1;
1439 if (sym->attr.dimension || sym->attr.codimension)
1441 /* Create variables to hold the non-constant bits of array info. */
1442 gfc_build_qualified_array (decl, sym);
1444 if (sym->attr.contiguous
1445 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1446 GFC_DECL_PACKED_ARRAY (decl) = 1;
1449 /* Remember this variable for allocation/cleanup. */
1450 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1451 || (sym->ts.type == BT_CLASS &&
1452 (CLASS_DATA (sym)->attr.dimension
1453 || CLASS_DATA (sym)->attr.allocatable))
1454 || (sym->ts.type == BT_DERIVED
1455 && (sym->ts.u.derived->attr.alloc_comp
1456 || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
1457 && !sym->ns->proc_name->attr.is_main_program
1458 && gfc_is_finalizable (sym->ts.u.derived, NULL))))
1459 /* This applies a derived type default initializer. */
1460 || (sym->ts.type == BT_DERIVED
1461 && sym->attr.save == SAVE_NONE
1463 && !sym->attr.allocatable
1464 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1465 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1466 gfc_defer_symbol_init (sym);
1468 gfc_finish_var_decl (decl, sym);
1470 if (sym->ts.type == BT_CHARACTER)
1472 /* Character variables need special handling. */
1473 gfc_allocate_lang_decl (decl);
1475 if (TREE_CODE (length) != INTEGER_CST)
1477 gfc_finish_var_decl (length, sym);
1478 gcc_assert (!sym->value);
1481 else if (sym->attr.subref_array_pointer)
1483 /* We need the span for these beasts. */
1484 gfc_allocate_lang_decl (decl);
1487 if (sym->attr.subref_array_pointer)
1490 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1491 span = build_decl (input_location,
1492 VAR_DECL, create_tmp_var_name ("span"),
1493 gfc_array_index_type);
1494 gfc_finish_var_decl (span, sym);
1495 TREE_STATIC (span) = TREE_STATIC (decl);
1496 DECL_ARTIFICIAL (span) = 1;
1498 GFC_DECL_SPAN (decl) = span;
1499 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1502 if (sym->ts.type == BT_CLASS)
1503 GFC_DECL_CLASS(decl) = 1;
1505 sym->backend_decl = decl;
1507 if (sym->attr.assign)
1508 gfc_add_assign_aux_vars (sym);
1510 if (intrinsic_array_parameter)
1512 TREE_STATIC (decl) = 1;
1513 DECL_EXTERNAL (decl) = 0;
1516 if (TREE_STATIC (decl)
1517 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1518 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1519 || gfc_option.flag_max_stack_var_size == 0
1520 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1521 && (gfc_option.coarray != GFC_FCOARRAY_LIB
1522 || !sym->attr.codimension || sym->attr.allocatable))
1524 /* Add static initializer. For procedures, it is only needed if
1525 SAVE is specified otherwise they need to be reinitialized
1526 every time the procedure is entered. The TREE_STATIC is
1527 in this case due to -fmax-stack-var-size=. */
1529 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1530 TREE_TYPE (decl), sym->attr.dimension
1531 || (sym->attr.codimension
1532 && sym->attr.allocatable),
1533 sym->attr.pointer || sym->attr.allocatable
1534 || sym->ts.type == BT_CLASS,
1535 sym->attr.proc_pointer);
1538 if (!TREE_STATIC (decl)
1539 && POINTER_TYPE_P (TREE_TYPE (decl))
1540 && !sym->attr.pointer
1541 && !sym->attr.allocatable
1542 && !sym->attr.proc_pointer
1543 && !sym->attr.select_type_temporary)
1544 DECL_BY_REFERENCE (decl) = 1;
1546 if (sym->attr.associate_var)
1547 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
1550 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1551 TREE_READONLY (decl) = 1;
1557 /* Substitute a temporary variable in place of the real one. */
1560 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1562 save->attr = sym->attr;
1563 save->decl = sym->backend_decl;
1565 gfc_clear_attr (&sym->attr);
1566 sym->attr.referenced = 1;
1567 sym->attr.flavor = FL_VARIABLE;
1569 sym->backend_decl = decl;
1573 /* Restore the original variable. */
1576 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1578 sym->attr = save->attr;
1579 sym->backend_decl = save->decl;
1583 /* Declare a procedure pointer. */
1586 get_proc_pointer_decl (gfc_symbol *sym)
1591 decl = sym->backend_decl;
1595 decl = build_decl (input_location,
1596 VAR_DECL, get_identifier (sym->name),
1597 build_pointer_type (gfc_get_function_type (sym)));
1601 /* Apply name mangling. */
1602 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1603 if (sym->attr.use_assoc)
1604 DECL_IGNORED_P (decl) = 1;
1607 if ((sym->ns->proc_name
1608 && sym->ns->proc_name->backend_decl == current_function_decl)
1609 || sym->attr.contained)
1610 gfc_add_decl_to_function (decl);
1611 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1612 gfc_add_decl_to_parent_function (decl);
1614 sym->backend_decl = decl;
1616 /* If a variable is USE associated, it's always external. */
1617 if (sym->attr.use_assoc)
1619 DECL_EXTERNAL (decl) = 1;
1620 TREE_PUBLIC (decl) = 1;
1622 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1624 /* This is the declaration of a module variable. */
1625 TREE_PUBLIC (decl) = 1;
1626 TREE_STATIC (decl) = 1;
1629 if (!sym->attr.use_assoc
1630 && (sym->attr.save != SAVE_NONE || sym->attr.data
1631 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1632 TREE_STATIC (decl) = 1;
1634 if (TREE_STATIC (decl) && sym->value)
1636 /* Add static initializer. */
1637 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1639 sym->attr.dimension,
1643 /* Handle threadprivate procedure pointers. */
1644 if (sym->attr.threadprivate
1645 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1646 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1648 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1649 decl_attributes (&decl, attributes, 0);
1655 /* Get a basic decl for an external function. */
1658 gfc_get_extern_function_decl (gfc_symbol * sym)
1664 gfc_intrinsic_sym *isym;
1666 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1671 if (sym->backend_decl)
1672 return sym->backend_decl;
1674 /* We should never be creating external decls for alternate entry points.
1675 The procedure may be an alternate entry point, but we don't want/need
1677 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1679 if (sym->attr.proc_pointer)
1680 return get_proc_pointer_decl (sym);
1682 /* See if this is an external procedure from the same file. If so,
1683 return the backend_decl. */
1684 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label
1685 ? sym->binding_label : sym->name);
1687 if (gsym && !gsym->defined)
1690 /* This can happen because of C binding. */
1691 if (gsym && gsym->ns && gsym->ns->proc_name
1692 && gsym->ns->proc_name->attr.flavor == FL_MODULE)
1695 if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1696 && !sym->backend_decl
1698 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1699 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1701 if (!gsym->ns->proc_name->backend_decl)
1703 /* By construction, the external function cannot be
1704 a contained procedure. */
1707 gfc_save_backend_locus (&old_loc);
1710 gfc_create_function_decl (gsym->ns, true);
1713 gfc_restore_backend_locus (&old_loc);
1716 /* If the namespace has entries, the proc_name is the
1717 entry master. Find the entry and use its backend_decl.
1718 otherwise, use the proc_name backend_decl. */
1719 if (gsym->ns->entries)
1721 gfc_entry_list *entry = gsym->ns->entries;
1723 for (; entry; entry = entry->next)
1725 if (strcmp (gsym->name, entry->sym->name) == 0)
1727 sym->backend_decl = entry->sym->backend_decl;
1733 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1735 if (sym->backend_decl)
1737 /* Avoid problems of double deallocation of the backend declaration
1738 later in gfc_trans_use_stmts; cf. PR 45087. */
1739 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1740 sym->attr.use_assoc = 0;
1742 return sym->backend_decl;
1746 /* See if this is a module procedure from the same file. If so,
1747 return the backend_decl. */
1749 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1752 if (gsym && gsym->ns
1753 && (gsym->type == GSYM_MODULE
1754 || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE)))
1759 if (gsym->type == GSYM_MODULE)
1760 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1762 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s);
1764 if (s && s->backend_decl)
1766 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1767 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1769 else if (sym->ts.type == BT_CHARACTER)
1770 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1771 sym->backend_decl = s->backend_decl;
1772 return sym->backend_decl;
1776 if (sym->attr.intrinsic)
1778 /* Call the resolution function to get the actual name. This is
1779 a nasty hack which relies on the resolution functions only looking
1780 at the first argument. We pass NULL for the second argument
1781 otherwise things like AINT get confused. */
1782 isym = gfc_find_function (sym->name);
1783 gcc_assert (isym->resolve.f0 != NULL);
1785 memset (&e, 0, sizeof (e));
1786 e.expr_type = EXPR_FUNCTION;
1788 memset (&argexpr, 0, sizeof (argexpr));
1789 gcc_assert (isym->formal);
1790 argexpr.ts = isym->formal->ts;
1792 if (isym->formal->next == NULL)
1793 isym->resolve.f1 (&e, &argexpr);
1796 if (isym->formal->next->next == NULL)
1797 isym->resolve.f2 (&e, &argexpr, NULL);
1800 if (isym->formal->next->next->next == NULL)
1801 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1804 /* All specific intrinsics take less than 5 arguments. */
1805 gcc_assert (isym->formal->next->next->next->next == NULL);
1806 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1811 if (gfc_option.flag_f2c
1812 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1813 || e.ts.type == BT_COMPLEX))
1815 /* Specific which needs a different implementation if f2c
1816 calling conventions are used. */
1817 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1820 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1822 name = get_identifier (s);
1823 mangled_name = name;
1827 name = gfc_sym_identifier (sym);
1828 mangled_name = gfc_sym_mangled_function_id (sym);
1831 type = gfc_get_function_type (sym);
1832 fndecl = build_decl (input_location,
1833 FUNCTION_DECL, name, type);
1835 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1836 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1837 the opposite of declaring a function as static in C). */
1838 DECL_EXTERNAL (fndecl) = 1;
1839 TREE_PUBLIC (fndecl) = 1;
1841 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1842 decl_attributes (&fndecl, attributes, 0);
1844 gfc_set_decl_assembler_name (fndecl, mangled_name);
1846 /* Set the context of this decl. */
1847 if (0 && sym->ns && sym->ns->proc_name)
1849 /* TODO: Add external decls to the appropriate scope. */
1850 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1854 /* Global declaration, e.g. intrinsic subroutine. */
1855 DECL_CONTEXT (fndecl) = NULL_TREE;
1858 /* Set attributes for PURE functions. A call to PURE function in the
1859 Fortran 95 sense is both pure and without side effects in the C
1861 if (sym->attr.pure || sym->attr.implicit_pure)
1863 if (sym->attr.function && !gfc_return_by_reference (sym))
1864 DECL_PURE_P (fndecl) = 1;
1865 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1866 parameters and don't use alternate returns (is this
1867 allowed?). In that case, calls to them are meaningless, and
1868 can be optimized away. See also in build_function_decl(). */
1869 TREE_SIDE_EFFECTS (fndecl) = 0;
1872 /* Mark non-returning functions. */
1873 if (sym->attr.noreturn)
1874 TREE_THIS_VOLATILE(fndecl) = 1;
1876 sym->backend_decl = fndecl;
1878 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1879 pushdecl_top_level (fndecl);
1882 && sym->formal_ns->proc_name == sym
1883 && sym->formal_ns->omp_declare_simd)
1884 gfc_trans_omp_declare_simd (sym->formal_ns);
1890 /* Create a declaration for a procedure. For external functions (in the C
1891 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1892 a master function with alternate entry points. */
1895 build_function_decl (gfc_symbol * sym, bool global)
1897 tree fndecl, type, attributes;
1898 symbol_attribute attr;
1900 gfc_formal_arglist *f;
1902 gcc_assert (!sym->attr.external);
1904 if (sym->backend_decl)
1907 /* Set the line and filename. sym->declared_at seems to point to the
1908 last statement for subroutines, but it'll do for now. */
1909 gfc_set_backend_locus (&sym->declared_at);
1911 /* Allow only one nesting level. Allow public declarations. */
1912 gcc_assert (current_function_decl == NULL_TREE
1913 || DECL_FILE_SCOPE_P (current_function_decl)
1914 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1915 == NAMESPACE_DECL));
1917 type = gfc_get_function_type (sym);
1918 fndecl = build_decl (input_location,
1919 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1923 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1924 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1925 the opposite of declaring a function as static in C). */
1926 DECL_EXTERNAL (fndecl) = 0;
1928 if (sym->attr.access == ACCESS_UNKNOWN && sym->module
1929 && (sym->ns->default_access == ACCESS_PRIVATE
1930 || (sym->ns->default_access == ACCESS_UNKNOWN
1931 && gfc_option.flag_module_private)))
1932 sym->attr.access = ACCESS_PRIVATE;
1934 if (!current_function_decl
1935 && !sym->attr.entry_master && !sym->attr.is_main_program
1936 && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
1937 || sym->attr.public_used))
1938 TREE_PUBLIC (fndecl) = 1;
1940 if (sym->attr.referenced || sym->attr.entry_master)
1941 TREE_USED (fndecl) = 1;
1943 attributes = add_attributes_to_decl (attr, NULL_TREE);
1944 decl_attributes (&fndecl, attributes, 0);
1946 /* Figure out the return type of the declared function, and build a
1947 RESULT_DECL for it. If this is a subroutine with alternate
1948 returns, build a RESULT_DECL for it. */
1949 result_decl = NULL_TREE;
1950 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1953 if (gfc_return_by_reference (sym))
1954 type = void_type_node;
1957 if (sym->result != sym)
1958 result_decl = gfc_sym_identifier (sym->result);
1960 type = TREE_TYPE (TREE_TYPE (fndecl));
1965 /* Look for alternate return placeholders. */
1966 int has_alternate_returns = 0;
1967 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
1971 has_alternate_returns = 1;
1976 if (has_alternate_returns)
1977 type = integer_type_node;
1979 type = void_type_node;
1982 result_decl = build_decl (input_location,
1983 RESULT_DECL, result_decl, type);
1984 DECL_ARTIFICIAL (result_decl) = 1;
1985 DECL_IGNORED_P (result_decl) = 1;
1986 DECL_CONTEXT (result_decl) = fndecl;
1987 DECL_RESULT (fndecl) = result_decl;
1989 /* Don't call layout_decl for a RESULT_DECL.
1990 layout_decl (result_decl, 0); */
1992 /* TREE_STATIC means the function body is defined here. */
1993 TREE_STATIC (fndecl) = 1;
1995 /* Set attributes for PURE functions. A call to a PURE function in the
1996 Fortran 95 sense is both pure and without side effects in the C
1998 if (attr.pure || attr.implicit_pure)
2000 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
2001 including an alternate return. In that case it can also be
2002 marked as PURE. See also in gfc_get_extern_function_decl(). */
2003 if (attr.function && !gfc_return_by_reference (sym))
2004 DECL_PURE_P (fndecl) = 1;
2005 TREE_SIDE_EFFECTS (fndecl) = 0;
2009 /* Layout the function declaration and put it in the binding level
2010 of the current function. */
2013 pushdecl_top_level (fndecl);
2017 /* Perform name mangling if this is a top level or module procedure. */
2018 if (current_function_decl == NULL_TREE)
2019 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
2021 sym->backend_decl = fndecl;
2025 /* Create the DECL_ARGUMENTS for a procedure. */
2028 create_function_arglist (gfc_symbol * sym)
2031 gfc_formal_arglist *f;
2032 tree typelist, hidden_typelist;
2033 tree arglist, hidden_arglist;
2037 fndecl = sym->backend_decl;
2039 /* Build formal argument list. Make sure that their TREE_CONTEXT is
2040 the new FUNCTION_DECL node. */
2041 arglist = NULL_TREE;
2042 hidden_arglist = NULL_TREE;
2043 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
2045 if (sym->attr.entry_master)
2047 type = TREE_VALUE (typelist);
2048 parm = build_decl (input_location,
2049 PARM_DECL, get_identifier ("__entry"), type);
2051 DECL_CONTEXT (parm) = fndecl;
2052 DECL_ARG_TYPE (parm) = type;
2053 TREE_READONLY (parm) = 1;
2054 gfc_finish_decl (parm);
2055 DECL_ARTIFICIAL (parm) = 1;
2057 arglist = chainon (arglist, parm);
2058 typelist = TREE_CHAIN (typelist);
2061 if (gfc_return_by_reference (sym))
2063 tree type = TREE_VALUE (typelist), length = NULL;
2065 if (sym->ts.type == BT_CHARACTER)
2067 /* Length of character result. */
2068 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2070 length = build_decl (input_location,
2072 get_identifier (".__result"),
2074 if (!sym->ts.u.cl->length)
2076 sym->ts.u.cl->backend_decl = length;
2077 TREE_USED (length) = 1;
2079 gcc_assert (TREE_CODE (length) == PARM_DECL);
2080 DECL_CONTEXT (length) = fndecl;
2081 DECL_ARG_TYPE (length) = len_type;
2082 TREE_READONLY (length) = 1;
2083 DECL_ARTIFICIAL (length) = 1;
2084 gfc_finish_decl (length);
2085 if (sym->ts.u.cl->backend_decl == NULL
2086 || sym->ts.u.cl->backend_decl == length)
2091 if (sym->ts.u.cl->backend_decl == NULL)
2093 tree len = build_decl (input_location,
2095 get_identifier ("..__result"),
2096 gfc_charlen_type_node);
2097 DECL_ARTIFICIAL (len) = 1;
2098 TREE_USED (len) = 1;
2099 sym->ts.u.cl->backend_decl = len;
2102 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2103 arg = sym->result ? sym->result : sym;
2104 backend_decl = arg->backend_decl;
2105 /* Temporary clear it, so that gfc_sym_type creates complete
2107 arg->backend_decl = NULL;
2108 type = gfc_sym_type (arg);
2109 arg->backend_decl = backend_decl;
2110 type = build_reference_type (type);
2114 parm = build_decl (input_location,
2115 PARM_DECL, get_identifier ("__result"), type);
2117 DECL_CONTEXT (parm) = fndecl;
2118 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2119 TREE_READONLY (parm) = 1;
2120 DECL_ARTIFICIAL (parm) = 1;
2121 gfc_finish_decl (parm);
2123 arglist = chainon (arglist, parm);
2124 typelist = TREE_CHAIN (typelist);
2126 if (sym->ts.type == BT_CHARACTER)
2128 gfc_allocate_lang_decl (parm);
2129 arglist = chainon (arglist, length);
2130 typelist = TREE_CHAIN (typelist);
2134 hidden_typelist = typelist;
2135 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2136 if (f->sym != NULL) /* Ignore alternate returns. */
2137 hidden_typelist = TREE_CHAIN (hidden_typelist);
2139 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2141 char name[GFC_MAX_SYMBOL_LEN + 2];
2143 /* Ignore alternate returns. */
2147 type = TREE_VALUE (typelist);
2149 if (f->sym->ts.type == BT_CHARACTER
2150 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2152 tree len_type = TREE_VALUE (hidden_typelist);
2153 tree length = NULL_TREE;
2154 if (!f->sym->ts.deferred)
2155 gcc_assert (len_type == gfc_charlen_type_node);
2157 gcc_assert (POINTER_TYPE_P (len_type));
2159 strcpy (&name[1], f->sym->name);
2161 length = build_decl (input_location,
2162 PARM_DECL, get_identifier (name), len_type);
2164 hidden_arglist = chainon (hidden_arglist, length);
2165 DECL_CONTEXT (length) = fndecl;
2166 DECL_ARTIFICIAL (length) = 1;
2167 DECL_ARG_TYPE (length) = len_type;
2168 TREE_READONLY (length) = 1;
2169 gfc_finish_decl (length);
2171 /* Remember the passed value. */
2172 if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2174 /* This can happen if the same type is used for multiple
2175 arguments. We need to copy cl as otherwise
2176 cl->passed_length gets overwritten. */
2177 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2179 f->sym->ts.u.cl->passed_length = length;
2181 /* Use the passed value for assumed length variables. */
2182 if (!f->sym->ts.u.cl->length)
2184 TREE_USED (length) = 1;
2185 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2186 f->sym->ts.u.cl->backend_decl = length;
2189 hidden_typelist = TREE_CHAIN (hidden_typelist);
2191 if (f->sym->ts.u.cl->backend_decl == NULL
2192 || f->sym->ts.u.cl->backend_decl == length)
2194 if (f->sym->ts.u.cl->backend_decl == NULL)
2195 gfc_create_string_length (f->sym);
2197 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2198 if (f->sym->attr.flavor == FL_PROCEDURE)
2199 type = build_pointer_type (gfc_get_function_type (f->sym));
2201 type = gfc_sym_type (f->sym);
2204 /* For noncharacter scalar intrinsic types, VALUE passes the value,
2205 hence, the optional status cannot be transferred via a NULL pointer.
2206 Thus, we will use a hidden argument in that case. */
2207 else if (f->sym->attr.optional && f->sym->attr.value
2208 && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS
2209 && f->sym->ts.type != BT_DERIVED)
2212 strcpy (&name[1], f->sym->name);
2214 tmp = build_decl (input_location,
2215 PARM_DECL, get_identifier (name),
2218 hidden_arglist = chainon (hidden_arglist, tmp);
2219 DECL_CONTEXT (tmp) = fndecl;
2220 DECL_ARTIFICIAL (tmp) = 1;
2221 DECL_ARG_TYPE (tmp) = boolean_type_node;
2222 TREE_READONLY (tmp) = 1;
2223 gfc_finish_decl (tmp);
2226 /* For non-constant length array arguments, make sure they use
2227 a different type node from TYPE_ARG_TYPES type. */
2228 if (f->sym->attr.dimension
2229 && type == TREE_VALUE (typelist)
2230 && TREE_CODE (type) == POINTER_TYPE
2231 && GFC_ARRAY_TYPE_P (type)
2232 && f->sym->as->type != AS_ASSUMED_SIZE
2233 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2235 if (f->sym->attr.flavor == FL_PROCEDURE)
2236 type = build_pointer_type (gfc_get_function_type (f->sym));
2238 type = gfc_sym_type (f->sym);
2241 if (f->sym->attr.proc_pointer)
2242 type = build_pointer_type (type);
2244 if (f->sym->attr.volatile_)
2245 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2247 /* Build the argument declaration. */
2248 parm = build_decl (input_location,
2249 PARM_DECL, gfc_sym_identifier (f->sym), type);
2251 if (f->sym->attr.volatile_)
2253 TREE_THIS_VOLATILE (parm) = 1;
2254 TREE_SIDE_EFFECTS (parm) = 1;
2257 /* Fill in arg stuff. */
2258 DECL_CONTEXT (parm) = fndecl;
2259 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2260 /* All implementation args are read-only. */
2261 TREE_READONLY (parm) = 1;
2262 if (POINTER_TYPE_P (type)
2263 && (!f->sym->attr.proc_pointer
2264 && f->sym->attr.flavor != FL_PROCEDURE))
2265 DECL_BY_REFERENCE (parm) = 1;
2267 gfc_finish_decl (parm);
2268 gfc_finish_decl_attrs (parm, &f->sym->attr);
2270 f->sym->backend_decl = parm;
2272 /* Coarrays which are descriptorless or assumed-shape pass with
2273 -fcoarray=lib the token and the offset as hidden arguments. */
2274 if (gfc_option.coarray == GFC_FCOARRAY_LIB
2275 && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
2276 && !f->sym->attr.allocatable)
2277 || (f->sym->ts.type == BT_CLASS
2278 && CLASS_DATA (f->sym)->attr.codimension
2279 && !CLASS_DATA (f->sym)->attr.allocatable)))
2285 gcc_assert (f->sym->backend_decl != NULL_TREE
2286 && !sym->attr.is_bind_c);
2287 caf_type = f->sym->ts.type == BT_CLASS
2288 ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
2289 : TREE_TYPE (f->sym->backend_decl);
2291 token = build_decl (input_location, PARM_DECL,
2292 create_tmp_var_name ("caf_token"),
2293 build_qualified_type (pvoid_type_node,
2294 TYPE_QUAL_RESTRICT));
2295 if ((f->sym->ts.type != BT_CLASS
2296 && f->sym->as->type != AS_DEFERRED)
2297 || (f->sym->ts.type == BT_CLASS
2298 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2300 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2301 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2302 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2303 gfc_allocate_lang_decl (f->sym->backend_decl);
2304 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2308 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2309 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2312 DECL_CONTEXT (token) = fndecl;
2313 DECL_ARTIFICIAL (token) = 1;
2314 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2315 TREE_READONLY (token) = 1;
2316 hidden_arglist = chainon (hidden_arglist, token);
2317 gfc_finish_decl (token);
2319 offset = build_decl (input_location, PARM_DECL,
2320 create_tmp_var_name ("caf_offset"),
2321 gfc_array_index_type);
2323 if ((f->sym->ts.type != BT_CLASS
2324 && f->sym->as->type != AS_DEFERRED)
2325 || (f->sym->ts.type == BT_CLASS
2326 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
2328 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2330 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2334 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2335 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2337 DECL_CONTEXT (offset) = fndecl;
2338 DECL_ARTIFICIAL (offset) = 1;
2339 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2340 TREE_READONLY (offset) = 1;
2341 hidden_arglist = chainon (hidden_arglist, offset);
2342 gfc_finish_decl (offset);
2345 arglist = chainon (arglist, parm);
2346 typelist = TREE_CHAIN (typelist);
2349 /* Add the hidden string length parameters, unless the procedure
2351 if (!sym->attr.is_bind_c)
2352 arglist = chainon (arglist, hidden_arglist);
2354 gcc_assert (hidden_typelist == NULL_TREE
2355 || TREE_VALUE (hidden_typelist) == void_type_node);
2356 DECL_ARGUMENTS (fndecl) = arglist;
2359 /* Do the setup necessary before generating the body of a function. */
2362 trans_function_start (gfc_symbol * sym)
2366 fndecl = sym->backend_decl;
2368 /* Let GCC know the current scope is this function. */
2369 current_function_decl = fndecl;
2371 /* Let the world know what we're about to do. */
2372 announce_function (fndecl);
2374 if (DECL_FILE_SCOPE_P (fndecl))
2376 /* Create RTL for function declaration. */
2377 rest_of_decl_compilation (fndecl, 1, 0);
2380 /* Create RTL for function definition. */
2381 make_decl_rtl (fndecl);
2383 allocate_struct_function (fndecl, false);
2385 /* function.c requires a push at the start of the function. */
2389 /* Create thunks for alternate entry points. */
2392 build_entry_thunks (gfc_namespace * ns, bool global)
2394 gfc_formal_arglist *formal;
2395 gfc_formal_arglist *thunk_formal;
2397 gfc_symbol *thunk_sym;
2403 /* This should always be a toplevel function. */
2404 gcc_assert (current_function_decl == NULL_TREE);
2406 gfc_save_backend_locus (&old_loc);
2407 for (el = ns->entries; el; el = el->next)
2409 vec<tree, va_gc> *args = NULL;
2410 vec<tree, va_gc> *string_args = NULL;
2412 thunk_sym = el->sym;
2414 build_function_decl (thunk_sym, global);
2415 create_function_arglist (thunk_sym);
2417 trans_function_start (thunk_sym);
2419 thunk_fndecl = thunk_sym->backend_decl;
2421 gfc_init_block (&body);
2423 /* Pass extra parameter identifying this entry point. */
2424 tmp = build_int_cst (gfc_array_index_type, el->id);
2425 vec_safe_push (args, tmp);
2427 if (thunk_sym->attr.function)
2429 if (gfc_return_by_reference (ns->proc_name))
2431 tree ref = DECL_ARGUMENTS (current_function_decl);
2432 vec_safe_push (args, ref);
2433 if (ns->proc_name->ts.type == BT_CHARACTER)
2434 vec_safe_push (args, DECL_CHAIN (ref));
2438 for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
2439 formal = formal->next)
2441 /* Ignore alternate returns. */
2442 if (formal->sym == NULL)
2445 /* We don't have a clever way of identifying arguments, so resort to
2446 a brute-force search. */
2447 for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
2449 thunk_formal = thunk_formal->next)
2451 if (thunk_formal->sym == formal->sym)
2457 /* Pass the argument. */
2458 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2459 vec_safe_push (args, thunk_formal->sym->backend_decl);
2460 if (formal->sym->ts.type == BT_CHARACTER)
2462 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2463 vec_safe_push (string_args, tmp);
2468 /* Pass NULL for a missing argument. */
2469 vec_safe_push (args, null_pointer_node);
2470 if (formal->sym->ts.type == BT_CHARACTER)
2472 tmp = build_int_cst (gfc_charlen_type_node, 0);
2473 vec_safe_push (string_args, tmp);
2478 /* Call the master function. */
2479 vec_safe_splice (args, string_args);
2480 tmp = ns->proc_name->backend_decl;
2481 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2482 if (ns->proc_name->attr.mixed_entry_master)
2484 tree union_decl, field;
2485 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2487 union_decl = build_decl (input_location,
2488 VAR_DECL, get_identifier ("__result"),
2489 TREE_TYPE (master_type));
2490 DECL_ARTIFICIAL (union_decl) = 1;
2491 DECL_EXTERNAL (union_decl) = 0;
2492 TREE_PUBLIC (union_decl) = 0;
2493 TREE_USED (union_decl) = 1;
2494 layout_decl (union_decl, 0);
2495 pushdecl (union_decl);
2497 DECL_CONTEXT (union_decl) = current_function_decl;
2498 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2499 TREE_TYPE (union_decl), union_decl, tmp);
2500 gfc_add_expr_to_block (&body, tmp);
2502 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2503 field; field = DECL_CHAIN (field))
2504 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2505 thunk_sym->result->name) == 0)
2507 gcc_assert (field != NULL_TREE);
2508 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2509 TREE_TYPE (field), union_decl, field,
2511 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2512 TREE_TYPE (DECL_RESULT (current_function_decl)),
2513 DECL_RESULT (current_function_decl), tmp);
2514 tmp = build1_v (RETURN_EXPR, tmp);
2516 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2519 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2520 TREE_TYPE (DECL_RESULT (current_function_decl)),
2521 DECL_RESULT (current_function_decl), tmp);
2522 tmp = build1_v (RETURN_EXPR, tmp);
2524 gfc_add_expr_to_block (&body, tmp);
2526 /* Finish off this function and send it for code generation. */
2527 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2530 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2531 DECL_SAVED_TREE (thunk_fndecl)
2532 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2533 DECL_INITIAL (thunk_fndecl));
2535 /* Output the GENERIC tree. */
2536 dump_function (TDI_original, thunk_fndecl);
2538 /* Store the end of the function, so that we get good line number
2539 info for the epilogue. */
2540 cfun->function_end_locus = input_location;
2542 /* We're leaving the context of this function, so zap cfun.
2543 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2544 tree_rest_of_compilation. */
2547 current_function_decl = NULL_TREE;
2549 cgraph_finalize_function (thunk_fndecl, true);
2551 /* We share the symbols in the formal argument list with other entry
2552 points and the master function. Clear them so that they are
2553 recreated for each function. */
2554 for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
2555 formal = formal->next)
2556 if (formal->sym != NULL) /* Ignore alternate returns. */
2558 formal->sym->backend_decl = NULL_TREE;
2559 if (formal->sym->ts.type == BT_CHARACTER)
2560 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2563 if (thunk_sym->attr.function)
2565 if (thunk_sym->ts.type == BT_CHARACTER)
2566 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2567 if (thunk_sym->result->ts.type == BT_CHARACTER)
2568 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2572 gfc_restore_backend_locus (&old_loc);
2576 /* Create a decl for a function, and create any thunks for alternate entry
2577 points. If global is true, generate the function in the global binding
2578 level, otherwise in the current binding level (which can be global). */
2581 gfc_create_function_decl (gfc_namespace * ns, bool global)
2583 /* Create a declaration for the master function. */
2584 build_function_decl (ns->proc_name, global);
2586 /* Compile the entry thunks. */
2588 build_entry_thunks (ns, global);
2590 /* Now create the read argument list. */
2591 create_function_arglist (ns->proc_name);
2593 if (ns->omp_declare_simd)
2594 gfc_trans_omp_declare_simd (ns);
2597 /* Return the decl used to hold the function return value. If
2598 parent_flag is set, the context is the parent_scope. */
2601 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2605 tree this_fake_result_decl;
2606 tree this_function_decl;
2608 char name[GFC_MAX_SYMBOL_LEN + 10];
2612 this_fake_result_decl = parent_fake_result_decl;
2613 this_function_decl = DECL_CONTEXT (current_function_decl);
2617 this_fake_result_decl = current_fake_result_decl;
2618 this_function_decl = current_function_decl;
2622 && sym->ns->proc_name->backend_decl == this_function_decl
2623 && sym->ns->proc_name->attr.entry_master
2624 && sym != sym->ns->proc_name)
2627 if (this_fake_result_decl != NULL)
2628 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2629 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2632 return TREE_VALUE (t);
2633 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2636 this_fake_result_decl = parent_fake_result_decl;
2638 this_fake_result_decl = current_fake_result_decl;
2640 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2644 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2645 field; field = DECL_CHAIN (field))
2646 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2650 gcc_assert (field != NULL_TREE);
2651 decl = fold_build3_loc (input_location, COMPONENT_REF,
2652 TREE_TYPE (field), decl, field, NULL_TREE);
2655 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2657 gfc_add_decl_to_parent_function (var);
2659 gfc_add_decl_to_function (var);
2661 SET_DECL_VALUE_EXPR (var, decl);
2662 DECL_HAS_VALUE_EXPR_P (var) = 1;
2663 GFC_DECL_RESULT (var) = 1;
2665 TREE_CHAIN (this_fake_result_decl)
2666 = tree_cons (get_identifier (sym->name), var,
2667 TREE_CHAIN (this_fake_result_decl));
2671 if (this_fake_result_decl != NULL_TREE)
2672 return TREE_VALUE (this_fake_result_decl);
2674 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2679 if (sym->ts.type == BT_CHARACTER)
2681 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2682 length = gfc_create_string_length (sym);
2684 length = sym->ts.u.cl->backend_decl;
2685 if (TREE_CODE (length) == VAR_DECL
2686 && DECL_CONTEXT (length) == NULL_TREE)
2687 gfc_add_decl_to_function (length);
2690 if (gfc_return_by_reference (sym))
2692 decl = DECL_ARGUMENTS (this_function_decl);
2694 if (sym->ns->proc_name->backend_decl == this_function_decl
2695 && sym->ns->proc_name->attr.entry_master)
2696 decl = DECL_CHAIN (decl);
2698 TREE_USED (decl) = 1;
2700 decl = gfc_build_dummy_array_decl (sym, decl);
2704 sprintf (name, "__result_%.20s",
2705 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2707 if (!sym->attr.mixed_entry_master && sym->attr.function)
2708 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2709 VAR_DECL, get_identifier (name),
2710 gfc_sym_type (sym));
2712 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2713 VAR_DECL, get_identifier (name),
2714 TREE_TYPE (TREE_TYPE (this_function_decl)));
2715 DECL_ARTIFICIAL (decl) = 1;
2716 DECL_EXTERNAL (decl) = 0;
2717 TREE_PUBLIC (decl) = 0;
2718 TREE_USED (decl) = 1;
2719 GFC_DECL_RESULT (decl) = 1;
2720 TREE_ADDRESSABLE (decl) = 1;
2722 layout_decl (decl, 0);
2723 gfc_finish_decl_attrs (decl, &sym->attr);
2726 gfc_add_decl_to_parent_function (decl);
2728 gfc_add_decl_to_function (decl);
2732 parent_fake_result_decl = build_tree_list (NULL, decl);
2734 current_fake_result_decl = build_tree_list (NULL, decl);
2740 /* Builds a function decl. The remaining parameters are the types of the
2741 function arguments. Negative nargs indicates a varargs function. */
2744 build_library_function_decl_1 (tree name, const char *spec,
2745 tree rettype, int nargs, va_list p)
2747 vec<tree, va_gc> *arglist;
2752 /* Library functions must be declared with global scope. */
2753 gcc_assert (current_function_decl == NULL_TREE);
2755 /* Create a list of the argument types. */
2756 vec_alloc (arglist, abs (nargs));
2757 for (n = abs (nargs); n > 0; n--)
2759 tree argtype = va_arg (p, tree);
2760 arglist->quick_push (argtype);
2763 /* Build the function type and decl. */
2765 fntype = build_function_type_vec (rettype, arglist);
2767 fntype = build_varargs_function_type_vec (rettype, arglist);
2770 tree attr_args = build_tree_list (NULL_TREE,
2771 build_string (strlen (spec), spec));
2772 tree attrs = tree_cons (get_identifier ("fn spec"),
2773 attr_args, TYPE_ATTRIBUTES (fntype));
2774 fntype = build_type_attribute_variant (fntype, attrs);
2776 fndecl = build_decl (input_location,
2777 FUNCTION_DECL, name, fntype);
2779 /* Mark this decl as external. */
2780 DECL_EXTERNAL (fndecl) = 1;
2781 TREE_PUBLIC (fndecl) = 1;
2785 rest_of_decl_compilation (fndecl, 1, 0);
2790 /* Builds a function decl. The remaining parameters are the types of the
2791 function arguments. Negative nargs indicates a varargs function. */
2794 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2798 va_start (args, nargs);
2799 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2804 /* Builds a function decl. The remaining parameters are the types of the
2805 function arguments. Negative nargs indicates a varargs function.
2806 The SPEC parameter specifies the function argument and return type
2807 specification according to the fnspec function type attribute. */
2810 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2811 tree rettype, int nargs, ...)
2815 va_start (args, nargs);
2816 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2822 gfc_build_intrinsic_function_decls (void)
2824 tree gfc_int4_type_node = gfc_get_int_type (4);
2825 tree gfc_int8_type_node = gfc_get_int_type (8);
2826 tree gfc_int16_type_node = gfc_get_int_type (16);
2827 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2828 tree pchar1_type_node = gfc_get_pchar_type (1);
2829 tree pchar4_type_node = gfc_get_pchar_type (4);
2831 /* String functions. */
2832 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2833 get_identifier (PREFIX("compare_string")), "..R.R",
2834 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2835 gfc_charlen_type_node, pchar1_type_node);
2836 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2837 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2839 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2840 get_identifier (PREFIX("concat_string")), "..W.R.R",
2841 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2842 gfc_charlen_type_node, pchar1_type_node,
2843 gfc_charlen_type_node, pchar1_type_node);
2844 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2846 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2847 get_identifier (PREFIX("string_len_trim")), "..R",
2848 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2849 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2850 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2852 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2853 get_identifier (PREFIX("string_index")), "..R.R.",
2854 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2855 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2856 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2857 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2859 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2860 get_identifier (PREFIX("string_scan")), "..R.R.",
2861 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2862 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2863 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2864 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2866 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2867 get_identifier (PREFIX("string_verify")), "..R.R.",
2868 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2869 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2870 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2871 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2873 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2874 get_identifier (PREFIX("string_trim")), ".Ww.R",
2875 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2876 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2879 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2880 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2881 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2882 build_pointer_type (pchar1_type_node), integer_type_node,
2885 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2886 get_identifier (PREFIX("adjustl")), ".W.R",
2887 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2889 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2891 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2892 get_identifier (PREFIX("adjustr")), ".W.R",
2893 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2895 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2897 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2898 get_identifier (PREFIX("select_string")), ".R.R.",
2899 integer_type_node, 4, pvoid_type_node, integer_type_node,
2900 pchar1_type_node, gfc_charlen_type_node);
2901 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2902 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2904 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2905 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2906 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2907 gfc_charlen_type_node, pchar4_type_node);
2908 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2909 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2911 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2912 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2913 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2914 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2916 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2918 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2919 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2920 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2921 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2922 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2924 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2925 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2926 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2927 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2928 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2929 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2931 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2932 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2933 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2934 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2935 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2936 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2938 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2939 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2940 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2941 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2942 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2943 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2945 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2946 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2947 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2948 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2951 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2952 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2953 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2954 build_pointer_type (pchar4_type_node), integer_type_node,
2957 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2958 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2959 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2961 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2963 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2964 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2965 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2967 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2969 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2970 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2971 integer_type_node, 4, pvoid_type_node, integer_type_node,
2972 pvoid_type_node, gfc_charlen_type_node);
2973 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2974 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2977 /* Conversion between character kinds. */
2979 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2980 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2981 void_type_node, 3, build_pointer_type (pchar4_type_node),
2982 gfc_charlen_type_node, pchar1_type_node);
2984 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2985 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2986 void_type_node, 3, build_pointer_type (pchar1_type_node),
2987 gfc_charlen_type_node, pchar4_type_node);
2989 /* Misc. functions. */
2991 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2992 get_identifier (PREFIX("ttynam")), ".W",
2993 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2996 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2997 get_identifier (PREFIX("fdate")), ".W",
2998 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
3000 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3001 get_identifier (PREFIX("ctime")), ".W",
3002 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3003 gfc_int8_type_node);
3005 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3006 get_identifier (PREFIX("selected_char_kind")), "..R",
3007 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
3008 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3009 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3011 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
3012 get_identifier (PREFIX("selected_int_kind")), ".R",
3013 gfc_int4_type_node, 1, pvoid_type_node);
3014 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
3015 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
3017 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
3018 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
3019 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
3021 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
3022 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
3024 /* Power functions. */
3026 tree ctype, rtype, itype, jtype;
3027 int rkind, ikind, jkind;
3030 static int ikinds[NIKINDS] = {4, 8, 16};
3031 static int rkinds[NRKINDS] = {4, 8, 10, 16};
3032 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
3034 for (ikind=0; ikind < NIKINDS; ikind++)
3036 itype = gfc_get_int_type (ikinds[ikind]);
3038 for (jkind=0; jkind < NIKINDS; jkind++)
3040 jtype = gfc_get_int_type (ikinds[jkind]);
3043 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3045 gfor_fndecl_math_powi[jkind][ikind].integer =
3046 gfc_build_library_function_decl (get_identifier (name),
3047 jtype, 2, jtype, itype);
3048 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3049 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3053 for (rkind = 0; rkind < NRKINDS; rkind ++)
3055 rtype = gfc_get_real_type (rkinds[rkind]);
3058 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
3060 gfor_fndecl_math_powi[rkind][ikind].real =
3061 gfc_build_library_function_decl (get_identifier (name),
3062 rtype, 2, rtype, itype);
3063 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3064 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3067 ctype = gfc_get_complex_type (rkinds[rkind]);
3070 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
3072 gfor_fndecl_math_powi[rkind][ikind].cmplx =
3073 gfc_build_library_function_decl (get_identifier (name),
3074 ctype, 2,ctype, itype);
3075 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3076 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3084 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
3085 get_identifier (PREFIX("ishftc4")),
3086 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
3087 gfc_int4_type_node);
3088 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
3089 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
3091 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
3092 get_identifier (PREFIX("ishftc8")),
3093 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
3094 gfc_int4_type_node);
3095 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3096 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3098 if (gfc_int16_type_node)
3100 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3101 get_identifier (PREFIX("ishftc16")),
3102 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
3103 gfc_int4_type_node);
3104 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3105 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3108 /* BLAS functions. */
3110 tree pint = build_pointer_type (integer_type_node);
3111 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3112 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3113 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3114 tree pz = build_pointer_type
3115 (gfc_get_complex_type (gfc_default_double_kind));
3117 gfor_fndecl_sgemm = gfc_build_library_function_decl
3119 (gfc_option.flag_underscoring ? "sgemm_"
3121 void_type_node, 15, pchar_type_node,
3122 pchar_type_node, pint, pint, pint, ps, ps, pint,
3123 ps, pint, ps, ps, pint, integer_type_node,
3125 gfor_fndecl_dgemm = gfc_build_library_function_decl
3127 (gfc_option.flag_underscoring ? "dgemm_"
3129 void_type_node, 15, pchar_type_node,
3130 pchar_type_node, pint, pint, pint, pd, pd, pint,
3131 pd, pint, pd, pd, pint, integer_type_node,
3133 gfor_fndecl_cgemm = gfc_build_library_function_decl
3135 (gfc_option.flag_underscoring ? "cgemm_"
3137 void_type_node, 15, pchar_type_node,
3138 pchar_type_node, pint, pint, pint, pc, pc, pint,
3139 pc, pint, pc, pc, pint, integer_type_node,
3141 gfor_fndecl_zgemm = gfc_build_library_function_decl
3143 (gfc_option.flag_underscoring ? "zgemm_"
3145 void_type_node, 15, pchar_type_node,
3146 pchar_type_node, pint, pint, pint, pz, pz, pint,
3147 pz, pint, pz, pz, pint, integer_type_node,
3151 /* Other functions. */
3152 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3153 get_identifier (PREFIX("size0")), ".R",
3154 gfc_array_index_type, 1, pvoid_type_node);
3155 DECL_PURE_P (gfor_fndecl_size0) = 1;
3156 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3158 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3159 get_identifier (PREFIX("size1")), ".R",
3160 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3161 DECL_PURE_P (gfor_fndecl_size1) = 1;
3162 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3164 gfor_fndecl_iargc = gfc_build_library_function_decl (
3165 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3166 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3170 /* Make prototypes for runtime library functions. */
3173 gfc_build_builtin_function_decls (void)
3175 tree gfc_int4_type_node = gfc_get_int_type (4);
3177 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3178 get_identifier (PREFIX("stop_numeric")),
3179 void_type_node, 1, gfc_int4_type_node);
3180 /* STOP doesn't return. */
3181 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3183 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
3184 get_identifier (PREFIX("stop_numeric_f08")),
3185 void_type_node, 1, gfc_int4_type_node);
3186 /* STOP doesn't return. */
3187 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
3189 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3190 get_identifier (PREFIX("stop_string")), ".R.",
3191 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3192 /* STOP doesn't return. */
3193 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3195 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3196 get_identifier (PREFIX("error_stop_numeric")),
3197 void_type_node, 1, gfc_int4_type_node);
3198 /* ERROR STOP doesn't return. */
3199 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3201 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3202 get_identifier (PREFIX("error_stop_string")), ".R.",
3203 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3204 /* ERROR STOP doesn't return. */
3205 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3207 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3208 get_identifier (PREFIX("pause_numeric")),
3209 void_type_node, 1, gfc_int4_type_node);
3211 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3212 get_identifier (PREFIX("pause_string")), ".R.",
3213 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3215 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3216 get_identifier (PREFIX("runtime_error")), ".R",
3217 void_type_node, -1, pchar_type_node);
3218 /* The runtime_error function does not return. */
3219 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3221 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3222 get_identifier (PREFIX("runtime_error_at")), ".RR",
3223 void_type_node, -2, pchar_type_node, pchar_type_node);
3224 /* The runtime_error_at function does not return. */
3225 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3227 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3228 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3229 void_type_node, -2, pchar_type_node, pchar_type_node);
3231 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3232 get_identifier (PREFIX("generate_error")), ".R.R",
3233 void_type_node, 3, pvoid_type_node, integer_type_node,
3236 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3237 get_identifier (PREFIX("os_error")), ".R",
3238 void_type_node, 1, pchar_type_node);
3239 /* The runtime_error function does not return. */
3240 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3242 gfor_fndecl_set_args = gfc_build_library_function_decl (
3243 get_identifier (PREFIX("set_args")),
3244 void_type_node, 2, integer_type_node,
3245 build_pointer_type (pchar_type_node));
3247 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3248 get_identifier (PREFIX("set_fpe")),
3249 void_type_node, 1, integer_type_node);
3251 /* Keep the array dimension in sync with the call, later in this file. */
3252 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3253 get_identifier (PREFIX("set_options")), "..R",
3254 void_type_node, 2, integer_type_node,
3255 build_pointer_type (integer_type_node));
3257 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3258 get_identifier (PREFIX("set_convert")),
3259 void_type_node, 1, integer_type_node);
3261 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3262 get_identifier (PREFIX("set_record_marker")),
3263 void_type_node, 1, integer_type_node);
3265 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3266 get_identifier (PREFIX("set_max_subrecord_length")),
3267 void_type_node, 1, integer_type_node);
3269 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3270 get_identifier (PREFIX("internal_pack")), ".r",
3271 pvoid_type_node, 1, pvoid_type_node);
3273 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3274 get_identifier (PREFIX("internal_unpack")), ".wR",
3275 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3277 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3278 get_identifier (PREFIX("associated")), ".RR",
3279 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3280 DECL_PURE_P (gfor_fndecl_associated) = 1;
3281 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3283 /* Coarray library calls. */
3284 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3286 tree pint_type, pppchar_type;
3288 pint_type = build_pointer_type (integer_type_node);
3290 = build_pointer_type (build_pointer_type (pchar_type_node));
3292 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3293 get_identifier (PREFIX("caf_init")), void_type_node,
3294 2, pint_type, pppchar_type);
3296 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3297 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3299 gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
3300 get_identifier (PREFIX("caf_this_image")), integer_type_node,
3301 1, integer_type_node);
3303 gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
3304 get_identifier (PREFIX("caf_num_images")), integer_type_node,
3305 2, integer_type_node, integer_type_node);
3307 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3308 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3309 size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3310 pchar_type_node, integer_type_node);
3312 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3313 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
3314 ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
3316 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3317 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3319 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3320 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3322 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3323 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3324 3, pint_type, pchar_type_node, integer_type_node);
3326 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3327 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3328 5, integer_type_node, pint_type, pint_type,
3329 pchar_type_node, integer_type_node);
3331 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3332 get_identifier (PREFIX("caf_error_stop")),
3333 void_type_node, 1, gfc_int4_type_node);
3334 /* CAF's ERROR STOP doesn't return. */
3335 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3337 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3338 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3339 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3340 /* CAF's ERROR STOP doesn't return. */
3341 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3343 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
3344 get_identifier (PREFIX("caf_co_max")), "WR.WW",
3345 void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
3346 pint_type, pchar_type_node, integer_type_node, integer_type_node);
3348 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
3349 get_identifier (PREFIX("caf_co_min")), "WR.WW",
3350 void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
3351 pint_type, pchar_type_node, integer_type_node, integer_type_node);
3353 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
3354 get_identifier (PREFIX("caf_co_sum")), "WR.WW",
3355 void_type_node, 6, pvoid_type_node, pvoid_type_node, integer_type_node,
3356 pint_type, pchar_type_node, integer_type_node);
3359 gfc_build_intrinsic_function_decls ();
3360 gfc_build_intrinsic_lib_fndecls ();
3361 gfc_build_io_library_fndecls ();
3365 /* Evaluate the length of dummy character variables. */
3368 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3369 gfc_wrapped_block *block)
3373 gfc_finish_decl (cl->backend_decl);
3375 gfc_start_block (&init);
3377 /* Evaluate the string length expression. */
3378 gfc_conv_string_length (cl, NULL, &init);
3380 gfc_trans_vla_type_sizes (sym, &init);
3382 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3386 /* Allocate and cleanup an automatic character variable. */
3389 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3395 gcc_assert (sym->backend_decl);
3396 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3398 gfc_init_block (&init);
3400 /* Evaluate the string length expression. */
3401 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3403 gfc_trans_vla_type_sizes (sym, &init);
3405 decl = sym->backend_decl;
3407 /* Emit a DECL_EXPR for this variable, which will cause the
3408 gimplifier to allocate storage, and all that good stuff. */
3409 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3410 gfc_add_expr_to_block (&init, tmp);
3412 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3415 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3418 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3422 gcc_assert (sym->backend_decl);
3423 gfc_start_block (&init);
3425 /* Set the initial value to length. See the comments in
3426 function gfc_add_assign_aux_vars in this file. */
3427 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3428 build_int_cst (gfc_charlen_type_node, -2));
3430 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3434 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3436 tree t = *tp, var, val;
3438 if (t == NULL || t == error_mark_node)
3440 if (TREE_CONSTANT (t) || DECL_P (t))
3443 if (TREE_CODE (t) == SAVE_EXPR)
3445 if (SAVE_EXPR_RESOLVED_P (t))
3447 *tp = TREE_OPERAND (t, 0);
3450 val = TREE_OPERAND (t, 0);
3455 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3456 gfc_add_decl_to_function (var);
3457 gfc_add_modify (body, var, val);
3458 if (TREE_CODE (t) == SAVE_EXPR)
3459 TREE_OPERAND (t, 0) = var;
3464 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3468 if (type == NULL || type == error_mark_node)
3471 type = TYPE_MAIN_VARIANT (type);
3473 if (TREE_CODE (type) == INTEGER_TYPE)
3475 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3476 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3478 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3480 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3481 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3484 else if (TREE_CODE (type) == ARRAY_TYPE)
3486 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3487 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3488 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3489 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3491 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3493 TYPE_SIZE (t) = TYPE_SIZE (type);
3494 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3499 /* Make sure all type sizes and array domains are either constant,
3500 or variable or parameter decls. This is a simplified variant
3501 of gimplify_type_sizes, but we can't use it here, as none of the
3502 variables in the expressions have been gimplified yet.
3503 As type sizes and domains for various variable length arrays
3504 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3505 time, without this routine gimplify_type_sizes in the middle-end
3506 could result in the type sizes being gimplified earlier than where
3507 those variables are initialized. */
3510 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3512 tree type = TREE_TYPE (sym->backend_decl);
3514 if (TREE_CODE (type) == FUNCTION_TYPE
3515 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3517 if (! current_fake_result_decl)
3520 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3523 while (POINTER_TYPE_P (type))
3524 type = TREE_TYPE (type);
3526 if (GFC_DESCRIPTOR_TYPE_P (type))
3528 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3530 while (POINTER_TYPE_P (etype))
3531 etype = TREE_TYPE (etype);
3533 gfc_trans_vla_type_sizes_1 (etype, body);
3536 gfc_trans_vla_type_sizes_1 (type, body);
3540 /* Initialize a derived type by building an lvalue from the symbol
3541 and using trans_assignment to do the work. Set dealloc to false
3542 if no deallocation prior the assignment is needed. */
3544 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3552 gcc_assert (!sym->attr.allocatable);
3553 gfc_set_sym_referenced (sym);
3554 e = gfc_lval_expr_from_sym (sym);
3555 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3556 if (sym->attr.dummy && (sym->attr.optional
3557 || sym->ns->proc_name->attr.entry_master))
3559 present = gfc_conv_expr_present (sym);
3560 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3561 tmp, build_empty_stmt (input_location));
3563 gfc_add_expr_to_block (block, tmp);
3568 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3569 them their default initializer, if they do not have allocatable
3570 components, they have their allocatable components deallocated. */
3573 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3576 gfc_formal_arglist *f;
3580 gfc_init_block (&init);
3581 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
3582 if (f->sym && f->sym->attr.intent == INTENT_OUT
3583 && !f->sym->attr.pointer
3584 && f->sym->ts.type == BT_DERIVED)
3588 /* Note: Allocatables are excluded as they are already handled
3590 if (!f->sym->attr.allocatable
3591 && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
3596 gfc_init_block (&block);
3597 f->sym->attr.referenced = 1;
3598 e = gfc_lval_expr_from_sym (f->sym);
3599 gfc_add_finalizer_call (&block, e);
3601 tmp = gfc_finish_block (&block);
3604 if (tmp == NULL_TREE && !f->sym->attr.allocatable
3605 && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3606 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3607 f->sym->backend_decl,
3608 f->sym->as ? f->sym->as->rank : 0);
3610 if (tmp != NULL_TREE && (f->sym->attr.optional
3611 || f->sym->ns->proc_name->attr.entry_master))
3613 present = gfc_conv_expr_present (f->sym);
3614 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3615 present, tmp, build_empty_stmt (input_location));
3618 if (tmp != NULL_TREE)
3619 gfc_add_expr_to_block (&init, tmp);
3620 else if (f->sym->value && !f->sym->attr.allocatable)
3621 gfc_init_default_dt (f->sym, &init, true);
3623 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3624 && f->sym->ts.type == BT_CLASS
3625 && !CLASS_DATA (f->sym)->attr.class_pointer
3626 && !CLASS_DATA (f->sym)->attr.allocatable)
3631 gfc_init_block (&block);
3632 f->sym->attr.referenced = 1;
3633 e = gfc_lval_expr_from_sym (f->sym);
3634 gfc_add_finalizer_call (&block, e);
3636 tmp = gfc_finish_block (&block);
3638 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3640 present = gfc_conv_expr_present (f->sym);
3641 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3643 build_empty_stmt (input_location));
3646 gfc_add_expr_to_block (&init, tmp);
3649 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3653 /* Generate function entry and exit code, and add it to the function body.
3655 Allocation and initialization of array variables.
3656 Allocation of character string variables.
3657 Initialization and possibly repacking of dummy arrays.
3658 Initialization of ASSIGN statement auxiliary variable.
3659 Initialization of ASSOCIATE names.
3660 Automatic deallocation. */
3663 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3667 gfc_formal_arglist *f;
3668 stmtblock_t tmpblock;
3669 bool seen_trans_deferred_array = false;
3675 /* Deal with implicit return variables. Explicit return variables will
3676 already have been added. */
3677 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3679 if (!current_fake_result_decl)
3681 gfc_entry_list *el = NULL;
3682 if (proc_sym->attr.entry_master)
3684 for (el = proc_sym->ns->entries; el; el = el->next)
3685 if (el->sym != el->sym->result)
3688 /* TODO: move to the appropriate place in resolve.c. */
3689 if (warn_return_type && el == NULL)
3690 gfc_warning ("Return value of function '%s' at %L not set",
3691 proc_sym->name, &proc_sym->declared_at);
3693 else if (proc_sym->as)
3695 tree result = TREE_VALUE (current_fake_result_decl);
3696 gfc_trans_dummy_array_bias (proc_sym, result, block);
3698 /* An automatic character length, pointer array result. */
3699 if (proc_sym->ts.type == BT_CHARACTER
3700 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3701 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3703 else if (proc_sym->ts.type == BT_CHARACTER)
3705 if (proc_sym->ts.deferred)
3708 gfc_save_backend_locus (&loc);
3709 gfc_set_backend_locus (&proc_sym->declared_at);
3710 gfc_start_block (&init);
3711 /* Zero the string length on entry. */
3712 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3713 build_int_cst (gfc_charlen_type_node, 0));
3714 /* Null the pointer. */
3715 e = gfc_lval_expr_from_sym (proc_sym);
3716 gfc_init_se (&se, NULL);
3717 se.want_pointer = 1;
3718 gfc_conv_expr (&se, e);
3721 gfc_add_modify (&init, tmp,
3722 fold_convert (TREE_TYPE (se.expr),
3723 null_pointer_node));
3724 gfc_restore_backend_locus (&loc);
3726 /* Pass back the string length on exit. */
3727 tmp = proc_sym->ts.u.cl->passed_length;
3728 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3729 tmp = fold_convert (gfc_charlen_type_node, tmp);
3730 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3731 gfc_charlen_type_node, tmp,
3732 proc_sym->ts.u.cl->backend_decl);
3733 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3735 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3736 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3739 gcc_assert (gfc_option.flag_f2c
3740 && proc_sym->ts.type == BT_COMPLEX);
3743 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3744 should be done here so that the offsets and lbounds of arrays
3746 gfc_save_backend_locus (&loc);
3747 gfc_set_backend_locus (&proc_sym->declared_at);
3748 init_intent_out_dt (proc_sym, block);
3749 gfc_restore_backend_locus (&loc);
3751 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3753 bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
3754 && (sym->ts.u.derived->attr.alloc_comp
3755 || gfc_is_finalizable (sym->ts.u.derived,
3760 if (sym->attr.subref_array_pointer
3761 && GFC_DECL_SPAN (sym->backend_decl)
3762 && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
3764 gfc_init_block (&tmpblock);
3765 gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
3766 build_int_cst (gfc_array_index_type, 0));
3767 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3771 if (sym->ts.type == BT_CLASS
3772 && (sym->attr.save || gfc_option.flag_max_stack_var_size == 0)
3773 && CLASS_DATA (sym)->attr.allocatable)
3777 if (UNLIMITED_POLY (sym))
3778 vptr = null_pointer_node;
3782 vsym = gfc_find_derived_vtab (sym->ts.u.derived);
3783 vptr = gfc_get_symbol_decl (vsym);
3784 vptr = gfc_build_addr_expr (NULL, vptr);
3787 if (CLASS_DATA (sym)->attr.dimension
3788 || (CLASS_DATA (sym)->attr.codimension
3789 && gfc_option.coarray != GFC_FCOARRAY_LIB))
3791 tmp = gfc_class_data_get (sym->backend_decl);
3792 tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
3795 tmp = null_pointer_node;
3797 DECL_INITIAL (sym->backend_decl)
3798 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
3799 TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
3801 else if (sym->attr.dimension || sym->attr.codimension)
3803 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3804 array_type tmp = sym->as->type;
3805 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3810 if (sym->attr.dummy || sym->attr.result)
3811 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3812 else if (sym->attr.pointer || sym->attr.allocatable)
3814 if (TREE_STATIC (sym->backend_decl))
3816 gfc_save_backend_locus (&loc);
3817 gfc_set_backend_locus (&sym->declared_at);
3818 gfc_trans_static_array_pointer (sym);
3819 gfc_restore_backend_locus (&loc);
3823 seen_trans_deferred_array = true;
3824 gfc_trans_deferred_array (sym, block);
3827 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3829 gfc_init_block (&tmpblock);
3830 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3832 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3836 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3838 gfc_save_backend_locus (&loc);
3839 gfc_set_backend_locus (&sym->declared_at);
3841 if (alloc_comp_or_fini)
3843 seen_trans_deferred_array = true;
3844 gfc_trans_deferred_array (sym, block);
3846 else if (sym->ts.type == BT_DERIVED
3849 && sym->attr.save == SAVE_NONE)
3851 gfc_start_block (&tmpblock);
3852 gfc_init_default_dt (sym, &tmpblock, false);
3853 gfc_add_init_cleanup (block,
3854 gfc_finish_block (&tmpblock),
3858 gfc_trans_auto_array_allocation (sym->backend_decl,
3860 gfc_restore_backend_locus (&loc);
3864 case AS_ASSUMED_SIZE:
3865 /* Must be a dummy parameter. */
3866 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3868 /* We should always pass assumed size arrays the g77 way. */
3869 if (sym->attr.dummy)
3870 gfc_trans_g77_array (sym, block);
3873 case AS_ASSUMED_SHAPE:
3874 /* Must be a dummy parameter. */
3875 gcc_assert (sym->attr.dummy);
3877 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3880 case AS_ASSUMED_RANK:
3882 seen_trans_deferred_array = true;
3883 gfc_trans_deferred_array (sym, block);
3889 if (alloc_comp_or_fini && !seen_trans_deferred_array)
3890 gfc_trans_deferred_array (sym, block);
3892 else if ((!sym->attr.dummy || sym->ts.deferred)
3893 && (sym->ts.type == BT_CLASS
3894 && CLASS_DATA (sym)->attr.class_pointer))
3896 else if ((!sym->attr.dummy || sym->ts.deferred)
3897 && (sym->attr.allocatable
3898 || (sym->ts.type == BT_CLASS
3899 && CLASS_DATA (sym)->attr.allocatable)))
3901 if (!sym->attr.save && gfc_option.flag_max_stack_var_size != 0)
3903 tree descriptor = NULL_TREE;
3905 /* Nullify and automatic deallocation of allocatable
3907 e = gfc_lval_expr_from_sym (sym);
3908 if (sym->ts.type == BT_CLASS)
3909 gfc_add_data_component (e);
3911 gfc_init_se (&se, NULL);
3912 if (sym->ts.type != BT_CLASS
3913 || sym->ts.u.derived->attr.dimension
3914 || sym->ts.u.derived->attr.codimension)
3916 se.want_pointer = 1;
3917 gfc_conv_expr (&se, e);
3919 else if (sym->ts.type == BT_CLASS
3920 && !CLASS_DATA (sym)->attr.dimension
3921 && !CLASS_DATA (sym)->attr.codimension)
3923 se.want_pointer = 1;
3924 gfc_conv_expr (&se, e);
3928 gfc_conv_expr (&se, e);
3929 descriptor = se.expr;
3930 se.expr = gfc_conv_descriptor_data_addr (se.expr);
3931 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3935 gfc_save_backend_locus (&loc);
3936 gfc_set_backend_locus (&sym->declared_at);
3937 gfc_start_block (&init);
3939 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3941 /* Nullify when entering the scope. */
3942 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3943 TREE_TYPE (se.expr), se.expr,
3944 fold_convert (TREE_TYPE (se.expr),
3945 null_pointer_node));
3946 if (sym->attr.optional)
3948 tree present = gfc_conv_expr_present (sym);
3949 tmp = build3_loc (input_location, COND_EXPR,
3950 void_type_node, present, tmp,
3951 build_empty_stmt (input_location));
3953 gfc_add_expr_to_block (&init, tmp);
3956 if ((sym->attr.dummy || sym->attr.result)
3957 && sym->ts.type == BT_CHARACTER
3958 && sym->ts.deferred)
3960 /* Character length passed by reference. */
3961 tmp = sym->ts.u.cl->passed_length;
3962 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3963 tmp = fold_convert (gfc_charlen_type_node, tmp);
3965 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3966 /* Zero the string length when entering the scope. */
3967 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3968 build_int_cst (gfc_charlen_type_node, 0));
3973 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
3974 gfc_charlen_type_node,
3975 sym->ts.u.cl->backend_decl, tmp);
3976 if (sym->attr.optional)
3978 tree present = gfc_conv_expr_present (sym);
3979 tmp2 = build3_loc (input_location, COND_EXPR,
3980 void_type_node, present, tmp2,
3981 build_empty_stmt (input_location));
3983 gfc_add_expr_to_block (&init, tmp2);
3986 gfc_restore_backend_locus (&loc);
3988 /* Pass the final character length back. */
3989 if (sym->attr.intent != INTENT_IN)
3991 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3992 gfc_charlen_type_node, tmp,
3993 sym->ts.u.cl->backend_decl);
3994 if (sym->attr.optional)
3996 tree present = gfc_conv_expr_present (sym);
3997 tmp = build3_loc (input_location, COND_EXPR,
3998 void_type_node, present, tmp,
3999 build_empty_stmt (input_location));
4006 gfc_restore_backend_locus (&loc);
4008 /* Deallocate when leaving the scope. Nullifying is not
4010 if (!sym->attr.result && !sym->attr.dummy
4011 && !sym->ns->proc_name->attr.is_main_program)
4013 if (sym->ts.type == BT_CLASS
4014 && CLASS_DATA (sym)->attr.codimension)
4015 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
4016 NULL_TREE, NULL_TREE,
4017 NULL_TREE, true, NULL,
4021 gfc_expr *expr = gfc_lval_expr_from_sym (sym);
4022 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
4023 true, expr, sym->ts);
4024 gfc_free_expr (expr);
4027 if (sym->ts.type == BT_CLASS)
4029 /* Initialize _vptr to declared type. */
4033 gfc_save_backend_locus (&loc);
4034 gfc_set_backend_locus (&sym->declared_at);
4035 e = gfc_lval_expr_from_sym (sym);
4036 gfc_add_vptr_component (e);
4037 gfc_init_se (&se, NULL);
4038 se.want_pointer = 1;
4039 gfc_conv_expr (&se, e);
4041 if (UNLIMITED_POLY (sym))
4042 rhs = build_int_cst (TREE_TYPE (se.expr), 0);
4045 vtab = gfc_find_derived_vtab (sym->ts.u.derived);
4046 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
4047 gfc_get_symbol_decl (vtab));
4049 gfc_add_modify (&init, se.expr, rhs);
4050 gfc_restore_backend_locus (&loc);
4053 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4056 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
4061 /* If we get to here, all that should be left are pointers. */
4062 gcc_assert (sym->attr.pointer);
4064 if (sym->attr.dummy)
4066 gfc_start_block (&init);
4068 /* Character length passed by reference. */
4069 tmp = sym->ts.u.cl->passed_length;
4070 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4071 tmp = fold_convert (gfc_charlen_type_node, tmp);
4072 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
4073 /* Pass the final character length back. */
4074 if (sym->attr.intent != INTENT_IN)
4075 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4076 gfc_charlen_type_node, tmp,
4077 sym->ts.u.cl->backend_decl);
4080 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4083 else if (sym->ts.deferred)
4084 gfc_fatal_error ("Deferred type parameter not yet supported");
4085 else if (alloc_comp_or_fini)
4086 gfc_trans_deferred_array (sym, block);
4087 else if (sym->ts.type == BT_CHARACTER)
4089 gfc_save_backend_locus (&loc);
4090 gfc_set_backend_locus (&sym->declared_at);
4091 if (sym->attr.dummy || sym->attr.result)
4092 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
4094 gfc_trans_auto_character_variable (sym, block);
4095 gfc_restore_backend_locus (&loc);
4097 else if (sym->attr.assign)
4099 gfc_save_backend_locus (&loc);
4100 gfc_set_backend_locus (&sym->declared_at);
4101 gfc_trans_assign_aux_var (sym, block);
4102 gfc_restore_backend_locus (&loc);
4104 else if (sym->ts.type == BT_DERIVED
4107 && sym->attr.save == SAVE_NONE)
4109 gfc_start_block (&tmpblock);
4110 gfc_init_default_dt (sym, &tmpblock, false);
4111 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
4114 else if (!(UNLIMITED_POLY(sym)))
4118 gfc_init_block (&tmpblock);
4120 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
4122 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
4124 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
4125 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
4126 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
4130 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
4131 && current_fake_result_decl != NULL)
4133 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
4134 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
4135 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
4138 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
4141 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
4143 /* Hash and equality functions for module_htab. */
4146 module_htab_do_hash (const void *x)
4148 return htab_hash_string (((const struct module_htab_entry *)x)->name);
4152 module_htab_eq (const void *x1, const void *x2)
4154 return strcmp ((((const struct module_htab_entry *)x1)->name),
4155 (const char *)x2) == 0;
4158 /* Hash and equality functions for module_htab's decls. */
4161 module_htab_decls_hash (const void *x)
4163 const_tree t = (const_tree) x;
4164 const_tree n = DECL_NAME (t);
4166 n = TYPE_NAME (TREE_TYPE (t));
4167 return htab_hash_string (IDENTIFIER_POINTER (n));
4171 module_htab_decls_eq (const void *x1, const void *x2)
4173 const_tree t1 = (const_tree) x1;
4174 const_tree n1 = DECL_NAME (t1);
4175 if (n1 == NULL_TREE)
4176 n1 = TYPE_NAME (TREE_TYPE (t1));
4177 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
4180 struct module_htab_entry *
4181 gfc_find_module (const char *name)
4186 module_htab = htab_create_ggc (10, module_htab_do_hash,
4187 module_htab_eq, NULL);
4189 slot = htab_find_slot_with_hash (module_htab, name,
4190 htab_hash_string (name), INSERT);
4193 module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> ();
4195 entry->name = gfc_get_string (name);
4196 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
4197 module_htab_decls_eq, NULL);
4198 *slot = (void *) entry;
4200 return (struct module_htab_entry *) *slot;
4204 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
4209 if (DECL_NAME (decl))
4210 name = IDENTIFIER_POINTER (DECL_NAME (decl));
4213 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
4214 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
4216 slot = htab_find_slot_with_hash (entry->decls, name,
4217 htab_hash_string (name), INSERT);
4219 *slot = (void *) decl;
4222 static struct module_htab_entry *cur_module;
4225 /* Generate debugging symbols for namelists. This function must come after
4226 generate_local_decl to ensure that the variables in the namelist are
4227 already declared. */
4230 generate_namelist_decl (gfc_symbol * sym)
4234 vec<constructor_elt, va_gc> *nml_decls = NULL;
4236 gcc_assert (sym->attr.flavor == FL_NAMELIST);
4237 for (nml = sym->namelist; nml; nml = nml->next)
4239 if (nml->sym->backend_decl == NULL_TREE)
4241 nml->sym->attr.referenced = 1;
4242 nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym);
4244 DECL_IGNORED_P (nml->sym->backend_decl) = 0;
4245 CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl);
4248 decl = make_node (NAMELIST_DECL);
4249 TREE_TYPE (decl) = void_type_node;
4250 NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls);
4251 DECL_NAME (decl) = get_identifier (sym->name);
4256 /* Output an initialized decl for a module variable. */
4259 gfc_create_module_variable (gfc_symbol * sym)
4263 /* Module functions with alternate entries are dealt with later and
4264 would get caught by the next condition. */
4265 if (sym->attr.entry)
4268 /* Make sure we convert the types of the derived types from iso_c_binding
4270 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4271 && sym->ts.type == BT_DERIVED)
4272 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4274 if (sym->attr.flavor == FL_DERIVED
4275 && sym->backend_decl
4276 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4278 decl = sym->backend_decl;
4279 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4281 if (!sym->attr.use_assoc)
4283 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4284 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4285 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4286 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4287 == sym->ns->proc_name->backend_decl);
4289 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4290 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4291 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4294 /* Only output variables, procedure pointers and array valued,
4295 or derived type, parameters. */
4296 if (sym->attr.flavor != FL_VARIABLE
4297 && !(sym->attr.flavor == FL_PARAMETER
4298 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4299 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4302 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4304 decl = sym->backend_decl;
4305 gcc_assert (DECL_FILE_SCOPE_P (decl));
4306 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4307 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4308 gfc_module_add_decl (cur_module, decl);
4311 /* Don't generate variables from other modules. Variables from
4312 COMMONs and Cray pointees will already have been generated. */
4313 if (sym->attr.use_assoc || sym->attr.in_common || sym->attr.cray_pointee)
4316 /* Equivalenced variables arrive here after creation. */
4317 if (sym->backend_decl
4318 && (sym->equiv_built || sym->attr.in_equivalence))
4321 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4322 internal_error ("backend decl for module variable %s already exists",
4325 if (sym->module && !sym->attr.result && !sym->attr.dummy
4326 && (sym->attr.access == ACCESS_UNKNOWN
4327 && (sym->ns->default_access == ACCESS_PRIVATE
4328 || (sym->ns->default_access == ACCESS_UNKNOWN
4329 && gfc_option.flag_module_private))))
4330 sym->attr.access = ACCESS_PRIVATE;
4332 if (warn_unused_variable && !sym->attr.referenced
4333 && sym->attr.access == ACCESS_PRIVATE)
4334 gfc_warning ("Unused PRIVATE module variable '%s' declared at %L",
4335 sym->name, &sym->declared_at);
4337 /* We always want module variables to be created. */
4338 sym->attr.referenced = 1;
4339 /* Create the decl. */
4340 decl = gfc_get_symbol_decl (sym);
4342 /* Create the variable. */
4344 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4345 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4346 rest_of_decl_compilation (decl, 1, 0);
4347 gfc_module_add_decl (cur_module, decl);
4349 /* Also add length of strings. */
4350 if (sym->ts.type == BT_CHARACTER)
4354 length = sym->ts.u.cl->backend_decl;
4355 gcc_assert (length || sym->attr.proc_pointer);
4356 if (length && !INTEGER_CST_P (length))
4359 rest_of_decl_compilation (length, 1, 0);
4363 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4364 && sym->attr.referenced && !sym->attr.use_assoc)
4365 has_coarray_vars = true;
4368 /* Emit debug information for USE statements. */
4371 gfc_trans_use_stmts (gfc_namespace * ns)
4373 gfc_use_list *use_stmt;
4374 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4376 struct module_htab_entry *entry
4377 = gfc_find_module (use_stmt->module_name);
4378 gfc_use_rename *rent;
4380 if (entry->namespace_decl == NULL)
4382 entry->namespace_decl
4383 = build_decl (input_location,
4385 get_identifier (use_stmt->module_name),
4387 DECL_EXTERNAL (entry->namespace_decl) = 1;
4389 gfc_set_backend_locus (&use_stmt->where);
4390 if (!use_stmt->only_flag)
4391 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4393 ns->proc_name->backend_decl,
4395 for (rent = use_stmt->rename; rent; rent = rent->next)
4397 tree decl, local_name;
4400 if (rent->op != INTRINSIC_NONE)
4403 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4404 htab_hash_string (rent->use_name),
4410 st = gfc_find_symtree (ns->sym_root,
4412 ? rent->local_name : rent->use_name);
4414 /* The following can happen if a derived type is renamed. */
4418 name = xstrdup (rent->local_name[0]
4419 ? rent->local_name : rent->use_name);
4420 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4421 st = gfc_find_symtree (ns->sym_root, name);
4426 /* Sometimes, generic interfaces wind up being over-ruled by a
4427 local symbol (see PR41062). */
4428 if (!st->n.sym->attr.use_assoc)
4431 if (st->n.sym->backend_decl
4432 && DECL_P (st->n.sym->backend_decl)
4433 && st->n.sym->module
4434 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4436 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4437 || (TREE_CODE (st->n.sym->backend_decl)
4439 decl = copy_node (st->n.sym->backend_decl);
4440 DECL_CONTEXT (decl) = entry->namespace_decl;
4441 DECL_EXTERNAL (decl) = 1;
4442 DECL_IGNORED_P (decl) = 0;
4443 DECL_INITIAL (decl) = NULL_TREE;
4445 else if (st->n.sym->attr.flavor == FL_NAMELIST
4446 && st->n.sym->attr.use_only
4447 && st->n.sym->module
4448 && strcmp (st->n.sym->module, use_stmt->module_name)
4451 decl = generate_namelist_decl (st->n.sym);
4452 DECL_CONTEXT (decl) = entry->namespace_decl;
4453 DECL_EXTERNAL (decl) = 1;
4454 DECL_IGNORED_P (decl) = 0;
4455 DECL_INITIAL (decl) = NULL_TREE;
4459 *slot = error_mark_node;
4460 htab_clear_slot (entry->decls, slot);
4465 decl = (tree) *slot;
4466 if (rent->local_name[0])
4467 local_name = get_identifier (rent->local_name);
4469 local_name = NULL_TREE;
4470 gfc_set_backend_locus (&rent->where);
4471 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4472 ns->proc_name->backend_decl,
4473 !use_stmt->only_flag);
4479 /* Return true if expr is a constant initializer that gfc_conv_initializer
4483 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4493 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4495 else if (expr->expr_type == EXPR_STRUCTURE)
4496 return check_constant_initializer (expr, ts, false, false);
4497 else if (expr->expr_type != EXPR_ARRAY)
4499 for (c = gfc_constructor_first (expr->value.constructor);
4500 c; c = gfc_constructor_next (c))
4504 if (c->expr->expr_type == EXPR_STRUCTURE)
4506 if (!check_constant_initializer (c->expr, ts, false, false))
4509 else if (c->expr->expr_type != EXPR_CONSTANT)
4514 else switch (ts->type)
4517 if (expr->expr_type != EXPR_STRUCTURE)
4519 cm = expr->ts.u.derived->components;
4520 for (c = gfc_constructor_first (expr->value.constructor);
4521 c; c = gfc_constructor_next (c), cm = cm->next)
4523 if (!c->expr || cm->attr.allocatable)
4525 if (!check_constant_initializer (c->expr, &cm->ts,
4532 return expr->expr_type == EXPR_CONSTANT;
4536 /* Emit debug info for parameters and unreferenced variables with
4540 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4544 if (sym->attr.flavor != FL_PARAMETER
4545 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4548 if (sym->backend_decl != NULL
4549 || sym->value == NULL
4550 || sym->attr.use_assoc
4553 || sym->attr.function
4554 || sym->attr.intrinsic
4555 || sym->attr.pointer
4556 || sym->attr.allocatable
4557 || sym->attr.cray_pointee
4558 || sym->attr.threadprivate
4559 || sym->attr.is_bind_c
4560 || sym->attr.subref_array_pointer
4561 || sym->attr.assign)
4564 if (sym->ts.type == BT_CHARACTER)
4566 gfc_conv_const_charlen (sym->ts.u.cl);
4567 if (sym->ts.u.cl->backend_decl == NULL
4568 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4571 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4578 if (sym->as->type != AS_EXPLICIT)
4580 for (n = 0; n < sym->as->rank; n++)
4581 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4582 || sym->as->upper[n] == NULL
4583 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4587 if (!check_constant_initializer (sym->value, &sym->ts,
4588 sym->attr.dimension, false))
4591 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4594 /* Create the decl for the variable or constant. */
4595 decl = build_decl (input_location,
4596 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4597 gfc_sym_identifier (sym), gfc_sym_type (sym));
4598 if (sym->attr.flavor == FL_PARAMETER)
4599 TREE_READONLY (decl) = 1;
4600 gfc_set_decl_location (decl, &sym->declared_at);
4601 if (sym->attr.dimension)
4602 GFC_DECL_PACKED_ARRAY (decl) = 1;
4603 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4604 TREE_STATIC (decl) = 1;
4605 TREE_USED (decl) = 1;
4606 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4607 TREE_PUBLIC (decl) = 1;
4608 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4610 sym->attr.dimension,
4612 debug_hooks->global_decl (decl);
4617 generate_coarray_sym_init (gfc_symbol *sym)
4619 tree tmp, size, decl, token;
4621 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4622 || sym->attr.use_assoc || !sym->attr.referenced)
4625 decl = sym->backend_decl;
4626 TREE_USED(decl) = 1;
4627 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4629 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4630 to make sure the variable is not optimized away. */
4631 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4633 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4635 /* Ensure that we do not have size=0 for zero-sized arrays. */
4636 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4637 fold_convert (size_type_node, size),
4638 build_int_cst (size_type_node, 1));
4640 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4642 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4643 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4644 fold_convert (size_type_node, tmp), size);
4647 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4648 token = gfc_build_addr_expr (ppvoid_type_node,
4649 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4651 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4652 build_int_cst (integer_type_node,
4653 GFC_CAF_COARRAY_STATIC), /* type. */
4654 token, null_pointer_node, /* token, stat. */
4655 null_pointer_node, /* errgmsg, errmsg_len. */
4656 build_int_cst (integer_type_node, 0));
4658 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4661 /* Handle "static" initializer. */
4664 sym->attr.pointer = 1;
4665 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4667 sym->attr.pointer = 0;
4668 gfc_add_expr_to_block (&caf_init_block, tmp);
4673 /* Generate constructor function to initialize static, nonallocatable
4677 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4679 tree fndecl, tmp, decl, save_fn_decl;
4681 save_fn_decl = current_function_decl;
4682 push_function_context ();
4684 tmp = build_function_type_list (void_type_node, NULL_TREE);
4685 fndecl = build_decl (input_location, FUNCTION_DECL,
4686 create_tmp_var_name ("_caf_init"), tmp);
4688 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4689 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4691 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4692 DECL_ARTIFICIAL (decl) = 1;
4693 DECL_IGNORED_P (decl) = 1;
4694 DECL_CONTEXT (decl) = fndecl;
4695 DECL_RESULT (fndecl) = decl;
4698 current_function_decl = fndecl;
4699 announce_function (fndecl);
4701 rest_of_decl_compilation (fndecl, 0, 0);
4702 make_decl_rtl (fndecl);
4703 allocate_struct_function (fndecl, false);
4706 gfc_init_block (&caf_init_block);
4708 gfc_traverse_ns (ns, generate_coarray_sym_init);
4710 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4714 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4716 DECL_SAVED_TREE (fndecl)
4717 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4718 DECL_INITIAL (fndecl));
4719 dump_function (TDI_original, fndecl);
4721 cfun->function_end_locus = input_location;
4724 if (decl_function_context (fndecl))
4725 (void) cgraph_create_node (fndecl);
4727 cgraph_finalize_function (fndecl, true);
4729 pop_function_context ();
4730 current_function_decl = save_fn_decl;
4735 create_module_nml_decl (gfc_symbol *sym)
4737 if (sym->attr.flavor == FL_NAMELIST)
4739 tree decl = generate_namelist_decl (sym);
4741 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4742 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4743 rest_of_decl_compilation (decl, 1, 0);
4744 gfc_module_add_decl (cur_module, decl);
4749 /* Generate all the required code for module variables. */
4752 gfc_generate_module_vars (gfc_namespace * ns)
4754 module_namespace = ns;
4755 cur_module = gfc_find_module (ns->proc_name->name);
4757 /* Check if the frontend left the namespace in a reasonable state. */
4758 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4760 /* Generate COMMON blocks. */
4761 gfc_trans_common (ns);
4763 has_coarray_vars = false;
4765 /* Create decls for all the module variables. */
4766 gfc_traverse_ns (ns, gfc_create_module_variable);
4767 gfc_traverse_ns (ns, create_module_nml_decl);
4769 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4770 generate_coarray_init (ns);
4774 gfc_trans_use_stmts (ns);
4775 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4780 gfc_generate_contained_functions (gfc_namespace * parent)
4784 /* We create all the prototypes before generating any code. */
4785 for (ns = parent->contained; ns; ns = ns->sibling)
4787 /* Skip namespaces from used modules. */
4788 if (ns->parent != parent)
4791 gfc_create_function_decl (ns, false);
4794 for (ns = parent->contained; ns; ns = ns->sibling)
4796 /* Skip namespaces from used modules. */
4797 if (ns->parent != parent)
4800 gfc_generate_function_code (ns);
4805 /* Drill down through expressions for the array specification bounds and
4806 character length calling generate_local_decl for all those variables
4807 that have not already been declared. */
4810 generate_local_decl (gfc_symbol *);
4812 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4815 expr_decls (gfc_expr *e, gfc_symbol *sym,
4816 int *f ATTRIBUTE_UNUSED)
4818 if (e->expr_type != EXPR_VARIABLE
4819 || sym == e->symtree->n.sym
4820 || e->symtree->n.sym->mark
4821 || e->symtree->n.sym->ns != sym->ns)
4824 generate_local_decl (e->symtree->n.sym);
4829 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4831 gfc_traverse_expr (e, sym, expr_decls, 0);
4835 /* Check for dependencies in the character length and array spec. */
4838 generate_dependency_declarations (gfc_symbol *sym)
4842 if (sym->ts.type == BT_CHARACTER
4844 && sym->ts.u.cl->length
4845 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4846 generate_expr_decls (sym, sym->ts.u.cl->length);
4848 if (sym->as && sym->as->rank)
4850 for (i = 0; i < sym->as->rank; i++)
4852 generate_expr_decls (sym, sym->as->lower[i]);
4853 generate_expr_decls (sym, sym->as->upper[i]);
4859 /* Generate decls for all local variables. We do this to ensure correct
4860 handling of expressions which only appear in the specification of
4864 generate_local_decl (gfc_symbol * sym)
4866 if (sym->attr.flavor == FL_VARIABLE)
4868 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4869 && sym->attr.referenced && !sym->attr.use_assoc)
4870 has_coarray_vars = true;
4872 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4873 generate_dependency_declarations (sym);
4875 if (sym->attr.referenced)
4876 gfc_get_symbol_decl (sym);
4878 /* Warnings for unused dummy arguments. */
4879 else if (sym->attr.dummy && !sym->attr.in_namelist)
4881 /* INTENT(out) dummy arguments are likely meant to be set. */
4882 if (gfc_option.warn_unused_dummy_argument
4883 && sym->attr.intent == INTENT_OUT)
4885 if (sym->ts.type != BT_DERIVED)
4886 gfc_warning ("Dummy argument '%s' at %L was declared "
4887 "INTENT(OUT) but was not set", sym->name,
4889 else if (!gfc_has_default_initializer (sym->ts.u.derived)
4890 && !sym->ts.u.derived->attr.zero_comp)
4891 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4892 "declared INTENT(OUT) but was not set and "
4893 "does not have a default initializer",
4894 sym->name, &sym->declared_at);
4895 if (sym->backend_decl != NULL_TREE)
4896 TREE_NO_WARNING(sym->backend_decl) = 1;
4898 else if (gfc_option.warn_unused_dummy_argument)
4900 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4902 if (sym->backend_decl != NULL_TREE)
4903 TREE_NO_WARNING(sym->backend_decl) = 1;
4907 /* Warn for unused variables, but not if they're inside a common
4908 block or a namelist. */
4909 else if (warn_unused_variable
4910 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
4912 if (sym->attr.use_only)
4914 gfc_warning ("Unused module variable '%s' which has been "
4915 "explicitly imported at %L", sym->name,
4917 if (sym->backend_decl != NULL_TREE)
4918 TREE_NO_WARNING(sym->backend_decl) = 1;
4920 else if (!sym->attr.use_assoc)
4922 gfc_warning ("Unused variable '%s' declared at %L",
4923 sym->name, &sym->declared_at);
4924 if (sym->backend_decl != NULL_TREE)
4925 TREE_NO_WARNING(sym->backend_decl) = 1;
4929 /* For variable length CHARACTER parameters, the PARM_DECL already
4930 references the length variable, so force gfc_get_symbol_decl
4931 even when not referenced. If optimize > 0, it will be optimized
4932 away anyway. But do this only after emitting -Wunused-parameter
4933 warning if requested. */
4934 if (sym->attr.dummy && !sym->attr.referenced
4935 && sym->ts.type == BT_CHARACTER
4936 && sym->ts.u.cl->backend_decl != NULL
4937 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4939 sym->attr.referenced = 1;
4940 gfc_get_symbol_decl (sym);
4943 /* INTENT(out) dummy arguments and result variables with allocatable
4944 components are reset by default and need to be set referenced to
4945 generate the code for nullification and automatic lengths. */
4946 if (!sym->attr.referenced
4947 && sym->ts.type == BT_DERIVED
4948 && sym->ts.u.derived->attr.alloc_comp
4949 && !sym->attr.pointer
4950 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4952 (sym->attr.result && sym != sym->result)))
4954 sym->attr.referenced = 1;
4955 gfc_get_symbol_decl (sym);
4958 /* Check for dependencies in the array specification and string
4959 length, adding the necessary declarations to the function. We
4960 mark the symbol now, as well as in traverse_ns, to prevent
4961 getting stuck in a circular dependency. */
4964 else if (sym->attr.flavor == FL_PARAMETER)
4966 if (warn_unused_parameter
4967 && !sym->attr.referenced)
4969 if (!sym->attr.use_assoc)
4970 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4972 else if (sym->attr.use_only)
4973 gfc_warning ("Unused parameter '%s' which has been explicitly "
4974 "imported at %L", sym->name, &sym->declared_at);
4977 else if (sym->attr.flavor == FL_PROCEDURE)
4979 /* TODO: move to the appropriate place in resolve.c. */
4980 if (warn_return_type
4981 && sym->attr.function
4983 && sym != sym->result
4984 && !sym->result->attr.referenced
4985 && !sym->attr.use_assoc
4986 && sym->attr.if_source != IFSRC_IFBODY)
4988 gfc_warning ("Return value '%s' of function '%s' declared at "
4989 "%L not set", sym->result->name, sym->name,
4990 &sym->result->declared_at);
4992 /* Prevents "Unused variable" warning for RESULT variables. */
4993 sym->result->mark = 1;
4997 if (sym->attr.dummy == 1)
4999 /* Modify the tree type for scalar character dummy arguments of bind(c)
5000 procedures if they are passed by value. The tree type for them will
5001 be promoted to INTEGER_TYPE for the middle end, which appears to be
5002 what C would do with characters passed by-value. The value attribute
5003 implies the dummy is a scalar. */
5004 if (sym->attr.value == 1 && sym->backend_decl != NULL
5005 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
5006 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
5007 gfc_conv_scalar_char_value (sym, NULL, NULL);
5009 /* Unused procedure passed as dummy argument. */
5010 if (sym->attr.flavor == FL_PROCEDURE)
5012 if (!sym->attr.referenced)
5014 if (gfc_option.warn_unused_dummy_argument)
5015 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
5019 /* Silence bogus "unused parameter" warnings from the
5021 if (sym->backend_decl != NULL_TREE)
5022 TREE_NO_WARNING (sym->backend_decl) = 1;
5026 /* Make sure we convert the types of the derived types from iso_c_binding
5028 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
5029 && sym->ts.type == BT_DERIVED)
5030 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
5035 generate_local_nml_decl (gfc_symbol * sym)
5037 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc)
5039 tree decl = generate_namelist_decl (sym);
5046 generate_local_vars (gfc_namespace * ns)
5048 gfc_traverse_ns (ns, generate_local_decl);
5049 gfc_traverse_ns (ns, generate_local_nml_decl);
5053 /* Generate a switch statement to jump to the correct entry point. Also
5054 creates the label decls for the entry points. */
5057 gfc_trans_entry_master_switch (gfc_entry_list * el)
5064 gfc_init_block (&block);
5065 for (; el; el = el->next)
5067 /* Add the case label. */
5068 label = gfc_build_label_decl (NULL_TREE);
5069 val = build_int_cst (gfc_array_index_type, el->id);
5070 tmp = build_case_label (val, NULL_TREE, label);
5071 gfc_add_expr_to_block (&block, tmp);
5073 /* And jump to the actual entry point. */
5074 label = gfc_build_label_decl (NULL_TREE);
5075 tmp = build1_v (GOTO_EXPR, label);
5076 gfc_add_expr_to_block (&block, tmp);
5078 /* Save the label decl. */
5081 tmp = gfc_finish_block (&block);
5082 /* The first argument selects the entry point. */
5083 val = DECL_ARGUMENTS (current_function_decl);
5084 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
5085 val, tmp, NULL_TREE);
5090 /* Add code to string lengths of actual arguments passed to a function against
5091 the expected lengths of the dummy arguments. */
5094 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
5096 gfc_formal_arglist *formal;
5098 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
5099 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
5100 && !formal->sym->ts.deferred)
5102 enum tree_code comparison;
5107 const char *message;
5113 gcc_assert (cl->passed_length != NULL_TREE);
5114 gcc_assert (cl->backend_decl != NULL_TREE);
5116 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
5117 string lengths must match exactly. Otherwise, it is only required
5118 that the actual string length is *at least* the expected one.
5119 Sequence association allows for a mismatch of the string length
5120 if the actual argument is (part of) an array, but only if the
5121 dummy argument is an array. (See "Sequence association" in
5122 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
5123 if (fsym->attr.pointer || fsym->attr.allocatable
5124 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
5125 || fsym->as->type == AS_ASSUMED_RANK)))
5127 comparison = NE_EXPR;
5128 message = _("Actual string length does not match the declared one"
5129 " for dummy argument '%s' (%ld/%ld)");
5131 else if (fsym->as && fsym->as->rank != 0)
5135 comparison = LT_EXPR;
5136 message = _("Actual string length is shorter than the declared one"
5137 " for dummy argument '%s' (%ld/%ld)");
5140 /* Build the condition. For optional arguments, an actual length
5141 of 0 is also acceptable if the associated string is NULL, which
5142 means the argument was not passed. */
5143 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
5144 cl->passed_length, cl->backend_decl);
5145 if (fsym->attr.optional)
5151 not_0length = fold_build2_loc (input_location, NE_EXPR,
5154 build_zero_cst (gfc_charlen_type_node));
5155 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5156 fsym->attr.referenced = 1;
5157 not_absent = gfc_conv_expr_present (fsym);
5159 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5160 boolean_type_node, not_0length,
5163 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5164 boolean_type_node, cond, absent_failed);
5167 /* Build the runtime check. */
5168 argname = gfc_build_cstring_const (fsym->name);
5169 argname = gfc_build_addr_expr (pchar_type_node, argname);
5170 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
5172 fold_convert (long_integer_type_node,
5174 fold_convert (long_integer_type_node,
5181 create_main_function (tree fndecl)
5185 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
5188 old_context = current_function_decl;
5192 push_function_context ();
5193 saved_parent_function_decls = saved_function_decls;
5194 saved_function_decls = NULL_TREE;
5197 /* main() function must be declared with global scope. */
5198 gcc_assert (current_function_decl == NULL_TREE);
5200 /* Declare the function. */
5201 tmp = build_function_type_list (integer_type_node, integer_type_node,
5202 build_pointer_type (pchar_type_node),
5204 main_identifier_node = get_identifier ("main");
5205 ftn_main = build_decl (input_location, FUNCTION_DECL,
5206 main_identifier_node, tmp);
5207 DECL_EXTERNAL (ftn_main) = 0;
5208 TREE_PUBLIC (ftn_main) = 1;
5209 TREE_STATIC (ftn_main) = 1;
5210 DECL_ATTRIBUTES (ftn_main)
5211 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
5213 /* Setup the result declaration (for "return 0"). */
5214 result_decl = build_decl (input_location,
5215 RESULT_DECL, NULL_TREE, integer_type_node);
5216 DECL_ARTIFICIAL (result_decl) = 1;
5217 DECL_IGNORED_P (result_decl) = 1;
5218 DECL_CONTEXT (result_decl) = ftn_main;
5219 DECL_RESULT (ftn_main) = result_decl;
5221 pushdecl (ftn_main);
5223 /* Get the arguments. */
5225 arglist = NULL_TREE;
5226 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
5228 tmp = TREE_VALUE (typelist);
5229 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
5230 DECL_CONTEXT (argc) = ftn_main;
5231 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
5232 TREE_READONLY (argc) = 1;
5233 gfc_finish_decl (argc);
5234 arglist = chainon (arglist, argc);
5236 typelist = TREE_CHAIN (typelist);
5237 tmp = TREE_VALUE (typelist);
5238 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5239 DECL_CONTEXT (argv) = ftn_main;
5240 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5241 TREE_READONLY (argv) = 1;
5242 DECL_BY_REFERENCE (argv) = 1;
5243 gfc_finish_decl (argv);
5244 arglist = chainon (arglist, argv);
5246 DECL_ARGUMENTS (ftn_main) = arglist;
5247 current_function_decl = ftn_main;
5248 announce_function (ftn_main);
5250 rest_of_decl_compilation (ftn_main, 1, 0);
5251 make_decl_rtl (ftn_main);
5252 allocate_struct_function (ftn_main, false);
5255 gfc_init_block (&body);
5257 /* Call some libgfortran initialization routines, call then MAIN__(). */
5259 /* Call _gfortran_caf_init (*argc, ***argv). */
5260 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5262 tree pint_type, pppchar_type;
5263 pint_type = build_pointer_type (integer_type_node);
5265 = build_pointer_type (build_pointer_type (pchar_type_node));
5267 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
5268 gfc_build_addr_expr (pint_type, argc),
5269 gfc_build_addr_expr (pppchar_type, argv));
5270 gfc_add_expr_to_block (&body, tmp);
5273 /* Call _gfortran_set_args (argc, argv). */
5274 TREE_USED (argc) = 1;
5275 TREE_USED (argv) = 1;
5276 tmp = build_call_expr_loc (input_location,
5277 gfor_fndecl_set_args, 2, argc, argv);
5278 gfc_add_expr_to_block (&body, tmp);
5280 /* Add a call to set_options to set up the runtime library Fortran
5281 language standard parameters. */
5283 tree array_type, array, var;
5284 vec<constructor_elt, va_gc> *v = NULL;
5286 /* Passing a new option to the library requires four modifications:
5287 + add it to the tree_cons list below
5288 + change the array size in the call to build_array_type
5289 + change the first argument to the library call
5290 gfor_fndecl_set_options
5291 + modify the library (runtime/compile_options.c)! */
5293 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5294 build_int_cst (integer_type_node,
5295 gfc_option.warn_std));
5296 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5297 build_int_cst (integer_type_node,
5298 gfc_option.allow_std));
5299 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5300 build_int_cst (integer_type_node, pedantic));
5301 /* TODO: This is the old -fdump-core option, which is unused but
5302 passed due to ABI compatibility; remove when bumping the
5304 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5305 build_int_cst (integer_type_node,
5307 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5308 build_int_cst (integer_type_node,
5309 gfc_option.flag_backtrace));
5310 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5311 build_int_cst (integer_type_node,
5312 gfc_option.flag_sign_zero));
5313 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5314 build_int_cst (integer_type_node,
5316 & GFC_RTCHECK_BOUNDS)));
5317 /* TODO: This is the -frange-check option, which no longer affects
5318 library behavior; when bumping the library ABI this slot can be
5319 reused for something else. As it is the last element in the
5320 array, we can instead leave it out altogether. */
5321 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5322 build_int_cst (integer_type_node, 0));
5323 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5324 build_int_cst (integer_type_node,
5325 gfc_option.fpe_summary));
5327 array_type = build_array_type (integer_type_node,
5328 build_index_type (size_int (8)));
5329 array = build_constructor (array_type, v);
5330 TREE_CONSTANT (array) = 1;
5331 TREE_STATIC (array) = 1;
5333 /* Create a static variable to hold the jump table. */
5334 var = gfc_create_var (array_type, "options");
5335 TREE_CONSTANT (var) = 1;
5336 TREE_STATIC (var) = 1;
5337 TREE_READONLY (var) = 1;
5338 DECL_INITIAL (var) = array;
5339 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5341 tmp = build_call_expr_loc (input_location,
5342 gfor_fndecl_set_options, 2,
5343 build_int_cst (integer_type_node, 9), var);
5344 gfc_add_expr_to_block (&body, tmp);
5347 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5348 the library will raise a FPE when needed. */
5349 if (gfc_option.fpe != 0)
5351 tmp = build_call_expr_loc (input_location,
5352 gfor_fndecl_set_fpe, 1,
5353 build_int_cst (integer_type_node,
5355 gfc_add_expr_to_block (&body, tmp);
5358 /* If this is the main program and an -fconvert option was provided,
5359 add a call to set_convert. */
5361 if (gfc_option.convert != GFC_CONVERT_NATIVE)
5363 tmp = build_call_expr_loc (input_location,
5364 gfor_fndecl_set_convert, 1,
5365 build_int_cst (integer_type_node,
5366 gfc_option.convert));
5367 gfc_add_expr_to_block (&body, tmp);
5370 /* If this is the main program and an -frecord-marker option was provided,
5371 add a call to set_record_marker. */
5373 if (gfc_option.record_marker != 0)
5375 tmp = build_call_expr_loc (input_location,
5376 gfor_fndecl_set_record_marker, 1,
5377 build_int_cst (integer_type_node,
5378 gfc_option.record_marker));
5379 gfc_add_expr_to_block (&body, tmp);
5382 if (gfc_option.max_subrecord_length != 0)
5384 tmp = build_call_expr_loc (input_location,
5385 gfor_fndecl_set_max_subrecord_length, 1,
5386 build_int_cst (integer_type_node,
5387 gfc_option.max_subrecord_length));
5388 gfc_add_expr_to_block (&body, tmp);
5391 /* Call MAIN__(). */
5392 tmp = build_call_expr_loc (input_location,
5394 gfc_add_expr_to_block (&body, tmp);
5396 /* Mark MAIN__ as used. */
5397 TREE_USED (fndecl) = 1;
5399 /* Coarray: Call _gfortran_caf_finalize(void). */
5400 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5402 /* Per F2008, 8.5.1 END of the main program implies a
5404 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5405 tmp = build_call_expr_loc (input_location, tmp, 0);
5406 gfc_add_expr_to_block (&body, tmp);
5408 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5409 gfc_add_expr_to_block (&body, tmp);
5413 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5414 DECL_RESULT (ftn_main),
5415 build_int_cst (integer_type_node, 0));
5416 tmp = build1_v (RETURN_EXPR, tmp);
5417 gfc_add_expr_to_block (&body, tmp);
5420 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5423 /* Finish off this function and send it for code generation. */
5425 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5427 DECL_SAVED_TREE (ftn_main)
5428 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5429 DECL_INITIAL (ftn_main));
5431 /* Output the GENERIC tree. */
5432 dump_function (TDI_original, ftn_main);
5434 cgraph_finalize_function (ftn_main, true);
5438 pop_function_context ();
5439 saved_function_decls = saved_parent_function_decls;
5441 current_function_decl = old_context;
5445 /* Get the result expression for a procedure. */
5448 get_proc_result (gfc_symbol* sym)
5450 if (sym->attr.subroutine || sym == sym->result)
5452 if (current_fake_result_decl != NULL)
5453 return TREE_VALUE (current_fake_result_decl);
5458 return sym->result->backend_decl;
5462 /* Generate an appropriate return-statement for a procedure. */
5465 gfc_generate_return (void)
5471 sym = current_procedure_symbol;
5472 fndecl = sym->backend_decl;
5474 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5478 result = get_proc_result (sym);
5480 /* Set the return value to the dummy result variable. The
5481 types may be different for scalar default REAL functions
5482 with -ff2c, therefore we have to convert. */
5483 if (result != NULL_TREE)
5485 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5486 result = fold_build2_loc (input_location, MODIFY_EXPR,
5487 TREE_TYPE (result), DECL_RESULT (fndecl),
5492 return build1_v (RETURN_EXPR, result);
5496 /* Generate code for a function. */
5499 gfc_generate_function_code (gfc_namespace * ns)
5505 stmtblock_t init, cleanup;
5507 gfc_wrapped_block try_block;
5508 tree recurcheckvar = NULL_TREE;
5510 gfc_symbol *previous_procedure_symbol;
5514 sym = ns->proc_name;
5515 previous_procedure_symbol = current_procedure_symbol;
5516 current_procedure_symbol = sym;
5518 /* Check that the frontend isn't still using this. */
5519 gcc_assert (sym->tlink == NULL);
5522 /* Create the declaration for functions with global scope. */
5523 if (!sym->backend_decl)
5524 gfc_create_function_decl (ns, false);
5526 fndecl = sym->backend_decl;
5527 old_context = current_function_decl;
5531 push_function_context ();
5532 saved_parent_function_decls = saved_function_decls;
5533 saved_function_decls = NULL_TREE;
5536 trans_function_start (sym);
5538 gfc_init_block (&init);
5540 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5542 /* Copy length backend_decls to all entry point result
5547 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5548 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5549 for (el = ns->entries; el; el = el->next)
5550 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5553 /* Translate COMMON blocks. */
5554 gfc_trans_common (ns);
5556 /* Null the parent fake result declaration if this namespace is
5557 a module function or an external procedures. */
5558 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5559 || ns->parent == NULL)
5560 parent_fake_result_decl = NULL_TREE;
5562 gfc_generate_contained_functions (ns);
5564 nonlocal_dummy_decls = NULL;
5565 nonlocal_dummy_decl_pset = NULL;
5567 has_coarray_vars = false;
5568 generate_local_vars (ns);
5570 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5571 generate_coarray_init (ns);
5573 /* Keep the parent fake result declaration in module functions
5574 or external procedures. */
5575 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5576 || ns->parent == NULL)
5577 current_fake_result_decl = parent_fake_result_decl;
5579 current_fake_result_decl = NULL_TREE;
5581 is_recursive = sym->attr.recursive
5582 || (sym->attr.entry_master
5583 && sym->ns->entries->sym->attr.recursive);
5584 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5586 && !gfc_option.flag_recursive)
5590 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5592 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5593 TREE_STATIC (recurcheckvar) = 1;
5594 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5595 gfc_add_expr_to_block (&init, recurcheckvar);
5596 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5597 &sym->declared_at, msg);
5598 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5602 /* Now generate the code for the body of this function. */
5603 gfc_init_block (&body);
5605 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5606 && sym->attr.subroutine)
5608 tree alternate_return;
5609 alternate_return = gfc_get_fake_result_decl (sym, 0);
5610 gfc_add_modify (&body, alternate_return, integer_zero_node);
5615 /* Jump to the correct entry point. */
5616 tmp = gfc_trans_entry_master_switch (ns->entries);
5617 gfc_add_expr_to_block (&body, tmp);
5620 /* If bounds-checking is enabled, generate code to check passed in actual
5621 arguments against the expected dummy argument attributes (e.g. string
5623 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5624 add_argument_checking (&body, sym);
5626 tmp = gfc_trans_code (ns->code);
5627 gfc_add_expr_to_block (&body, tmp);
5629 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5631 tree result = get_proc_result (sym);
5633 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5635 if (sym->attr.allocatable && sym->attr.dimension == 0
5636 && sym->result == sym)
5637 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5638 null_pointer_node));
5639 else if (sym->ts.type == BT_CLASS
5640 && CLASS_DATA (sym)->attr.allocatable
5641 && CLASS_DATA (sym)->attr.dimension == 0
5642 && sym->result == sym)
5644 tmp = CLASS_DATA (sym)->backend_decl;
5645 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5646 TREE_TYPE (tmp), result, tmp, NULL_TREE);
5647 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5648 null_pointer_node));
5650 else if (sym->ts.type == BT_DERIVED
5651 && sym->ts.u.derived->attr.alloc_comp
5652 && !sym->attr.allocatable)
5654 rank = sym->as ? sym->as->rank : 0;
5655 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5656 gfc_add_expr_to_block (&init, tmp);
5660 if (result == NULL_TREE)
5662 /* TODO: move to the appropriate place in resolve.c. */
5663 if (warn_return_type && sym == sym->result)
5664 gfc_warning ("Return value of function '%s' at %L not set",
5665 sym->name, &sym->declared_at);
5666 if (warn_return_type)
5667 TREE_NO_WARNING(sym->backend_decl) = 1;
5670 gfc_add_expr_to_block (&body, gfc_generate_return ());
5673 gfc_init_block (&cleanup);
5675 /* Reset recursion-check variable. */
5676 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5678 && !gfc_option.gfc_flag_openmp
5679 && recurcheckvar != NULL_TREE)
5681 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5682 recurcheckvar = NULL;
5685 /* Finish the function body and add init and cleanup code. */
5686 tmp = gfc_finish_block (&body);
5687 gfc_start_wrapped_block (&try_block, tmp);
5688 /* Add code to create and cleanup arrays. */
5689 gfc_trans_deferred_vars (sym, &try_block);
5690 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5691 gfc_finish_block (&cleanup));
5693 /* Add all the decls we created during processing. */
5694 decl = saved_function_decls;
5699 next = DECL_CHAIN (decl);
5700 DECL_CHAIN (decl) = NULL_TREE;
5704 saved_function_decls = NULL_TREE;
5706 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5709 /* Finish off this function and send it for code generation. */
5711 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5713 DECL_SAVED_TREE (fndecl)
5714 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5715 DECL_INITIAL (fndecl));
5717 if (nonlocal_dummy_decls)
5719 BLOCK_VARS (DECL_INITIAL (fndecl))
5720 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5721 pointer_set_destroy (nonlocal_dummy_decl_pset);
5722 nonlocal_dummy_decls = NULL;
5723 nonlocal_dummy_decl_pset = NULL;
5726 /* Output the GENERIC tree. */
5727 dump_function (TDI_original, fndecl);
5729 /* Store the end of the function, so that we get good line number
5730 info for the epilogue. */
5731 cfun->function_end_locus = input_location;
5733 /* We're leaving the context of this function, so zap cfun.
5734 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5735 tree_rest_of_compilation. */
5740 pop_function_context ();
5741 saved_function_decls = saved_parent_function_decls;
5743 current_function_decl = old_context;
5745 if (decl_function_context (fndecl))
5747 /* Register this function with cgraph just far enough to get it
5748 added to our parent's nested function list.
5749 If there are static coarrays in this function, the nested _caf_init
5750 function has already called cgraph_create_node, which also created
5751 the cgraph node for this function. */
5752 if (!has_coarray_vars || gfc_option.coarray != GFC_FCOARRAY_LIB)
5753 (void) cgraph_create_node (fndecl);
5756 cgraph_finalize_function (fndecl, true);
5758 gfc_trans_use_stmts (ns);
5759 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5761 if (sym->attr.is_main_program)
5762 create_main_function (fndecl);
5764 current_procedure_symbol = previous_procedure_symbol;
5769 gfc_generate_constructors (void)
5771 gcc_assert (gfc_static_ctors == NULL_TREE);
5779 if (gfc_static_ctors == NULL_TREE)
5782 fnname = get_file_function_name ("I");
5783 type = build_function_type_list (void_type_node, NULL_TREE);
5785 fndecl = build_decl (input_location,
5786 FUNCTION_DECL, fnname, type);
5787 TREE_PUBLIC (fndecl) = 1;
5789 decl = build_decl (input_location,
5790 RESULT_DECL, NULL_TREE, void_type_node);
5791 DECL_ARTIFICIAL (decl) = 1;
5792 DECL_IGNORED_P (decl) = 1;
5793 DECL_CONTEXT (decl) = fndecl;
5794 DECL_RESULT (fndecl) = decl;
5798 current_function_decl = fndecl;
5800 rest_of_decl_compilation (fndecl, 1, 0);
5802 make_decl_rtl (fndecl);
5804 allocate_struct_function (fndecl, false);
5808 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5810 tmp = build_call_expr_loc (input_location,
5811 TREE_VALUE (gfc_static_ctors), 0);
5812 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5818 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5819 DECL_SAVED_TREE (fndecl)
5820 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5821 DECL_INITIAL (fndecl));
5823 free_after_parsing (cfun);
5824 free_after_compilation (cfun);
5826 tree_rest_of_compilation (fndecl);
5828 current_function_decl = NULL_TREE;
5832 /* Translates a BLOCK DATA program unit. This means emitting the
5833 commons contained therein plus their initializations. We also emit
5834 a globally visible symbol to make sure that each BLOCK DATA program
5835 unit remains unique. */
5838 gfc_generate_block_data (gfc_namespace * ns)
5843 /* Tell the backend the source location of the block data. */
5845 gfc_set_backend_locus (&ns->proc_name->declared_at);
5847 gfc_set_backend_locus (&gfc_current_locus);
5849 /* Process the DATA statements. */
5850 gfc_trans_common (ns);
5852 /* Create a global symbol with the mane of the block data. This is to
5853 generate linker errors if the same name is used twice. It is never
5856 id = gfc_sym_mangled_function_id (ns->proc_name);
5858 id = get_identifier ("__BLOCK_DATA__");
5860 decl = build_decl (input_location,
5861 VAR_DECL, id, gfc_array_index_type);
5862 TREE_PUBLIC (decl) = 1;
5863 TREE_STATIC (decl) = 1;
5864 DECL_IGNORED_P (decl) = 1;
5867 rest_of_decl_compilation (decl, 1, 0);
5871 /* Process the local variables of a BLOCK construct. */
5874 gfc_process_block_locals (gfc_namespace* ns)
5878 gcc_assert (saved_local_decls == NULL_TREE);
5879 has_coarray_vars = false;
5881 generate_local_vars (ns);
5883 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5884 generate_coarray_init (ns);
5886 decl = saved_local_decls;
5891 next = DECL_CHAIN (decl);
5892 DECL_CHAIN (decl) = NULL_TREE;
5896 saved_local_decls = NULL_TREE;
5900 #include "gt-fortran-trans-decl.h"