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"
28 #include "tree-dump.h"
29 #include "gimple.h" /* For create_tmp_var_raw. */
32 #include "tm.h" /* For rtl.h. */
33 #include "rtl.h" /* For decl_default_tls_model. */
40 #include "pointer-set.h"
41 #include "constructor.h"
43 #include "trans-types.h"
44 #include "trans-array.h"
45 #include "trans-const.h"
46 /* Only for gfc_trans_code. Shouldn't need to include this. */
47 #include "trans-stmt.h"
49 #define MAX_LABEL_VALUE 99999
52 /* Holds the result of the function if no result variable specified. */
54 static GTY(()) tree current_fake_result_decl;
55 static GTY(()) tree parent_fake_result_decl;
57 static GTY(()) tree current_function_return_label;
60 /* Holds the variable DECLs for the current function. */
62 static GTY(()) tree saved_function_decls;
63 static GTY(()) tree saved_parent_function_decls;
65 static struct pointer_set_t *nonlocal_dummy_decl_pset;
66 static GTY(()) tree nonlocal_dummy_decls;
68 /* Holds the variable DECLs that are locals. */
70 static GTY(()) tree saved_local_decls;
72 /* The namespace of the module we're currently generating. Only used while
73 outputting decls for module variables. Do not rely on this being set. */
75 static gfc_namespace *module_namespace;
78 /* List of static constructor functions. */
80 tree gfc_static_ctors;
83 /* Function declarations for builtin library functions. */
85 tree gfor_fndecl_pause_numeric;
86 tree gfor_fndecl_pause_string;
87 tree gfor_fndecl_stop_numeric;
88 tree gfor_fndecl_stop_string;
89 tree gfor_fndecl_error_stop_numeric;
90 tree gfor_fndecl_error_stop_string;
91 tree gfor_fndecl_runtime_error;
92 tree gfor_fndecl_runtime_error_at;
93 tree gfor_fndecl_runtime_warning_at;
94 tree gfor_fndecl_os_error;
95 tree gfor_fndecl_generate_error;
96 tree gfor_fndecl_set_args;
97 tree gfor_fndecl_set_fpe;
98 tree gfor_fndecl_set_options;
99 tree gfor_fndecl_set_convert;
100 tree gfor_fndecl_set_record_marker;
101 tree gfor_fndecl_set_max_subrecord_length;
102 tree gfor_fndecl_ctime;
103 tree gfor_fndecl_fdate;
104 tree gfor_fndecl_ttynam;
105 tree gfor_fndecl_in_pack;
106 tree gfor_fndecl_in_unpack;
107 tree gfor_fndecl_associated;
110 /* Math functions. Many other math functions are handled in
111 trans-intrinsic.c. */
113 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
114 tree gfor_fndecl_math_ishftc4;
115 tree gfor_fndecl_math_ishftc8;
116 tree gfor_fndecl_math_ishftc16;
119 /* String functions. */
121 tree gfor_fndecl_compare_string;
122 tree gfor_fndecl_concat_string;
123 tree gfor_fndecl_string_len_trim;
124 tree gfor_fndecl_string_index;
125 tree gfor_fndecl_string_scan;
126 tree gfor_fndecl_string_verify;
127 tree gfor_fndecl_string_trim;
128 tree gfor_fndecl_string_minmax;
129 tree gfor_fndecl_adjustl;
130 tree gfor_fndecl_adjustr;
131 tree gfor_fndecl_select_string;
132 tree gfor_fndecl_compare_string_char4;
133 tree gfor_fndecl_concat_string_char4;
134 tree gfor_fndecl_string_len_trim_char4;
135 tree gfor_fndecl_string_index_char4;
136 tree gfor_fndecl_string_scan_char4;
137 tree gfor_fndecl_string_verify_char4;
138 tree gfor_fndecl_string_trim_char4;
139 tree gfor_fndecl_string_minmax_char4;
140 tree gfor_fndecl_adjustl_char4;
141 tree gfor_fndecl_adjustr_char4;
142 tree gfor_fndecl_select_string_char4;
145 /* Conversion between character kinds. */
146 tree gfor_fndecl_convert_char1_to_char4;
147 tree gfor_fndecl_convert_char4_to_char1;
150 /* Other misc. runtime library functions. */
152 tree gfor_fndecl_size0;
153 tree gfor_fndecl_size1;
154 tree gfor_fndecl_iargc;
155 tree gfor_fndecl_clz128;
156 tree gfor_fndecl_ctz128;
158 /* Intrinsic functions implemented in Fortran. */
159 tree gfor_fndecl_sc_kind;
160 tree gfor_fndecl_si_kind;
161 tree gfor_fndecl_sr_kind;
163 /* BLAS gemm functions. */
164 tree gfor_fndecl_sgemm;
165 tree gfor_fndecl_dgemm;
166 tree gfor_fndecl_cgemm;
167 tree gfor_fndecl_zgemm;
171 gfc_add_decl_to_parent_function (tree decl)
174 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
175 DECL_NONLOCAL (decl) = 1;
176 TREE_CHAIN (decl) = saved_parent_function_decls;
177 saved_parent_function_decls = decl;
181 gfc_add_decl_to_function (tree decl)
184 TREE_USED (decl) = 1;
185 DECL_CONTEXT (decl) = current_function_decl;
186 TREE_CHAIN (decl) = saved_function_decls;
187 saved_function_decls = decl;
191 add_decl_as_local (tree decl)
194 TREE_USED (decl) = 1;
195 DECL_CONTEXT (decl) = current_function_decl;
196 TREE_CHAIN (decl) = saved_local_decls;
197 saved_local_decls = decl;
201 /* Build a backend label declaration. Set TREE_USED for named labels.
202 The context of the label is always the current_function_decl. All
203 labels are marked artificial. */
206 gfc_build_label_decl (tree label_id)
208 /* 2^32 temporaries should be enough. */
209 static unsigned int tmp_num = 1;
213 if (label_id == NULL_TREE)
215 /* Build an internal label name. */
216 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
217 label_id = get_identifier (label_name);
222 /* Build the LABEL_DECL node. Labels have no type. */
223 label_decl = build_decl (input_location,
224 LABEL_DECL, label_id, void_type_node);
225 DECL_CONTEXT (label_decl) = current_function_decl;
226 DECL_MODE (label_decl) = VOIDmode;
228 /* We always define the label as used, even if the original source
229 file never references the label. We don't want all kinds of
230 spurious warnings for old-style Fortran code with too many
232 TREE_USED (label_decl) = 1;
234 DECL_ARTIFICIAL (label_decl) = 1;
239 /* Returns the return label for the current function. */
242 gfc_get_return_label (void)
244 char name[GFC_MAX_SYMBOL_LEN + 10];
246 if (current_function_return_label)
247 return current_function_return_label;
249 sprintf (name, "__return_%s",
250 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
252 current_function_return_label =
253 gfc_build_label_decl (get_identifier (name));
255 DECL_ARTIFICIAL (current_function_return_label) = 1;
257 return current_function_return_label;
261 /* Set the backend source location of a decl. */
264 gfc_set_decl_location (tree decl, locus * loc)
266 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
270 /* Return the backend label declaration for a given label structure,
271 or create it if it doesn't exist yet. */
274 gfc_get_label_decl (gfc_st_label * lp)
276 if (lp->backend_decl)
277 return lp->backend_decl;
280 char label_name[GFC_MAX_SYMBOL_LEN + 1];
283 /* Validate the label declaration from the front end. */
284 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
286 /* Build a mangled name for the label. */
287 sprintf (label_name, "__label_%.6d", lp->value);
289 /* Build the LABEL_DECL node. */
290 label_decl = gfc_build_label_decl (get_identifier (label_name));
292 /* Tell the debugger where the label came from. */
293 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
294 gfc_set_decl_location (label_decl, &lp->where);
296 DECL_ARTIFICIAL (label_decl) = 1;
298 /* Store the label in the label list and return the LABEL_DECL. */
299 lp->backend_decl = label_decl;
305 /* Convert a gfc_symbol to an identifier of the same name. */
308 gfc_sym_identifier (gfc_symbol * sym)
310 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
311 return (get_identifier ("MAIN__"));
313 return (get_identifier (sym->name));
317 /* Construct mangled name from symbol name. */
320 gfc_sym_mangled_identifier (gfc_symbol * sym)
322 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
324 /* Prevent the mangling of identifiers that have an assigned
325 binding label (mainly those that are bind(c)). */
326 if (sym->attr.is_bind_c == 1
327 && sym->binding_label[0] != '\0')
328 return get_identifier(sym->binding_label);
330 if (sym->module == NULL)
331 return gfc_sym_identifier (sym);
334 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
335 return get_identifier (name);
340 /* Construct mangled function name from symbol name. */
343 gfc_sym_mangled_function_id (gfc_symbol * sym)
346 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
348 /* It may be possible to simply use the binding label if it's
349 provided, and remove the other checks. Then we could use it
350 for other things if we wished. */
351 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
352 sym->binding_label[0] != '\0')
353 /* use the binding label rather than the mangled name */
354 return get_identifier (sym->binding_label);
356 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
357 || (sym->module != NULL && (sym->attr.external
358 || sym->attr.if_source == IFSRC_IFBODY)))
360 /* Main program is mangled into MAIN__. */
361 if (sym->attr.is_main_program)
362 return get_identifier ("MAIN__");
364 /* Intrinsic procedures are never mangled. */
365 if (sym->attr.proc == PROC_INTRINSIC)
366 return get_identifier (sym->name);
368 if (gfc_option.flag_underscoring)
370 has_underscore = strchr (sym->name, '_') != 0;
371 if (gfc_option.flag_second_underscore && has_underscore)
372 snprintf (name, sizeof name, "%s__", sym->name);
374 snprintf (name, sizeof name, "%s_", sym->name);
375 return get_identifier (name);
378 return get_identifier (sym->name);
382 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
383 return get_identifier (name);
389 gfc_set_decl_assembler_name (tree decl, tree name)
391 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
392 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
396 /* Returns true if a variable of specified size should go on the stack. */
399 gfc_can_put_var_on_stack (tree size)
401 unsigned HOST_WIDE_INT low;
403 if (!INTEGER_CST_P (size))
406 if (gfc_option.flag_max_stack_var_size < 0)
409 if (TREE_INT_CST_HIGH (size) != 0)
412 low = TREE_INT_CST_LOW (size);
413 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
416 /* TODO: Set a per-function stack size limit. */
422 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
423 an expression involving its corresponding pointer. There are
424 2 cases; one for variable size arrays, and one for everything else,
425 because variable-sized arrays require one fewer level of
429 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
431 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
434 /* Parameters need to be dereferenced. */
435 if (sym->cp_pointer->attr.dummy)
436 ptr_decl = build_fold_indirect_ref_loc (input_location,
439 /* Check to see if we're dealing with a variable-sized array. */
440 if (sym->attr.dimension
441 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
443 /* These decls will be dereferenced later, so we don't dereference
445 value = convert (TREE_TYPE (decl), ptr_decl);
449 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
451 value = build_fold_indirect_ref_loc (input_location,
455 SET_DECL_VALUE_EXPR (decl, value);
456 DECL_HAS_VALUE_EXPR_P (decl) = 1;
457 GFC_DECL_CRAY_POINTEE (decl) = 1;
458 /* This is a fake variable just for debugging purposes. */
459 TREE_ASM_WRITTEN (decl) = 1;
463 /* Finish processing of a declaration without an initial value. */
466 gfc_finish_decl (tree decl)
468 gcc_assert (TREE_CODE (decl) == PARM_DECL
469 || DECL_INITIAL (decl) == NULL_TREE);
471 if (TREE_CODE (decl) != VAR_DECL)
474 if (DECL_SIZE (decl) == NULL_TREE
475 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
476 layout_decl (decl, 0);
478 /* A few consistency checks. */
479 /* A static variable with an incomplete type is an error if it is
480 initialized. Also if it is not file scope. Otherwise, let it
481 through, but if it is not `extern' then it may cause an error
483 /* An automatic variable with an incomplete type is an error. */
485 /* We should know the storage size. */
486 gcc_assert (DECL_SIZE (decl) != NULL_TREE
487 || (TREE_STATIC (decl)
488 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
489 : DECL_EXTERNAL (decl)));
491 /* The storage size should be constant. */
492 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
494 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
498 /* Apply symbol attributes to a variable, and add it to the function scope. */
501 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
504 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
505 This is the equivalent of the TARGET variables.
506 We also need to set this if the variable is passed by reference in a
509 /* Set DECL_VALUE_EXPR for Cray Pointees. */
510 if (sym->attr.cray_pointee)
511 gfc_finish_cray_pointee (decl, sym);
513 if (sym->attr.target)
514 TREE_ADDRESSABLE (decl) = 1;
515 /* If it wasn't used we wouldn't be getting it. */
516 TREE_USED (decl) = 1;
518 /* Chain this decl to the pending declarations. Don't do pushdecl()
519 because this would add them to the current scope rather than the
521 if (current_function_decl != NULL_TREE)
523 if (sym->ns->proc_name->backend_decl == current_function_decl
524 || sym->result == sym)
525 gfc_add_decl_to_function (decl);
526 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
527 /* This is a BLOCK construct. */
528 add_decl_as_local (decl);
530 gfc_add_decl_to_parent_function (decl);
533 if (sym->attr.cray_pointee)
536 if(sym->attr.is_bind_c == 1)
538 /* We need to put variables that are bind(c) into the common
539 segment of the object file, because this is what C would do.
540 gfortran would typically put them in either the BSS or
541 initialized data segments, and only mark them as common if
542 they were part of common blocks. However, if they are not put
543 into common space, then C cannot initialize global Fortran
544 variables that it interoperates with and the draft says that
545 either Fortran or C should be able to initialize it (but not
546 both, of course.) (J3/04-007, section 15.3). */
547 TREE_PUBLIC(decl) = 1;
548 DECL_COMMON(decl) = 1;
551 /* If a variable is USE associated, it's always external. */
552 if (sym->attr.use_assoc)
554 DECL_EXTERNAL (decl) = 1;
555 TREE_PUBLIC (decl) = 1;
557 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
559 /* TODO: Don't set sym->module for result or dummy variables. */
560 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
561 /* This is the declaration of a module variable. */
562 TREE_PUBLIC (decl) = 1;
563 TREE_STATIC (decl) = 1;
566 /* Derived types are a bit peculiar because of the possibility of
567 a default initializer; this must be applied each time the variable
568 comes into scope it therefore need not be static. These variables
569 are SAVE_NONE but have an initializer. Otherwise explicitly
570 initialized variables are SAVE_IMPLICIT and explicitly saved are
572 if (!sym->attr.use_assoc
573 && (sym->attr.save != SAVE_NONE || sym->attr.data
574 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
575 TREE_STATIC (decl) = 1;
577 if (sym->attr.volatile_)
579 TREE_THIS_VOLATILE (decl) = 1;
580 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
581 TREE_TYPE (decl) = new_type;
584 /* Keep variables larger than max-stack-var-size off stack. */
585 if (!sym->ns->proc_name->attr.recursive
586 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
587 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
588 /* Put variable length auto array pointers always into stack. */
589 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
590 || sym->attr.dimension == 0
591 || sym->as->type != AS_EXPLICIT
593 || sym->attr.allocatable)
594 && !DECL_ARTIFICIAL (decl))
595 TREE_STATIC (decl) = 1;
597 /* Handle threadprivate variables. */
598 if (sym->attr.threadprivate
599 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
600 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
602 if (!sym->attr.target
603 && !sym->attr.pointer
604 && !sym->attr.cray_pointee
605 && !sym->attr.proc_pointer)
606 DECL_RESTRICTED_P (decl) = 1;
610 /* Allocate the lang-specific part of a decl. */
613 gfc_allocate_lang_decl (tree decl)
615 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
616 ggc_alloc_cleared (sizeof (struct lang_decl));
619 /* Remember a symbol to generate initialization/cleanup code at function
623 gfc_defer_symbol_init (gfc_symbol * sym)
629 /* Don't add a symbol twice. */
633 last = head = sym->ns->proc_name;
636 /* Make sure that setup code for dummy variables which are used in the
637 setup of other variables is generated first. */
640 /* Find the first dummy arg seen after us, or the first non-dummy arg.
641 This is a circular list, so don't go past the head. */
643 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
649 /* Insert in between last and p. */
655 /* Create an array index type variable with function scope. */
658 create_index_var (const char * pfx, int nest)
662 decl = gfc_create_var_np (gfc_array_index_type, pfx);
664 gfc_add_decl_to_parent_function (decl);
666 gfc_add_decl_to_function (decl);
671 /* Create variables to hold all the non-constant bits of info for a
672 descriptorless array. Remember these in the lang-specific part of the
676 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
682 type = TREE_TYPE (decl);
684 /* We just use the descriptor, if there is one. */
685 if (GFC_DESCRIPTOR_TYPE_P (type))
688 gcc_assert (GFC_ARRAY_TYPE_P (type));
689 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
690 && !sym->attr.contained;
692 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
694 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
696 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
697 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
699 /* Don't try to use the unknown bound for assumed shape arrays. */
700 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
701 && (sym->as->type != AS_ASSUMED_SIZE
702 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
704 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
705 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
708 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
710 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
711 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
714 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
716 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
718 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
721 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
723 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
726 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
727 && sym->as->type != AS_ASSUMED_SIZE)
729 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
730 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
733 if (POINTER_TYPE_P (type))
735 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
736 gcc_assert (TYPE_LANG_SPECIFIC (type)
737 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
738 type = TREE_TYPE (type);
741 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
745 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
746 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
747 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
749 TYPE_DOMAIN (type) = range;
753 if (TYPE_NAME (type) != NULL_TREE
754 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
755 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
757 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
759 for (dim = 0; dim < sym->as->rank - 1; dim++)
761 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
762 gtype = TREE_TYPE (gtype);
764 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
765 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
766 TYPE_NAME (type) = NULL_TREE;
769 if (TYPE_NAME (type) == NULL_TREE)
771 tree gtype = TREE_TYPE (type), rtype, type_decl;
773 for (dim = sym->as->rank - 1; dim >= 0; dim--)
776 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
777 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
778 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
779 gtype = build_array_type (gtype, rtype);
780 /* Ensure the bound variables aren't optimized out at -O0.
781 For -O1 and above they often will be optimized out, but
782 can be tracked by VTA. Also clear the artificial
783 lbound.N or ubound.N DECL_NAME, so that it doesn't end up
785 if (lbound && TREE_CODE (lbound) == VAR_DECL
786 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
788 if (DECL_NAME (lbound)
789 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
791 DECL_NAME (lbound) = NULL_TREE;
792 DECL_IGNORED_P (lbound) = 0;
794 if (ubound && TREE_CODE (ubound) == VAR_DECL
795 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
797 if (DECL_NAME (ubound)
798 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
800 DECL_NAME (ubound) = NULL_TREE;
801 DECL_IGNORED_P (ubound) = 0;
804 TYPE_NAME (type) = type_decl = build_decl (input_location,
805 TYPE_DECL, NULL, gtype);
806 DECL_ORIGINAL_TYPE (type_decl) = gtype;
811 /* For some dummy arguments we don't use the actual argument directly.
812 Instead we create a local decl and use that. This allows us to perform
813 initialization, and construct full type information. */
816 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
826 if (sym->attr.pointer || sym->attr.allocatable)
829 /* Add to list of variables if not a fake result variable. */
830 if (sym->attr.result || sym->attr.dummy)
831 gfc_defer_symbol_init (sym);
833 type = TREE_TYPE (dummy);
834 gcc_assert (TREE_CODE (dummy) == PARM_DECL
835 && POINTER_TYPE_P (type));
837 /* Do we know the element size? */
838 known_size = sym->ts.type != BT_CHARACTER
839 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
841 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
843 /* For descriptorless arrays with known element size the actual
844 argument is sufficient. */
845 gcc_assert (GFC_ARRAY_TYPE_P (type));
846 gfc_build_qualified_array (dummy, sym);
850 type = TREE_TYPE (type);
851 if (GFC_DESCRIPTOR_TYPE_P (type))
853 /* Create a descriptorless array pointer. */
857 /* Even when -frepack-arrays is used, symbols with TARGET attribute
859 if (!gfc_option.flag_repack_arrays || sym->attr.target)
861 if (as->type == AS_ASSUMED_SIZE)
862 packed = PACKED_FULL;
866 if (as->type == AS_EXPLICIT)
868 packed = PACKED_FULL;
869 for (n = 0; n < as->rank; n++)
873 && as->upper[n]->expr_type == EXPR_CONSTANT
874 && as->lower[n]->expr_type == EXPR_CONSTANT))
875 packed = PACKED_PARTIAL;
879 packed = PACKED_PARTIAL;
882 type = gfc_typenode_for_spec (&sym->ts);
883 type = gfc_get_nodesc_array_type (type, sym->as, packed,
888 /* We now have an expression for the element size, so create a fully
889 qualified type. Reset sym->backend decl or this will just return the
891 DECL_ARTIFICIAL (sym->backend_decl) = 1;
892 sym->backend_decl = NULL_TREE;
893 type = gfc_sym_type (sym);
894 packed = PACKED_FULL;
897 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
898 decl = build_decl (input_location,
899 VAR_DECL, get_identifier (name), type);
901 DECL_ARTIFICIAL (decl) = 1;
902 TREE_PUBLIC (decl) = 0;
903 TREE_STATIC (decl) = 0;
904 DECL_EXTERNAL (decl) = 0;
906 /* We should never get deferred shape arrays here. We used to because of
908 gcc_assert (sym->as->type != AS_DEFERRED);
910 if (packed == PACKED_PARTIAL)
911 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
912 else if (packed == PACKED_FULL)
913 GFC_DECL_PACKED_ARRAY (decl) = 1;
915 gfc_build_qualified_array (decl, sym);
917 if (DECL_LANG_SPECIFIC (dummy))
918 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
920 gfc_allocate_lang_decl (decl);
922 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
924 if (sym->ns->proc_name->backend_decl == current_function_decl
925 || sym->attr.contained)
926 gfc_add_decl_to_function (decl);
928 gfc_add_decl_to_parent_function (decl);
933 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
934 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
935 pointing to the artificial variable for debug info purposes. */
938 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
942 if (! nonlocal_dummy_decl_pset)
943 nonlocal_dummy_decl_pset = pointer_set_create ();
945 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
948 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
949 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
950 TREE_TYPE (sym->backend_decl));
951 DECL_ARTIFICIAL (decl) = 0;
952 TREE_USED (decl) = 1;
953 TREE_PUBLIC (decl) = 0;
954 TREE_STATIC (decl) = 0;
955 DECL_EXTERNAL (decl) = 0;
956 if (DECL_BY_REFERENCE (dummy))
957 DECL_BY_REFERENCE (decl) = 1;
958 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
959 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
960 DECL_HAS_VALUE_EXPR_P (decl) = 1;
961 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
962 TREE_CHAIN (decl) = nonlocal_dummy_decls;
963 nonlocal_dummy_decls = decl;
966 /* Return a constant or a variable to use as a string length. Does not
967 add the decl to the current scope. */
970 gfc_create_string_length (gfc_symbol * sym)
972 gcc_assert (sym->ts.u.cl);
973 gfc_conv_const_charlen (sym->ts.u.cl);
975 if (sym->ts.u.cl->backend_decl == NULL_TREE)
978 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
980 /* Also prefix the mangled name. */
981 strcpy (&name[1], sym->name);
983 length = build_decl (input_location,
984 VAR_DECL, get_identifier (name),
985 gfc_charlen_type_node);
986 DECL_ARTIFICIAL (length) = 1;
987 TREE_USED (length) = 1;
988 if (sym->ns->proc_name->tlink != NULL)
989 gfc_defer_symbol_init (sym);
991 sym->ts.u.cl->backend_decl = length;
994 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
995 return sym->ts.u.cl->backend_decl;
998 /* If a variable is assigned a label, we add another two auxiliary
1002 gfc_add_assign_aux_vars (gfc_symbol * sym)
1008 gcc_assert (sym->backend_decl);
1010 decl = sym->backend_decl;
1011 gfc_allocate_lang_decl (decl);
1012 GFC_DECL_ASSIGN (decl) = 1;
1013 length = build_decl (input_location,
1014 VAR_DECL, create_tmp_var_name (sym->name),
1015 gfc_charlen_type_node);
1016 addr = build_decl (input_location,
1017 VAR_DECL, create_tmp_var_name (sym->name),
1019 gfc_finish_var_decl (length, sym);
1020 gfc_finish_var_decl (addr, sym);
1021 /* STRING_LENGTH is also used as flag. Less than -1 means that
1022 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1023 target label's address. Otherwise, value is the length of a format string
1024 and ASSIGN_ADDR is its address. */
1025 if (TREE_STATIC (length))
1026 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1028 gfc_defer_symbol_init (sym);
1030 GFC_DECL_STRING_LEN (decl) = length;
1031 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1036 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1041 for (id = 0; id < EXT_ATTR_NUM; id++)
1042 if (sym_attr.ext_attr & (1 << id))
1044 attr = build_tree_list (
1045 get_identifier (ext_attr_list[id].middle_end_name),
1047 list = chainon (list, attr);
1054 /* Return the decl for a gfc_symbol, create it if it doesn't already
1058 gfc_get_symbol_decl (gfc_symbol * sym)
1061 tree length = NULL_TREE;
1065 gcc_assert (sym->attr.referenced
1066 || sym->attr.use_assoc
1067 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
1069 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1070 byref = gfc_return_by_reference (sym->ns->proc_name);
1074 /* Make sure that the vtab for the declared type is completed. */
1075 if (sym->ts.type == BT_CLASS)
1077 gfc_component *c = gfc_find_component (sym->ts.u.derived,
1078 "$data", true, true);
1079 if (!c->ts.u.derived->backend_decl)
1080 gfc_find_derived_vtab (c->ts.u.derived, true);
1083 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1085 /* Return via extra parameter. */
1086 if (sym->attr.result && byref
1087 && !sym->backend_decl)
1090 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1091 /* For entry master function skip over the __entry
1093 if (sym->ns->proc_name->attr.entry_master)
1094 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1097 /* Dummy variables should already have been created. */
1098 gcc_assert (sym->backend_decl);
1100 /* Create a character length variable. */
1101 if (sym->ts.type == BT_CHARACTER)
1103 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1104 length = gfc_create_string_length (sym);
1106 length = sym->ts.u.cl->backend_decl;
1107 if (TREE_CODE (length) == VAR_DECL
1108 && DECL_CONTEXT (length) == NULL_TREE)
1110 /* Add the string length to the same context as the symbol. */
1111 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1112 gfc_add_decl_to_function (length);
1114 gfc_add_decl_to_parent_function (length);
1116 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1117 DECL_CONTEXT (length));
1119 gfc_defer_symbol_init (sym);
1123 /* Use a copy of the descriptor for dummy arrays. */
1124 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1126 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1127 /* Prevent the dummy from being detected as unused if it is copied. */
1128 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1129 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1130 sym->backend_decl = decl;
1133 TREE_USED (sym->backend_decl) = 1;
1134 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1136 gfc_add_assign_aux_vars (sym);
1139 if (sym->attr.dimension
1140 && DECL_LANG_SPECIFIC (sym->backend_decl)
1141 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1142 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1143 gfc_nonlocal_dummy_array_decl (sym);
1145 return sym->backend_decl;
1148 if (sym->backend_decl)
1149 return sym->backend_decl;
1151 /* If use associated and whole file compilation, use the module
1152 declaration. This is only needed for intrinsic types because
1153 they are substituted for one another during optimization. */
1154 if (gfc_option.flag_whole_file
1155 && sym->attr.flavor == FL_VARIABLE
1156 && sym->ts.type != BT_DERIVED
1157 && sym->attr.use_assoc
1162 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1163 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1167 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1168 if (s && s->backend_decl)
1170 if (sym->ts.type == BT_CHARACTER)
1171 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1172 return s->backend_decl;
1177 /* Catch function declarations. Only used for actual parameters and
1178 procedure pointers. */
1179 if (sym->attr.flavor == FL_PROCEDURE)
1181 decl = gfc_get_extern_function_decl (sym);
1182 gfc_set_decl_location (decl, &sym->declared_at);
1186 if (sym->attr.intrinsic)
1187 internal_error ("intrinsic variable which isn't a procedure");
1189 /* Create string length decl first so that they can be used in the
1190 type declaration. */
1191 if (sym->ts.type == BT_CHARACTER)
1192 length = gfc_create_string_length (sym);
1194 /* Create the decl for the variable. */
1195 decl = build_decl (sym->declared_at.lb->location,
1196 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1198 /* Add attributes to variables. Functions are handled elsewhere. */
1199 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1200 decl_attributes (&decl, attributes, 0);
1202 /* Symbols from modules should have their assembler names mangled.
1203 This is done here rather than in gfc_finish_var_decl because it
1204 is different for string length variables. */
1207 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1208 if (sym->attr.use_assoc)
1209 DECL_IGNORED_P (decl) = 1;
1212 if (sym->attr.dimension)
1214 /* Create variables to hold the non-constant bits of array info. */
1215 gfc_build_qualified_array (decl, sym);
1217 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1218 GFC_DECL_PACKED_ARRAY (decl) = 1;
1221 /* Remember this variable for allocation/cleanup. */
1222 if (sym->attr.dimension || sym->attr.allocatable
1223 || (sym->ts.type == BT_CLASS &&
1224 (sym->ts.u.derived->components->attr.dimension
1225 || sym->ts.u.derived->components->attr.allocatable))
1226 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1227 /* This applies a derived type default initializer. */
1228 || (sym->ts.type == BT_DERIVED
1229 && sym->attr.save == SAVE_NONE
1231 && !sym->attr.allocatable
1232 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1233 && !sym->attr.use_assoc))
1234 gfc_defer_symbol_init (sym);
1236 gfc_finish_var_decl (decl, sym);
1238 if (sym->ts.type == BT_CHARACTER)
1240 /* Character variables need special handling. */
1241 gfc_allocate_lang_decl (decl);
1243 if (TREE_CODE (length) != INTEGER_CST)
1245 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1249 /* Also prefix the mangled name for symbols from modules. */
1250 strcpy (&name[1], sym->name);
1253 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1254 gfc_set_decl_assembler_name (decl, get_identifier (name));
1256 gfc_finish_var_decl (length, sym);
1257 gcc_assert (!sym->value);
1260 else if (sym->attr.subref_array_pointer)
1262 /* We need the span for these beasts. */
1263 gfc_allocate_lang_decl (decl);
1266 if (sym->attr.subref_array_pointer)
1269 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1270 span = build_decl (input_location,
1271 VAR_DECL, create_tmp_var_name ("span"),
1272 gfc_array_index_type);
1273 gfc_finish_var_decl (span, sym);
1274 TREE_STATIC (span) = TREE_STATIC (decl);
1275 DECL_ARTIFICIAL (span) = 1;
1276 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1278 GFC_DECL_SPAN (decl) = span;
1279 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1282 sym->backend_decl = decl;
1284 if (sym->attr.assign)
1285 gfc_add_assign_aux_vars (sym);
1287 if (TREE_STATIC (decl) && !sym->attr.use_assoc
1288 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1289 || gfc_option.flag_max_stack_var_size == 0
1290 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1292 /* Add static initializer. For procedures, it is only needed if
1293 SAVE is specified otherwise they need to be reinitialized
1294 every time the procedure is entered. The TREE_STATIC is
1295 in this case due to -fmax-stack-var-size=. */
1296 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1297 TREE_TYPE (decl), sym->attr.dimension,
1298 sym->attr.pointer || sym->attr.allocatable);
1301 if (!TREE_STATIC (decl)
1302 && POINTER_TYPE_P (TREE_TYPE (decl))
1303 && !sym->attr.pointer
1304 && !sym->attr.allocatable
1305 && !sym->attr.proc_pointer)
1306 DECL_BY_REFERENCE (decl) = 1;
1312 /* Substitute a temporary variable in place of the real one. */
1315 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1317 save->attr = sym->attr;
1318 save->decl = sym->backend_decl;
1320 gfc_clear_attr (&sym->attr);
1321 sym->attr.referenced = 1;
1322 sym->attr.flavor = FL_VARIABLE;
1324 sym->backend_decl = decl;
1328 /* Restore the original variable. */
1331 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1333 sym->attr = save->attr;
1334 sym->backend_decl = save->decl;
1338 /* Declare a procedure pointer. */
1341 get_proc_pointer_decl (gfc_symbol *sym)
1346 decl = sym->backend_decl;
1350 decl = build_decl (input_location,
1351 VAR_DECL, get_identifier (sym->name),
1352 build_pointer_type (gfc_get_function_type (sym)));
1354 if ((sym->ns->proc_name
1355 && sym->ns->proc_name->backend_decl == current_function_decl)
1356 || sym->attr.contained)
1357 gfc_add_decl_to_function (decl);
1358 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1359 gfc_add_decl_to_parent_function (decl);
1361 sym->backend_decl = decl;
1363 /* If a variable is USE associated, it's always external. */
1364 if (sym->attr.use_assoc)
1366 DECL_EXTERNAL (decl) = 1;
1367 TREE_PUBLIC (decl) = 1;
1369 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1371 /* This is the declaration of a module variable. */
1372 TREE_PUBLIC (decl) = 1;
1373 TREE_STATIC (decl) = 1;
1376 if (!sym->attr.use_assoc
1377 && (sym->attr.save != SAVE_NONE || sym->attr.data
1378 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1379 TREE_STATIC (decl) = 1;
1381 if (TREE_STATIC (decl) && sym->value)
1383 /* Add static initializer. */
1384 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1386 sym->attr.proc_pointer ? false : sym->attr.dimension,
1387 sym->attr.proc_pointer);
1390 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1391 decl_attributes (&decl, attributes, 0);
1397 /* Get a basic decl for an external function. */
1400 gfc_get_extern_function_decl (gfc_symbol * sym)
1406 gfc_intrinsic_sym *isym;
1408 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1413 if (sym->backend_decl)
1414 return sym->backend_decl;
1416 /* We should never be creating external decls for alternate entry points.
1417 The procedure may be an alternate entry point, but we don't want/need
1419 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1421 if (sym->attr.proc_pointer)
1422 return get_proc_pointer_decl (sym);
1424 /* See if this is an external procedure from the same file. If so,
1425 return the backend_decl. */
1426 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1428 if (gfc_option.flag_whole_file
1429 && !sym->attr.use_assoc
1430 && !sym->backend_decl
1432 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1433 && gsym->ns->proc_name->backend_decl)
1435 /* If the namespace has entries, the proc_name is the
1436 entry master. Find the entry and use its backend_decl.
1437 otherwise, use the proc_name backend_decl. */
1438 if (gsym->ns->entries)
1440 gfc_entry_list *entry = gsym->ns->entries;
1442 for (; entry; entry = entry->next)
1444 if (strcmp (gsym->name, entry->sym->name) == 0)
1446 sym->backend_decl = entry->sym->backend_decl;
1453 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1456 if (sym->backend_decl)
1457 return sym->backend_decl;
1460 /* See if this is a module procedure from the same file. If so,
1461 return the backend_decl. */
1463 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1465 if (gfc_option.flag_whole_file
1467 && gsym->type == GSYM_MODULE)
1472 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1473 if (s && s->backend_decl)
1475 sym->backend_decl = s->backend_decl;
1476 return sym->backend_decl;
1480 if (sym->attr.intrinsic)
1482 /* Call the resolution function to get the actual name. This is
1483 a nasty hack which relies on the resolution functions only looking
1484 at the first argument. We pass NULL for the second argument
1485 otherwise things like AINT get confused. */
1486 isym = gfc_find_function (sym->name);
1487 gcc_assert (isym->resolve.f0 != NULL);
1489 memset (&e, 0, sizeof (e));
1490 e.expr_type = EXPR_FUNCTION;
1492 memset (&argexpr, 0, sizeof (argexpr));
1493 gcc_assert (isym->formal);
1494 argexpr.ts = isym->formal->ts;
1496 if (isym->formal->next == NULL)
1497 isym->resolve.f1 (&e, &argexpr);
1500 if (isym->formal->next->next == NULL)
1501 isym->resolve.f2 (&e, &argexpr, NULL);
1504 if (isym->formal->next->next->next == NULL)
1505 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1508 /* All specific intrinsics take less than 5 arguments. */
1509 gcc_assert (isym->formal->next->next->next->next == NULL);
1510 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1515 if (gfc_option.flag_f2c
1516 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1517 || e.ts.type == BT_COMPLEX))
1519 /* Specific which needs a different implementation if f2c
1520 calling conventions are used. */
1521 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1524 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1526 name = get_identifier (s);
1527 mangled_name = name;
1531 name = gfc_sym_identifier (sym);
1532 mangled_name = gfc_sym_mangled_function_id (sym);
1535 type = gfc_get_function_type (sym);
1536 fndecl = build_decl (input_location,
1537 FUNCTION_DECL, name, type);
1539 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1540 decl_attributes (&fndecl, attributes, 0);
1542 gfc_set_decl_assembler_name (fndecl, mangled_name);
1544 /* Set the context of this decl. */
1545 if (0 && sym->ns && sym->ns->proc_name)
1547 /* TODO: Add external decls to the appropriate scope. */
1548 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1552 /* Global declaration, e.g. intrinsic subroutine. */
1553 DECL_CONTEXT (fndecl) = NULL_TREE;
1556 DECL_EXTERNAL (fndecl) = 1;
1558 /* This specifies if a function is globally addressable, i.e. it is
1559 the opposite of declaring static in C. */
1560 TREE_PUBLIC (fndecl) = 1;
1562 /* Set attributes for PURE functions. A call to PURE function in the
1563 Fortran 95 sense is both pure and without side effects in the C
1565 if (sym->attr.pure || sym->attr.elemental)
1567 if (sym->attr.function && !gfc_return_by_reference (sym))
1568 DECL_PURE_P (fndecl) = 1;
1569 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1570 parameters and don't use alternate returns (is this
1571 allowed?). In that case, calls to them are meaningless, and
1572 can be optimized away. See also in build_function_decl(). */
1573 TREE_SIDE_EFFECTS (fndecl) = 0;
1576 /* Mark non-returning functions. */
1577 if (sym->attr.noreturn)
1578 TREE_THIS_VOLATILE(fndecl) = 1;
1580 sym->backend_decl = fndecl;
1582 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1583 pushdecl_top_level (fndecl);
1589 /* Create a declaration for a procedure. For external functions (in the C
1590 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1591 a master function with alternate entry points. */
1594 build_function_decl (gfc_symbol * sym)
1596 tree fndecl, type, attributes;
1597 symbol_attribute attr;
1599 gfc_formal_arglist *f;
1601 gcc_assert (!sym->backend_decl);
1602 gcc_assert (!sym->attr.external);
1604 /* Set the line and filename. sym->declared_at seems to point to the
1605 last statement for subroutines, but it'll do for now. */
1606 gfc_set_backend_locus (&sym->declared_at);
1608 /* Allow only one nesting level. Allow public declarations. */
1609 gcc_assert (current_function_decl == NULL_TREE
1610 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1611 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1614 type = gfc_get_function_type (sym);
1615 fndecl = build_decl (input_location,
1616 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1620 attributes = add_attributes_to_decl (attr, NULL_TREE);
1621 decl_attributes (&fndecl, attributes, 0);
1623 /* Perform name mangling if this is a top level or module procedure. */
1624 if (current_function_decl == NULL_TREE)
1625 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1627 /* Figure out the return type of the declared function, and build a
1628 RESULT_DECL for it. If this is a subroutine with alternate
1629 returns, build a RESULT_DECL for it. */
1630 result_decl = NULL_TREE;
1631 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1634 if (gfc_return_by_reference (sym))
1635 type = void_type_node;
1638 if (sym->result != sym)
1639 result_decl = gfc_sym_identifier (sym->result);
1641 type = TREE_TYPE (TREE_TYPE (fndecl));
1646 /* Look for alternate return placeholders. */
1647 int has_alternate_returns = 0;
1648 for (f = sym->formal; f; f = f->next)
1652 has_alternate_returns = 1;
1657 if (has_alternate_returns)
1658 type = integer_type_node;
1660 type = void_type_node;
1663 result_decl = build_decl (input_location,
1664 RESULT_DECL, result_decl, type);
1665 DECL_ARTIFICIAL (result_decl) = 1;
1666 DECL_IGNORED_P (result_decl) = 1;
1667 DECL_CONTEXT (result_decl) = fndecl;
1668 DECL_RESULT (fndecl) = result_decl;
1670 /* Don't call layout_decl for a RESULT_DECL.
1671 layout_decl (result_decl, 0); */
1673 /* Set up all attributes for the function. */
1674 DECL_CONTEXT (fndecl) = current_function_decl;
1675 DECL_EXTERNAL (fndecl) = 0;
1677 /* This specifies if a function is globally visible, i.e. it is
1678 the opposite of declaring static in C. */
1679 if (DECL_CONTEXT (fndecl) == NULL_TREE
1680 && !sym->attr.entry_master && !sym->attr.is_main_program)
1681 TREE_PUBLIC (fndecl) = 1;
1683 /* TREE_STATIC means the function body is defined here. */
1684 TREE_STATIC (fndecl) = 1;
1686 /* Set attributes for PURE functions. A call to a PURE function in the
1687 Fortran 95 sense is both pure and without side effects in the C
1689 if (attr.pure || attr.elemental)
1691 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1692 including an alternate return. In that case it can also be
1693 marked as PURE. See also in gfc_get_extern_function_decl(). */
1694 if (attr.function && !gfc_return_by_reference (sym))
1695 DECL_PURE_P (fndecl) = 1;
1696 TREE_SIDE_EFFECTS (fndecl) = 0;
1700 /* Layout the function declaration and put it in the binding level
1701 of the current function. */
1704 sym->backend_decl = fndecl;
1708 /* Create the DECL_ARGUMENTS for a procedure. */
1711 create_function_arglist (gfc_symbol * sym)
1714 gfc_formal_arglist *f;
1715 tree typelist, hidden_typelist;
1716 tree arglist, hidden_arglist;
1720 fndecl = sym->backend_decl;
1722 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1723 the new FUNCTION_DECL node. */
1724 arglist = NULL_TREE;
1725 hidden_arglist = NULL_TREE;
1726 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1728 if (sym->attr.entry_master)
1730 type = TREE_VALUE (typelist);
1731 parm = build_decl (input_location,
1732 PARM_DECL, get_identifier ("__entry"), type);
1734 DECL_CONTEXT (parm) = fndecl;
1735 DECL_ARG_TYPE (parm) = type;
1736 TREE_READONLY (parm) = 1;
1737 gfc_finish_decl (parm);
1738 DECL_ARTIFICIAL (parm) = 1;
1740 arglist = chainon (arglist, parm);
1741 typelist = TREE_CHAIN (typelist);
1744 if (gfc_return_by_reference (sym))
1746 tree type = TREE_VALUE (typelist), length = NULL;
1748 if (sym->ts.type == BT_CHARACTER)
1750 /* Length of character result. */
1751 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1752 gcc_assert (len_type == gfc_charlen_type_node);
1754 length = build_decl (input_location,
1756 get_identifier (".__result"),
1758 if (!sym->ts.u.cl->length)
1760 sym->ts.u.cl->backend_decl = length;
1761 TREE_USED (length) = 1;
1763 gcc_assert (TREE_CODE (length) == PARM_DECL);
1764 DECL_CONTEXT (length) = fndecl;
1765 DECL_ARG_TYPE (length) = len_type;
1766 TREE_READONLY (length) = 1;
1767 DECL_ARTIFICIAL (length) = 1;
1768 gfc_finish_decl (length);
1769 if (sym->ts.u.cl->backend_decl == NULL
1770 || sym->ts.u.cl->backend_decl == length)
1775 if (sym->ts.u.cl->backend_decl == NULL)
1777 tree len = build_decl (input_location,
1779 get_identifier ("..__result"),
1780 gfc_charlen_type_node);
1781 DECL_ARTIFICIAL (len) = 1;
1782 TREE_USED (len) = 1;
1783 sym->ts.u.cl->backend_decl = len;
1786 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1787 arg = sym->result ? sym->result : sym;
1788 backend_decl = arg->backend_decl;
1789 /* Temporary clear it, so that gfc_sym_type creates complete
1791 arg->backend_decl = NULL;
1792 type = gfc_sym_type (arg);
1793 arg->backend_decl = backend_decl;
1794 type = build_reference_type (type);
1798 parm = build_decl (input_location,
1799 PARM_DECL, get_identifier ("__result"), type);
1801 DECL_CONTEXT (parm) = fndecl;
1802 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1803 TREE_READONLY (parm) = 1;
1804 DECL_ARTIFICIAL (parm) = 1;
1805 gfc_finish_decl (parm);
1807 arglist = chainon (arglist, parm);
1808 typelist = TREE_CHAIN (typelist);
1810 if (sym->ts.type == BT_CHARACTER)
1812 gfc_allocate_lang_decl (parm);
1813 arglist = chainon (arglist, length);
1814 typelist = TREE_CHAIN (typelist);
1818 hidden_typelist = typelist;
1819 for (f = sym->formal; f; f = f->next)
1820 if (f->sym != NULL) /* Ignore alternate returns. */
1821 hidden_typelist = TREE_CHAIN (hidden_typelist);
1823 for (f = sym->formal; f; f = f->next)
1825 char name[GFC_MAX_SYMBOL_LEN + 2];
1827 /* Ignore alternate returns. */
1831 type = TREE_VALUE (typelist);
1833 if (f->sym->ts.type == BT_CHARACTER
1834 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1836 tree len_type = TREE_VALUE (hidden_typelist);
1837 tree length = NULL_TREE;
1838 gcc_assert (len_type == gfc_charlen_type_node);
1840 strcpy (&name[1], f->sym->name);
1842 length = build_decl (input_location,
1843 PARM_DECL, get_identifier (name), len_type);
1845 hidden_arglist = chainon (hidden_arglist, length);
1846 DECL_CONTEXT (length) = fndecl;
1847 DECL_ARTIFICIAL (length) = 1;
1848 DECL_ARG_TYPE (length) = len_type;
1849 TREE_READONLY (length) = 1;
1850 gfc_finish_decl (length);
1852 /* Remember the passed value. */
1853 if (f->sym->ts.u.cl->passed_length != NULL)
1855 /* This can happen if the same type is used for multiple
1856 arguments. We need to copy cl as otherwise
1857 cl->passed_length gets overwritten. */
1858 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1860 f->sym->ts.u.cl->passed_length = length;
1862 /* Use the passed value for assumed length variables. */
1863 if (!f->sym->ts.u.cl->length)
1865 TREE_USED (length) = 1;
1866 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1867 f->sym->ts.u.cl->backend_decl = length;
1870 hidden_typelist = TREE_CHAIN (hidden_typelist);
1872 if (f->sym->ts.u.cl->backend_decl == NULL
1873 || f->sym->ts.u.cl->backend_decl == length)
1875 if (f->sym->ts.u.cl->backend_decl == NULL)
1876 gfc_create_string_length (f->sym);
1878 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1879 if (f->sym->attr.flavor == FL_PROCEDURE)
1880 type = build_pointer_type (gfc_get_function_type (f->sym));
1882 type = gfc_sym_type (f->sym);
1886 /* For non-constant length array arguments, make sure they use
1887 a different type node from TYPE_ARG_TYPES type. */
1888 if (f->sym->attr.dimension
1889 && type == TREE_VALUE (typelist)
1890 && TREE_CODE (type) == POINTER_TYPE
1891 && GFC_ARRAY_TYPE_P (type)
1892 && f->sym->as->type != AS_ASSUMED_SIZE
1893 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1895 if (f->sym->attr.flavor == FL_PROCEDURE)
1896 type = build_pointer_type (gfc_get_function_type (f->sym));
1898 type = gfc_sym_type (f->sym);
1901 if (f->sym->attr.proc_pointer)
1902 type = build_pointer_type (type);
1904 /* Build the argument declaration. */
1905 parm = build_decl (input_location,
1906 PARM_DECL, gfc_sym_identifier (f->sym), type);
1908 /* Fill in arg stuff. */
1909 DECL_CONTEXT (parm) = fndecl;
1910 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1911 /* All implementation args are read-only. */
1912 TREE_READONLY (parm) = 1;
1913 if (POINTER_TYPE_P (type)
1914 && (!f->sym->attr.proc_pointer
1915 && f->sym->attr.flavor != FL_PROCEDURE))
1916 DECL_BY_REFERENCE (parm) = 1;
1918 gfc_finish_decl (parm);
1920 f->sym->backend_decl = parm;
1922 arglist = chainon (arglist, parm);
1923 typelist = TREE_CHAIN (typelist);
1926 /* Add the hidden string length parameters, unless the procedure
1928 if (!sym->attr.is_bind_c)
1929 arglist = chainon (arglist, hidden_arglist);
1931 gcc_assert (hidden_typelist == NULL_TREE
1932 || TREE_VALUE (hidden_typelist) == void_type_node);
1933 DECL_ARGUMENTS (fndecl) = arglist;
1936 /* Do the setup necessary before generating the body of a function. */
1939 trans_function_start (gfc_symbol * sym)
1943 fndecl = sym->backend_decl;
1945 /* Let GCC know the current scope is this function. */
1946 current_function_decl = fndecl;
1948 /* Let the world know what we're about to do. */
1949 announce_function (fndecl);
1951 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1953 /* Create RTL for function declaration. */
1954 rest_of_decl_compilation (fndecl, 1, 0);
1957 /* Create RTL for function definition. */
1958 make_decl_rtl (fndecl);
1960 init_function_start (fndecl);
1962 /* Even though we're inside a function body, we still don't want to
1963 call expand_expr to calculate the size of a variable-sized array.
1964 We haven't necessarily assigned RTL to all variables yet, so it's
1965 not safe to try to expand expressions involving them. */
1966 cfun->dont_save_pending_sizes_p = 1;
1968 /* function.c requires a push at the start of the function. */
1972 /* Create thunks for alternate entry points. */
1975 build_entry_thunks (gfc_namespace * ns)
1977 gfc_formal_arglist *formal;
1978 gfc_formal_arglist *thunk_formal;
1980 gfc_symbol *thunk_sym;
1988 /* This should always be a toplevel function. */
1989 gcc_assert (current_function_decl == NULL_TREE);
1991 gfc_get_backend_locus (&old_loc);
1992 for (el = ns->entries; el; el = el->next)
1994 thunk_sym = el->sym;
1996 build_function_decl (thunk_sym);
1997 create_function_arglist (thunk_sym);
1999 trans_function_start (thunk_sym);
2001 thunk_fndecl = thunk_sym->backend_decl;
2003 gfc_init_block (&body);
2005 /* Pass extra parameter identifying this entry point. */
2006 tmp = build_int_cst (gfc_array_index_type, el->id);
2007 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
2008 string_args = NULL_TREE;
2010 if (thunk_sym->attr.function)
2012 if (gfc_return_by_reference (ns->proc_name))
2014 tree ref = DECL_ARGUMENTS (current_function_decl);
2015 args = tree_cons (NULL_TREE, ref, args);
2016 if (ns->proc_name->ts.type == BT_CHARACTER)
2017 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
2022 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2024 /* Ignore alternate returns. */
2025 if (formal->sym == NULL)
2028 /* We don't have a clever way of identifying arguments, so resort to
2029 a brute-force search. */
2030 for (thunk_formal = thunk_sym->formal;
2032 thunk_formal = thunk_formal->next)
2034 if (thunk_formal->sym == formal->sym)
2040 /* Pass the argument. */
2041 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2042 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2044 if (formal->sym->ts.type == BT_CHARACTER)
2046 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2047 string_args = tree_cons (NULL_TREE, tmp, string_args);
2052 /* Pass NULL for a missing argument. */
2053 args = tree_cons (NULL_TREE, null_pointer_node, args);
2054 if (formal->sym->ts.type == BT_CHARACTER)
2056 tmp = build_int_cst (gfc_charlen_type_node, 0);
2057 string_args = tree_cons (NULL_TREE, tmp, string_args);
2062 /* Call the master function. */
2063 args = nreverse (args);
2064 args = chainon (args, nreverse (string_args));
2065 tmp = ns->proc_name->backend_decl;
2066 tmp = build_function_call_expr (input_location, tmp, args);
2067 if (ns->proc_name->attr.mixed_entry_master)
2069 tree union_decl, field;
2070 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2072 union_decl = build_decl (input_location,
2073 VAR_DECL, get_identifier ("__result"),
2074 TREE_TYPE (master_type));
2075 DECL_ARTIFICIAL (union_decl) = 1;
2076 DECL_EXTERNAL (union_decl) = 0;
2077 TREE_PUBLIC (union_decl) = 0;
2078 TREE_USED (union_decl) = 1;
2079 layout_decl (union_decl, 0);
2080 pushdecl (union_decl);
2082 DECL_CONTEXT (union_decl) = current_function_decl;
2083 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2085 gfc_add_expr_to_block (&body, tmp);
2087 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2088 field; field = TREE_CHAIN (field))
2089 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2090 thunk_sym->result->name) == 0)
2092 gcc_assert (field != NULL_TREE);
2093 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2094 union_decl, field, NULL_TREE);
2095 tmp = fold_build2 (MODIFY_EXPR,
2096 TREE_TYPE (DECL_RESULT (current_function_decl)),
2097 DECL_RESULT (current_function_decl), tmp);
2098 tmp = build1_v (RETURN_EXPR, tmp);
2100 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2103 tmp = fold_build2 (MODIFY_EXPR,
2104 TREE_TYPE (DECL_RESULT (current_function_decl)),
2105 DECL_RESULT (current_function_decl), tmp);
2106 tmp = build1_v (RETURN_EXPR, tmp);
2108 gfc_add_expr_to_block (&body, tmp);
2110 /* Finish off this function and send it for code generation. */
2111 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2114 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2115 DECL_SAVED_TREE (thunk_fndecl)
2116 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2117 DECL_INITIAL (thunk_fndecl));
2119 /* Output the GENERIC tree. */
2120 dump_function (TDI_original, thunk_fndecl);
2122 /* Store the end of the function, so that we get good line number
2123 info for the epilogue. */
2124 cfun->function_end_locus = input_location;
2126 /* We're leaving the context of this function, so zap cfun.
2127 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2128 tree_rest_of_compilation. */
2131 current_function_decl = NULL_TREE;
2133 cgraph_finalize_function (thunk_fndecl, true);
2135 /* We share the symbols in the formal argument list with other entry
2136 points and the master function. Clear them so that they are
2137 recreated for each function. */
2138 for (formal = thunk_sym->formal; formal; formal = formal->next)
2139 if (formal->sym != NULL) /* Ignore alternate returns. */
2141 formal->sym->backend_decl = NULL_TREE;
2142 if (formal->sym->ts.type == BT_CHARACTER)
2143 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2146 if (thunk_sym->attr.function)
2148 if (thunk_sym->ts.type == BT_CHARACTER)
2149 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2150 if (thunk_sym->result->ts.type == BT_CHARACTER)
2151 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2155 gfc_set_backend_locus (&old_loc);
2159 /* Create a decl for a function, and create any thunks for alternate entry
2163 gfc_create_function_decl (gfc_namespace * ns)
2165 /* Create a declaration for the master function. */
2166 build_function_decl (ns->proc_name);
2168 /* Compile the entry thunks. */
2170 build_entry_thunks (ns);
2172 /* Now create the read argument list. */
2173 create_function_arglist (ns->proc_name);
2176 /* Return the decl used to hold the function return value. If
2177 parent_flag is set, the context is the parent_scope. */
2180 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2184 tree this_fake_result_decl;
2185 tree this_function_decl;
2187 char name[GFC_MAX_SYMBOL_LEN + 10];
2191 this_fake_result_decl = parent_fake_result_decl;
2192 this_function_decl = DECL_CONTEXT (current_function_decl);
2196 this_fake_result_decl = current_fake_result_decl;
2197 this_function_decl = current_function_decl;
2201 && sym->ns->proc_name->backend_decl == this_function_decl
2202 && sym->ns->proc_name->attr.entry_master
2203 && sym != sym->ns->proc_name)
2206 if (this_fake_result_decl != NULL)
2207 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2208 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2211 return TREE_VALUE (t);
2212 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2215 this_fake_result_decl = parent_fake_result_decl;
2217 this_fake_result_decl = current_fake_result_decl;
2219 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2223 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2224 field; field = TREE_CHAIN (field))
2225 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2229 gcc_assert (field != NULL_TREE);
2230 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2231 decl, field, NULL_TREE);
2234 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2236 gfc_add_decl_to_parent_function (var);
2238 gfc_add_decl_to_function (var);
2240 SET_DECL_VALUE_EXPR (var, decl);
2241 DECL_HAS_VALUE_EXPR_P (var) = 1;
2242 GFC_DECL_RESULT (var) = 1;
2244 TREE_CHAIN (this_fake_result_decl)
2245 = tree_cons (get_identifier (sym->name), var,
2246 TREE_CHAIN (this_fake_result_decl));
2250 if (this_fake_result_decl != NULL_TREE)
2251 return TREE_VALUE (this_fake_result_decl);
2253 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2258 if (sym->ts.type == BT_CHARACTER)
2260 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2261 length = gfc_create_string_length (sym);
2263 length = sym->ts.u.cl->backend_decl;
2264 if (TREE_CODE (length) == VAR_DECL
2265 && DECL_CONTEXT (length) == NULL_TREE)
2266 gfc_add_decl_to_function (length);
2269 if (gfc_return_by_reference (sym))
2271 decl = DECL_ARGUMENTS (this_function_decl);
2273 if (sym->ns->proc_name->backend_decl == this_function_decl
2274 && sym->ns->proc_name->attr.entry_master)
2275 decl = TREE_CHAIN (decl);
2277 TREE_USED (decl) = 1;
2279 decl = gfc_build_dummy_array_decl (sym, decl);
2283 sprintf (name, "__result_%.20s",
2284 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2286 if (!sym->attr.mixed_entry_master && sym->attr.function)
2287 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2288 VAR_DECL, get_identifier (name),
2289 gfc_sym_type (sym));
2291 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2292 VAR_DECL, get_identifier (name),
2293 TREE_TYPE (TREE_TYPE (this_function_decl)));
2294 DECL_ARTIFICIAL (decl) = 1;
2295 DECL_EXTERNAL (decl) = 0;
2296 TREE_PUBLIC (decl) = 0;
2297 TREE_USED (decl) = 1;
2298 GFC_DECL_RESULT (decl) = 1;
2299 TREE_ADDRESSABLE (decl) = 1;
2301 layout_decl (decl, 0);
2304 gfc_add_decl_to_parent_function (decl);
2306 gfc_add_decl_to_function (decl);
2310 parent_fake_result_decl = build_tree_list (NULL, decl);
2312 current_fake_result_decl = build_tree_list (NULL, decl);
2318 /* Builds a function decl. The remaining parameters are the types of the
2319 function arguments. Negative nargs indicates a varargs function. */
2322 build_library_function_decl_1 (tree name, const char *spec,
2323 tree rettype, int nargs, va_list p)
2331 /* Library functions must be declared with global scope. */
2332 gcc_assert (current_function_decl == NULL_TREE);
2334 /* Create a list of the argument types. */
2335 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2337 argtype = va_arg (p, tree);
2338 arglist = gfc_chainon_list (arglist, argtype);
2343 /* Terminate the list. */
2344 arglist = gfc_chainon_list (arglist, void_type_node);
2347 /* Build the function type and decl. */
2348 fntype = build_function_type (rettype, arglist);
2351 tree attr_args = build_tree_list (NULL_TREE,
2352 build_string (strlen (spec), spec));
2353 tree attrs = tree_cons (get_identifier ("fn spec"),
2354 attr_args, TYPE_ATTRIBUTES (fntype));
2355 fntype = build_type_attribute_variant (fntype, attrs);
2357 fndecl = build_decl (input_location,
2358 FUNCTION_DECL, name, fntype);
2360 /* Mark this decl as external. */
2361 DECL_EXTERNAL (fndecl) = 1;
2362 TREE_PUBLIC (fndecl) = 1;
2366 rest_of_decl_compilation (fndecl, 1, 0);
2371 /* Builds a function decl. The remaining parameters are the types of the
2372 function arguments. Negative nargs indicates a varargs function. */
2375 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2379 va_start (args, nargs);
2380 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2385 /* Builds a function decl. The remaining parameters are the types of the
2386 function arguments. Negative nargs indicates a varargs function.
2387 The SPEC parameter specifies the function argument and return type
2388 specification according to the fnspec function type attribute. */
2391 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2392 tree rettype, int nargs, ...)
2396 va_start (args, nargs);
2397 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2403 gfc_build_intrinsic_function_decls (void)
2405 tree gfc_int4_type_node = gfc_get_int_type (4);
2406 tree gfc_int8_type_node = gfc_get_int_type (8);
2407 tree gfc_int16_type_node = gfc_get_int_type (16);
2408 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2409 tree pchar1_type_node = gfc_get_pchar_type (1);
2410 tree pchar4_type_node = gfc_get_pchar_type (4);
2412 /* String functions. */
2413 gfor_fndecl_compare_string =
2414 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2415 integer_type_node, 4,
2416 gfc_charlen_type_node, pchar1_type_node,
2417 gfc_charlen_type_node, pchar1_type_node);
2419 gfor_fndecl_concat_string =
2420 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2422 gfc_charlen_type_node, pchar1_type_node,
2423 gfc_charlen_type_node, pchar1_type_node,
2424 gfc_charlen_type_node, pchar1_type_node);
2426 gfor_fndecl_string_len_trim =
2427 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2428 gfc_int4_type_node, 2,
2429 gfc_charlen_type_node, pchar1_type_node);
2431 gfor_fndecl_string_index =
2432 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2433 gfc_int4_type_node, 5,
2434 gfc_charlen_type_node, pchar1_type_node,
2435 gfc_charlen_type_node, pchar1_type_node,
2436 gfc_logical4_type_node);
2438 gfor_fndecl_string_scan =
2439 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2440 gfc_int4_type_node, 5,
2441 gfc_charlen_type_node, pchar1_type_node,
2442 gfc_charlen_type_node, pchar1_type_node,
2443 gfc_logical4_type_node);
2445 gfor_fndecl_string_verify =
2446 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2447 gfc_int4_type_node, 5,
2448 gfc_charlen_type_node, pchar1_type_node,
2449 gfc_charlen_type_node, pchar1_type_node,
2450 gfc_logical4_type_node);
2452 gfor_fndecl_string_trim =
2453 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2455 build_pointer_type (gfc_charlen_type_node),
2456 build_pointer_type (pchar1_type_node),
2457 gfc_charlen_type_node, pchar1_type_node);
2459 gfor_fndecl_string_minmax =
2460 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2462 build_pointer_type (gfc_charlen_type_node),
2463 build_pointer_type (pchar1_type_node),
2464 integer_type_node, integer_type_node);
2466 gfor_fndecl_adjustl =
2467 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2468 void_type_node, 3, pchar1_type_node,
2469 gfc_charlen_type_node, pchar1_type_node);
2471 gfor_fndecl_adjustr =
2472 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2473 void_type_node, 3, pchar1_type_node,
2474 gfc_charlen_type_node, pchar1_type_node);
2476 gfor_fndecl_select_string =
2477 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2478 integer_type_node, 4, pvoid_type_node,
2479 integer_type_node, pchar1_type_node,
2480 gfc_charlen_type_node);
2482 gfor_fndecl_compare_string_char4 =
2483 gfc_build_library_function_decl (get_identifier
2484 (PREFIX("compare_string_char4")),
2485 integer_type_node, 4,
2486 gfc_charlen_type_node, pchar4_type_node,
2487 gfc_charlen_type_node, pchar4_type_node);
2489 gfor_fndecl_concat_string_char4 =
2490 gfc_build_library_function_decl (get_identifier
2491 (PREFIX("concat_string_char4")),
2493 gfc_charlen_type_node, pchar4_type_node,
2494 gfc_charlen_type_node, pchar4_type_node,
2495 gfc_charlen_type_node, pchar4_type_node);
2497 gfor_fndecl_string_len_trim_char4 =
2498 gfc_build_library_function_decl (get_identifier
2499 (PREFIX("string_len_trim_char4")),
2500 gfc_charlen_type_node, 2,
2501 gfc_charlen_type_node, pchar4_type_node);
2503 gfor_fndecl_string_index_char4 =
2504 gfc_build_library_function_decl (get_identifier
2505 (PREFIX("string_index_char4")),
2506 gfc_charlen_type_node, 5,
2507 gfc_charlen_type_node, pchar4_type_node,
2508 gfc_charlen_type_node, pchar4_type_node,
2509 gfc_logical4_type_node);
2511 gfor_fndecl_string_scan_char4 =
2512 gfc_build_library_function_decl (get_identifier
2513 (PREFIX("string_scan_char4")),
2514 gfc_charlen_type_node, 5,
2515 gfc_charlen_type_node, pchar4_type_node,
2516 gfc_charlen_type_node, pchar4_type_node,
2517 gfc_logical4_type_node);
2519 gfor_fndecl_string_verify_char4 =
2520 gfc_build_library_function_decl (get_identifier
2521 (PREFIX("string_verify_char4")),
2522 gfc_charlen_type_node, 5,
2523 gfc_charlen_type_node, pchar4_type_node,
2524 gfc_charlen_type_node, pchar4_type_node,
2525 gfc_logical4_type_node);
2527 gfor_fndecl_string_trim_char4 =
2528 gfc_build_library_function_decl (get_identifier
2529 (PREFIX("string_trim_char4")),
2531 build_pointer_type (gfc_charlen_type_node),
2532 build_pointer_type (pchar4_type_node),
2533 gfc_charlen_type_node, pchar4_type_node);
2535 gfor_fndecl_string_minmax_char4 =
2536 gfc_build_library_function_decl (get_identifier
2537 (PREFIX("string_minmax_char4")),
2539 build_pointer_type (gfc_charlen_type_node),
2540 build_pointer_type (pchar4_type_node),
2541 integer_type_node, integer_type_node);
2543 gfor_fndecl_adjustl_char4 =
2544 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2545 void_type_node, 3, pchar4_type_node,
2546 gfc_charlen_type_node, pchar4_type_node);
2548 gfor_fndecl_adjustr_char4 =
2549 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2550 void_type_node, 3, pchar4_type_node,
2551 gfc_charlen_type_node, pchar4_type_node);
2553 gfor_fndecl_select_string_char4 =
2554 gfc_build_library_function_decl (get_identifier
2555 (PREFIX("select_string_char4")),
2556 integer_type_node, 4, pvoid_type_node,
2557 integer_type_node, pvoid_type_node,
2558 gfc_charlen_type_node);
2561 /* Conversion between character kinds. */
2563 gfor_fndecl_convert_char1_to_char4 =
2564 gfc_build_library_function_decl (get_identifier
2565 (PREFIX("convert_char1_to_char4")),
2567 build_pointer_type (pchar4_type_node),
2568 gfc_charlen_type_node, pchar1_type_node);
2570 gfor_fndecl_convert_char4_to_char1 =
2571 gfc_build_library_function_decl (get_identifier
2572 (PREFIX("convert_char4_to_char1")),
2574 build_pointer_type (pchar1_type_node),
2575 gfc_charlen_type_node, pchar4_type_node);
2577 /* Misc. functions. */
2579 gfor_fndecl_ttynam =
2580 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2584 gfc_charlen_type_node,
2588 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2592 gfc_charlen_type_node);
2595 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2599 gfc_charlen_type_node,
2600 gfc_int8_type_node);
2602 gfor_fndecl_sc_kind =
2603 gfc_build_library_function_decl (get_identifier
2604 (PREFIX("selected_char_kind")),
2605 gfc_int4_type_node, 2,
2606 gfc_charlen_type_node, pchar_type_node);
2608 gfor_fndecl_si_kind =
2609 gfc_build_library_function_decl (get_identifier
2610 (PREFIX("selected_int_kind")),
2611 gfc_int4_type_node, 1, pvoid_type_node);
2613 gfor_fndecl_sr_kind =
2614 gfc_build_library_function_decl (get_identifier
2615 (PREFIX("selected_real_kind")),
2616 gfc_int4_type_node, 2,
2617 pvoid_type_node, pvoid_type_node);
2619 /* Power functions. */
2621 tree ctype, rtype, itype, jtype;
2622 int rkind, ikind, jkind;
2625 static int ikinds[NIKINDS] = {4, 8, 16};
2626 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2627 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2629 for (ikind=0; ikind < NIKINDS; ikind++)
2631 itype = gfc_get_int_type (ikinds[ikind]);
2633 for (jkind=0; jkind < NIKINDS; jkind++)
2635 jtype = gfc_get_int_type (ikinds[jkind]);
2638 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2640 gfor_fndecl_math_powi[jkind][ikind].integer =
2641 gfc_build_library_function_decl (get_identifier (name),
2642 jtype, 2, jtype, itype);
2643 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2647 for (rkind = 0; rkind < NRKINDS; rkind ++)
2649 rtype = gfc_get_real_type (rkinds[rkind]);
2652 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2654 gfor_fndecl_math_powi[rkind][ikind].real =
2655 gfc_build_library_function_decl (get_identifier (name),
2656 rtype, 2, rtype, itype);
2657 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2660 ctype = gfc_get_complex_type (rkinds[rkind]);
2663 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2665 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2666 gfc_build_library_function_decl (get_identifier (name),
2667 ctype, 2,ctype, itype);
2668 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2676 gfor_fndecl_math_ishftc4 =
2677 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2679 3, gfc_int4_type_node,
2680 gfc_int4_type_node, gfc_int4_type_node);
2681 gfor_fndecl_math_ishftc8 =
2682 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2684 3, gfc_int8_type_node,
2685 gfc_int4_type_node, gfc_int4_type_node);
2686 if (gfc_int16_type_node)
2687 gfor_fndecl_math_ishftc16 =
2688 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2689 gfc_int16_type_node, 3,
2690 gfc_int16_type_node,
2692 gfc_int4_type_node);
2694 /* BLAS functions. */
2696 tree pint = build_pointer_type (integer_type_node);
2697 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2698 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2699 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2700 tree pz = build_pointer_type
2701 (gfc_get_complex_type (gfc_default_double_kind));
2703 gfor_fndecl_sgemm = gfc_build_library_function_decl
2705 (gfc_option.flag_underscoring ? "sgemm_"
2707 void_type_node, 15, pchar_type_node,
2708 pchar_type_node, pint, pint, pint, ps, ps, pint,
2709 ps, pint, ps, ps, pint, integer_type_node,
2711 gfor_fndecl_dgemm = gfc_build_library_function_decl
2713 (gfc_option.flag_underscoring ? "dgemm_"
2715 void_type_node, 15, pchar_type_node,
2716 pchar_type_node, pint, pint, pint, pd, pd, pint,
2717 pd, pint, pd, pd, pint, integer_type_node,
2719 gfor_fndecl_cgemm = gfc_build_library_function_decl
2721 (gfc_option.flag_underscoring ? "cgemm_"
2723 void_type_node, 15, pchar_type_node,
2724 pchar_type_node, pint, pint, pint, pc, pc, pint,
2725 pc, pint, pc, pc, pint, integer_type_node,
2727 gfor_fndecl_zgemm = gfc_build_library_function_decl
2729 (gfc_option.flag_underscoring ? "zgemm_"
2731 void_type_node, 15, pchar_type_node,
2732 pchar_type_node, pint, pint, pint, pz, pz, pint,
2733 pz, pint, pz, pz, pint, integer_type_node,
2737 /* Other functions. */
2739 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2740 gfc_array_index_type,
2741 1, pvoid_type_node);
2743 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2744 gfc_array_index_type,
2746 gfc_array_index_type);
2749 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2753 if (gfc_type_for_size (128, true))
2755 tree uint128 = gfc_type_for_size (128, true);
2757 gfor_fndecl_clz128 =
2758 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2759 integer_type_node, 1, uint128);
2761 gfor_fndecl_ctz128 =
2762 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2763 integer_type_node, 1, uint128);
2768 /* Make prototypes for runtime library functions. */
2771 gfc_build_builtin_function_decls (void)
2773 tree gfc_int4_type_node = gfc_get_int_type (4);
2775 gfor_fndecl_stop_numeric =
2776 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2777 void_type_node, 1, gfc_int4_type_node);
2778 /* STOP doesn't return. */
2779 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2782 gfor_fndecl_stop_string =
2783 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2784 void_type_node, 2, pchar_type_node,
2785 gfc_int4_type_node);
2786 /* STOP doesn't return. */
2787 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2790 gfor_fndecl_error_stop_numeric =
2791 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_numeric")),
2792 void_type_node, 1, gfc_int4_type_node);
2793 /* ERROR STOP doesn't return. */
2794 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2797 gfor_fndecl_error_stop_string =
2798 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2799 void_type_node, 2, pchar_type_node,
2800 gfc_int4_type_node);
2801 /* ERROR STOP doesn't return. */
2802 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2805 gfor_fndecl_pause_numeric =
2806 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2807 void_type_node, 1, gfc_int4_type_node);
2809 gfor_fndecl_pause_string =
2810 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2811 void_type_node, 2, pchar_type_node,
2812 gfc_int4_type_node);
2814 gfor_fndecl_runtime_error =
2815 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2816 void_type_node, -1, pchar_type_node);
2817 /* The runtime_error function does not return. */
2818 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2820 gfor_fndecl_runtime_error_at =
2821 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2822 void_type_node, -2, pchar_type_node,
2824 /* The runtime_error_at function does not return. */
2825 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2827 gfor_fndecl_runtime_warning_at =
2828 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2829 void_type_node, -2, pchar_type_node,
2831 gfor_fndecl_generate_error =
2832 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2833 void_type_node, 3, pvoid_type_node,
2834 integer_type_node, pchar_type_node);
2836 gfor_fndecl_os_error =
2837 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2838 void_type_node, 1, pchar_type_node);
2839 /* The runtime_error function does not return. */
2840 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2842 gfor_fndecl_set_args =
2843 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2844 void_type_node, 2, integer_type_node,
2845 build_pointer_type (pchar_type_node));
2847 gfor_fndecl_set_fpe =
2848 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2849 void_type_node, 1, integer_type_node);
2851 /* Keep the array dimension in sync with the call, later in this file. */
2852 gfor_fndecl_set_options =
2853 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2854 void_type_node, 2, integer_type_node,
2855 build_pointer_type (integer_type_node));
2857 gfor_fndecl_set_convert =
2858 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2859 void_type_node, 1, integer_type_node);
2861 gfor_fndecl_set_record_marker =
2862 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2863 void_type_node, 1, integer_type_node);
2865 gfor_fndecl_set_max_subrecord_length =
2866 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2867 void_type_node, 1, integer_type_node);
2869 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2870 get_identifier (PREFIX("internal_pack")), ".r",
2871 pvoid_type_node, 1, pvoid_type_node);
2873 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2874 get_identifier (PREFIX("internal_unpack")), ".wR",
2875 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2877 gfor_fndecl_associated =
2878 gfc_build_library_function_decl (
2879 get_identifier (PREFIX("associated")),
2880 integer_type_node, 2, ppvoid_type_node,
2883 gfc_build_intrinsic_function_decls ();
2884 gfc_build_intrinsic_lib_fndecls ();
2885 gfc_build_io_library_fndecls ();
2889 /* Evaluate the length of dummy character variables. */
2892 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2896 gfc_finish_decl (cl->backend_decl);
2898 gfc_start_block (&body);
2900 /* Evaluate the string length expression. */
2901 gfc_conv_string_length (cl, NULL, &body);
2903 gfc_trans_vla_type_sizes (sym, &body);
2905 gfc_add_expr_to_block (&body, fnbody);
2906 return gfc_finish_block (&body);
2910 /* Allocate and cleanup an automatic character variable. */
2913 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2919 gcc_assert (sym->backend_decl);
2920 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2922 gfc_start_block (&body);
2924 /* Evaluate the string length expression. */
2925 gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2927 gfc_trans_vla_type_sizes (sym, &body);
2929 decl = sym->backend_decl;
2931 /* Emit a DECL_EXPR for this variable, which will cause the
2932 gimplifier to allocate storage, and all that good stuff. */
2933 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2934 gfc_add_expr_to_block (&body, tmp);
2936 gfc_add_expr_to_block (&body, fnbody);
2937 return gfc_finish_block (&body);
2940 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2943 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2947 gcc_assert (sym->backend_decl);
2948 gfc_start_block (&body);
2950 /* Set the initial value to length. See the comments in
2951 function gfc_add_assign_aux_vars in this file. */
2952 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2953 build_int_cst (NULL_TREE, -2));
2955 gfc_add_expr_to_block (&body, fnbody);
2956 return gfc_finish_block (&body);
2960 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2962 tree t = *tp, var, val;
2964 if (t == NULL || t == error_mark_node)
2966 if (TREE_CONSTANT (t) || DECL_P (t))
2969 if (TREE_CODE (t) == SAVE_EXPR)
2971 if (SAVE_EXPR_RESOLVED_P (t))
2973 *tp = TREE_OPERAND (t, 0);
2976 val = TREE_OPERAND (t, 0);
2981 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2982 gfc_add_decl_to_function (var);
2983 gfc_add_modify (body, var, val);
2984 if (TREE_CODE (t) == SAVE_EXPR)
2985 TREE_OPERAND (t, 0) = var;
2990 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2994 if (type == NULL || type == error_mark_node)
2997 type = TYPE_MAIN_VARIANT (type);
2999 if (TREE_CODE (type) == INTEGER_TYPE)
3001 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3002 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3004 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3006 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3007 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3010 else if (TREE_CODE (type) == ARRAY_TYPE)
3012 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3013 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3014 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3015 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3017 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3019 TYPE_SIZE (t) = TYPE_SIZE (type);
3020 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3025 /* Make sure all type sizes and array domains are either constant,
3026 or variable or parameter decls. This is a simplified variant
3027 of gimplify_type_sizes, but we can't use it here, as none of the
3028 variables in the expressions have been gimplified yet.
3029 As type sizes and domains for various variable length arrays
3030 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3031 time, without this routine gimplify_type_sizes in the middle-end
3032 could result in the type sizes being gimplified earlier than where
3033 those variables are initialized. */
3036 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3038 tree type = TREE_TYPE (sym->backend_decl);
3040 if (TREE_CODE (type) == FUNCTION_TYPE
3041 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3043 if (! current_fake_result_decl)
3046 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3049 while (POINTER_TYPE_P (type))
3050 type = TREE_TYPE (type);
3052 if (GFC_DESCRIPTOR_TYPE_P (type))
3054 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3056 while (POINTER_TYPE_P (etype))
3057 etype = TREE_TYPE (etype);
3059 gfc_trans_vla_type_sizes_1 (etype, body);
3062 gfc_trans_vla_type_sizes_1 (type, body);
3066 /* Initialize a derived type by building an lvalue from the symbol
3067 and using trans_assignment to do the work. Set dealloc to false
3068 if no deallocation prior the assignment is needed. */
3070 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3072 stmtblock_t fnblock;
3077 gfc_init_block (&fnblock);
3078 gcc_assert (!sym->attr.allocatable);
3079 gfc_set_sym_referenced (sym);
3080 e = gfc_lval_expr_from_sym (sym);
3081 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3082 if (sym->attr.dummy && (sym->attr.optional
3083 || sym->ns->proc_name->attr.entry_master))
3085 present = gfc_conv_expr_present (sym);
3086 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3087 tmp, build_empty_stmt (input_location));
3089 gfc_add_expr_to_block (&fnblock, tmp);
3092 gfc_add_expr_to_block (&fnblock, body);
3093 return gfc_finish_block (&fnblock);
3097 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3098 them their default initializer, if they do not have allocatable
3099 components, they have their allocatable components deallocated. */
3102 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3104 stmtblock_t fnblock;
3105 gfc_formal_arglist *f;
3109 gfc_init_block (&fnblock);
3110 for (f = proc_sym->formal; f; f = f->next)
3111 if (f->sym && f->sym->attr.intent == INTENT_OUT
3112 && !f->sym->attr.pointer
3113 && f->sym->ts.type == BT_DERIVED)
3115 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3117 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3118 f->sym->backend_decl,
3119 f->sym->as ? f->sym->as->rank : 0);
3121 if (f->sym->attr.optional
3122 || f->sym->ns->proc_name->attr.entry_master)
3124 present = gfc_conv_expr_present (f->sym);
3125 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3126 tmp, build_empty_stmt (input_location));
3129 gfc_add_expr_to_block (&fnblock, tmp);
3131 else if (f->sym->value)
3132 body = gfc_init_default_dt (f->sym, body, true);
3135 gfc_add_expr_to_block (&fnblock, body);
3136 return gfc_finish_block (&fnblock);
3140 /* Generate function entry and exit code, and add it to the function body.
3142 Allocation and initialization of array variables.
3143 Allocation of character string variables.
3144 Initialization and possibly repacking of dummy arrays.
3145 Initialization of ASSIGN statement auxiliary variable.
3146 Automatic deallocation. */
3149 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3153 gfc_formal_arglist *f;
3155 bool seen_trans_deferred_array = false;
3157 /* Deal with implicit return variables. Explicit return variables will
3158 already have been added. */
3159 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3161 if (!current_fake_result_decl)
3163 gfc_entry_list *el = NULL;
3164 if (proc_sym->attr.entry_master)
3166 for (el = proc_sym->ns->entries; el; el = el->next)
3167 if (el->sym != el->sym->result)
3170 /* TODO: move to the appropriate place in resolve.c. */
3171 if (warn_return_type && el == NULL)
3172 gfc_warning ("Return value of function '%s' at %L not set",
3173 proc_sym->name, &proc_sym->declared_at);
3175 else if (proc_sym->as)
3177 tree result = TREE_VALUE (current_fake_result_decl);
3178 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3180 /* An automatic character length, pointer array result. */
3181 if (proc_sym->ts.type == BT_CHARACTER
3182 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3183 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3186 else if (proc_sym->ts.type == BT_CHARACTER)
3188 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3189 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3193 gcc_assert (gfc_option.flag_f2c
3194 && proc_sym->ts.type == BT_COMPLEX);
3197 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3198 should be done here so that the offsets and lbounds of arrays
3200 fnbody = init_intent_out_dt (proc_sym, fnbody);
3202 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3204 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3205 && sym->ts.u.derived->attr.alloc_comp;
3206 if (sym->attr.dimension)
3208 switch (sym->as->type)
3211 if (sym->attr.dummy || sym->attr.result)
3213 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3214 else if (sym->attr.pointer || sym->attr.allocatable)
3216 if (TREE_STATIC (sym->backend_decl))
3217 gfc_trans_static_array_pointer (sym);
3220 seen_trans_deferred_array = true;
3221 fnbody = gfc_trans_deferred_array (sym, fnbody);
3226 if (sym_has_alloc_comp)
3228 seen_trans_deferred_array = true;
3229 fnbody = gfc_trans_deferred_array (sym, fnbody);
3231 else if (sym->ts.type == BT_DERIVED
3234 && sym->attr.save == SAVE_NONE)
3235 fnbody = gfc_init_default_dt (sym, fnbody, false);
3237 gfc_get_backend_locus (&loc);
3238 gfc_set_backend_locus (&sym->declared_at);
3239 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3241 gfc_set_backend_locus (&loc);
3245 case AS_ASSUMED_SIZE:
3246 /* Must be a dummy parameter. */
3247 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3249 /* We should always pass assumed size arrays the g77 way. */
3250 if (sym->attr.dummy)
3251 fnbody = gfc_trans_g77_array (sym, fnbody);
3254 case AS_ASSUMED_SHAPE:
3255 /* Must be a dummy parameter. */
3256 gcc_assert (sym->attr.dummy);
3258 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3263 seen_trans_deferred_array = true;
3264 fnbody = gfc_trans_deferred_array (sym, fnbody);
3270 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3271 fnbody = gfc_trans_deferred_array (sym, fnbody);
3273 else if (sym->attr.allocatable
3274 || (sym->ts.type == BT_CLASS
3275 && sym->ts.u.derived->components->attr.allocatable))
3277 if (!sym->attr.save)
3279 /* Nullify and automatic deallocation of allocatable
3286 e = gfc_lval_expr_from_sym (sym);
3287 if (sym->ts.type == BT_CLASS)
3288 gfc_add_component_ref (e, "$data");
3290 gfc_init_se (&se, NULL);
3291 se.want_pointer = 1;
3292 gfc_conv_expr (&se, e);
3295 /* Nullify when entering the scope. */
3296 gfc_start_block (&block);
3297 gfc_add_modify (&block, se.expr,
3298 fold_convert (TREE_TYPE (se.expr),
3299 null_pointer_node));
3300 gfc_add_expr_to_block (&block, fnbody);
3302 /* Deallocate when leaving the scope. Nullifying is not
3304 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3306 gfc_add_expr_to_block (&block, tmp);
3307 fnbody = gfc_finish_block (&block);
3310 else if (sym_has_alloc_comp)
3311 fnbody = gfc_trans_deferred_array (sym, fnbody);
3312 else if (sym->ts.type == BT_CHARACTER)
3314 gfc_get_backend_locus (&loc);
3315 gfc_set_backend_locus (&sym->declared_at);
3316 if (sym->attr.dummy || sym->attr.result)
3317 fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3319 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3320 gfc_set_backend_locus (&loc);
3322 else if (sym->attr.assign)
3324 gfc_get_backend_locus (&loc);
3325 gfc_set_backend_locus (&sym->declared_at);
3326 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3327 gfc_set_backend_locus (&loc);
3329 else if (sym->ts.type == BT_DERIVED
3332 && sym->attr.save == SAVE_NONE)
3333 fnbody = gfc_init_default_dt (sym, fnbody, false);
3338 gfc_init_block (&body);
3340 for (f = proc_sym->formal; f; f = f->next)
3342 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3344 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3345 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3346 gfc_trans_vla_type_sizes (f->sym, &body);
3350 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3351 && current_fake_result_decl != NULL)
3353 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3354 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3355 gfc_trans_vla_type_sizes (proc_sym, &body);
3358 gfc_add_expr_to_block (&body, fnbody);
3359 return gfc_finish_block (&body);
3362 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3364 /* Hash and equality functions for module_htab. */
3367 module_htab_do_hash (const void *x)
3369 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3373 module_htab_eq (const void *x1, const void *x2)
3375 return strcmp ((((const struct module_htab_entry *)x1)->name),
3376 (const char *)x2) == 0;
3379 /* Hash and equality functions for module_htab's decls. */
3382 module_htab_decls_hash (const void *x)
3384 const_tree t = (const_tree) x;
3385 const_tree n = DECL_NAME (t);
3387 n = TYPE_NAME (TREE_TYPE (t));
3388 return htab_hash_string (IDENTIFIER_POINTER (n));
3392 module_htab_decls_eq (const void *x1, const void *x2)
3394 const_tree t1 = (const_tree) x1;
3395 const_tree n1 = DECL_NAME (t1);
3396 if (n1 == NULL_TREE)
3397 n1 = TYPE_NAME (TREE_TYPE (t1));
3398 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3401 struct module_htab_entry *
3402 gfc_find_module (const char *name)
3407 module_htab = htab_create_ggc (10, module_htab_do_hash,
3408 module_htab_eq, NULL);
3410 slot = htab_find_slot_with_hash (module_htab, name,
3411 htab_hash_string (name), INSERT);
3414 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3416 entry->name = gfc_get_string (name);
3417 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3418 module_htab_decls_eq, NULL);
3419 *slot = (void *) entry;
3421 return (struct module_htab_entry *) *slot;
3425 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3430 if (DECL_NAME (decl))
3431 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3434 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3435 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3437 slot = htab_find_slot_with_hash (entry->decls, name,
3438 htab_hash_string (name), INSERT);
3440 *slot = (void *) decl;
3443 static struct module_htab_entry *cur_module;
3445 /* Output an initialized decl for a module variable. */
3448 gfc_create_module_variable (gfc_symbol * sym)
3452 /* Module functions with alternate entries are dealt with later and
3453 would get caught by the next condition. */
3454 if (sym->attr.entry)
3457 /* Make sure we convert the types of the derived types from iso_c_binding
3459 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3460 && sym->ts.type == BT_DERIVED)
3461 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3463 if (sym->attr.flavor == FL_DERIVED
3464 && sym->backend_decl
3465 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3467 decl = sym->backend_decl;
3468 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3470 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3471 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3473 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3474 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3475 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3476 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3477 == sym->ns->proc_name->backend_decl);
3479 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3480 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3481 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3484 /* Only output variables, procedure pointers and array valued,
3485 or derived type, parameters. */
3486 if (sym->attr.flavor != FL_VARIABLE
3487 && !(sym->attr.flavor == FL_PARAMETER
3488 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3489 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3492 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3494 decl = sym->backend_decl;
3495 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3496 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3497 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3498 gfc_module_add_decl (cur_module, decl);
3501 /* Don't generate variables from other modules. Variables from
3502 COMMONs will already have been generated. */
3503 if (sym->attr.use_assoc || sym->attr.in_common)
3506 /* Equivalenced variables arrive here after creation. */
3507 if (sym->backend_decl
3508 && (sym->equiv_built || sym->attr.in_equivalence))
3511 if (sym->backend_decl && !sym->attr.vtab)
3512 internal_error ("backend decl for module variable %s already exists",
3515 /* We always want module variables to be created. */
3516 sym->attr.referenced = 1;
3517 /* Create the decl. */
3518 decl = gfc_get_symbol_decl (sym);
3520 /* Create the variable. */
3522 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3523 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3524 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3525 rest_of_decl_compilation (decl, 1, 0);
3526 gfc_module_add_decl (cur_module, decl);
3528 /* Also add length of strings. */
3529 if (sym->ts.type == BT_CHARACTER)
3533 length = sym->ts.u.cl->backend_decl;
3534 gcc_assert (length || sym->attr.proc_pointer);
3535 if (length && !INTEGER_CST_P (length))
3538 rest_of_decl_compilation (length, 1, 0);
3543 /* Emit debug information for USE statements. */
3546 gfc_trans_use_stmts (gfc_namespace * ns)
3548 gfc_use_list *use_stmt;
3549 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3551 struct module_htab_entry *entry
3552 = gfc_find_module (use_stmt->module_name);
3553 gfc_use_rename *rent;
3555 if (entry->namespace_decl == NULL)
3557 entry->namespace_decl
3558 = build_decl (input_location,
3560 get_identifier (use_stmt->module_name),
3562 DECL_EXTERNAL (entry->namespace_decl) = 1;
3564 gfc_set_backend_locus (&use_stmt->where);
3565 if (!use_stmt->only_flag)
3566 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3568 ns->proc_name->backend_decl,
3570 for (rent = use_stmt->rename; rent; rent = rent->next)
3572 tree decl, local_name;
3575 if (rent->op != INTRINSIC_NONE)
3578 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3579 htab_hash_string (rent->use_name),
3585 st = gfc_find_symtree (ns->sym_root,
3587 ? rent->local_name : rent->use_name);
3590 /* Sometimes, generic interfaces wind up being over-ruled by a
3591 local symbol (see PR41062). */
3592 if (!st->n.sym->attr.use_assoc)
3595 if (st->n.sym->backend_decl
3596 && DECL_P (st->n.sym->backend_decl)
3597 && st->n.sym->module
3598 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3600 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3601 || (TREE_CODE (st->n.sym->backend_decl)
3603 decl = copy_node (st->n.sym->backend_decl);
3604 DECL_CONTEXT (decl) = entry->namespace_decl;
3605 DECL_EXTERNAL (decl) = 1;
3606 DECL_IGNORED_P (decl) = 0;
3607 DECL_INITIAL (decl) = NULL_TREE;
3611 *slot = error_mark_node;
3612 htab_clear_slot (entry->decls, slot);
3617 decl = (tree) *slot;
3618 if (rent->local_name[0])
3619 local_name = get_identifier (rent->local_name);
3621 local_name = NULL_TREE;
3622 gfc_set_backend_locus (&rent->where);
3623 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3624 ns->proc_name->backend_decl,
3625 !use_stmt->only_flag);
3631 /* Return true if expr is a constant initializer that gfc_conv_initializer
3635 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3645 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3647 else if (expr->expr_type == EXPR_STRUCTURE)
3648 return check_constant_initializer (expr, ts, false, false);
3649 else if (expr->expr_type != EXPR_ARRAY)
3651 for (c = gfc_constructor_first (expr->value.constructor);
3652 c; c = gfc_constructor_next (c))
3656 if (c->expr->expr_type == EXPR_STRUCTURE)
3658 if (!check_constant_initializer (c->expr, ts, false, false))
3661 else if (c->expr->expr_type != EXPR_CONSTANT)
3666 else switch (ts->type)
3669 if (expr->expr_type != EXPR_STRUCTURE)
3671 cm = expr->ts.u.derived->components;
3672 for (c = gfc_constructor_first (expr->value.constructor);
3673 c; c = gfc_constructor_next (c), cm = cm->next)
3675 if (!c->expr || cm->attr.allocatable)
3677 if (!check_constant_initializer (c->expr, &cm->ts,
3684 return expr->expr_type == EXPR_CONSTANT;
3688 /* Emit debug info for parameters and unreferenced variables with
3692 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3696 if (sym->attr.flavor != FL_PARAMETER
3697 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3700 if (sym->backend_decl != NULL
3701 || sym->value == NULL
3702 || sym->attr.use_assoc
3705 || sym->attr.function
3706 || sym->attr.intrinsic
3707 || sym->attr.pointer
3708 || sym->attr.allocatable
3709 || sym->attr.cray_pointee
3710 || sym->attr.threadprivate
3711 || sym->attr.is_bind_c
3712 || sym->attr.subref_array_pointer
3713 || sym->attr.assign)
3716 if (sym->ts.type == BT_CHARACTER)
3718 gfc_conv_const_charlen (sym->ts.u.cl);
3719 if (sym->ts.u.cl->backend_decl == NULL
3720 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3723 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3730 if (sym->as->type != AS_EXPLICIT)
3732 for (n = 0; n < sym->as->rank; n++)
3733 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3734 || sym->as->upper[n] == NULL
3735 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3739 if (!check_constant_initializer (sym->value, &sym->ts,
3740 sym->attr.dimension, false))
3743 /* Create the decl for the variable or constant. */
3744 decl = build_decl (input_location,
3745 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3746 gfc_sym_identifier (sym), gfc_sym_type (sym));
3747 if (sym->attr.flavor == FL_PARAMETER)
3748 TREE_READONLY (decl) = 1;
3749 gfc_set_decl_location (decl, &sym->declared_at);
3750 if (sym->attr.dimension)
3751 GFC_DECL_PACKED_ARRAY (decl) = 1;
3752 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3753 TREE_STATIC (decl) = 1;
3754 TREE_USED (decl) = 1;
3755 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3756 TREE_PUBLIC (decl) = 1;
3758 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3759 sym->attr.dimension, 0);
3760 debug_hooks->global_decl (decl);
3763 /* Generate all the required code for module variables. */
3766 gfc_generate_module_vars (gfc_namespace * ns)
3768 module_namespace = ns;
3769 cur_module = gfc_find_module (ns->proc_name->name);
3771 /* Check if the frontend left the namespace in a reasonable state. */
3772 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3774 /* Generate COMMON blocks. */
3775 gfc_trans_common (ns);
3777 /* Create decls for all the module variables. */
3778 gfc_traverse_ns (ns, gfc_create_module_variable);
3782 gfc_trans_use_stmts (ns);
3783 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3788 gfc_generate_contained_functions (gfc_namespace * parent)
3792 /* We create all the prototypes before generating any code. */
3793 for (ns = parent->contained; ns; ns = ns->sibling)
3795 /* Skip namespaces from used modules. */
3796 if (ns->parent != parent)
3799 gfc_create_function_decl (ns);
3802 for (ns = parent->contained; ns; ns = ns->sibling)
3804 /* Skip namespaces from used modules. */
3805 if (ns->parent != parent)
3808 gfc_generate_function_code (ns);
3813 /* Drill down through expressions for the array specification bounds and
3814 character length calling generate_local_decl for all those variables
3815 that have not already been declared. */
3818 generate_local_decl (gfc_symbol *);
3820 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3823 expr_decls (gfc_expr *e, gfc_symbol *sym,
3824 int *f ATTRIBUTE_UNUSED)
3826 if (e->expr_type != EXPR_VARIABLE
3827 || sym == e->symtree->n.sym
3828 || e->symtree->n.sym->mark
3829 || e->symtree->n.sym->ns != sym->ns)
3832 generate_local_decl (e->symtree->n.sym);
3837 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3839 gfc_traverse_expr (e, sym, expr_decls, 0);
3843 /* Check for dependencies in the character length and array spec. */
3846 generate_dependency_declarations (gfc_symbol *sym)
3850 if (sym->ts.type == BT_CHARACTER
3852 && sym->ts.u.cl->length
3853 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3854 generate_expr_decls (sym, sym->ts.u.cl->length);
3856 if (sym->as && sym->as->rank)
3858 for (i = 0; i < sym->as->rank; i++)
3860 generate_expr_decls (sym, sym->as->lower[i]);
3861 generate_expr_decls (sym, sym->as->upper[i]);
3867 /* Generate decls for all local variables. We do this to ensure correct
3868 handling of expressions which only appear in the specification of
3872 generate_local_decl (gfc_symbol * sym)
3874 if (sym->attr.flavor == FL_VARIABLE)
3876 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3877 generate_dependency_declarations (sym);
3879 if (sym->attr.referenced)
3880 gfc_get_symbol_decl (sym);
3881 /* INTENT(out) dummy arguments are likely meant to be set. */
3882 else if (warn_unused_variable
3884 && sym->attr.intent == INTENT_OUT)
3886 if (sym->ts.type != BT_DERIVED)
3887 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
3888 "but was not set", sym->name, &sym->declared_at);
3889 else if (!gfc_has_default_initializer (sym->ts.u.derived))
3890 gfc_warning ("Derived-type dummy argument '%s' at %L was "
3891 "declared INTENT(OUT) but was not set and does "
3892 "not have a default initializer",
3893 sym->name, &sym->declared_at);
3895 /* Specific warning for unused dummy arguments. */
3896 else if (warn_unused_variable && sym->attr.dummy)
3897 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3899 /* Warn for unused variables, but not if they're inside a common
3900 block or are use-associated. */
3901 else if (warn_unused_variable
3902 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3903 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3906 /* For variable length CHARACTER parameters, the PARM_DECL already
3907 references the length variable, so force gfc_get_symbol_decl
3908 even when not referenced. If optimize > 0, it will be optimized
3909 away anyway. But do this only after emitting -Wunused-parameter
3910 warning if requested. */
3911 if (sym->attr.dummy && !sym->attr.referenced
3912 && sym->ts.type == BT_CHARACTER
3913 && sym->ts.u.cl->backend_decl != NULL
3914 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3916 sym->attr.referenced = 1;
3917 gfc_get_symbol_decl (sym);
3920 /* INTENT(out) dummy arguments and result variables with allocatable
3921 components are reset by default and need to be set referenced to
3922 generate the code for nullification and automatic lengths. */
3923 if (!sym->attr.referenced
3924 && sym->ts.type == BT_DERIVED
3925 && sym->ts.u.derived->attr.alloc_comp
3926 && !sym->attr.pointer
3927 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3929 (sym->attr.result && sym != sym->result)))
3931 sym->attr.referenced = 1;
3932 gfc_get_symbol_decl (sym);
3935 /* Check for dependencies in the array specification and string
3936 length, adding the necessary declarations to the function. We
3937 mark the symbol now, as well as in traverse_ns, to prevent
3938 getting stuck in a circular dependency. */
3941 /* We do not want the middle-end to warn about unused parameters
3942 as this was already done above. */
3943 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3944 TREE_NO_WARNING(sym->backend_decl) = 1;
3946 else if (sym->attr.flavor == FL_PARAMETER)
3948 if (warn_unused_parameter
3949 && !sym->attr.referenced
3950 && !sym->attr.use_assoc)
3951 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3954 else if (sym->attr.flavor == FL_PROCEDURE)
3956 /* TODO: move to the appropriate place in resolve.c. */
3957 if (warn_return_type
3958 && sym->attr.function
3960 && sym != sym->result
3961 && !sym->result->attr.referenced
3962 && !sym->attr.use_assoc
3963 && sym->attr.if_source != IFSRC_IFBODY)
3965 gfc_warning ("Return value '%s' of function '%s' declared at "
3966 "%L not set", sym->result->name, sym->name,
3967 &sym->result->declared_at);
3969 /* Prevents "Unused variable" warning for RESULT variables. */
3970 sym->result->mark = 1;
3974 if (sym->attr.dummy == 1)
3976 /* Modify the tree type for scalar character dummy arguments of bind(c)
3977 procedures if they are passed by value. The tree type for them will
3978 be promoted to INTEGER_TYPE for the middle end, which appears to be
3979 what C would do with characters passed by-value. The value attribute
3980 implies the dummy is a scalar. */
3981 if (sym->attr.value == 1 && sym->backend_decl != NULL
3982 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3983 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3984 gfc_conv_scalar_char_value (sym, NULL, NULL);
3987 /* Make sure we convert the types of the derived types from iso_c_binding
3989 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3990 && sym->ts.type == BT_DERIVED)
3991 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3995 generate_local_vars (gfc_namespace * ns)
3997 gfc_traverse_ns (ns, generate_local_decl);
4001 /* Generate a switch statement to jump to the correct entry point. Also
4002 creates the label decls for the entry points. */
4005 gfc_trans_entry_master_switch (gfc_entry_list * el)
4012 gfc_init_block (&block);
4013 for (; el; el = el->next)
4015 /* Add the case label. */
4016 label = gfc_build_label_decl (NULL_TREE);
4017 val = build_int_cst (gfc_array_index_type, el->id);
4018 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4019 gfc_add_expr_to_block (&block, tmp);
4021 /* And jump to the actual entry point. */
4022 label = gfc_build_label_decl (NULL_TREE);
4023 tmp = build1_v (GOTO_EXPR, label);
4024 gfc_add_expr_to_block (&block, tmp);
4026 /* Save the label decl. */
4029 tmp = gfc_finish_block (&block);
4030 /* The first argument selects the entry point. */
4031 val = DECL_ARGUMENTS (current_function_decl);
4032 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4037 /* Add code to string lengths of actual arguments passed to a function against
4038 the expected lengths of the dummy arguments. */
4041 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4043 gfc_formal_arglist *formal;
4045 for (formal = sym->formal; formal; formal = formal->next)
4046 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4048 enum tree_code comparison;
4053 const char *message;
4059 gcc_assert (cl->passed_length != NULL_TREE);
4060 gcc_assert (cl->backend_decl != NULL_TREE);
4062 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4063 string lengths must match exactly. Otherwise, it is only required
4064 that the actual string length is *at least* the expected one.
4065 Sequence association allows for a mismatch of the string length
4066 if the actual argument is (part of) an array, but only if the
4067 dummy argument is an array. (See "Sequence association" in
4068 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4069 if (fsym->attr.pointer || fsym->attr.allocatable
4070 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4072 comparison = NE_EXPR;
4073 message = _("Actual string length does not match the declared one"
4074 " for dummy argument '%s' (%ld/%ld)");
4076 else if (fsym->as && fsym->as->rank != 0)
4080 comparison = LT_EXPR;
4081 message = _("Actual string length is shorter than the declared one"
4082 " for dummy argument '%s' (%ld/%ld)");
4085 /* Build the condition. For optional arguments, an actual length
4086 of 0 is also acceptable if the associated string is NULL, which
4087 means the argument was not passed. */
4088 cond = fold_build2 (comparison, boolean_type_node,
4089 cl->passed_length, cl->backend_decl);
4090 if (fsym->attr.optional)
4096 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4098 fold_convert (gfc_charlen_type_node,
4099 integer_zero_node));
4100 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4101 fsym->attr.referenced = 1;
4102 not_absent = gfc_conv_expr_present (fsym);
4104 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4105 not_0length, not_absent);
4107 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4108 cond, absent_failed);
4111 /* Build the runtime check. */
4112 argname = gfc_build_cstring_const (fsym->name);
4113 argname = gfc_build_addr_expr (pchar_type_node, argname);
4114 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4116 fold_convert (long_integer_type_node,
4118 fold_convert (long_integer_type_node,
4125 create_main_function (tree fndecl)
4129 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4132 old_context = current_function_decl;
4136 push_function_context ();
4137 saved_parent_function_decls = saved_function_decls;
4138 saved_function_decls = NULL_TREE;
4141 /* main() function must be declared with global scope. */
4142 gcc_assert (current_function_decl == NULL_TREE);
4144 /* Declare the function. */
4145 tmp = build_function_type_list (integer_type_node, integer_type_node,
4146 build_pointer_type (pchar_type_node),
4148 main_identifier_node = get_identifier ("main");
4149 ftn_main = build_decl (input_location, FUNCTION_DECL,
4150 main_identifier_node, tmp);
4151 DECL_EXTERNAL (ftn_main) = 0;
4152 TREE_PUBLIC (ftn_main) = 1;
4153 TREE_STATIC (ftn_main) = 1;
4154 DECL_ATTRIBUTES (ftn_main)
4155 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4157 /* Setup the result declaration (for "return 0"). */
4158 result_decl = build_decl (input_location,
4159 RESULT_DECL, NULL_TREE, integer_type_node);
4160 DECL_ARTIFICIAL (result_decl) = 1;
4161 DECL_IGNORED_P (result_decl) = 1;
4162 DECL_CONTEXT (result_decl) = ftn_main;
4163 DECL_RESULT (ftn_main) = result_decl;
4165 pushdecl (ftn_main);
4167 /* Get the arguments. */
4169 arglist = NULL_TREE;
4170 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4172 tmp = TREE_VALUE (typelist);
4173 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4174 DECL_CONTEXT (argc) = ftn_main;
4175 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4176 TREE_READONLY (argc) = 1;
4177 gfc_finish_decl (argc);
4178 arglist = chainon (arglist, argc);
4180 typelist = TREE_CHAIN (typelist);
4181 tmp = TREE_VALUE (typelist);
4182 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4183 DECL_CONTEXT (argv) = ftn_main;
4184 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4185 TREE_READONLY (argv) = 1;
4186 DECL_BY_REFERENCE (argv) = 1;
4187 gfc_finish_decl (argv);
4188 arglist = chainon (arglist, argv);
4190 DECL_ARGUMENTS (ftn_main) = arglist;
4191 current_function_decl = ftn_main;
4192 announce_function (ftn_main);
4194 rest_of_decl_compilation (ftn_main, 1, 0);
4195 make_decl_rtl (ftn_main);
4196 init_function_start (ftn_main);
4199 gfc_init_block (&body);
4201 /* Call some libgfortran initialization routines, call then MAIN__(). */
4203 /* Call _gfortran_set_args (argc, argv). */
4204 TREE_USED (argc) = 1;
4205 TREE_USED (argv) = 1;
4206 tmp = build_call_expr_loc (input_location,
4207 gfor_fndecl_set_args, 2, argc, argv);
4208 gfc_add_expr_to_block (&body, tmp);
4210 /* Add a call to set_options to set up the runtime library Fortran
4211 language standard parameters. */
4213 tree array_type, array, var;
4214 VEC(constructor_elt,gc) *v = NULL;
4216 /* Passing a new option to the library requires four modifications:
4217 + add it to the tree_cons list below
4218 + change the array size in the call to build_array_type
4219 + change the first argument to the library call
4220 gfor_fndecl_set_options
4221 + modify the library (runtime/compile_options.c)! */
4223 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4224 build_int_cst (integer_type_node,
4225 gfc_option.warn_std));
4226 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4227 build_int_cst (integer_type_node,
4228 gfc_option.allow_std));
4229 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4230 build_int_cst (integer_type_node, pedantic));
4231 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4232 build_int_cst (integer_type_node,
4233 gfc_option.flag_dump_core));
4234 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4235 build_int_cst (integer_type_node,
4236 gfc_option.flag_backtrace));
4237 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4238 build_int_cst (integer_type_node,
4239 gfc_option.flag_sign_zero));
4240 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4241 build_int_cst (integer_type_node,
4243 & GFC_RTCHECK_BOUNDS)));
4244 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4245 build_int_cst (integer_type_node,
4246 gfc_option.flag_range_check));
4248 array_type = build_array_type (integer_type_node,
4249 build_index_type (build_int_cst (NULL_TREE, 7)));
4250 array = build_constructor (array_type, v);
4251 TREE_CONSTANT (array) = 1;
4252 TREE_STATIC (array) = 1;
4254 /* Create a static variable to hold the jump table. */
4255 var = gfc_create_var (array_type, "options");
4256 TREE_CONSTANT (var) = 1;
4257 TREE_STATIC (var) = 1;
4258 TREE_READONLY (var) = 1;
4259 DECL_INITIAL (var) = array;
4260 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4262 tmp = build_call_expr_loc (input_location,
4263 gfor_fndecl_set_options, 2,
4264 build_int_cst (integer_type_node, 8), var);
4265 gfc_add_expr_to_block (&body, tmp);
4268 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4269 the library will raise a FPE when needed. */
4270 if (gfc_option.fpe != 0)
4272 tmp = build_call_expr_loc (input_location,
4273 gfor_fndecl_set_fpe, 1,
4274 build_int_cst (integer_type_node,
4276 gfc_add_expr_to_block (&body, tmp);
4279 /* If this is the main program and an -fconvert option was provided,
4280 add a call to set_convert. */
4282 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4284 tmp = build_call_expr_loc (input_location,
4285 gfor_fndecl_set_convert, 1,
4286 build_int_cst (integer_type_node,
4287 gfc_option.convert));
4288 gfc_add_expr_to_block (&body, tmp);
4291 /* If this is the main program and an -frecord-marker option was provided,
4292 add a call to set_record_marker. */
4294 if (gfc_option.record_marker != 0)
4296 tmp = build_call_expr_loc (input_location,
4297 gfor_fndecl_set_record_marker, 1,
4298 build_int_cst (integer_type_node,
4299 gfc_option.record_marker));
4300 gfc_add_expr_to_block (&body, tmp);
4303 if (gfc_option.max_subrecord_length != 0)
4305 tmp = build_call_expr_loc (input_location,
4306 gfor_fndecl_set_max_subrecord_length, 1,
4307 build_int_cst (integer_type_node,
4308 gfc_option.max_subrecord_length));
4309 gfc_add_expr_to_block (&body, tmp);
4312 /* Call MAIN__(). */
4313 tmp = build_call_expr_loc (input_location,
4315 gfc_add_expr_to_block (&body, tmp);
4317 /* Mark MAIN__ as used. */
4318 TREE_USED (fndecl) = 1;
4321 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4322 build_int_cst (integer_type_node, 0));
4323 tmp = build1_v (RETURN_EXPR, tmp);
4324 gfc_add_expr_to_block (&body, tmp);
4327 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4330 /* Finish off this function and send it for code generation. */
4332 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4334 DECL_SAVED_TREE (ftn_main)
4335 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4336 DECL_INITIAL (ftn_main));
4338 /* Output the GENERIC tree. */
4339 dump_function (TDI_original, ftn_main);
4341 cgraph_finalize_function (ftn_main, true);
4345 pop_function_context ();
4346 saved_function_decls = saved_parent_function_decls;
4348 current_function_decl = old_context;
4352 /* Generate code for a function. */
4355 gfc_generate_function_code (gfc_namespace * ns)
4365 tree recurcheckvar = NULL_TREE;
4370 sym = ns->proc_name;
4372 /* Check that the frontend isn't still using this. */
4373 gcc_assert (sym->tlink == NULL);
4376 /* Create the declaration for functions with global scope. */
4377 if (!sym->backend_decl)
4378 gfc_create_function_decl (ns);
4380 fndecl = sym->backend_decl;
4381 old_context = current_function_decl;
4385 push_function_context ();
4386 saved_parent_function_decls = saved_function_decls;
4387 saved_function_decls = NULL_TREE;
4390 trans_function_start (sym);
4392 gfc_init_block (&block);
4394 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4396 /* Copy length backend_decls to all entry point result
4401 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4402 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4403 for (el = ns->entries; el; el = el->next)
4404 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4407 /* Translate COMMON blocks. */
4408 gfc_trans_common (ns);
4410 /* Null the parent fake result declaration if this namespace is
4411 a module function or an external procedures. */
4412 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4413 || ns->parent == NULL)
4414 parent_fake_result_decl = NULL_TREE;
4416 gfc_generate_contained_functions (ns);
4418 nonlocal_dummy_decls = NULL;
4419 nonlocal_dummy_decl_pset = NULL;
4421 generate_local_vars (ns);
4423 /* Keep the parent fake result declaration in module functions
4424 or external procedures. */
4425 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4426 || ns->parent == NULL)
4427 current_fake_result_decl = parent_fake_result_decl;
4429 current_fake_result_decl = NULL_TREE;
4431 current_function_return_label = NULL;
4433 /* Now generate the code for the body of this function. */
4434 gfc_init_block (&body);
4436 is_recursive = sym->attr.recursive
4437 || (sym->attr.entry_master
4438 && sym->ns->entries->sym->attr.recursive);
4439 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4441 && !gfc_option.flag_recursive)
4445 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4447 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4448 TREE_STATIC (recurcheckvar) = 1;
4449 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4450 gfc_add_expr_to_block (&block, recurcheckvar);
4451 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4452 &sym->declared_at, msg);
4453 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4457 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4458 && sym->attr.subroutine)
4460 tree alternate_return;
4461 alternate_return = gfc_get_fake_result_decl (sym, 0);
4462 gfc_add_modify (&body, alternate_return, integer_zero_node);
4467 /* Jump to the correct entry point. */
4468 tmp = gfc_trans_entry_master_switch (ns->entries);
4469 gfc_add_expr_to_block (&body, tmp);
4472 /* If bounds-checking is enabled, generate code to check passed in actual
4473 arguments against the expected dummy argument attributes (e.g. string
4475 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4476 add_argument_checking (&body, sym);
4478 tmp = gfc_trans_code (ns->code);
4479 gfc_add_expr_to_block (&body, tmp);
4481 /* Add a return label if needed. */
4482 if (current_function_return_label)
4484 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4485 gfc_add_expr_to_block (&body, tmp);
4488 tmp = gfc_finish_block (&body);
4489 /* Add code to create and cleanup arrays. */
4490 tmp = gfc_trans_deferred_vars (sym, tmp);
4492 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4494 if (sym->attr.subroutine || sym == sym->result)
4496 if (current_fake_result_decl != NULL)
4497 result = TREE_VALUE (current_fake_result_decl);
4500 current_fake_result_decl = NULL_TREE;
4503 result = sym->result->backend_decl;
4505 if (result != NULL_TREE
4506 && sym->attr.function
4507 && !sym->attr.pointer)
4509 if (sym->ts.type == BT_DERIVED
4510 && sym->ts.u.derived->attr.alloc_comp)
4512 rank = sym->as ? sym->as->rank : 0;
4513 tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4514 gfc_add_expr_to_block (&block, tmp2);
4516 else if (sym->attr.allocatable && sym->attr.dimension == 0)
4517 gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
4518 null_pointer_node));
4521 gfc_add_expr_to_block (&block, tmp);
4523 /* Reset recursion-check variable. */
4524 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4526 && !gfc_option.flag_openmp
4527 && recurcheckvar != NULL_TREE)
4529 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4530 recurcheckvar = NULL;
4533 if (result == NULL_TREE)
4535 /* TODO: move to the appropriate place in resolve.c. */
4536 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4537 gfc_warning ("Return value of function '%s' at %L not set",
4538 sym->name, &sym->declared_at);
4540 TREE_NO_WARNING(sym->backend_decl) = 1;
4544 /* Set the return value to the dummy result variable. The
4545 types may be different for scalar default REAL functions
4546 with -ff2c, therefore we have to convert. */
4547 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4548 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4549 DECL_RESULT (fndecl), tmp);
4550 tmp = build1_v (RETURN_EXPR, tmp);
4551 gfc_add_expr_to_block (&block, tmp);
4556 gfc_add_expr_to_block (&block, tmp);
4557 /* Reset recursion-check variable. */
4558 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4560 && !gfc_option.flag_openmp
4561 && recurcheckvar != NULL_TREE)
4563 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4564 recurcheckvar = NULL_TREE;
4569 /* Add all the decls we created during processing. */
4570 decl = saved_function_decls;
4575 next = TREE_CHAIN (decl);
4576 TREE_CHAIN (decl) = NULL_TREE;
4580 saved_function_decls = NULL_TREE;
4582 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4585 /* Finish off this function and send it for code generation. */
4587 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4589 DECL_SAVED_TREE (fndecl)
4590 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4591 DECL_INITIAL (fndecl));
4593 if (nonlocal_dummy_decls)
4595 BLOCK_VARS (DECL_INITIAL (fndecl))
4596 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4597 pointer_set_destroy (nonlocal_dummy_decl_pset);
4598 nonlocal_dummy_decls = NULL;
4599 nonlocal_dummy_decl_pset = NULL;
4602 /* Output the GENERIC tree. */
4603 dump_function (TDI_original, fndecl);
4605 /* Store the end of the function, so that we get good line number
4606 info for the epilogue. */
4607 cfun->function_end_locus = input_location;
4609 /* We're leaving the context of this function, so zap cfun.
4610 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4611 tree_rest_of_compilation. */
4616 pop_function_context ();
4617 saved_function_decls = saved_parent_function_decls;
4619 current_function_decl = old_context;
4621 if (decl_function_context (fndecl))
4622 /* Register this function with cgraph just far enough to get it
4623 added to our parent's nested function list. */
4624 (void) cgraph_node (fndecl);
4626 cgraph_finalize_function (fndecl, true);
4628 gfc_trans_use_stmts (ns);
4629 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4631 if (sym->attr.is_main_program)
4632 create_main_function (fndecl);
4637 gfc_generate_constructors (void)
4639 gcc_assert (gfc_static_ctors == NULL_TREE);
4647 if (gfc_static_ctors == NULL_TREE)
4650 fnname = get_file_function_name ("I");
4651 type = build_function_type_list (void_type_node, NULL_TREE);
4653 fndecl = build_decl (input_location,
4654 FUNCTION_DECL, fnname, type);
4655 TREE_PUBLIC (fndecl) = 1;
4657 decl = build_decl (input_location,
4658 RESULT_DECL, NULL_TREE, void_type_node);
4659 DECL_ARTIFICIAL (decl) = 1;
4660 DECL_IGNORED_P (decl) = 1;
4661 DECL_CONTEXT (decl) = fndecl;
4662 DECL_RESULT (fndecl) = decl;
4666 current_function_decl = fndecl;
4668 rest_of_decl_compilation (fndecl, 1, 0);
4670 make_decl_rtl (fndecl);
4672 init_function_start (fndecl);
4676 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4678 tmp = build_call_expr_loc (input_location,
4679 TREE_VALUE (gfc_static_ctors), 0);
4680 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4686 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4687 DECL_SAVED_TREE (fndecl)
4688 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4689 DECL_INITIAL (fndecl));
4691 free_after_parsing (cfun);
4692 free_after_compilation (cfun);
4694 tree_rest_of_compilation (fndecl);
4696 current_function_decl = NULL_TREE;
4700 /* Translates a BLOCK DATA program unit. This means emitting the
4701 commons contained therein plus their initializations. We also emit
4702 a globally visible symbol to make sure that each BLOCK DATA program
4703 unit remains unique. */
4706 gfc_generate_block_data (gfc_namespace * ns)
4711 /* Tell the backend the source location of the block data. */
4713 gfc_set_backend_locus (&ns->proc_name->declared_at);
4715 gfc_set_backend_locus (&gfc_current_locus);
4717 /* Process the DATA statements. */
4718 gfc_trans_common (ns);
4720 /* Create a global symbol with the mane of the block data. This is to
4721 generate linker errors if the same name is used twice. It is never
4724 id = gfc_sym_mangled_function_id (ns->proc_name);
4726 id = get_identifier ("__BLOCK_DATA__");
4728 decl = build_decl (input_location,
4729 VAR_DECL, id, gfc_array_index_type);
4730 TREE_PUBLIC (decl) = 1;
4731 TREE_STATIC (decl) = 1;
4732 DECL_IGNORED_P (decl) = 1;
4735 rest_of_decl_compilation (decl, 1, 0);
4739 /* Process the local variables of a BLOCK construct. */
4742 gfc_process_block_locals (gfc_namespace* ns)
4746 gcc_assert (saved_local_decls == NULL_TREE);
4747 generate_local_vars (ns);
4749 decl = saved_local_decls;
4754 next = TREE_CHAIN (decl);
4755 TREE_CHAIN (decl) = NULL_TREE;
4759 saved_local_decls = NULL_TREE;
4763 #include "gt-fortran-trans-decl.h"