1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
29 #include "tree-dump.h"
30 #include "gimple.h" /* For create_tmp_var_raw. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For announce_function. */
34 #include "output.h" /* For decl_default_tls_model. */
41 #include "pointer-set.h"
42 #include "constructor.h"
44 #include "trans-types.h"
45 #include "trans-array.h"
46 #include "trans-const.h"
47 /* Only for gfc_trans_code. Shouldn't need to include this. */
48 #include "trans-stmt.h"
50 #define MAX_LABEL_VALUE 99999
53 /* Holds the result of the function if no result variable specified. */
55 static GTY(()) tree current_fake_result_decl;
56 static GTY(()) tree parent_fake_result_decl;
59 /* Holds the variable DECLs for the current function. */
61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls;
64 static struct pointer_set_t *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
67 /* Holds the variable DECLs that are locals. */
69 static GTY(()) tree saved_local_decls;
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
74 static gfc_namespace *module_namespace;
76 /* The currently processed procedure symbol. */
77 static gfc_symbol* current_procedure_symbol = NULL;
80 /* List of static constructor functions. */
82 tree gfc_static_ctors;
85 /* Function declarations for builtin library functions. */
87 tree gfor_fndecl_pause_numeric;
88 tree gfor_fndecl_pause_string;
89 tree gfor_fndecl_stop_numeric;
90 tree gfor_fndecl_stop_string;
91 tree gfor_fndecl_error_stop_numeric;
92 tree gfor_fndecl_error_stop_string;
93 tree gfor_fndecl_runtime_error;
94 tree gfor_fndecl_runtime_error_at;
95 tree gfor_fndecl_runtime_warning_at;
96 tree gfor_fndecl_os_error;
97 tree gfor_fndecl_generate_error;
98 tree gfor_fndecl_set_args;
99 tree gfor_fndecl_set_fpe;
100 tree gfor_fndecl_set_options;
101 tree gfor_fndecl_set_convert;
102 tree gfor_fndecl_set_record_marker;
103 tree gfor_fndecl_set_max_subrecord_length;
104 tree gfor_fndecl_ctime;
105 tree gfor_fndecl_fdate;
106 tree gfor_fndecl_ttynam;
107 tree gfor_fndecl_in_pack;
108 tree gfor_fndecl_in_unpack;
109 tree gfor_fndecl_associated;
112 /* Math functions. Many other math functions are handled in
113 trans-intrinsic.c. */
115 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
116 tree gfor_fndecl_math_ishftc4;
117 tree gfor_fndecl_math_ishftc8;
118 tree gfor_fndecl_math_ishftc16;
121 /* String functions. */
123 tree gfor_fndecl_compare_string;
124 tree gfor_fndecl_concat_string;
125 tree gfor_fndecl_string_len_trim;
126 tree gfor_fndecl_string_index;
127 tree gfor_fndecl_string_scan;
128 tree gfor_fndecl_string_verify;
129 tree gfor_fndecl_string_trim;
130 tree gfor_fndecl_string_minmax;
131 tree gfor_fndecl_adjustl;
132 tree gfor_fndecl_adjustr;
133 tree gfor_fndecl_select_string;
134 tree gfor_fndecl_compare_string_char4;
135 tree gfor_fndecl_concat_string_char4;
136 tree gfor_fndecl_string_len_trim_char4;
137 tree gfor_fndecl_string_index_char4;
138 tree gfor_fndecl_string_scan_char4;
139 tree gfor_fndecl_string_verify_char4;
140 tree gfor_fndecl_string_trim_char4;
141 tree gfor_fndecl_string_minmax_char4;
142 tree gfor_fndecl_adjustl_char4;
143 tree gfor_fndecl_adjustr_char4;
144 tree gfor_fndecl_select_string_char4;
147 /* Conversion between character kinds. */
148 tree gfor_fndecl_convert_char1_to_char4;
149 tree gfor_fndecl_convert_char4_to_char1;
152 /* Other misc. runtime library functions. */
154 tree gfor_fndecl_size0;
155 tree gfor_fndecl_size1;
156 tree gfor_fndecl_iargc;
157 tree gfor_fndecl_clz128;
158 tree gfor_fndecl_ctz128;
160 /* Intrinsic functions implemented in Fortran. */
161 tree gfor_fndecl_sc_kind;
162 tree gfor_fndecl_si_kind;
163 tree gfor_fndecl_sr_kind;
165 /* BLAS gemm functions. */
166 tree gfor_fndecl_sgemm;
167 tree gfor_fndecl_dgemm;
168 tree gfor_fndecl_cgemm;
169 tree gfor_fndecl_zgemm;
173 gfc_add_decl_to_parent_function (tree decl)
176 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
177 DECL_NONLOCAL (decl) = 1;
178 DECL_CHAIN (decl) = saved_parent_function_decls;
179 saved_parent_function_decls = decl;
183 gfc_add_decl_to_function (tree decl)
186 TREE_USED (decl) = 1;
187 DECL_CONTEXT (decl) = current_function_decl;
188 DECL_CHAIN (decl) = saved_function_decls;
189 saved_function_decls = decl;
193 add_decl_as_local (tree decl)
196 TREE_USED (decl) = 1;
197 DECL_CONTEXT (decl) = current_function_decl;
198 DECL_CHAIN (decl) = saved_local_decls;
199 saved_local_decls = decl;
203 /* Build a backend label declaration. Set TREE_USED for named labels.
204 The context of the label is always the current_function_decl. All
205 labels are marked artificial. */
208 gfc_build_label_decl (tree label_id)
210 /* 2^32 temporaries should be enough. */
211 static unsigned int tmp_num = 1;
215 if (label_id == NULL_TREE)
217 /* Build an internal label name. */
218 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
219 label_id = get_identifier (label_name);
224 /* Build the LABEL_DECL node. Labels have no type. */
225 label_decl = build_decl (input_location,
226 LABEL_DECL, label_id, void_type_node);
227 DECL_CONTEXT (label_decl) = current_function_decl;
228 DECL_MODE (label_decl) = VOIDmode;
230 /* We always define the label as used, even if the original source
231 file never references the label. We don't want all kinds of
232 spurious warnings for old-style Fortran code with too many
234 TREE_USED (label_decl) = 1;
236 DECL_ARTIFICIAL (label_decl) = 1;
241 /* Set the backend source location of a decl. */
244 gfc_set_decl_location (tree decl, locus * loc)
246 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
250 /* Return the backend label declaration for a given label structure,
251 or create it if it doesn't exist yet. */
254 gfc_get_label_decl (gfc_st_label * lp)
256 if (lp->backend_decl)
257 return lp->backend_decl;
260 char label_name[GFC_MAX_SYMBOL_LEN + 1];
263 /* Validate the label declaration from the front end. */
264 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
266 /* Build a mangled name for the label. */
267 sprintf (label_name, "__label_%.6d", lp->value);
269 /* Build the LABEL_DECL node. */
270 label_decl = gfc_build_label_decl (get_identifier (label_name));
272 /* Tell the debugger where the label came from. */
273 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
274 gfc_set_decl_location (label_decl, &lp->where);
276 DECL_ARTIFICIAL (label_decl) = 1;
278 /* Store the label in the label list and return the LABEL_DECL. */
279 lp->backend_decl = label_decl;
285 /* Convert a gfc_symbol to an identifier of the same name. */
288 gfc_sym_identifier (gfc_symbol * sym)
290 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
291 return (get_identifier ("MAIN__"));
293 return (get_identifier (sym->name));
297 /* Construct mangled name from symbol name. */
300 gfc_sym_mangled_identifier (gfc_symbol * sym)
302 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
304 /* Prevent the mangling of identifiers that have an assigned
305 binding label (mainly those that are bind(c)). */
306 if (sym->attr.is_bind_c == 1
307 && sym->binding_label[0] != '\0')
308 return get_identifier(sym->binding_label);
310 if (sym->module == NULL)
311 return gfc_sym_identifier (sym);
314 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
315 return get_identifier (name);
320 /* Construct mangled function name from symbol name. */
323 gfc_sym_mangled_function_id (gfc_symbol * sym)
326 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
328 /* It may be possible to simply use the binding label if it's
329 provided, and remove the other checks. Then we could use it
330 for other things if we wished. */
331 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
332 sym->binding_label[0] != '\0')
333 /* use the binding label rather than the mangled name */
334 return get_identifier (sym->binding_label);
336 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
337 || (sym->module != NULL && (sym->attr.external
338 || sym->attr.if_source == IFSRC_IFBODY)))
340 /* Main program is mangled into MAIN__. */
341 if (sym->attr.is_main_program)
342 return get_identifier ("MAIN__");
344 /* Intrinsic procedures are never mangled. */
345 if (sym->attr.proc == PROC_INTRINSIC)
346 return get_identifier (sym->name);
348 if (gfc_option.flag_underscoring)
350 has_underscore = strchr (sym->name, '_') != 0;
351 if (gfc_option.flag_second_underscore && has_underscore)
352 snprintf (name, sizeof name, "%s__", sym->name);
354 snprintf (name, sizeof name, "%s_", sym->name);
355 return get_identifier (name);
358 return get_identifier (sym->name);
362 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
363 return get_identifier (name);
369 gfc_set_decl_assembler_name (tree decl, tree name)
371 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
372 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
376 /* Returns true if a variable of specified size should go on the stack. */
379 gfc_can_put_var_on_stack (tree size)
381 unsigned HOST_WIDE_INT low;
383 if (!INTEGER_CST_P (size))
386 if (gfc_option.flag_max_stack_var_size < 0)
389 if (TREE_INT_CST_HIGH (size) != 0)
392 low = TREE_INT_CST_LOW (size);
393 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
396 /* TODO: Set a per-function stack size limit. */
402 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
403 an expression involving its corresponding pointer. There are
404 2 cases; one for variable size arrays, and one for everything else,
405 because variable-sized arrays require one fewer level of
409 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
411 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
414 /* Parameters need to be dereferenced. */
415 if (sym->cp_pointer->attr.dummy)
416 ptr_decl = build_fold_indirect_ref_loc (input_location,
419 /* Check to see if we're dealing with a variable-sized array. */
420 if (sym->attr.dimension
421 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
423 /* These decls will be dereferenced later, so we don't dereference
425 value = convert (TREE_TYPE (decl), ptr_decl);
429 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
431 value = build_fold_indirect_ref_loc (input_location,
435 SET_DECL_VALUE_EXPR (decl, value);
436 DECL_HAS_VALUE_EXPR_P (decl) = 1;
437 GFC_DECL_CRAY_POINTEE (decl) = 1;
438 /* This is a fake variable just for debugging purposes. */
439 TREE_ASM_WRITTEN (decl) = 1;
443 /* Finish processing of a declaration without an initial value. */
446 gfc_finish_decl (tree decl)
448 gcc_assert (TREE_CODE (decl) == PARM_DECL
449 || DECL_INITIAL (decl) == NULL_TREE);
451 if (TREE_CODE (decl) != VAR_DECL)
454 if (DECL_SIZE (decl) == NULL_TREE
455 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
456 layout_decl (decl, 0);
458 /* A few consistency checks. */
459 /* A static variable with an incomplete type is an error if it is
460 initialized. Also if it is not file scope. Otherwise, let it
461 through, but if it is not `extern' then it may cause an error
463 /* An automatic variable with an incomplete type is an error. */
465 /* We should know the storage size. */
466 gcc_assert (DECL_SIZE (decl) != NULL_TREE
467 || (TREE_STATIC (decl)
468 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
469 : DECL_EXTERNAL (decl)));
471 /* The storage size should be constant. */
472 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
474 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
478 /* Apply symbol attributes to a variable, and add it to the function scope. */
481 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
484 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
485 This is the equivalent of the TARGET variables.
486 We also need to set this if the variable is passed by reference in a
489 /* Set DECL_VALUE_EXPR for Cray Pointees. */
490 if (sym->attr.cray_pointee)
491 gfc_finish_cray_pointee (decl, sym);
493 if (sym->attr.target)
494 TREE_ADDRESSABLE (decl) = 1;
495 /* If it wasn't used we wouldn't be getting it. */
496 TREE_USED (decl) = 1;
498 /* Chain this decl to the pending declarations. Don't do pushdecl()
499 because this would add them to the current scope rather than the
501 if (current_function_decl != NULL_TREE)
503 if (sym->ns->proc_name->backend_decl == current_function_decl
504 || sym->result == sym)
505 gfc_add_decl_to_function (decl);
506 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
507 /* This is a BLOCK construct. */
508 add_decl_as_local (decl);
510 gfc_add_decl_to_parent_function (decl);
513 if (sym->attr.cray_pointee)
516 if(sym->attr.is_bind_c == 1)
518 /* We need to put variables that are bind(c) into the common
519 segment of the object file, because this is what C would do.
520 gfortran would typically put them in either the BSS or
521 initialized data segments, and only mark them as common if
522 they were part of common blocks. However, if they are not put
523 into common space, then C cannot initialize global Fortran
524 variables that it interoperates with and the draft says that
525 either Fortran or C should be able to initialize it (but not
526 both, of course.) (J3/04-007, section 15.3). */
527 TREE_PUBLIC(decl) = 1;
528 DECL_COMMON(decl) = 1;
531 /* If a variable is USE associated, it's always external. */
532 if (sym->attr.use_assoc)
534 DECL_EXTERNAL (decl) = 1;
535 TREE_PUBLIC (decl) = 1;
537 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
539 /* TODO: Don't set sym->module for result or dummy variables. */
540 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
541 /* This is the declaration of a module variable. */
542 TREE_PUBLIC (decl) = 1;
543 TREE_STATIC (decl) = 1;
546 /* Derived types are a bit peculiar because of the possibility of
547 a default initializer; this must be applied each time the variable
548 comes into scope it therefore need not be static. These variables
549 are SAVE_NONE but have an initializer. Otherwise explicitly
550 initialized variables are SAVE_IMPLICIT and explicitly saved are
552 if (!sym->attr.use_assoc
553 && (sym->attr.save != SAVE_NONE || sym->attr.data
554 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
555 TREE_STATIC (decl) = 1;
557 if (sym->attr.volatile_)
559 TREE_THIS_VOLATILE (decl) = 1;
560 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
561 TREE_TYPE (decl) = new_type;
564 /* Keep variables larger than max-stack-var-size off stack. */
565 if (!sym->ns->proc_name->attr.recursive
566 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
567 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
568 /* Put variable length auto array pointers always into stack. */
569 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
570 || sym->attr.dimension == 0
571 || sym->as->type != AS_EXPLICIT
573 || sym->attr.allocatable)
574 && !DECL_ARTIFICIAL (decl))
575 TREE_STATIC (decl) = 1;
577 /* Handle threadprivate variables. */
578 if (sym->attr.threadprivate
579 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
580 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
582 if (!sym->attr.target
583 && !sym->attr.pointer
584 && !sym->attr.cray_pointee
585 && !sym->attr.proc_pointer)
586 DECL_RESTRICTED_P (decl) = 1;
590 /* Allocate the lang-specific part of a decl. */
593 gfc_allocate_lang_decl (tree decl)
595 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
599 /* Remember a symbol to generate initialization/cleanup code at function
603 gfc_defer_symbol_init (gfc_symbol * sym)
609 /* Don't add a symbol twice. */
613 last = head = sym->ns->proc_name;
616 /* Make sure that setup code for dummy variables which are used in the
617 setup of other variables is generated first. */
620 /* Find the first dummy arg seen after us, or the first non-dummy arg.
621 This is a circular list, so don't go past the head. */
623 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
629 /* Insert in between last and p. */
635 /* Create an array index type variable with function scope. */
638 create_index_var (const char * pfx, int nest)
642 decl = gfc_create_var_np (gfc_array_index_type, pfx);
644 gfc_add_decl_to_parent_function (decl);
646 gfc_add_decl_to_function (decl);
651 /* Create variables to hold all the non-constant bits of info for a
652 descriptorless array. Remember these in the lang-specific part of the
656 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
661 gfc_namespace* procns;
663 type = TREE_TYPE (decl);
665 /* We just use the descriptor, if there is one. */
666 if (GFC_DESCRIPTOR_TYPE_P (type))
669 gcc_assert (GFC_ARRAY_TYPE_P (type));
670 procns = gfc_find_proc_namespace (sym->ns);
671 nest = (procns->proc_name->backend_decl != current_function_decl)
672 && !sym->attr.contained;
674 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
676 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
678 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
679 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
681 /* Don't try to use the unknown bound for assumed shape arrays. */
682 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
683 && (sym->as->type != AS_ASSUMED_SIZE
684 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
686 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
687 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
690 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
692 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
693 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
696 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
698 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
700 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
703 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
705 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
708 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
709 && sym->as->type != AS_ASSUMED_SIZE)
711 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
712 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
715 if (POINTER_TYPE_P (type))
717 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
718 gcc_assert (TYPE_LANG_SPECIFIC (type)
719 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
720 type = TREE_TYPE (type);
723 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
727 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
728 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
729 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
731 TYPE_DOMAIN (type) = range;
735 if (TYPE_NAME (type) != NULL_TREE
736 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
737 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
739 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
741 for (dim = 0; dim < sym->as->rank - 1; dim++)
743 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
744 gtype = TREE_TYPE (gtype);
746 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
747 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
748 TYPE_NAME (type) = NULL_TREE;
751 if (TYPE_NAME (type) == NULL_TREE)
753 tree gtype = TREE_TYPE (type), rtype, type_decl;
755 for (dim = sym->as->rank - 1; dim >= 0; dim--)
758 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
759 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
760 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
761 gtype = build_array_type (gtype, rtype);
762 /* Ensure the bound variables aren't optimized out at -O0.
763 For -O1 and above they often will be optimized out, but
764 can be tracked by VTA. Also set DECL_NAMELESS, so that
765 the artificial lbound.N or ubound.N DECL_NAME doesn't
766 end up in debug info. */
767 if (lbound && TREE_CODE (lbound) == VAR_DECL
768 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
770 if (DECL_NAME (lbound)
771 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
773 DECL_NAMELESS (lbound) = 1;
774 DECL_IGNORED_P (lbound) = 0;
776 if (ubound && TREE_CODE (ubound) == VAR_DECL
777 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
779 if (DECL_NAME (ubound)
780 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
782 DECL_NAMELESS (ubound) = 1;
783 DECL_IGNORED_P (ubound) = 0;
786 TYPE_NAME (type) = type_decl = build_decl (input_location,
787 TYPE_DECL, NULL, gtype);
788 DECL_ORIGINAL_TYPE (type_decl) = gtype;
793 /* For some dummy arguments we don't use the actual argument directly.
794 Instead we create a local decl and use that. This allows us to perform
795 initialization, and construct full type information. */
798 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
808 if (sym->attr.pointer || sym->attr.allocatable)
811 /* Add to list of variables if not a fake result variable. */
812 if (sym->attr.result || sym->attr.dummy)
813 gfc_defer_symbol_init (sym);
815 type = TREE_TYPE (dummy);
816 gcc_assert (TREE_CODE (dummy) == PARM_DECL
817 && POINTER_TYPE_P (type));
819 /* Do we know the element size? */
820 known_size = sym->ts.type != BT_CHARACTER
821 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
823 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
825 /* For descriptorless arrays with known element size the actual
826 argument is sufficient. */
827 gcc_assert (GFC_ARRAY_TYPE_P (type));
828 gfc_build_qualified_array (dummy, sym);
832 type = TREE_TYPE (type);
833 if (GFC_DESCRIPTOR_TYPE_P (type))
835 /* Create a descriptorless array pointer. */
839 /* Even when -frepack-arrays is used, symbols with TARGET attribute
841 if (!gfc_option.flag_repack_arrays || sym->attr.target)
843 if (as->type == AS_ASSUMED_SIZE)
844 packed = PACKED_FULL;
848 if (as->type == AS_EXPLICIT)
850 packed = PACKED_FULL;
851 for (n = 0; n < as->rank; n++)
855 && as->upper[n]->expr_type == EXPR_CONSTANT
856 && as->lower[n]->expr_type == EXPR_CONSTANT))
857 packed = PACKED_PARTIAL;
861 packed = PACKED_PARTIAL;
864 type = gfc_typenode_for_spec (&sym->ts);
865 type = gfc_get_nodesc_array_type (type, sym->as, packed,
870 /* We now have an expression for the element size, so create a fully
871 qualified type. Reset sym->backend decl or this will just return the
873 DECL_ARTIFICIAL (sym->backend_decl) = 1;
874 sym->backend_decl = NULL_TREE;
875 type = gfc_sym_type (sym);
876 packed = PACKED_FULL;
879 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
880 decl = build_decl (input_location,
881 VAR_DECL, get_identifier (name), type);
883 DECL_ARTIFICIAL (decl) = 1;
884 DECL_NAMELESS (decl) = 1;
885 TREE_PUBLIC (decl) = 0;
886 TREE_STATIC (decl) = 0;
887 DECL_EXTERNAL (decl) = 0;
889 /* We should never get deferred shape arrays here. We used to because of
891 gcc_assert (sym->as->type != AS_DEFERRED);
893 if (packed == PACKED_PARTIAL)
894 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
895 else if (packed == PACKED_FULL)
896 GFC_DECL_PACKED_ARRAY (decl) = 1;
898 gfc_build_qualified_array (decl, sym);
900 if (DECL_LANG_SPECIFIC (dummy))
901 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
903 gfc_allocate_lang_decl (decl);
905 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
907 if (sym->ns->proc_name->backend_decl == current_function_decl
908 || sym->attr.contained)
909 gfc_add_decl_to_function (decl);
911 gfc_add_decl_to_parent_function (decl);
916 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
917 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
918 pointing to the artificial variable for debug info purposes. */
921 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
925 if (! nonlocal_dummy_decl_pset)
926 nonlocal_dummy_decl_pset = pointer_set_create ();
928 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
931 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
932 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
933 TREE_TYPE (sym->backend_decl));
934 DECL_ARTIFICIAL (decl) = 0;
935 TREE_USED (decl) = 1;
936 TREE_PUBLIC (decl) = 0;
937 TREE_STATIC (decl) = 0;
938 DECL_EXTERNAL (decl) = 0;
939 if (DECL_BY_REFERENCE (dummy))
940 DECL_BY_REFERENCE (decl) = 1;
941 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
942 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
943 DECL_HAS_VALUE_EXPR_P (decl) = 1;
944 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
945 DECL_CHAIN (decl) = nonlocal_dummy_decls;
946 nonlocal_dummy_decls = decl;
949 /* Return a constant or a variable to use as a string length. Does not
950 add the decl to the current scope. */
953 gfc_create_string_length (gfc_symbol * sym)
955 gcc_assert (sym->ts.u.cl);
956 gfc_conv_const_charlen (sym->ts.u.cl);
958 if (sym->ts.u.cl->backend_decl == NULL_TREE)
961 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
963 /* Also prefix the mangled name. */
964 strcpy (&name[1], sym->name);
966 length = build_decl (input_location,
967 VAR_DECL, get_identifier (name),
968 gfc_charlen_type_node);
969 DECL_ARTIFICIAL (length) = 1;
970 TREE_USED (length) = 1;
971 if (sym->ns->proc_name->tlink != NULL)
972 gfc_defer_symbol_init (sym);
974 sym->ts.u.cl->backend_decl = length;
977 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
978 return sym->ts.u.cl->backend_decl;
981 /* If a variable is assigned a label, we add another two auxiliary
985 gfc_add_assign_aux_vars (gfc_symbol * sym)
991 gcc_assert (sym->backend_decl);
993 decl = sym->backend_decl;
994 gfc_allocate_lang_decl (decl);
995 GFC_DECL_ASSIGN (decl) = 1;
996 length = build_decl (input_location,
997 VAR_DECL, create_tmp_var_name (sym->name),
998 gfc_charlen_type_node);
999 addr = build_decl (input_location,
1000 VAR_DECL, create_tmp_var_name (sym->name),
1002 gfc_finish_var_decl (length, sym);
1003 gfc_finish_var_decl (addr, sym);
1004 /* STRING_LENGTH is also used as flag. Less than -1 means that
1005 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1006 target label's address. Otherwise, value is the length of a format string
1007 and ASSIGN_ADDR is its address. */
1008 if (TREE_STATIC (length))
1009 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1011 gfc_defer_symbol_init (sym);
1013 GFC_DECL_STRING_LEN (decl) = length;
1014 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1019 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1024 for (id = 0; id < EXT_ATTR_NUM; id++)
1025 if (sym_attr.ext_attr & (1 << id))
1027 attr = build_tree_list (
1028 get_identifier (ext_attr_list[id].middle_end_name),
1030 list = chainon (list, attr);
1037 /* Return the decl for a gfc_symbol, create it if it doesn't already
1041 gfc_get_symbol_decl (gfc_symbol * sym)
1044 tree length = NULL_TREE;
1048 gcc_assert (sym->attr.referenced
1049 || sym->attr.use_assoc
1050 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1051 || (sym->module && sym->attr.if_source != IFSRC_DECL
1052 && sym->backend_decl));
1054 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1055 byref = gfc_return_by_reference (sym->ns->proc_name);
1059 /* Make sure that the vtab for the declared type is completed. */
1060 if (sym->ts.type == BT_CLASS)
1062 gfc_component *c = CLASS_DATA (sym);
1063 if (!c->ts.u.derived->backend_decl)
1064 gfc_find_derived_vtab (c->ts.u.derived);
1067 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1069 /* Return via extra parameter. */
1070 if (sym->attr.result && byref
1071 && !sym->backend_decl)
1074 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1075 /* For entry master function skip over the __entry
1077 if (sym->ns->proc_name->attr.entry_master)
1078 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1081 /* Dummy variables should already have been created. */
1082 gcc_assert (sym->backend_decl);
1084 /* Create a character length variable. */
1085 if (sym->ts.type == BT_CHARACTER)
1087 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1088 length = gfc_create_string_length (sym);
1090 length = sym->ts.u.cl->backend_decl;
1091 if (TREE_CODE (length) == VAR_DECL
1092 && DECL_CONTEXT (length) == NULL_TREE)
1094 /* Add the string length to the same context as the symbol. */
1095 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1096 gfc_add_decl_to_function (length);
1098 gfc_add_decl_to_parent_function (length);
1100 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1101 DECL_CONTEXT (length));
1103 gfc_defer_symbol_init (sym);
1107 /* Use a copy of the descriptor for dummy arrays. */
1108 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1110 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1111 /* Prevent the dummy from being detected as unused if it is copied. */
1112 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1113 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1114 sym->backend_decl = decl;
1117 TREE_USED (sym->backend_decl) = 1;
1118 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1120 gfc_add_assign_aux_vars (sym);
1123 if (sym->attr.dimension
1124 && DECL_LANG_SPECIFIC (sym->backend_decl)
1125 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1126 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1127 gfc_nonlocal_dummy_array_decl (sym);
1129 return sym->backend_decl;
1132 if (sym->backend_decl)
1133 return sym->backend_decl;
1135 /* If use associated and whole file compilation, use the module
1137 if (gfc_option.flag_whole_file
1138 && sym->attr.flavor == FL_VARIABLE
1139 && sym->attr.use_assoc
1144 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1145 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1149 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1150 if (s && s->backend_decl)
1152 if (sym->ts.type == BT_DERIVED)
1153 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1155 if (sym->ts.type == BT_CHARACTER)
1156 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1157 sym->backend_decl = s->backend_decl;
1158 return sym->backend_decl;
1163 /* Catch function declarations. Only used for actual parameters and
1164 procedure pointers. */
1165 if (sym->attr.flavor == FL_PROCEDURE)
1167 decl = gfc_get_extern_function_decl (sym);
1168 gfc_set_decl_location (decl, &sym->declared_at);
1172 if (sym->attr.intrinsic)
1173 internal_error ("intrinsic variable which isn't a procedure");
1175 /* Create string length decl first so that they can be used in the
1176 type declaration. */
1177 if (sym->ts.type == BT_CHARACTER)
1178 length = gfc_create_string_length (sym);
1180 /* Create the decl for the variable. */
1181 decl = build_decl (sym->declared_at.lb->location,
1182 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1184 /* Add attributes to variables. Functions are handled elsewhere. */
1185 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1186 decl_attributes (&decl, attributes, 0);
1188 /* Symbols from modules should have their assembler names mangled.
1189 This is done here rather than in gfc_finish_var_decl because it
1190 is different for string length variables. */
1193 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1194 if (sym->attr.use_assoc)
1195 DECL_IGNORED_P (decl) = 1;
1198 if (sym->attr.dimension)
1200 /* Create variables to hold the non-constant bits of array info. */
1201 gfc_build_qualified_array (decl, sym);
1203 if (sym->attr.contiguous
1204 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1205 GFC_DECL_PACKED_ARRAY (decl) = 1;
1208 /* Remember this variable for allocation/cleanup. */
1209 if (sym->attr.dimension || sym->attr.allocatable
1210 || (sym->ts.type == BT_CLASS &&
1211 (CLASS_DATA (sym)->attr.dimension
1212 || CLASS_DATA (sym)->attr.allocatable))
1213 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1214 /* This applies a derived type default initializer. */
1215 || (sym->ts.type == BT_DERIVED
1216 && sym->attr.save == SAVE_NONE
1218 && !sym->attr.allocatable
1219 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1220 && !sym->attr.use_assoc))
1221 gfc_defer_symbol_init (sym);
1223 gfc_finish_var_decl (decl, sym);
1225 if (sym->ts.type == BT_CHARACTER)
1227 /* Character variables need special handling. */
1228 gfc_allocate_lang_decl (decl);
1230 if (TREE_CODE (length) != INTEGER_CST)
1232 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1236 /* Also prefix the mangled name for symbols from modules. */
1237 strcpy (&name[1], sym->name);
1240 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1241 gfc_set_decl_assembler_name (decl, get_identifier (name));
1243 gfc_finish_var_decl (length, sym);
1244 gcc_assert (!sym->value);
1247 else if (sym->attr.subref_array_pointer)
1249 /* We need the span for these beasts. */
1250 gfc_allocate_lang_decl (decl);
1253 if (sym->attr.subref_array_pointer)
1256 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1257 span = build_decl (input_location,
1258 VAR_DECL, create_tmp_var_name ("span"),
1259 gfc_array_index_type);
1260 gfc_finish_var_decl (span, sym);
1261 TREE_STATIC (span) = TREE_STATIC (decl);
1262 DECL_ARTIFICIAL (span) = 1;
1263 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1265 GFC_DECL_SPAN (decl) = span;
1266 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1269 sym->backend_decl = decl;
1271 if (sym->attr.assign)
1272 gfc_add_assign_aux_vars (sym);
1274 if (TREE_STATIC (decl) && !sym->attr.use_assoc
1275 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1276 || gfc_option.flag_max_stack_var_size == 0
1277 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1279 /* Add static initializer. For procedures, it is only needed if
1280 SAVE is specified otherwise they need to be reinitialized
1281 every time the procedure is entered. The TREE_STATIC is
1282 in this case due to -fmax-stack-var-size=. */
1283 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1284 TREE_TYPE (decl), sym->attr.dimension,
1285 sym->attr.pointer || sym->attr.allocatable);
1288 if (!TREE_STATIC (decl)
1289 && POINTER_TYPE_P (TREE_TYPE (decl))
1290 && !sym->attr.pointer
1291 && !sym->attr.allocatable
1292 && !sym->attr.proc_pointer)
1293 DECL_BY_REFERENCE (decl) = 1;
1299 /* Substitute a temporary variable in place of the real one. */
1302 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1304 save->attr = sym->attr;
1305 save->decl = sym->backend_decl;
1307 gfc_clear_attr (&sym->attr);
1308 sym->attr.referenced = 1;
1309 sym->attr.flavor = FL_VARIABLE;
1311 sym->backend_decl = decl;
1315 /* Restore the original variable. */
1318 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1320 sym->attr = save->attr;
1321 sym->backend_decl = save->decl;
1325 /* Declare a procedure pointer. */
1328 get_proc_pointer_decl (gfc_symbol *sym)
1333 decl = sym->backend_decl;
1337 decl = build_decl (input_location,
1338 VAR_DECL, get_identifier (sym->name),
1339 build_pointer_type (gfc_get_function_type (sym)));
1341 if ((sym->ns->proc_name
1342 && sym->ns->proc_name->backend_decl == current_function_decl)
1343 || sym->attr.contained)
1344 gfc_add_decl_to_function (decl);
1345 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1346 gfc_add_decl_to_parent_function (decl);
1348 sym->backend_decl = decl;
1350 /* If a variable is USE associated, it's always external. */
1351 if (sym->attr.use_assoc)
1353 DECL_EXTERNAL (decl) = 1;
1354 TREE_PUBLIC (decl) = 1;
1356 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1358 /* This is the declaration of a module variable. */
1359 TREE_PUBLIC (decl) = 1;
1360 TREE_STATIC (decl) = 1;
1363 if (!sym->attr.use_assoc
1364 && (sym->attr.save != SAVE_NONE || sym->attr.data
1365 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1366 TREE_STATIC (decl) = 1;
1368 if (TREE_STATIC (decl) && sym->value)
1370 /* Add static initializer. */
1371 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1373 sym->attr.proc_pointer ? false : sym->attr.dimension,
1374 sym->attr.proc_pointer);
1377 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1378 decl_attributes (&decl, attributes, 0);
1384 /* Get a basic decl for an external function. */
1387 gfc_get_extern_function_decl (gfc_symbol * sym)
1393 gfc_intrinsic_sym *isym;
1395 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1400 if (sym->backend_decl)
1401 return sym->backend_decl;
1403 /* We should never be creating external decls for alternate entry points.
1404 The procedure may be an alternate entry point, but we don't want/need
1406 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1408 if (sym->attr.proc_pointer)
1409 return get_proc_pointer_decl (sym);
1411 /* See if this is an external procedure from the same file. If so,
1412 return the backend_decl. */
1413 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1415 if (gfc_option.flag_whole_file
1416 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1417 && !sym->backend_decl
1419 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1420 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1422 if (!gsym->ns->proc_name->backend_decl)
1424 /* By construction, the external function cannot be
1425 a contained procedure. */
1427 tree save_fn_decl = current_function_decl;
1429 current_function_decl = NULL_TREE;
1430 gfc_get_backend_locus (&old_loc);
1433 gfc_create_function_decl (gsym->ns, true);
1436 gfc_set_backend_locus (&old_loc);
1437 current_function_decl = save_fn_decl;
1440 /* If the namespace has entries, the proc_name is the
1441 entry master. Find the entry and use its backend_decl.
1442 otherwise, use the proc_name backend_decl. */
1443 if (gsym->ns->entries)
1445 gfc_entry_list *entry = gsym->ns->entries;
1447 for (; entry; entry = entry->next)
1449 if (strcmp (gsym->name, entry->sym->name) == 0)
1451 sym->backend_decl = entry->sym->backend_decl;
1457 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1459 if (sym->backend_decl)
1461 /* Avoid problems of double deallocation of the backend declaration
1462 later in gfc_trans_use_stmts; cf. PR 45087. */
1463 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1464 sym->attr.use_assoc = 0;
1466 return sym->backend_decl;
1470 /* See if this is a module procedure from the same file. If so,
1471 return the backend_decl. */
1473 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1475 if (gfc_option.flag_whole_file
1477 && gsym->type == GSYM_MODULE)
1482 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1483 if (s && s->backend_decl)
1485 sym->backend_decl = s->backend_decl;
1486 return sym->backend_decl;
1490 if (sym->attr.intrinsic)
1492 /* Call the resolution function to get the actual name. This is
1493 a nasty hack which relies on the resolution functions only looking
1494 at the first argument. We pass NULL for the second argument
1495 otherwise things like AINT get confused. */
1496 isym = gfc_find_function (sym->name);
1497 gcc_assert (isym->resolve.f0 != NULL);
1499 memset (&e, 0, sizeof (e));
1500 e.expr_type = EXPR_FUNCTION;
1502 memset (&argexpr, 0, sizeof (argexpr));
1503 gcc_assert (isym->formal);
1504 argexpr.ts = isym->formal->ts;
1506 if (isym->formal->next == NULL)
1507 isym->resolve.f1 (&e, &argexpr);
1510 if (isym->formal->next->next == NULL)
1511 isym->resolve.f2 (&e, &argexpr, NULL);
1514 if (isym->formal->next->next->next == NULL)
1515 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1518 /* All specific intrinsics take less than 5 arguments. */
1519 gcc_assert (isym->formal->next->next->next->next == NULL);
1520 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1525 if (gfc_option.flag_f2c
1526 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1527 || e.ts.type == BT_COMPLEX))
1529 /* Specific which needs a different implementation if f2c
1530 calling conventions are used. */
1531 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1534 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1536 name = get_identifier (s);
1537 mangled_name = name;
1541 name = gfc_sym_identifier (sym);
1542 mangled_name = gfc_sym_mangled_function_id (sym);
1545 type = gfc_get_function_type (sym);
1546 fndecl = build_decl (input_location,
1547 FUNCTION_DECL, name, type);
1549 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1550 decl_attributes (&fndecl, attributes, 0);
1552 gfc_set_decl_assembler_name (fndecl, mangled_name);
1554 /* Set the context of this decl. */
1555 if (0 && sym->ns && sym->ns->proc_name)
1557 /* TODO: Add external decls to the appropriate scope. */
1558 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1562 /* Global declaration, e.g. intrinsic subroutine. */
1563 DECL_CONTEXT (fndecl) = NULL_TREE;
1566 DECL_EXTERNAL (fndecl) = 1;
1568 /* This specifies if a function is globally addressable, i.e. it is
1569 the opposite of declaring static in C. */
1570 TREE_PUBLIC (fndecl) = 1;
1572 /* Set attributes for PURE functions. A call to PURE function in the
1573 Fortran 95 sense is both pure and without side effects in the C
1575 if (sym->attr.pure || sym->attr.elemental)
1577 if (sym->attr.function && !gfc_return_by_reference (sym))
1578 DECL_PURE_P (fndecl) = 1;
1579 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1580 parameters and don't use alternate returns (is this
1581 allowed?). In that case, calls to them are meaningless, and
1582 can be optimized away. See also in build_function_decl(). */
1583 TREE_SIDE_EFFECTS (fndecl) = 0;
1586 /* Mark non-returning functions. */
1587 if (sym->attr.noreturn)
1588 TREE_THIS_VOLATILE(fndecl) = 1;
1590 sym->backend_decl = fndecl;
1592 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1593 pushdecl_top_level (fndecl);
1599 /* Create a declaration for a procedure. For external functions (in the C
1600 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1601 a master function with alternate entry points. */
1604 build_function_decl (gfc_symbol * sym, bool global)
1606 tree fndecl, type, attributes;
1607 symbol_attribute attr;
1609 gfc_formal_arglist *f;
1611 gcc_assert (!sym->backend_decl);
1612 gcc_assert (!sym->attr.external);
1614 /* Set the line and filename. sym->declared_at seems to point to the
1615 last statement for subroutines, but it'll do for now. */
1616 gfc_set_backend_locus (&sym->declared_at);
1618 /* Allow only one nesting level. Allow public declarations. */
1619 gcc_assert (current_function_decl == NULL_TREE
1620 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1621 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1624 type = gfc_get_function_type (sym);
1625 fndecl = build_decl (input_location,
1626 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1630 attributes = add_attributes_to_decl (attr, NULL_TREE);
1631 decl_attributes (&fndecl, attributes, 0);
1633 /* Perform name mangling if this is a top level or module procedure. */
1634 if (current_function_decl == NULL_TREE)
1635 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1637 /* Figure out the return type of the declared function, and build a
1638 RESULT_DECL for it. If this is a subroutine with alternate
1639 returns, build a RESULT_DECL for it. */
1640 result_decl = NULL_TREE;
1641 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1644 if (gfc_return_by_reference (sym))
1645 type = void_type_node;
1648 if (sym->result != sym)
1649 result_decl = gfc_sym_identifier (sym->result);
1651 type = TREE_TYPE (TREE_TYPE (fndecl));
1656 /* Look for alternate return placeholders. */
1657 int has_alternate_returns = 0;
1658 for (f = sym->formal; f; f = f->next)
1662 has_alternate_returns = 1;
1667 if (has_alternate_returns)
1668 type = integer_type_node;
1670 type = void_type_node;
1673 result_decl = build_decl (input_location,
1674 RESULT_DECL, result_decl, type);
1675 DECL_ARTIFICIAL (result_decl) = 1;
1676 DECL_IGNORED_P (result_decl) = 1;
1677 DECL_CONTEXT (result_decl) = fndecl;
1678 DECL_RESULT (fndecl) = result_decl;
1680 /* Don't call layout_decl for a RESULT_DECL.
1681 layout_decl (result_decl, 0); */
1683 /* Set up all attributes for the function. */
1684 DECL_CONTEXT (fndecl) = current_function_decl;
1685 DECL_EXTERNAL (fndecl) = 0;
1687 /* This specifies if a function is globally visible, i.e. it is
1688 the opposite of declaring static in C. */
1689 if (DECL_CONTEXT (fndecl) == NULL_TREE
1690 && !sym->attr.entry_master && !sym->attr.is_main_program)
1691 TREE_PUBLIC (fndecl) = 1;
1693 /* TREE_STATIC means the function body is defined here. */
1694 TREE_STATIC (fndecl) = 1;
1696 /* Set attributes for PURE functions. A call to a PURE function in the
1697 Fortran 95 sense is both pure and without side effects in the C
1699 if (attr.pure || attr.elemental)
1701 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1702 including an alternate return. In that case it can also be
1703 marked as PURE. See also in gfc_get_extern_function_decl(). */
1704 if (attr.function && !gfc_return_by_reference (sym))
1705 DECL_PURE_P (fndecl) = 1;
1706 TREE_SIDE_EFFECTS (fndecl) = 0;
1710 /* Layout the function declaration and put it in the binding level
1711 of the current function. */
1714 pushdecl_top_level (fndecl);
1718 sym->backend_decl = fndecl;
1722 /* Create the DECL_ARGUMENTS for a procedure. */
1725 create_function_arglist (gfc_symbol * sym)
1728 gfc_formal_arglist *f;
1729 tree typelist, hidden_typelist;
1730 tree arglist, hidden_arglist;
1734 fndecl = sym->backend_decl;
1736 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1737 the new FUNCTION_DECL node. */
1738 arglist = NULL_TREE;
1739 hidden_arglist = NULL_TREE;
1740 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1742 if (sym->attr.entry_master)
1744 type = TREE_VALUE (typelist);
1745 parm = build_decl (input_location,
1746 PARM_DECL, get_identifier ("__entry"), type);
1748 DECL_CONTEXT (parm) = fndecl;
1749 DECL_ARG_TYPE (parm) = type;
1750 TREE_READONLY (parm) = 1;
1751 gfc_finish_decl (parm);
1752 DECL_ARTIFICIAL (parm) = 1;
1754 arglist = chainon (arglist, parm);
1755 typelist = TREE_CHAIN (typelist);
1758 if (gfc_return_by_reference (sym))
1760 tree type = TREE_VALUE (typelist), length = NULL;
1762 if (sym->ts.type == BT_CHARACTER)
1764 /* Length of character result. */
1765 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1766 gcc_assert (len_type == gfc_charlen_type_node);
1768 length = build_decl (input_location,
1770 get_identifier (".__result"),
1772 if (!sym->ts.u.cl->length)
1774 sym->ts.u.cl->backend_decl = length;
1775 TREE_USED (length) = 1;
1777 gcc_assert (TREE_CODE (length) == PARM_DECL);
1778 DECL_CONTEXT (length) = fndecl;
1779 DECL_ARG_TYPE (length) = len_type;
1780 TREE_READONLY (length) = 1;
1781 DECL_ARTIFICIAL (length) = 1;
1782 gfc_finish_decl (length);
1783 if (sym->ts.u.cl->backend_decl == NULL
1784 || sym->ts.u.cl->backend_decl == length)
1789 if (sym->ts.u.cl->backend_decl == NULL)
1791 tree len = build_decl (input_location,
1793 get_identifier ("..__result"),
1794 gfc_charlen_type_node);
1795 DECL_ARTIFICIAL (len) = 1;
1796 TREE_USED (len) = 1;
1797 sym->ts.u.cl->backend_decl = len;
1800 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1801 arg = sym->result ? sym->result : sym;
1802 backend_decl = arg->backend_decl;
1803 /* Temporary clear it, so that gfc_sym_type creates complete
1805 arg->backend_decl = NULL;
1806 type = gfc_sym_type (arg);
1807 arg->backend_decl = backend_decl;
1808 type = build_reference_type (type);
1812 parm = build_decl (input_location,
1813 PARM_DECL, get_identifier ("__result"), type);
1815 DECL_CONTEXT (parm) = fndecl;
1816 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1817 TREE_READONLY (parm) = 1;
1818 DECL_ARTIFICIAL (parm) = 1;
1819 gfc_finish_decl (parm);
1821 arglist = chainon (arglist, parm);
1822 typelist = TREE_CHAIN (typelist);
1824 if (sym->ts.type == BT_CHARACTER)
1826 gfc_allocate_lang_decl (parm);
1827 arglist = chainon (arglist, length);
1828 typelist = TREE_CHAIN (typelist);
1832 hidden_typelist = typelist;
1833 for (f = sym->formal; f; f = f->next)
1834 if (f->sym != NULL) /* Ignore alternate returns. */
1835 hidden_typelist = TREE_CHAIN (hidden_typelist);
1837 for (f = sym->formal; f; f = f->next)
1839 char name[GFC_MAX_SYMBOL_LEN + 2];
1841 /* Ignore alternate returns. */
1845 type = TREE_VALUE (typelist);
1847 if (f->sym->ts.type == BT_CHARACTER
1848 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1850 tree len_type = TREE_VALUE (hidden_typelist);
1851 tree length = NULL_TREE;
1852 gcc_assert (len_type == gfc_charlen_type_node);
1854 strcpy (&name[1], f->sym->name);
1856 length = build_decl (input_location,
1857 PARM_DECL, get_identifier (name), len_type);
1859 hidden_arglist = chainon (hidden_arglist, length);
1860 DECL_CONTEXT (length) = fndecl;
1861 DECL_ARTIFICIAL (length) = 1;
1862 DECL_ARG_TYPE (length) = len_type;
1863 TREE_READONLY (length) = 1;
1864 gfc_finish_decl (length);
1866 /* Remember the passed value. */
1867 if (f->sym->ts.u.cl->passed_length != NULL)
1869 /* This can happen if the same type is used for multiple
1870 arguments. We need to copy cl as otherwise
1871 cl->passed_length gets overwritten. */
1872 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1874 f->sym->ts.u.cl->passed_length = length;
1876 /* Use the passed value for assumed length variables. */
1877 if (!f->sym->ts.u.cl->length)
1879 TREE_USED (length) = 1;
1880 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1881 f->sym->ts.u.cl->backend_decl = length;
1884 hidden_typelist = TREE_CHAIN (hidden_typelist);
1886 if (f->sym->ts.u.cl->backend_decl == NULL
1887 || f->sym->ts.u.cl->backend_decl == length)
1889 if (f->sym->ts.u.cl->backend_decl == NULL)
1890 gfc_create_string_length (f->sym);
1892 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1893 if (f->sym->attr.flavor == FL_PROCEDURE)
1894 type = build_pointer_type (gfc_get_function_type (f->sym));
1896 type = gfc_sym_type (f->sym);
1900 /* For non-constant length array arguments, make sure they use
1901 a different type node from TYPE_ARG_TYPES type. */
1902 if (f->sym->attr.dimension
1903 && type == TREE_VALUE (typelist)
1904 && TREE_CODE (type) == POINTER_TYPE
1905 && GFC_ARRAY_TYPE_P (type)
1906 && f->sym->as->type != AS_ASSUMED_SIZE
1907 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1909 if (f->sym->attr.flavor == FL_PROCEDURE)
1910 type = build_pointer_type (gfc_get_function_type (f->sym));
1912 type = gfc_sym_type (f->sym);
1915 if (f->sym->attr.proc_pointer)
1916 type = build_pointer_type (type);
1918 /* Build the argument declaration. */
1919 parm = build_decl (input_location,
1920 PARM_DECL, gfc_sym_identifier (f->sym), type);
1922 /* Fill in arg stuff. */
1923 DECL_CONTEXT (parm) = fndecl;
1924 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1925 /* All implementation args are read-only. */
1926 TREE_READONLY (parm) = 1;
1927 if (POINTER_TYPE_P (type)
1928 && (!f->sym->attr.proc_pointer
1929 && f->sym->attr.flavor != FL_PROCEDURE))
1930 DECL_BY_REFERENCE (parm) = 1;
1932 gfc_finish_decl (parm);
1934 f->sym->backend_decl = parm;
1936 arglist = chainon (arglist, parm);
1937 typelist = TREE_CHAIN (typelist);
1940 /* Add the hidden string length parameters, unless the procedure
1942 if (!sym->attr.is_bind_c)
1943 arglist = chainon (arglist, hidden_arglist);
1945 gcc_assert (hidden_typelist == NULL_TREE
1946 || TREE_VALUE (hidden_typelist) == void_type_node);
1947 DECL_ARGUMENTS (fndecl) = arglist;
1950 /* Do the setup necessary before generating the body of a function. */
1953 trans_function_start (gfc_symbol * sym)
1957 fndecl = sym->backend_decl;
1959 /* Let GCC know the current scope is this function. */
1960 current_function_decl = fndecl;
1962 /* Let the world know what we're about to do. */
1963 announce_function (fndecl);
1965 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1967 /* Create RTL for function declaration. */
1968 rest_of_decl_compilation (fndecl, 1, 0);
1971 /* Create RTL for function definition. */
1972 make_decl_rtl (fndecl);
1974 init_function_start (fndecl);
1976 /* Even though we're inside a function body, we still don't want to
1977 call expand_expr to calculate the size of a variable-sized array.
1978 We haven't necessarily assigned RTL to all variables yet, so it's
1979 not safe to try to expand expressions involving them. */
1980 cfun->dont_save_pending_sizes_p = 1;
1982 /* function.c requires a push at the start of the function. */
1986 /* Create thunks for alternate entry points. */
1989 build_entry_thunks (gfc_namespace * ns, bool global)
1991 gfc_formal_arglist *formal;
1992 gfc_formal_arglist *thunk_formal;
1994 gfc_symbol *thunk_sym;
2000 /* This should always be a toplevel function. */
2001 gcc_assert (current_function_decl == NULL_TREE);
2003 gfc_get_backend_locus (&old_loc);
2004 for (el = ns->entries; el; el = el->next)
2006 VEC(tree,gc) *args = NULL;
2007 VEC(tree,gc) *string_args = NULL;
2009 thunk_sym = el->sym;
2011 build_function_decl (thunk_sym, global);
2012 create_function_arglist (thunk_sym);
2014 trans_function_start (thunk_sym);
2016 thunk_fndecl = thunk_sym->backend_decl;
2018 gfc_init_block (&body);
2020 /* Pass extra parameter identifying this entry point. */
2021 tmp = build_int_cst (gfc_array_index_type, el->id);
2022 VEC_safe_push (tree, gc, args, tmp);
2024 if (thunk_sym->attr.function)
2026 if (gfc_return_by_reference (ns->proc_name))
2028 tree ref = DECL_ARGUMENTS (current_function_decl);
2029 VEC_safe_push (tree, gc, args, ref);
2030 if (ns->proc_name->ts.type == BT_CHARACTER)
2031 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2035 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2037 /* Ignore alternate returns. */
2038 if (formal->sym == NULL)
2041 /* We don't have a clever way of identifying arguments, so resort to
2042 a brute-force search. */
2043 for (thunk_formal = thunk_sym->formal;
2045 thunk_formal = thunk_formal->next)
2047 if (thunk_formal->sym == formal->sym)
2053 /* Pass the argument. */
2054 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2055 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2056 if (formal->sym->ts.type == BT_CHARACTER)
2058 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2059 VEC_safe_push (tree, gc, string_args, tmp);
2064 /* Pass NULL for a missing argument. */
2065 VEC_safe_push (tree, gc, args, null_pointer_node);
2066 if (formal->sym->ts.type == BT_CHARACTER)
2068 tmp = build_int_cst (gfc_charlen_type_node, 0);
2069 VEC_safe_push (tree, gc, string_args, tmp);
2074 /* Call the master function. */
2075 VEC_safe_splice (tree, gc, args, string_args);
2076 tmp = ns->proc_name->backend_decl;
2077 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2078 if (ns->proc_name->attr.mixed_entry_master)
2080 tree union_decl, field;
2081 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2083 union_decl = build_decl (input_location,
2084 VAR_DECL, get_identifier ("__result"),
2085 TREE_TYPE (master_type));
2086 DECL_ARTIFICIAL (union_decl) = 1;
2087 DECL_EXTERNAL (union_decl) = 0;
2088 TREE_PUBLIC (union_decl) = 0;
2089 TREE_USED (union_decl) = 1;
2090 layout_decl (union_decl, 0);
2091 pushdecl (union_decl);
2093 DECL_CONTEXT (union_decl) = current_function_decl;
2094 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2096 gfc_add_expr_to_block (&body, tmp);
2098 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2099 field; field = DECL_CHAIN (field))
2100 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2101 thunk_sym->result->name) == 0)
2103 gcc_assert (field != NULL_TREE);
2104 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2105 union_decl, field, NULL_TREE);
2106 tmp = fold_build2 (MODIFY_EXPR,
2107 TREE_TYPE (DECL_RESULT (current_function_decl)),
2108 DECL_RESULT (current_function_decl), tmp);
2109 tmp = build1_v (RETURN_EXPR, tmp);
2111 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2114 tmp = fold_build2 (MODIFY_EXPR,
2115 TREE_TYPE (DECL_RESULT (current_function_decl)),
2116 DECL_RESULT (current_function_decl), tmp);
2117 tmp = build1_v (RETURN_EXPR, tmp);
2119 gfc_add_expr_to_block (&body, tmp);
2121 /* Finish off this function and send it for code generation. */
2122 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2125 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2126 DECL_SAVED_TREE (thunk_fndecl)
2127 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2128 DECL_INITIAL (thunk_fndecl));
2130 /* Output the GENERIC tree. */
2131 dump_function (TDI_original, thunk_fndecl);
2133 /* Store the end of the function, so that we get good line number
2134 info for the epilogue. */
2135 cfun->function_end_locus = input_location;
2137 /* We're leaving the context of this function, so zap cfun.
2138 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2139 tree_rest_of_compilation. */
2142 current_function_decl = NULL_TREE;
2144 cgraph_finalize_function (thunk_fndecl, true);
2146 /* We share the symbols in the formal argument list with other entry
2147 points and the master function. Clear them so that they are
2148 recreated for each function. */
2149 for (formal = thunk_sym->formal; formal; formal = formal->next)
2150 if (formal->sym != NULL) /* Ignore alternate returns. */
2152 formal->sym->backend_decl = NULL_TREE;
2153 if (formal->sym->ts.type == BT_CHARACTER)
2154 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2157 if (thunk_sym->attr.function)
2159 if (thunk_sym->ts.type == BT_CHARACTER)
2160 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2161 if (thunk_sym->result->ts.type == BT_CHARACTER)
2162 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2166 gfc_set_backend_locus (&old_loc);
2170 /* Create a decl for a function, and create any thunks for alternate entry
2171 points. If global is true, generate the function in the global binding
2172 level, otherwise in the current binding level (which can be global). */
2175 gfc_create_function_decl (gfc_namespace * ns, bool global)
2177 /* Create a declaration for the master function. */
2178 build_function_decl (ns->proc_name, global);
2180 /* Compile the entry thunks. */
2182 build_entry_thunks (ns, global);
2184 /* Now create the read argument list. */
2185 create_function_arglist (ns->proc_name);
2188 /* Return the decl used to hold the function return value. If
2189 parent_flag is set, the context is the parent_scope. */
2192 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2196 tree this_fake_result_decl;
2197 tree this_function_decl;
2199 char name[GFC_MAX_SYMBOL_LEN + 10];
2203 this_fake_result_decl = parent_fake_result_decl;
2204 this_function_decl = DECL_CONTEXT (current_function_decl);
2208 this_fake_result_decl = current_fake_result_decl;
2209 this_function_decl = current_function_decl;
2213 && sym->ns->proc_name->backend_decl == this_function_decl
2214 && sym->ns->proc_name->attr.entry_master
2215 && sym != sym->ns->proc_name)
2218 if (this_fake_result_decl != NULL)
2219 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2220 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2223 return TREE_VALUE (t);
2224 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2227 this_fake_result_decl = parent_fake_result_decl;
2229 this_fake_result_decl = current_fake_result_decl;
2231 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2235 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2236 field; field = DECL_CHAIN (field))
2237 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2241 gcc_assert (field != NULL_TREE);
2242 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2243 decl, field, NULL_TREE);
2246 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2248 gfc_add_decl_to_parent_function (var);
2250 gfc_add_decl_to_function (var);
2252 SET_DECL_VALUE_EXPR (var, decl);
2253 DECL_HAS_VALUE_EXPR_P (var) = 1;
2254 GFC_DECL_RESULT (var) = 1;
2256 TREE_CHAIN (this_fake_result_decl)
2257 = tree_cons (get_identifier (sym->name), var,
2258 TREE_CHAIN (this_fake_result_decl));
2262 if (this_fake_result_decl != NULL_TREE)
2263 return TREE_VALUE (this_fake_result_decl);
2265 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2270 if (sym->ts.type == BT_CHARACTER)
2272 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2273 length = gfc_create_string_length (sym);
2275 length = sym->ts.u.cl->backend_decl;
2276 if (TREE_CODE (length) == VAR_DECL
2277 && DECL_CONTEXT (length) == NULL_TREE)
2278 gfc_add_decl_to_function (length);
2281 if (gfc_return_by_reference (sym))
2283 decl = DECL_ARGUMENTS (this_function_decl);
2285 if (sym->ns->proc_name->backend_decl == this_function_decl
2286 && sym->ns->proc_name->attr.entry_master)
2287 decl = DECL_CHAIN (decl);
2289 TREE_USED (decl) = 1;
2291 decl = gfc_build_dummy_array_decl (sym, decl);
2295 sprintf (name, "__result_%.20s",
2296 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2298 if (!sym->attr.mixed_entry_master && sym->attr.function)
2299 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2300 VAR_DECL, get_identifier (name),
2301 gfc_sym_type (sym));
2303 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2304 VAR_DECL, get_identifier (name),
2305 TREE_TYPE (TREE_TYPE (this_function_decl)));
2306 DECL_ARTIFICIAL (decl) = 1;
2307 DECL_EXTERNAL (decl) = 0;
2308 TREE_PUBLIC (decl) = 0;
2309 TREE_USED (decl) = 1;
2310 GFC_DECL_RESULT (decl) = 1;
2311 TREE_ADDRESSABLE (decl) = 1;
2313 layout_decl (decl, 0);
2316 gfc_add_decl_to_parent_function (decl);
2318 gfc_add_decl_to_function (decl);
2322 parent_fake_result_decl = build_tree_list (NULL, decl);
2324 current_fake_result_decl = build_tree_list (NULL, decl);
2330 /* Builds a function decl. The remaining parameters are the types of the
2331 function arguments. Negative nargs indicates a varargs function. */
2334 build_library_function_decl_1 (tree name, const char *spec,
2335 tree rettype, int nargs, va_list p)
2343 /* Library functions must be declared with global scope. */
2344 gcc_assert (current_function_decl == NULL_TREE);
2346 /* Create a list of the argument types. */
2347 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2349 argtype = va_arg (p, tree);
2350 arglist = gfc_chainon_list (arglist, argtype);
2355 /* Terminate the list. */
2356 arglist = gfc_chainon_list (arglist, void_type_node);
2359 /* Build the function type and decl. */
2360 fntype = build_function_type (rettype, arglist);
2363 tree attr_args = build_tree_list (NULL_TREE,
2364 build_string (strlen (spec), spec));
2365 tree attrs = tree_cons (get_identifier ("fn spec"),
2366 attr_args, TYPE_ATTRIBUTES (fntype));
2367 fntype = build_type_attribute_variant (fntype, attrs);
2369 fndecl = build_decl (input_location,
2370 FUNCTION_DECL, name, fntype);
2372 /* Mark this decl as external. */
2373 DECL_EXTERNAL (fndecl) = 1;
2374 TREE_PUBLIC (fndecl) = 1;
2378 rest_of_decl_compilation (fndecl, 1, 0);
2383 /* Builds a function decl. The remaining parameters are the types of the
2384 function arguments. Negative nargs indicates a varargs function. */
2387 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2391 va_start (args, nargs);
2392 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2397 /* Builds a function decl. The remaining parameters are the types of the
2398 function arguments. Negative nargs indicates a varargs function.
2399 The SPEC parameter specifies the function argument and return type
2400 specification according to the fnspec function type attribute. */
2403 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2404 tree rettype, int nargs, ...)
2408 va_start (args, nargs);
2409 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2415 gfc_build_intrinsic_function_decls (void)
2417 tree gfc_int4_type_node = gfc_get_int_type (4);
2418 tree gfc_int8_type_node = gfc_get_int_type (8);
2419 tree gfc_int16_type_node = gfc_get_int_type (16);
2420 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2421 tree pchar1_type_node = gfc_get_pchar_type (1);
2422 tree pchar4_type_node = gfc_get_pchar_type (4);
2424 /* String functions. */
2425 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2426 get_identifier (PREFIX("compare_string")), "..R.R",
2427 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2428 gfc_charlen_type_node, pchar1_type_node);
2429 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2431 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2432 get_identifier (PREFIX("concat_string")), "..W.R.R",
2433 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2434 gfc_charlen_type_node, pchar1_type_node,
2435 gfc_charlen_type_node, pchar1_type_node);
2437 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2438 get_identifier (PREFIX("string_len_trim")), "..R",
2439 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2440 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2442 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2443 get_identifier (PREFIX("string_index")), "..R.R.",
2444 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2445 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2446 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2448 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2449 get_identifier (PREFIX("string_scan")), "..R.R.",
2450 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2451 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2452 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2454 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2455 get_identifier (PREFIX("string_verify")), "..R.R.",
2456 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2457 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2458 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2460 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2461 get_identifier (PREFIX("string_trim")), ".Ww.R",
2462 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2463 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2466 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2467 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2468 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2469 build_pointer_type (pchar1_type_node), integer_type_node,
2472 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2473 get_identifier (PREFIX("adjustl")), ".W.R",
2474 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2477 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2478 get_identifier (PREFIX("adjustr")), ".W.R",
2479 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2482 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2483 get_identifier (PREFIX("select_string")), ".R.R.",
2484 integer_type_node, 4, pvoid_type_node, integer_type_node,
2485 pchar1_type_node, gfc_charlen_type_node);
2486 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2488 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2489 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2490 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2491 gfc_charlen_type_node, pchar4_type_node);
2492 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2494 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2495 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2496 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2497 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2500 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2501 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2502 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2503 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2505 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2506 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2507 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2508 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2509 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2511 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2512 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2513 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2514 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2515 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2517 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2518 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2519 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2520 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2521 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2523 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2524 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2525 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2526 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2529 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2530 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2531 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2532 build_pointer_type (pchar4_type_node), integer_type_node,
2535 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2536 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2537 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2540 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2541 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2542 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2545 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2546 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2547 integer_type_node, 4, pvoid_type_node, integer_type_node,
2548 pvoid_type_node, gfc_charlen_type_node);
2549 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2552 /* Conversion between character kinds. */
2554 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2555 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2556 void_type_node, 3, build_pointer_type (pchar4_type_node),
2557 gfc_charlen_type_node, pchar1_type_node);
2559 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2560 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2561 void_type_node, 3, build_pointer_type (pchar1_type_node),
2562 gfc_charlen_type_node, pchar4_type_node);
2564 /* Misc. functions. */
2566 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2567 get_identifier (PREFIX("ttynam")), ".W",
2568 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2571 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2572 get_identifier (PREFIX("fdate")), ".W",
2573 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2575 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2576 get_identifier (PREFIX("ctime")), ".W",
2577 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2578 gfc_int8_type_node);
2580 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2581 get_identifier (PREFIX("selected_char_kind")), "..R",
2582 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2583 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2585 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2586 get_identifier (PREFIX("selected_int_kind")), ".R",
2587 gfc_int4_type_node, 1, pvoid_type_node);
2588 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2590 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2591 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2592 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2594 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2596 /* Power functions. */
2598 tree ctype, rtype, itype, jtype;
2599 int rkind, ikind, jkind;
2602 static int ikinds[NIKINDS] = {4, 8, 16};
2603 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2604 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2606 for (ikind=0; ikind < NIKINDS; ikind++)
2608 itype = gfc_get_int_type (ikinds[ikind]);
2610 for (jkind=0; jkind < NIKINDS; jkind++)
2612 jtype = gfc_get_int_type (ikinds[jkind]);
2615 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2617 gfor_fndecl_math_powi[jkind][ikind].integer =
2618 gfc_build_library_function_decl (get_identifier (name),
2619 jtype, 2, jtype, itype);
2620 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2624 for (rkind = 0; rkind < NRKINDS; rkind ++)
2626 rtype = gfc_get_real_type (rkinds[rkind]);
2629 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2631 gfor_fndecl_math_powi[rkind][ikind].real =
2632 gfc_build_library_function_decl (get_identifier (name),
2633 rtype, 2, rtype, itype);
2634 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2637 ctype = gfc_get_complex_type (rkinds[rkind]);
2640 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2642 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2643 gfc_build_library_function_decl (get_identifier (name),
2644 ctype, 2,ctype, itype);
2645 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2653 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2654 get_identifier (PREFIX("ishftc4")),
2655 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2656 gfc_int4_type_node);
2658 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2659 get_identifier (PREFIX("ishftc8")),
2660 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2661 gfc_int4_type_node);
2663 if (gfc_int16_type_node)
2664 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2665 get_identifier (PREFIX("ishftc16")),
2666 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2667 gfc_int4_type_node);
2669 /* BLAS functions. */
2671 tree pint = build_pointer_type (integer_type_node);
2672 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2673 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2674 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2675 tree pz = build_pointer_type
2676 (gfc_get_complex_type (gfc_default_double_kind));
2678 gfor_fndecl_sgemm = gfc_build_library_function_decl
2680 (gfc_option.flag_underscoring ? "sgemm_"
2682 void_type_node, 15, pchar_type_node,
2683 pchar_type_node, pint, pint, pint, ps, ps, pint,
2684 ps, pint, ps, ps, pint, integer_type_node,
2686 gfor_fndecl_dgemm = gfc_build_library_function_decl
2688 (gfc_option.flag_underscoring ? "dgemm_"
2690 void_type_node, 15, pchar_type_node,
2691 pchar_type_node, pint, pint, pint, pd, pd, pint,
2692 pd, pint, pd, pd, pint, integer_type_node,
2694 gfor_fndecl_cgemm = gfc_build_library_function_decl
2696 (gfc_option.flag_underscoring ? "cgemm_"
2698 void_type_node, 15, pchar_type_node,
2699 pchar_type_node, pint, pint, pint, pc, pc, pint,
2700 pc, pint, pc, pc, pint, integer_type_node,
2702 gfor_fndecl_zgemm = gfc_build_library_function_decl
2704 (gfc_option.flag_underscoring ? "zgemm_"
2706 void_type_node, 15, pchar_type_node,
2707 pchar_type_node, pint, pint, pint, pz, pz, pint,
2708 pz, pint, pz, pz, pint, integer_type_node,
2712 /* Other functions. */
2713 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2714 get_identifier (PREFIX("size0")), ".R",
2715 gfc_array_index_type, 1, pvoid_type_node);
2716 DECL_PURE_P (gfor_fndecl_size0) = 1;
2718 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2719 get_identifier (PREFIX("size1")), ".R",
2720 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2721 DECL_PURE_P (gfor_fndecl_size1) = 1;
2723 gfor_fndecl_iargc = gfc_build_library_function_decl (
2724 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2726 if (gfc_type_for_size (128, true))
2728 tree uint128 = gfc_type_for_size (128, true);
2730 gfor_fndecl_clz128 = gfc_build_library_function_decl (
2731 get_identifier (PREFIX ("clz128")), integer_type_node, 1, uint128);
2732 TREE_READONLY (gfor_fndecl_clz128) = 1;
2734 gfor_fndecl_ctz128 = gfc_build_library_function_decl (
2735 get_identifier (PREFIX ("ctz128")), integer_type_node, 1, uint128);
2736 TREE_READONLY (gfor_fndecl_ctz128) = 1;
2741 /* Make prototypes for runtime library functions. */
2744 gfc_build_builtin_function_decls (void)
2746 tree gfc_int4_type_node = gfc_get_int_type (4);
2748 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2749 get_identifier (PREFIX("stop_numeric")),
2750 void_type_node, 1, gfc_int4_type_node);
2751 /* STOP doesn't return. */
2752 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2754 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2755 get_identifier (PREFIX("stop_string")), ".R.",
2756 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2757 /* STOP doesn't return. */
2758 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2760 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2761 get_identifier (PREFIX("error_stop_numeric")),
2762 void_type_node, 1, gfc_int4_type_node);
2763 /* ERROR STOP doesn't return. */
2764 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2766 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2767 get_identifier (PREFIX("error_stop_string")), ".R.",
2768 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2769 /* ERROR STOP doesn't return. */
2770 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2772 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2773 get_identifier (PREFIX("pause_numeric")),
2774 void_type_node, 1, gfc_int4_type_node);
2776 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2777 get_identifier (PREFIX("pause_string")), ".R.",
2778 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2780 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2781 get_identifier (PREFIX("runtime_error")), ".R",
2782 void_type_node, -1, pchar_type_node);
2783 /* The runtime_error function does not return. */
2784 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2786 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2787 get_identifier (PREFIX("runtime_error_at")), ".RR",
2788 void_type_node, -2, pchar_type_node, pchar_type_node);
2789 /* The runtime_error_at function does not return. */
2790 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2792 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2793 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2794 void_type_node, -2, pchar_type_node, pchar_type_node);
2796 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2797 get_identifier (PREFIX("generate_error")), ".R.R",
2798 void_type_node, 3, pvoid_type_node, integer_type_node,
2801 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2802 get_identifier (PREFIX("os_error")), ".R",
2803 void_type_node, 1, pchar_type_node);
2804 /* The runtime_error function does not return. */
2805 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2807 gfor_fndecl_set_args = gfc_build_library_function_decl (
2808 get_identifier (PREFIX("set_args")),
2809 void_type_node, 2, integer_type_node,
2810 build_pointer_type (pchar_type_node));
2812 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2813 get_identifier (PREFIX("set_fpe")),
2814 void_type_node, 1, integer_type_node);
2816 /* Keep the array dimension in sync with the call, later in this file. */
2817 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2818 get_identifier (PREFIX("set_options")), "..R",
2819 void_type_node, 2, integer_type_node,
2820 build_pointer_type (integer_type_node));
2822 gfor_fndecl_set_convert = gfc_build_library_function_decl (
2823 get_identifier (PREFIX("set_convert")),
2824 void_type_node, 1, integer_type_node);
2826 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2827 get_identifier (PREFIX("set_record_marker")),
2828 void_type_node, 1, integer_type_node);
2830 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
2831 get_identifier (PREFIX("set_max_subrecord_length")),
2832 void_type_node, 1, integer_type_node);
2834 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2835 get_identifier (PREFIX("internal_pack")), ".r",
2836 pvoid_type_node, 1, pvoid_type_node);
2838 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2839 get_identifier (PREFIX("internal_unpack")), ".wR",
2840 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2842 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
2843 get_identifier (PREFIX("associated")), ".RR",
2844 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
2845 DECL_PURE_P (gfor_fndecl_associated) = 1;
2847 gfc_build_intrinsic_function_decls ();
2848 gfc_build_intrinsic_lib_fndecls ();
2849 gfc_build_io_library_fndecls ();
2853 /* Evaluate the length of dummy character variables. */
2856 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
2857 gfc_wrapped_block *block)
2861 gfc_finish_decl (cl->backend_decl);
2863 gfc_start_block (&init);
2865 /* Evaluate the string length expression. */
2866 gfc_conv_string_length (cl, NULL, &init);
2868 gfc_trans_vla_type_sizes (sym, &init);
2870 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2874 /* Allocate and cleanup an automatic character variable. */
2877 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
2883 gcc_assert (sym->backend_decl);
2884 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2886 gfc_start_block (&init);
2888 /* Evaluate the string length expression. */
2889 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
2891 gfc_trans_vla_type_sizes (sym, &init);
2893 decl = sym->backend_decl;
2895 /* Emit a DECL_EXPR for this variable, which will cause the
2896 gimplifier to allocate storage, and all that good stuff. */
2897 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2898 gfc_add_expr_to_block (&init, tmp);
2900 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2903 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2906 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
2910 gcc_assert (sym->backend_decl);
2911 gfc_start_block (&init);
2913 /* Set the initial value to length. See the comments in
2914 function gfc_add_assign_aux_vars in this file. */
2915 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
2916 build_int_cst (NULL_TREE, -2));
2918 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2922 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2924 tree t = *tp, var, val;
2926 if (t == NULL || t == error_mark_node)
2928 if (TREE_CONSTANT (t) || DECL_P (t))
2931 if (TREE_CODE (t) == SAVE_EXPR)
2933 if (SAVE_EXPR_RESOLVED_P (t))
2935 *tp = TREE_OPERAND (t, 0);
2938 val = TREE_OPERAND (t, 0);
2943 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2944 gfc_add_decl_to_function (var);
2945 gfc_add_modify (body, var, val);
2946 if (TREE_CODE (t) == SAVE_EXPR)
2947 TREE_OPERAND (t, 0) = var;
2952 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2956 if (type == NULL || type == error_mark_node)
2959 type = TYPE_MAIN_VARIANT (type);
2961 if (TREE_CODE (type) == INTEGER_TYPE)
2963 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2964 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2966 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2968 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2969 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2972 else if (TREE_CODE (type) == ARRAY_TYPE)
2974 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2975 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2976 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2977 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2979 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2981 TYPE_SIZE (t) = TYPE_SIZE (type);
2982 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2987 /* Make sure all type sizes and array domains are either constant,
2988 or variable or parameter decls. This is a simplified variant
2989 of gimplify_type_sizes, but we can't use it here, as none of the
2990 variables in the expressions have been gimplified yet.
2991 As type sizes and domains for various variable length arrays
2992 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2993 time, without this routine gimplify_type_sizes in the middle-end
2994 could result in the type sizes being gimplified earlier than where
2995 those variables are initialized. */
2998 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3000 tree type = TREE_TYPE (sym->backend_decl);
3002 if (TREE_CODE (type) == FUNCTION_TYPE
3003 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3005 if (! current_fake_result_decl)
3008 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3011 while (POINTER_TYPE_P (type))
3012 type = TREE_TYPE (type);
3014 if (GFC_DESCRIPTOR_TYPE_P (type))
3016 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3018 while (POINTER_TYPE_P (etype))
3019 etype = TREE_TYPE (etype);
3021 gfc_trans_vla_type_sizes_1 (etype, body);
3024 gfc_trans_vla_type_sizes_1 (type, body);
3028 /* Initialize a derived type by building an lvalue from the symbol
3029 and using trans_assignment to do the work. Set dealloc to false
3030 if no deallocation prior the assignment is needed. */
3032 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3040 gcc_assert (!sym->attr.allocatable);
3041 gfc_set_sym_referenced (sym);
3042 e = gfc_lval_expr_from_sym (sym);
3043 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3044 if (sym->attr.dummy && (sym->attr.optional
3045 || sym->ns->proc_name->attr.entry_master))
3047 present = gfc_conv_expr_present (sym);
3048 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3049 tmp, build_empty_stmt (input_location));
3051 gfc_add_expr_to_block (block, tmp);
3056 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3057 them their default initializer, if they do not have allocatable
3058 components, they have their allocatable components deallocated. */
3061 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3064 gfc_formal_arglist *f;
3068 gfc_init_block (&init);
3069 for (f = proc_sym->formal; f; f = f->next)
3070 if (f->sym && f->sym->attr.intent == INTENT_OUT
3071 && !f->sym->attr.pointer
3072 && f->sym->ts.type == BT_DERIVED)
3074 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3076 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3077 f->sym->backend_decl,
3078 f->sym->as ? f->sym->as->rank : 0);
3080 if (f->sym->attr.optional
3081 || f->sym->ns->proc_name->attr.entry_master)
3083 present = gfc_conv_expr_present (f->sym);
3084 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3085 tmp, build_empty_stmt (input_location));
3088 gfc_add_expr_to_block (&init, tmp);
3090 else if (f->sym->value)
3091 gfc_init_default_dt (f->sym, &init, true);
3094 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3098 /* Generate function entry and exit code, and add it to the function body.
3100 Allocation and initialization of array variables.
3101 Allocation of character string variables.
3102 Initialization and possibly repacking of dummy arrays.
3103 Initialization of ASSIGN statement auxiliary variable.
3104 Automatic deallocation. */
3107 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3111 gfc_formal_arglist *f;
3112 stmtblock_t tmpblock;
3113 bool seen_trans_deferred_array = false;
3115 /* Deal with implicit return variables. Explicit return variables will
3116 already have been added. */
3117 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3119 if (!current_fake_result_decl)
3121 gfc_entry_list *el = NULL;
3122 if (proc_sym->attr.entry_master)
3124 for (el = proc_sym->ns->entries; el; el = el->next)
3125 if (el->sym != el->sym->result)
3128 /* TODO: move to the appropriate place in resolve.c. */
3129 if (warn_return_type && el == NULL)
3130 gfc_warning ("Return value of function '%s' at %L not set",
3131 proc_sym->name, &proc_sym->declared_at);
3133 else if (proc_sym->as)
3135 tree result = TREE_VALUE (current_fake_result_decl);
3136 gfc_trans_dummy_array_bias (proc_sym, result, block);
3138 /* An automatic character length, pointer array result. */
3139 if (proc_sym->ts.type == BT_CHARACTER
3140 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3141 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3143 else if (proc_sym->ts.type == BT_CHARACTER)
3145 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3146 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3149 gcc_assert (gfc_option.flag_f2c
3150 && proc_sym->ts.type == BT_COMPLEX);
3153 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3154 should be done here so that the offsets and lbounds of arrays
3156 init_intent_out_dt (proc_sym, block);
3158 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3160 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3161 && sym->ts.u.derived->attr.alloc_comp;
3162 if (sym->attr.dimension)
3164 switch (sym->as->type)
3167 if (sym->attr.dummy || sym->attr.result)
3168 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3169 else if (sym->attr.pointer || sym->attr.allocatable)
3171 if (TREE_STATIC (sym->backend_decl))
3172 gfc_trans_static_array_pointer (sym);
3175 seen_trans_deferred_array = true;
3176 gfc_trans_deferred_array (sym, block);
3181 if (sym_has_alloc_comp)
3183 seen_trans_deferred_array = true;
3184 gfc_trans_deferred_array (sym, block);
3186 else if (sym->ts.type == BT_DERIVED
3189 && sym->attr.save == SAVE_NONE)
3191 gfc_start_block (&tmpblock);
3192 gfc_init_default_dt (sym, &tmpblock, false);
3193 gfc_add_init_cleanup (block,
3194 gfc_finish_block (&tmpblock),
3198 gfc_get_backend_locus (&loc);
3199 gfc_set_backend_locus (&sym->declared_at);
3200 gfc_trans_auto_array_allocation (sym->backend_decl,
3202 gfc_set_backend_locus (&loc);
3206 case AS_ASSUMED_SIZE:
3207 /* Must be a dummy parameter. */
3208 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3210 /* We should always pass assumed size arrays the g77 way. */
3211 if (sym->attr.dummy)
3212 gfc_trans_g77_array (sym, block);
3215 case AS_ASSUMED_SHAPE:
3216 /* Must be a dummy parameter. */
3217 gcc_assert (sym->attr.dummy);
3219 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3223 seen_trans_deferred_array = true;
3224 gfc_trans_deferred_array (sym, block);
3230 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3231 gfc_trans_deferred_array (sym, block);
3233 else if (sym->attr.allocatable
3234 || (sym->ts.type == BT_CLASS
3235 && CLASS_DATA (sym)->attr.allocatable))
3237 if (!sym->attr.save)
3239 /* Nullify and automatic deallocation of allocatable
3246 e = gfc_lval_expr_from_sym (sym);
3247 if (sym->ts.type == BT_CLASS)
3248 gfc_add_component_ref (e, "$data");
3250 gfc_init_se (&se, NULL);
3251 se.want_pointer = 1;
3252 gfc_conv_expr (&se, e);
3255 /* Nullify when entering the scope. */
3256 gfc_start_block (&init);
3257 gfc_add_modify (&init, se.expr,
3258 fold_convert (TREE_TYPE (se.expr),
3259 null_pointer_node));
3261 /* Deallocate when leaving the scope. Nullifying is not
3264 if (!sym->attr.result)
3265 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
3267 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3270 else if (sym_has_alloc_comp)
3271 gfc_trans_deferred_array (sym, block);
3272 else if (sym->ts.type == BT_CHARACTER)
3274 gfc_get_backend_locus (&loc);
3275 gfc_set_backend_locus (&sym->declared_at);
3276 if (sym->attr.dummy || sym->attr.result)
3277 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3279 gfc_trans_auto_character_variable (sym, block);
3280 gfc_set_backend_locus (&loc);
3282 else if (sym->attr.assign)
3284 gfc_get_backend_locus (&loc);
3285 gfc_set_backend_locus (&sym->declared_at);
3286 gfc_trans_assign_aux_var (sym, block);
3287 gfc_set_backend_locus (&loc);
3289 else if (sym->ts.type == BT_DERIVED
3292 && sym->attr.save == SAVE_NONE)
3294 gfc_start_block (&tmpblock);
3295 gfc_init_default_dt (sym, &tmpblock, false);
3296 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3303 gfc_init_block (&tmpblock);
3305 for (f = proc_sym->formal; f; f = f->next)
3307 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3309 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3310 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3311 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3315 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3316 && current_fake_result_decl != NULL)
3318 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3319 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3320 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3323 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3326 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3328 /* Hash and equality functions for module_htab. */
3331 module_htab_do_hash (const void *x)
3333 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3337 module_htab_eq (const void *x1, const void *x2)
3339 return strcmp ((((const struct module_htab_entry *)x1)->name),
3340 (const char *)x2) == 0;
3343 /* Hash and equality functions for module_htab's decls. */
3346 module_htab_decls_hash (const void *x)
3348 const_tree t = (const_tree) x;
3349 const_tree n = DECL_NAME (t);
3351 n = TYPE_NAME (TREE_TYPE (t));
3352 return htab_hash_string (IDENTIFIER_POINTER (n));
3356 module_htab_decls_eq (const void *x1, const void *x2)
3358 const_tree t1 = (const_tree) x1;
3359 const_tree n1 = DECL_NAME (t1);
3360 if (n1 == NULL_TREE)
3361 n1 = TYPE_NAME (TREE_TYPE (t1));
3362 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3365 struct module_htab_entry *
3366 gfc_find_module (const char *name)
3371 module_htab = htab_create_ggc (10, module_htab_do_hash,
3372 module_htab_eq, NULL);
3374 slot = htab_find_slot_with_hash (module_htab, name,
3375 htab_hash_string (name), INSERT);
3378 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3380 entry->name = gfc_get_string (name);
3381 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3382 module_htab_decls_eq, NULL);
3383 *slot = (void *) entry;
3385 return (struct module_htab_entry *) *slot;
3389 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3394 if (DECL_NAME (decl))
3395 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3398 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3399 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3401 slot = htab_find_slot_with_hash (entry->decls, name,
3402 htab_hash_string (name), INSERT);
3404 *slot = (void *) decl;
3407 static struct module_htab_entry *cur_module;
3409 /* Output an initialized decl for a module variable. */
3412 gfc_create_module_variable (gfc_symbol * sym)
3416 /* Module functions with alternate entries are dealt with later and
3417 would get caught by the next condition. */
3418 if (sym->attr.entry)
3421 /* Make sure we convert the types of the derived types from iso_c_binding
3423 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3424 && sym->ts.type == BT_DERIVED)
3425 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3427 if (sym->attr.flavor == FL_DERIVED
3428 && sym->backend_decl
3429 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3431 decl = sym->backend_decl;
3432 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3434 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3435 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3437 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3438 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3439 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3440 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3441 == sym->ns->proc_name->backend_decl);
3443 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3444 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3445 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3448 /* Only output variables, procedure pointers and array valued,
3449 or derived type, parameters. */
3450 if (sym->attr.flavor != FL_VARIABLE
3451 && !(sym->attr.flavor == FL_PARAMETER
3452 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3453 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3456 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3458 decl = sym->backend_decl;
3459 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3460 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3461 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3462 gfc_module_add_decl (cur_module, decl);
3465 /* Don't generate variables from other modules. Variables from
3466 COMMONs will already have been generated. */
3467 if (sym->attr.use_assoc || sym->attr.in_common)
3470 /* Equivalenced variables arrive here after creation. */
3471 if (sym->backend_decl
3472 && (sym->equiv_built || sym->attr.in_equivalence))
3475 if (sym->backend_decl && !sym->attr.vtab)
3476 internal_error ("backend decl for module variable %s already exists",
3479 /* We always want module variables to be created. */
3480 sym->attr.referenced = 1;
3481 /* Create the decl. */
3482 decl = gfc_get_symbol_decl (sym);
3484 /* Create the variable. */
3486 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3487 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3488 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3489 rest_of_decl_compilation (decl, 1, 0);
3490 gfc_module_add_decl (cur_module, decl);
3492 /* Also add length of strings. */
3493 if (sym->ts.type == BT_CHARACTER)
3497 length = sym->ts.u.cl->backend_decl;
3498 gcc_assert (length || sym->attr.proc_pointer);
3499 if (length && !INTEGER_CST_P (length))
3502 rest_of_decl_compilation (length, 1, 0);
3507 /* Emit debug information for USE statements. */
3510 gfc_trans_use_stmts (gfc_namespace * ns)
3512 gfc_use_list *use_stmt;
3513 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3515 struct module_htab_entry *entry
3516 = gfc_find_module (use_stmt->module_name);
3517 gfc_use_rename *rent;
3519 if (entry->namespace_decl == NULL)
3521 entry->namespace_decl
3522 = build_decl (input_location,
3524 get_identifier (use_stmt->module_name),
3526 DECL_EXTERNAL (entry->namespace_decl) = 1;
3528 gfc_set_backend_locus (&use_stmt->where);
3529 if (!use_stmt->only_flag)
3530 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3532 ns->proc_name->backend_decl,
3534 for (rent = use_stmt->rename; rent; rent = rent->next)
3536 tree decl, local_name;
3539 if (rent->op != INTRINSIC_NONE)
3542 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3543 htab_hash_string (rent->use_name),
3549 st = gfc_find_symtree (ns->sym_root,
3551 ? rent->local_name : rent->use_name);
3554 /* Sometimes, generic interfaces wind up being over-ruled by a
3555 local symbol (see PR41062). */
3556 if (!st->n.sym->attr.use_assoc)
3559 if (st->n.sym->backend_decl
3560 && DECL_P (st->n.sym->backend_decl)
3561 && st->n.sym->module
3562 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3564 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3565 || (TREE_CODE (st->n.sym->backend_decl)
3567 decl = copy_node (st->n.sym->backend_decl);
3568 DECL_CONTEXT (decl) = entry->namespace_decl;
3569 DECL_EXTERNAL (decl) = 1;
3570 DECL_IGNORED_P (decl) = 0;
3571 DECL_INITIAL (decl) = NULL_TREE;
3575 *slot = error_mark_node;
3576 htab_clear_slot (entry->decls, slot);
3581 decl = (tree) *slot;
3582 if (rent->local_name[0])
3583 local_name = get_identifier (rent->local_name);
3585 local_name = NULL_TREE;
3586 gfc_set_backend_locus (&rent->where);
3587 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3588 ns->proc_name->backend_decl,
3589 !use_stmt->only_flag);
3595 /* Return true if expr is a constant initializer that gfc_conv_initializer
3599 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3609 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3611 else if (expr->expr_type == EXPR_STRUCTURE)
3612 return check_constant_initializer (expr, ts, false, false);
3613 else if (expr->expr_type != EXPR_ARRAY)
3615 for (c = gfc_constructor_first (expr->value.constructor);
3616 c; c = gfc_constructor_next (c))
3620 if (c->expr->expr_type == EXPR_STRUCTURE)
3622 if (!check_constant_initializer (c->expr, ts, false, false))
3625 else if (c->expr->expr_type != EXPR_CONSTANT)
3630 else switch (ts->type)
3633 if (expr->expr_type != EXPR_STRUCTURE)
3635 cm = expr->ts.u.derived->components;
3636 for (c = gfc_constructor_first (expr->value.constructor);
3637 c; c = gfc_constructor_next (c), cm = cm->next)
3639 if (!c->expr || cm->attr.allocatable)
3641 if (!check_constant_initializer (c->expr, &cm->ts,
3648 return expr->expr_type == EXPR_CONSTANT;
3652 /* Emit debug info for parameters and unreferenced variables with
3656 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3660 if (sym->attr.flavor != FL_PARAMETER
3661 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3664 if (sym->backend_decl != NULL
3665 || sym->value == NULL
3666 || sym->attr.use_assoc
3669 || sym->attr.function
3670 || sym->attr.intrinsic
3671 || sym->attr.pointer
3672 || sym->attr.allocatable
3673 || sym->attr.cray_pointee
3674 || sym->attr.threadprivate
3675 || sym->attr.is_bind_c
3676 || sym->attr.subref_array_pointer
3677 || sym->attr.assign)
3680 if (sym->ts.type == BT_CHARACTER)
3682 gfc_conv_const_charlen (sym->ts.u.cl);
3683 if (sym->ts.u.cl->backend_decl == NULL
3684 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3687 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3694 if (sym->as->type != AS_EXPLICIT)
3696 for (n = 0; n < sym->as->rank; n++)
3697 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3698 || sym->as->upper[n] == NULL
3699 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3703 if (!check_constant_initializer (sym->value, &sym->ts,
3704 sym->attr.dimension, false))
3707 /* Create the decl for the variable or constant. */
3708 decl = build_decl (input_location,
3709 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3710 gfc_sym_identifier (sym), gfc_sym_type (sym));
3711 if (sym->attr.flavor == FL_PARAMETER)
3712 TREE_READONLY (decl) = 1;
3713 gfc_set_decl_location (decl, &sym->declared_at);
3714 if (sym->attr.dimension)
3715 GFC_DECL_PACKED_ARRAY (decl) = 1;
3716 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3717 TREE_STATIC (decl) = 1;
3718 TREE_USED (decl) = 1;
3719 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3720 TREE_PUBLIC (decl) = 1;
3722 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3723 sym->attr.dimension, 0);
3724 debug_hooks->global_decl (decl);
3727 /* Generate all the required code for module variables. */
3730 gfc_generate_module_vars (gfc_namespace * ns)
3732 module_namespace = ns;
3733 cur_module = gfc_find_module (ns->proc_name->name);
3735 /* Check if the frontend left the namespace in a reasonable state. */
3736 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3738 /* Generate COMMON blocks. */
3739 gfc_trans_common (ns);
3741 /* Create decls for all the module variables. */
3742 gfc_traverse_ns (ns, gfc_create_module_variable);
3746 gfc_trans_use_stmts (ns);
3747 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3752 gfc_generate_contained_functions (gfc_namespace * parent)
3756 /* We create all the prototypes before generating any code. */
3757 for (ns = parent->contained; ns; ns = ns->sibling)
3759 /* Skip namespaces from used modules. */
3760 if (ns->parent != parent)
3763 gfc_create_function_decl (ns, false);
3766 for (ns = parent->contained; ns; ns = ns->sibling)
3768 /* Skip namespaces from used modules. */
3769 if (ns->parent != parent)
3772 gfc_generate_function_code (ns);
3777 /* Drill down through expressions for the array specification bounds and
3778 character length calling generate_local_decl for all those variables
3779 that have not already been declared. */
3782 generate_local_decl (gfc_symbol *);
3784 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3787 expr_decls (gfc_expr *e, gfc_symbol *sym,
3788 int *f ATTRIBUTE_UNUSED)
3790 if (e->expr_type != EXPR_VARIABLE
3791 || sym == e->symtree->n.sym
3792 || e->symtree->n.sym->mark
3793 || e->symtree->n.sym->ns != sym->ns)
3796 generate_local_decl (e->symtree->n.sym);
3801 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3803 gfc_traverse_expr (e, sym, expr_decls, 0);
3807 /* Check for dependencies in the character length and array spec. */
3810 generate_dependency_declarations (gfc_symbol *sym)
3814 if (sym->ts.type == BT_CHARACTER
3816 && sym->ts.u.cl->length
3817 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3818 generate_expr_decls (sym, sym->ts.u.cl->length);
3820 if (sym->as && sym->as->rank)
3822 for (i = 0; i < sym->as->rank; i++)
3824 generate_expr_decls (sym, sym->as->lower[i]);
3825 generate_expr_decls (sym, sym->as->upper[i]);
3831 /* Generate decls for all local variables. We do this to ensure correct
3832 handling of expressions which only appear in the specification of
3836 generate_local_decl (gfc_symbol * sym)
3838 if (sym->attr.flavor == FL_VARIABLE)
3840 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3841 generate_dependency_declarations (sym);
3843 if (sym->attr.referenced)
3844 gfc_get_symbol_decl (sym);
3846 /* Warnings for unused dummy arguments. */
3847 else if (sym->attr.dummy)
3849 /* INTENT(out) dummy arguments are likely meant to be set. */
3850 if (gfc_option.warn_unused_dummy_argument
3851 && sym->attr.intent == INTENT_OUT)
3853 if (sym->ts.type != BT_DERIVED)
3854 gfc_warning ("Dummy argument '%s' at %L was declared "
3855 "INTENT(OUT) but was not set", sym->name,
3857 else if (!gfc_has_default_initializer (sym->ts.u.derived))
3858 gfc_warning ("Derived-type dummy argument '%s' at %L was "
3859 "declared INTENT(OUT) but was not set and "
3860 "does not have a default initializer",
3861 sym->name, &sym->declared_at);
3863 else if (gfc_option.warn_unused_dummy_argument)
3864 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3868 /* Warn for unused variables, but not if they're inside a common
3869 block or are use-associated. */
3870 else if (warn_unused_variable
3871 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3872 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3875 /* For variable length CHARACTER parameters, the PARM_DECL already
3876 references the length variable, so force gfc_get_symbol_decl
3877 even when not referenced. If optimize > 0, it will be optimized
3878 away anyway. But do this only after emitting -Wunused-parameter
3879 warning if requested. */
3880 if (sym->attr.dummy && !sym->attr.referenced
3881 && sym->ts.type == BT_CHARACTER
3882 && sym->ts.u.cl->backend_decl != NULL
3883 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3885 sym->attr.referenced = 1;
3886 gfc_get_symbol_decl (sym);
3889 /* INTENT(out) dummy arguments and result variables with allocatable
3890 components are reset by default and need to be set referenced to
3891 generate the code for nullification and automatic lengths. */
3892 if (!sym->attr.referenced
3893 && sym->ts.type == BT_DERIVED
3894 && sym->ts.u.derived->attr.alloc_comp
3895 && !sym->attr.pointer
3896 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3898 (sym->attr.result && sym != sym->result)))
3900 sym->attr.referenced = 1;
3901 gfc_get_symbol_decl (sym);
3904 /* Check for dependencies in the array specification and string
3905 length, adding the necessary declarations to the function. We
3906 mark the symbol now, as well as in traverse_ns, to prevent
3907 getting stuck in a circular dependency. */
3910 /* We do not want the middle-end to warn about unused parameters
3911 as this was already done above. */
3912 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3913 TREE_NO_WARNING(sym->backend_decl) = 1;
3915 else if (sym->attr.flavor == FL_PARAMETER)
3917 if (warn_unused_parameter
3918 && !sym->attr.referenced
3919 && !sym->attr.use_assoc)
3920 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3923 else if (sym->attr.flavor == FL_PROCEDURE)
3925 /* TODO: move to the appropriate place in resolve.c. */
3926 if (warn_return_type
3927 && sym->attr.function
3929 && sym != sym->result
3930 && !sym->result->attr.referenced
3931 && !sym->attr.use_assoc
3932 && sym->attr.if_source != IFSRC_IFBODY)
3934 gfc_warning ("Return value '%s' of function '%s' declared at "
3935 "%L not set", sym->result->name, sym->name,
3936 &sym->result->declared_at);
3938 /* Prevents "Unused variable" warning for RESULT variables. */
3939 sym->result->mark = 1;
3943 if (sym->attr.dummy == 1)
3945 /* Modify the tree type for scalar character dummy arguments of bind(c)
3946 procedures if they are passed by value. The tree type for them will
3947 be promoted to INTEGER_TYPE for the middle end, which appears to be
3948 what C would do with characters passed by-value. The value attribute
3949 implies the dummy is a scalar. */
3950 if (sym->attr.value == 1 && sym->backend_decl != NULL
3951 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3952 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3953 gfc_conv_scalar_char_value (sym, NULL, NULL);
3956 /* Make sure we convert the types of the derived types from iso_c_binding
3958 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3959 && sym->ts.type == BT_DERIVED)
3960 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3964 generate_local_vars (gfc_namespace * ns)
3966 gfc_traverse_ns (ns, generate_local_decl);
3970 /* Generate a switch statement to jump to the correct entry point. Also
3971 creates the label decls for the entry points. */
3974 gfc_trans_entry_master_switch (gfc_entry_list * el)
3981 gfc_init_block (&block);
3982 for (; el; el = el->next)
3984 /* Add the case label. */
3985 label = gfc_build_label_decl (NULL_TREE);
3986 val = build_int_cst (gfc_array_index_type, el->id);
3987 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3988 gfc_add_expr_to_block (&block, tmp);
3990 /* And jump to the actual entry point. */
3991 label = gfc_build_label_decl (NULL_TREE);
3992 tmp = build1_v (GOTO_EXPR, label);
3993 gfc_add_expr_to_block (&block, tmp);
3995 /* Save the label decl. */
3998 tmp = gfc_finish_block (&block);
3999 /* The first argument selects the entry point. */
4000 val = DECL_ARGUMENTS (current_function_decl);
4001 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4006 /* Add code to string lengths of actual arguments passed to a function against
4007 the expected lengths of the dummy arguments. */
4010 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4012 gfc_formal_arglist *formal;
4014 for (formal = sym->formal; formal; formal = formal->next)
4015 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4017 enum tree_code comparison;
4022 const char *message;
4028 gcc_assert (cl->passed_length != NULL_TREE);
4029 gcc_assert (cl->backend_decl != NULL_TREE);
4031 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4032 string lengths must match exactly. Otherwise, it is only required
4033 that the actual string length is *at least* the expected one.
4034 Sequence association allows for a mismatch of the string length
4035 if the actual argument is (part of) an array, but only if the
4036 dummy argument is an array. (See "Sequence association" in
4037 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4038 if (fsym->attr.pointer || fsym->attr.allocatable
4039 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4041 comparison = NE_EXPR;
4042 message = _("Actual string length does not match the declared one"
4043 " for dummy argument '%s' (%ld/%ld)");
4045 else if (fsym->as && fsym->as->rank != 0)
4049 comparison = LT_EXPR;
4050 message = _("Actual string length is shorter than the declared one"
4051 " for dummy argument '%s' (%ld/%ld)");
4054 /* Build the condition. For optional arguments, an actual length
4055 of 0 is also acceptable if the associated string is NULL, which
4056 means the argument was not passed. */
4057 cond = fold_build2 (comparison, boolean_type_node,
4058 cl->passed_length, cl->backend_decl);
4059 if (fsym->attr.optional)
4065 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4067 fold_convert (gfc_charlen_type_node,
4068 integer_zero_node));
4069 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4070 fsym->attr.referenced = 1;
4071 not_absent = gfc_conv_expr_present (fsym);
4073 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4074 not_0length, not_absent);
4076 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4077 cond, absent_failed);
4080 /* Build the runtime check. */
4081 argname = gfc_build_cstring_const (fsym->name);
4082 argname = gfc_build_addr_expr (pchar_type_node, argname);
4083 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4085 fold_convert (long_integer_type_node,
4087 fold_convert (long_integer_type_node,
4094 create_main_function (tree fndecl)
4098 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4101 old_context = current_function_decl;
4105 push_function_context ();
4106 saved_parent_function_decls = saved_function_decls;
4107 saved_function_decls = NULL_TREE;
4110 /* main() function must be declared with global scope. */
4111 gcc_assert (current_function_decl == NULL_TREE);
4113 /* Declare the function. */
4114 tmp = build_function_type_list (integer_type_node, integer_type_node,
4115 build_pointer_type (pchar_type_node),
4117 main_identifier_node = get_identifier ("main");
4118 ftn_main = build_decl (input_location, FUNCTION_DECL,
4119 main_identifier_node, tmp);
4120 DECL_EXTERNAL (ftn_main) = 0;
4121 TREE_PUBLIC (ftn_main) = 1;
4122 TREE_STATIC (ftn_main) = 1;
4123 DECL_ATTRIBUTES (ftn_main)
4124 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4126 /* Setup the result declaration (for "return 0"). */
4127 result_decl = build_decl (input_location,
4128 RESULT_DECL, NULL_TREE, integer_type_node);
4129 DECL_ARTIFICIAL (result_decl) = 1;
4130 DECL_IGNORED_P (result_decl) = 1;
4131 DECL_CONTEXT (result_decl) = ftn_main;
4132 DECL_RESULT (ftn_main) = result_decl;
4134 pushdecl (ftn_main);
4136 /* Get the arguments. */
4138 arglist = NULL_TREE;
4139 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4141 tmp = TREE_VALUE (typelist);
4142 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4143 DECL_CONTEXT (argc) = ftn_main;
4144 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4145 TREE_READONLY (argc) = 1;
4146 gfc_finish_decl (argc);
4147 arglist = chainon (arglist, argc);
4149 typelist = TREE_CHAIN (typelist);
4150 tmp = TREE_VALUE (typelist);
4151 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4152 DECL_CONTEXT (argv) = ftn_main;
4153 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4154 TREE_READONLY (argv) = 1;
4155 DECL_BY_REFERENCE (argv) = 1;
4156 gfc_finish_decl (argv);
4157 arglist = chainon (arglist, argv);
4159 DECL_ARGUMENTS (ftn_main) = arglist;
4160 current_function_decl = ftn_main;
4161 announce_function (ftn_main);
4163 rest_of_decl_compilation (ftn_main, 1, 0);
4164 make_decl_rtl (ftn_main);
4165 init_function_start (ftn_main);
4168 gfc_init_block (&body);
4170 /* Call some libgfortran initialization routines, call then MAIN__(). */
4172 /* Call _gfortran_set_args (argc, argv). */
4173 TREE_USED (argc) = 1;
4174 TREE_USED (argv) = 1;
4175 tmp = build_call_expr_loc (input_location,
4176 gfor_fndecl_set_args, 2, argc, argv);
4177 gfc_add_expr_to_block (&body, tmp);
4179 /* Add a call to set_options to set up the runtime library Fortran
4180 language standard parameters. */
4182 tree array_type, array, var;
4183 VEC(constructor_elt,gc) *v = NULL;
4185 /* Passing a new option to the library requires four modifications:
4186 + add it to the tree_cons list below
4187 + change the array size in the call to build_array_type
4188 + change the first argument to the library call
4189 gfor_fndecl_set_options
4190 + modify the library (runtime/compile_options.c)! */
4192 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4193 build_int_cst (integer_type_node,
4194 gfc_option.warn_std));
4195 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4196 build_int_cst (integer_type_node,
4197 gfc_option.allow_std));
4198 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4199 build_int_cst (integer_type_node, pedantic));
4200 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4201 build_int_cst (integer_type_node,
4202 gfc_option.flag_dump_core));
4203 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4204 build_int_cst (integer_type_node,
4205 gfc_option.flag_backtrace));
4206 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4207 build_int_cst (integer_type_node,
4208 gfc_option.flag_sign_zero));
4209 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4210 build_int_cst (integer_type_node,
4212 & GFC_RTCHECK_BOUNDS)));
4213 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4214 build_int_cst (integer_type_node,
4215 gfc_option.flag_range_check));
4217 array_type = build_array_type (integer_type_node,
4218 build_index_type (build_int_cst (NULL_TREE, 7)));
4219 array = build_constructor (array_type, v);
4220 TREE_CONSTANT (array) = 1;
4221 TREE_STATIC (array) = 1;
4223 /* Create a static variable to hold the jump table. */
4224 var = gfc_create_var (array_type, "options");
4225 TREE_CONSTANT (var) = 1;
4226 TREE_STATIC (var) = 1;
4227 TREE_READONLY (var) = 1;
4228 DECL_INITIAL (var) = array;
4229 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4231 tmp = build_call_expr_loc (input_location,
4232 gfor_fndecl_set_options, 2,
4233 build_int_cst (integer_type_node, 8), var);
4234 gfc_add_expr_to_block (&body, tmp);
4237 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4238 the library will raise a FPE when needed. */
4239 if (gfc_option.fpe != 0)
4241 tmp = build_call_expr_loc (input_location,
4242 gfor_fndecl_set_fpe, 1,
4243 build_int_cst (integer_type_node,
4245 gfc_add_expr_to_block (&body, tmp);
4248 /* If this is the main program and an -fconvert option was provided,
4249 add a call to set_convert. */
4251 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4253 tmp = build_call_expr_loc (input_location,
4254 gfor_fndecl_set_convert, 1,
4255 build_int_cst (integer_type_node,
4256 gfc_option.convert));
4257 gfc_add_expr_to_block (&body, tmp);
4260 /* If this is the main program and an -frecord-marker option was provided,
4261 add a call to set_record_marker. */
4263 if (gfc_option.record_marker != 0)
4265 tmp = build_call_expr_loc (input_location,
4266 gfor_fndecl_set_record_marker, 1,
4267 build_int_cst (integer_type_node,
4268 gfc_option.record_marker));
4269 gfc_add_expr_to_block (&body, tmp);
4272 if (gfc_option.max_subrecord_length != 0)
4274 tmp = build_call_expr_loc (input_location,
4275 gfor_fndecl_set_max_subrecord_length, 1,
4276 build_int_cst (integer_type_node,
4277 gfc_option.max_subrecord_length));
4278 gfc_add_expr_to_block (&body, tmp);
4281 /* Call MAIN__(). */
4282 tmp = build_call_expr_loc (input_location,
4284 gfc_add_expr_to_block (&body, tmp);
4286 /* Mark MAIN__ as used. */
4287 TREE_USED (fndecl) = 1;
4290 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4291 build_int_cst (integer_type_node, 0));
4292 tmp = build1_v (RETURN_EXPR, tmp);
4293 gfc_add_expr_to_block (&body, tmp);
4296 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4299 /* Finish off this function and send it for code generation. */
4301 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4303 DECL_SAVED_TREE (ftn_main)
4304 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4305 DECL_INITIAL (ftn_main));
4307 /* Output the GENERIC tree. */
4308 dump_function (TDI_original, ftn_main);
4310 cgraph_finalize_function (ftn_main, true);
4314 pop_function_context ();
4315 saved_function_decls = saved_parent_function_decls;
4317 current_function_decl = old_context;
4321 /* Get the result expression for a procedure. */
4324 get_proc_result (gfc_symbol* sym)
4326 if (sym->attr.subroutine || sym == sym->result)
4328 if (current_fake_result_decl != NULL)
4329 return TREE_VALUE (current_fake_result_decl);
4334 return sym->result->backend_decl;
4338 /* Generate an appropriate return-statement for a procedure. */
4341 gfc_generate_return (void)
4347 sym = current_procedure_symbol;
4348 fndecl = sym->backend_decl;
4350 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4354 result = get_proc_result (sym);
4356 /* Set the return value to the dummy result variable. The
4357 types may be different for scalar default REAL functions
4358 with -ff2c, therefore we have to convert. */
4359 if (result != NULL_TREE)
4361 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4362 result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
4363 DECL_RESULT (fndecl), result);
4367 return build1_v (RETURN_EXPR, result);
4371 /* Generate code for a function. */
4374 gfc_generate_function_code (gfc_namespace * ns)
4380 stmtblock_t init, cleanup;
4382 gfc_wrapped_block try_block;
4383 tree recurcheckvar = NULL_TREE;
4385 gfc_symbol *previous_procedure_symbol;
4389 sym = ns->proc_name;
4390 previous_procedure_symbol = current_procedure_symbol;
4391 current_procedure_symbol = sym;
4393 /* Check that the frontend isn't still using this. */
4394 gcc_assert (sym->tlink == NULL);
4397 /* Create the declaration for functions with global scope. */
4398 if (!sym->backend_decl)
4399 gfc_create_function_decl (ns, false);
4401 fndecl = sym->backend_decl;
4402 old_context = current_function_decl;
4406 push_function_context ();
4407 saved_parent_function_decls = saved_function_decls;
4408 saved_function_decls = NULL_TREE;
4411 trans_function_start (sym);
4413 gfc_init_block (&init);
4415 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4417 /* Copy length backend_decls to all entry point result
4422 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4423 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4424 for (el = ns->entries; el; el = el->next)
4425 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4428 /* Translate COMMON blocks. */
4429 gfc_trans_common (ns);
4431 /* Null the parent fake result declaration if this namespace is
4432 a module function or an external procedures. */
4433 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4434 || ns->parent == NULL)
4435 parent_fake_result_decl = NULL_TREE;
4437 gfc_generate_contained_functions (ns);
4439 nonlocal_dummy_decls = NULL;
4440 nonlocal_dummy_decl_pset = NULL;
4442 generate_local_vars (ns);
4444 /* Keep the parent fake result declaration in module functions
4445 or external procedures. */
4446 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4447 || ns->parent == NULL)
4448 current_fake_result_decl = parent_fake_result_decl;
4450 current_fake_result_decl = NULL_TREE;
4452 is_recursive = sym->attr.recursive
4453 || (sym->attr.entry_master
4454 && sym->ns->entries->sym->attr.recursive);
4455 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4457 && !gfc_option.flag_recursive)
4461 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4463 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4464 TREE_STATIC (recurcheckvar) = 1;
4465 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4466 gfc_add_expr_to_block (&init, recurcheckvar);
4467 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4468 &sym->declared_at, msg);
4469 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
4473 /* Now generate the code for the body of this function. */
4474 gfc_init_block (&body);
4476 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4477 && sym->attr.subroutine)
4479 tree alternate_return;
4480 alternate_return = gfc_get_fake_result_decl (sym, 0);
4481 gfc_add_modify (&body, alternate_return, integer_zero_node);
4486 /* Jump to the correct entry point. */
4487 tmp = gfc_trans_entry_master_switch (ns->entries);
4488 gfc_add_expr_to_block (&body, tmp);
4491 /* If bounds-checking is enabled, generate code to check passed in actual
4492 arguments against the expected dummy argument attributes (e.g. string
4494 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4495 add_argument_checking (&body, sym);
4497 tmp = gfc_trans_code (ns->code);
4498 gfc_add_expr_to_block (&body, tmp);
4500 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4502 tree result = get_proc_result (sym);
4504 if (result != NULL_TREE
4505 && sym->attr.function
4506 && !sym->attr.pointer)
4508 if (sym->ts.type == BT_DERIVED
4509 && sym->ts.u.derived->attr.alloc_comp)
4511 rank = sym->as ? sym->as->rank : 0;
4512 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4513 gfc_add_expr_to_block (&init, tmp);
4515 else if (sym->attr.allocatable && sym->attr.dimension == 0)
4516 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4517 null_pointer_node));
4520 if (result == NULL_TREE)
4522 /* TODO: move to the appropriate place in resolve.c. */
4523 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4524 gfc_warning ("Return value of function '%s' at %L not set",
4525 sym->name, &sym->declared_at);
4527 TREE_NO_WARNING(sym->backend_decl) = 1;
4530 gfc_add_expr_to_block (&body, gfc_generate_return ());
4533 gfc_init_block (&cleanup);
4535 /* Reset recursion-check variable. */
4536 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4538 && !gfc_option.flag_openmp
4539 && recurcheckvar != NULL_TREE)
4541 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4542 recurcheckvar = NULL;
4545 /* Finish the function body and add init and cleanup code. */
4546 tmp = gfc_finish_block (&body);
4547 gfc_start_wrapped_block (&try_block, tmp);
4548 /* Add code to create and cleanup arrays. */
4549 gfc_trans_deferred_vars (sym, &try_block);
4550 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
4551 gfc_finish_block (&cleanup));
4553 /* Add all the decls we created during processing. */
4554 decl = saved_function_decls;
4559 next = DECL_CHAIN (decl);
4560 DECL_CHAIN (decl) = NULL_TREE;
4564 saved_function_decls = NULL_TREE;
4566 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
4569 /* Finish off this function and send it for code generation. */
4571 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4573 DECL_SAVED_TREE (fndecl)
4574 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4575 DECL_INITIAL (fndecl));
4577 if (nonlocal_dummy_decls)
4579 BLOCK_VARS (DECL_INITIAL (fndecl))
4580 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4581 pointer_set_destroy (nonlocal_dummy_decl_pset);
4582 nonlocal_dummy_decls = NULL;
4583 nonlocal_dummy_decl_pset = NULL;
4586 /* Output the GENERIC tree. */
4587 dump_function (TDI_original, fndecl);
4589 /* Store the end of the function, so that we get good line number
4590 info for the epilogue. */
4591 cfun->function_end_locus = input_location;
4593 /* We're leaving the context of this function, so zap cfun.
4594 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4595 tree_rest_of_compilation. */
4600 pop_function_context ();
4601 saved_function_decls = saved_parent_function_decls;
4603 current_function_decl = old_context;
4605 if (decl_function_context (fndecl))
4606 /* Register this function with cgraph just far enough to get it
4607 added to our parent's nested function list. */
4608 (void) cgraph_node (fndecl);
4610 cgraph_finalize_function (fndecl, true);
4612 gfc_trans_use_stmts (ns);
4613 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4615 if (sym->attr.is_main_program)
4616 create_main_function (fndecl);
4618 current_procedure_symbol = previous_procedure_symbol;
4623 gfc_generate_constructors (void)
4625 gcc_assert (gfc_static_ctors == NULL_TREE);
4633 if (gfc_static_ctors == NULL_TREE)
4636 fnname = get_file_function_name ("I");
4637 type = build_function_type_list (void_type_node, NULL_TREE);
4639 fndecl = build_decl (input_location,
4640 FUNCTION_DECL, fnname, type);
4641 TREE_PUBLIC (fndecl) = 1;
4643 decl = build_decl (input_location,
4644 RESULT_DECL, NULL_TREE, void_type_node);
4645 DECL_ARTIFICIAL (decl) = 1;
4646 DECL_IGNORED_P (decl) = 1;
4647 DECL_CONTEXT (decl) = fndecl;
4648 DECL_RESULT (fndecl) = decl;
4652 current_function_decl = fndecl;
4654 rest_of_decl_compilation (fndecl, 1, 0);
4656 make_decl_rtl (fndecl);
4658 init_function_start (fndecl);
4662 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4664 tmp = build_call_expr_loc (input_location,
4665 TREE_VALUE (gfc_static_ctors), 0);
4666 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4672 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4673 DECL_SAVED_TREE (fndecl)
4674 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4675 DECL_INITIAL (fndecl));
4677 free_after_parsing (cfun);
4678 free_after_compilation (cfun);
4680 tree_rest_of_compilation (fndecl);
4682 current_function_decl = NULL_TREE;
4686 /* Translates a BLOCK DATA program unit. This means emitting the
4687 commons contained therein plus their initializations. We also emit
4688 a globally visible symbol to make sure that each BLOCK DATA program
4689 unit remains unique. */
4692 gfc_generate_block_data (gfc_namespace * ns)
4697 /* Tell the backend the source location of the block data. */
4699 gfc_set_backend_locus (&ns->proc_name->declared_at);
4701 gfc_set_backend_locus (&gfc_current_locus);
4703 /* Process the DATA statements. */
4704 gfc_trans_common (ns);
4706 /* Create a global symbol with the mane of the block data. This is to
4707 generate linker errors if the same name is used twice. It is never
4710 id = gfc_sym_mangled_function_id (ns->proc_name);
4712 id = get_identifier ("__BLOCK_DATA__");
4714 decl = build_decl (input_location,
4715 VAR_DECL, id, gfc_array_index_type);
4716 TREE_PUBLIC (decl) = 1;
4717 TREE_STATIC (decl) = 1;
4718 DECL_IGNORED_P (decl) = 1;
4721 rest_of_decl_compilation (decl, 1, 0);
4725 /* Process the local variables of a BLOCK construct. */
4728 gfc_process_block_locals (gfc_namespace* ns)
4732 gcc_assert (saved_local_decls == NULL_TREE);
4733 generate_local_vars (ns);
4735 decl = saved_local_decls;
4740 next = DECL_CHAIN (decl);
4741 DECL_CHAIN (decl) = NULL_TREE;
4745 saved_local_decls = NULL_TREE;
4749 #include "gt-fortran-trans-decl.h"