1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
29 #include "tree-dump.h"
30 #include "gimple.h" /* For create_tmp_var_raw. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For announce_function. */
34 #include "output.h" /* For decl_default_tls_model. */
41 #include "pointer-set.h"
42 #include "constructor.h"
44 #include "trans-types.h"
45 #include "trans-array.h"
46 #include "trans-const.h"
47 /* Only for gfc_trans_code. Shouldn't need to include this. */
48 #include "trans-stmt.h"
50 #define MAX_LABEL_VALUE 99999
53 /* Holds the result of the function if no result variable specified. */
55 static GTY(()) tree current_fake_result_decl;
56 static GTY(()) tree parent_fake_result_decl;
59 /* Holds the variable DECLs for the current function. */
61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls;
64 static struct pointer_set_t *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
67 /* Holds the variable DECLs that are locals. */
69 static GTY(()) tree saved_local_decls;
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
74 static gfc_namespace *module_namespace;
76 /* The currently processed procedure symbol. */
77 static gfc_symbol* current_procedure_symbol = NULL;
80 /* List of static constructor functions. */
82 tree gfc_static_ctors;
85 /* Function declarations for builtin library functions. */
87 tree gfor_fndecl_pause_numeric;
88 tree gfor_fndecl_pause_string;
89 tree gfor_fndecl_stop_numeric;
90 tree gfor_fndecl_stop_numeric_f08;
91 tree gfor_fndecl_stop_string;
92 tree gfor_fndecl_error_stop_numeric;
93 tree gfor_fndecl_error_stop_string;
94 tree gfor_fndecl_runtime_error;
95 tree gfor_fndecl_runtime_error_at;
96 tree gfor_fndecl_runtime_warning_at;
97 tree gfor_fndecl_os_error;
98 tree gfor_fndecl_generate_error;
99 tree gfor_fndecl_set_args;
100 tree gfor_fndecl_set_fpe;
101 tree gfor_fndecl_set_options;
102 tree gfor_fndecl_set_convert;
103 tree gfor_fndecl_set_record_marker;
104 tree gfor_fndecl_set_max_subrecord_length;
105 tree gfor_fndecl_ctime;
106 tree gfor_fndecl_fdate;
107 tree gfor_fndecl_ttynam;
108 tree gfor_fndecl_in_pack;
109 tree gfor_fndecl_in_unpack;
110 tree gfor_fndecl_associated;
113 /* Math functions. Many other math functions are handled in
114 trans-intrinsic.c. */
116 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
117 tree gfor_fndecl_math_ishftc4;
118 tree gfor_fndecl_math_ishftc8;
119 tree gfor_fndecl_math_ishftc16;
122 /* String functions. */
124 tree gfor_fndecl_compare_string;
125 tree gfor_fndecl_concat_string;
126 tree gfor_fndecl_string_len_trim;
127 tree gfor_fndecl_string_index;
128 tree gfor_fndecl_string_scan;
129 tree gfor_fndecl_string_verify;
130 tree gfor_fndecl_string_trim;
131 tree gfor_fndecl_string_minmax;
132 tree gfor_fndecl_adjustl;
133 tree gfor_fndecl_adjustr;
134 tree gfor_fndecl_select_string;
135 tree gfor_fndecl_compare_string_char4;
136 tree gfor_fndecl_concat_string_char4;
137 tree gfor_fndecl_string_len_trim_char4;
138 tree gfor_fndecl_string_index_char4;
139 tree gfor_fndecl_string_scan_char4;
140 tree gfor_fndecl_string_verify_char4;
141 tree gfor_fndecl_string_trim_char4;
142 tree gfor_fndecl_string_minmax_char4;
143 tree gfor_fndecl_adjustl_char4;
144 tree gfor_fndecl_adjustr_char4;
145 tree gfor_fndecl_select_string_char4;
148 /* Conversion between character kinds. */
149 tree gfor_fndecl_convert_char1_to_char4;
150 tree gfor_fndecl_convert_char4_to_char1;
153 /* Other misc. runtime library functions. */
154 tree gfor_fndecl_size0;
155 tree gfor_fndecl_size1;
156 tree gfor_fndecl_iargc;
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 DECL_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 DECL_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 DECL_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 /* Set the backend source location of a decl. */
242 gfc_set_decl_location (tree decl, locus * loc)
244 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
248 /* Return the backend label declaration for a given label structure,
249 or create it if it doesn't exist yet. */
252 gfc_get_label_decl (gfc_st_label * lp)
254 if (lp->backend_decl)
255 return lp->backend_decl;
258 char label_name[GFC_MAX_SYMBOL_LEN + 1];
261 /* Validate the label declaration from the front end. */
262 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
264 /* Build a mangled name for the label. */
265 sprintf (label_name, "__label_%.6d", lp->value);
267 /* Build the LABEL_DECL node. */
268 label_decl = gfc_build_label_decl (get_identifier (label_name));
270 /* Tell the debugger where the label came from. */
271 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
272 gfc_set_decl_location (label_decl, &lp->where);
274 DECL_ARTIFICIAL (label_decl) = 1;
276 /* Store the label in the label list and return the LABEL_DECL. */
277 lp->backend_decl = label_decl;
283 /* Convert a gfc_symbol to an identifier of the same name. */
286 gfc_sym_identifier (gfc_symbol * sym)
288 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
289 return (get_identifier ("MAIN__"));
291 return (get_identifier (sym->name));
295 /* Construct mangled name from symbol name. */
298 gfc_sym_mangled_identifier (gfc_symbol * sym)
300 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
302 /* Prevent the mangling of identifiers that have an assigned
303 binding label (mainly those that are bind(c)). */
304 if (sym->attr.is_bind_c == 1
305 && sym->binding_label[0] != '\0')
306 return get_identifier(sym->binding_label);
308 if (sym->module == NULL)
309 return gfc_sym_identifier (sym);
312 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
313 return get_identifier (name);
318 /* Construct mangled function name from symbol name. */
321 gfc_sym_mangled_function_id (gfc_symbol * sym)
324 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
326 /* It may be possible to simply use the binding label if it's
327 provided, and remove the other checks. Then we could use it
328 for other things if we wished. */
329 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
330 sym->binding_label[0] != '\0')
331 /* use the binding label rather than the mangled name */
332 return get_identifier (sym->binding_label);
334 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
335 || (sym->module != NULL && (sym->attr.external
336 || sym->attr.if_source == IFSRC_IFBODY)))
338 /* Main program is mangled into MAIN__. */
339 if (sym->attr.is_main_program)
340 return get_identifier ("MAIN__");
342 /* Intrinsic procedures are never mangled. */
343 if (sym->attr.proc == PROC_INTRINSIC)
344 return get_identifier (sym->name);
346 if (gfc_option.flag_underscoring)
348 has_underscore = strchr (sym->name, '_') != 0;
349 if (gfc_option.flag_second_underscore && has_underscore)
350 snprintf (name, sizeof name, "%s__", sym->name);
352 snprintf (name, sizeof name, "%s_", sym->name);
353 return get_identifier (name);
356 return get_identifier (sym->name);
360 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
361 return get_identifier (name);
367 gfc_set_decl_assembler_name (tree decl, tree name)
369 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
370 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
374 /* Returns true if a variable of specified size should go on the stack. */
377 gfc_can_put_var_on_stack (tree size)
379 unsigned HOST_WIDE_INT low;
381 if (!INTEGER_CST_P (size))
384 if (gfc_option.flag_max_stack_var_size < 0)
387 if (TREE_INT_CST_HIGH (size) != 0)
390 low = TREE_INT_CST_LOW (size);
391 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
394 /* TODO: Set a per-function stack size limit. */
400 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
401 an expression involving its corresponding pointer. There are
402 2 cases; one for variable size arrays, and one for everything else,
403 because variable-sized arrays require one fewer level of
407 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
409 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
412 /* Parameters need to be dereferenced. */
413 if (sym->cp_pointer->attr.dummy)
414 ptr_decl = build_fold_indirect_ref_loc (input_location,
417 /* Check to see if we're dealing with a variable-sized array. */
418 if (sym->attr.dimension
419 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
421 /* These decls will be dereferenced later, so we don't dereference
423 value = convert (TREE_TYPE (decl), ptr_decl);
427 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
429 value = build_fold_indirect_ref_loc (input_location,
433 SET_DECL_VALUE_EXPR (decl, value);
434 DECL_HAS_VALUE_EXPR_P (decl) = 1;
435 GFC_DECL_CRAY_POINTEE (decl) = 1;
436 /* This is a fake variable just for debugging purposes. */
437 TREE_ASM_WRITTEN (decl) = 1;
441 /* Finish processing of a declaration without an initial value. */
444 gfc_finish_decl (tree decl)
446 gcc_assert (TREE_CODE (decl) == PARM_DECL
447 || DECL_INITIAL (decl) == NULL_TREE);
449 if (TREE_CODE (decl) != VAR_DECL)
452 if (DECL_SIZE (decl) == NULL_TREE
453 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
454 layout_decl (decl, 0);
456 /* A few consistency checks. */
457 /* A static variable with an incomplete type is an error if it is
458 initialized. Also if it is not file scope. Otherwise, let it
459 through, but if it is not `extern' then it may cause an error
461 /* An automatic variable with an incomplete type is an error. */
463 /* We should know the storage size. */
464 gcc_assert (DECL_SIZE (decl) != NULL_TREE
465 || (TREE_STATIC (decl)
466 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
467 : DECL_EXTERNAL (decl)));
469 /* The storage size should be constant. */
470 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
472 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
476 /* Apply symbol attributes to a variable, and add it to the function scope. */
479 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
482 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
483 This is the equivalent of the TARGET variables.
484 We also need to set this if the variable is passed by reference in a
487 /* Set DECL_VALUE_EXPR for Cray Pointees. */
488 if (sym->attr.cray_pointee)
489 gfc_finish_cray_pointee (decl, sym);
491 if (sym->attr.target)
492 TREE_ADDRESSABLE (decl) = 1;
493 /* If it wasn't used we wouldn't be getting it. */
494 TREE_USED (decl) = 1;
496 /* Chain this decl to the pending declarations. Don't do pushdecl()
497 because this would add them to the current scope rather than the
499 if (current_function_decl != NULL_TREE)
501 if (sym->ns->proc_name->backend_decl == current_function_decl
502 || sym->result == sym)
503 gfc_add_decl_to_function (decl);
504 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
505 /* This is a BLOCK construct. */
506 add_decl_as_local (decl);
508 gfc_add_decl_to_parent_function (decl);
511 if (sym->attr.cray_pointee)
514 if(sym->attr.is_bind_c == 1)
516 /* We need to put variables that are bind(c) into the common
517 segment of the object file, because this is what C would do.
518 gfortran would typically put them in either the BSS or
519 initialized data segments, and only mark them as common if
520 they were part of common blocks. However, if they are not put
521 into common space, then C cannot initialize global Fortran
522 variables that it interoperates with and the draft says that
523 either Fortran or C should be able to initialize it (but not
524 both, of course.) (J3/04-007, section 15.3). */
525 TREE_PUBLIC(decl) = 1;
526 DECL_COMMON(decl) = 1;
529 /* If a variable is USE associated, it's always external. */
530 if (sym->attr.use_assoc)
532 DECL_EXTERNAL (decl) = 1;
533 TREE_PUBLIC (decl) = 1;
535 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
537 /* TODO: Don't set sym->module for result or dummy variables. */
538 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
539 /* This is the declaration of a module variable. */
540 TREE_PUBLIC (decl) = 1;
541 TREE_STATIC (decl) = 1;
544 /* Derived types are a bit peculiar because of the possibility of
545 a default initializer; this must be applied each time the variable
546 comes into scope it therefore need not be static. These variables
547 are SAVE_NONE but have an initializer. Otherwise explicitly
548 initialized variables are SAVE_IMPLICIT and explicitly saved are
550 if (!sym->attr.use_assoc
551 && (sym->attr.save != SAVE_NONE || sym->attr.data
552 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
553 TREE_STATIC (decl) = 1;
555 if (sym->attr.volatile_)
557 TREE_THIS_VOLATILE (decl) = 1;
558 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
559 TREE_TYPE (decl) = new_type;
562 /* Keep variables larger than max-stack-var-size off stack. */
563 if (!sym->ns->proc_name->attr.recursive
564 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
565 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
566 /* Put variable length auto array pointers always into stack. */
567 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
568 || sym->attr.dimension == 0
569 || sym->as->type != AS_EXPLICIT
571 || sym->attr.allocatable)
572 && !DECL_ARTIFICIAL (decl))
573 TREE_STATIC (decl) = 1;
575 /* Handle threadprivate variables. */
576 if (sym->attr.threadprivate
577 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
578 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
580 if (!sym->attr.target
581 && !sym->attr.pointer
582 && !sym->attr.cray_pointee
583 && !sym->attr.proc_pointer)
584 DECL_RESTRICTED_P (decl) = 1;
588 /* Allocate the lang-specific part of a decl. */
591 gfc_allocate_lang_decl (tree decl)
593 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
597 /* Remember a symbol to generate initialization/cleanup code at function
601 gfc_defer_symbol_init (gfc_symbol * sym)
607 /* Don't add a symbol twice. */
611 last = head = sym->ns->proc_name;
614 /* Make sure that setup code for dummy variables which are used in the
615 setup of other variables is generated first. */
618 /* Find the first dummy arg seen after us, or the first non-dummy arg.
619 This is a circular list, so don't go past the head. */
621 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
627 /* Insert in between last and p. */
633 /* Create an array index type variable with function scope. */
636 create_index_var (const char * pfx, int nest)
640 decl = gfc_create_var_np (gfc_array_index_type, pfx);
642 gfc_add_decl_to_parent_function (decl);
644 gfc_add_decl_to_function (decl);
649 /* Create variables to hold all the non-constant bits of info for a
650 descriptorless array. Remember these in the lang-specific part of the
654 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
659 gfc_namespace* procns;
661 type = TREE_TYPE (decl);
663 /* We just use the descriptor, if there is one. */
664 if (GFC_DESCRIPTOR_TYPE_P (type))
667 gcc_assert (GFC_ARRAY_TYPE_P (type));
668 procns = gfc_find_proc_namespace (sym->ns);
669 nest = (procns->proc_name->backend_decl != current_function_decl)
670 && !sym->attr.contained;
672 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
674 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
676 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
677 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
679 /* Don't try to use the unknown bound for assumed shape arrays. */
680 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
681 && (sym->as->type != AS_ASSUMED_SIZE
682 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
684 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
685 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
688 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
690 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
691 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
694 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
696 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
698 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
701 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
703 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
706 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
707 && sym->as->type != AS_ASSUMED_SIZE)
709 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
710 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
713 if (POINTER_TYPE_P (type))
715 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
716 gcc_assert (TYPE_LANG_SPECIFIC (type)
717 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
718 type = TREE_TYPE (type);
721 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
725 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
726 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
727 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
729 TYPE_DOMAIN (type) = range;
733 if (TYPE_NAME (type) != NULL_TREE
734 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
735 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
737 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
739 for (dim = 0; dim < sym->as->rank - 1; dim++)
741 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
742 gtype = TREE_TYPE (gtype);
744 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
745 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
746 TYPE_NAME (type) = NULL_TREE;
749 if (TYPE_NAME (type) == NULL_TREE)
751 tree gtype = TREE_TYPE (type), rtype, type_decl;
753 for (dim = sym->as->rank - 1; dim >= 0; dim--)
756 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
757 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
758 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
759 gtype = build_array_type (gtype, rtype);
760 /* Ensure the bound variables aren't optimized out at -O0.
761 For -O1 and above they often will be optimized out, but
762 can be tracked by VTA. Also set DECL_NAMELESS, so that
763 the artificial lbound.N or ubound.N DECL_NAME doesn't
764 end up in debug info. */
765 if (lbound && TREE_CODE (lbound) == VAR_DECL
766 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
768 if (DECL_NAME (lbound)
769 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
771 DECL_NAMELESS (lbound) = 1;
772 DECL_IGNORED_P (lbound) = 0;
774 if (ubound && TREE_CODE (ubound) == VAR_DECL
775 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
777 if (DECL_NAME (ubound)
778 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
780 DECL_NAMELESS (ubound) = 1;
781 DECL_IGNORED_P (ubound) = 0;
784 TYPE_NAME (type) = type_decl = build_decl (input_location,
785 TYPE_DECL, NULL, gtype);
786 DECL_ORIGINAL_TYPE (type_decl) = gtype;
791 /* For some dummy arguments we don't use the actual argument directly.
792 Instead we create a local decl and use that. This allows us to perform
793 initialization, and construct full type information. */
796 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
806 if (sym->attr.pointer || sym->attr.allocatable)
809 /* Add to list of variables if not a fake result variable. */
810 if (sym->attr.result || sym->attr.dummy)
811 gfc_defer_symbol_init (sym);
813 type = TREE_TYPE (dummy);
814 gcc_assert (TREE_CODE (dummy) == PARM_DECL
815 && POINTER_TYPE_P (type));
817 /* Do we know the element size? */
818 known_size = sym->ts.type != BT_CHARACTER
819 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
821 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
823 /* For descriptorless arrays with known element size the actual
824 argument is sufficient. */
825 gcc_assert (GFC_ARRAY_TYPE_P (type));
826 gfc_build_qualified_array (dummy, sym);
830 type = TREE_TYPE (type);
831 if (GFC_DESCRIPTOR_TYPE_P (type))
833 /* Create a descriptorless array pointer. */
837 /* Even when -frepack-arrays is used, symbols with TARGET attribute
839 if (!gfc_option.flag_repack_arrays || sym->attr.target)
841 if (as->type == AS_ASSUMED_SIZE)
842 packed = PACKED_FULL;
846 if (as->type == AS_EXPLICIT)
848 packed = PACKED_FULL;
849 for (n = 0; n < as->rank; n++)
853 && as->upper[n]->expr_type == EXPR_CONSTANT
854 && as->lower[n]->expr_type == EXPR_CONSTANT))
855 packed = PACKED_PARTIAL;
859 packed = PACKED_PARTIAL;
862 type = gfc_typenode_for_spec (&sym->ts);
863 type = gfc_get_nodesc_array_type (type, sym->as, packed,
868 /* We now have an expression for the element size, so create a fully
869 qualified type. Reset sym->backend decl or this will just return the
871 DECL_ARTIFICIAL (sym->backend_decl) = 1;
872 sym->backend_decl = NULL_TREE;
873 type = gfc_sym_type (sym);
874 packed = PACKED_FULL;
877 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
878 decl = build_decl (input_location,
879 VAR_DECL, get_identifier (name), type);
881 DECL_ARTIFICIAL (decl) = 1;
882 DECL_NAMELESS (decl) = 1;
883 TREE_PUBLIC (decl) = 0;
884 TREE_STATIC (decl) = 0;
885 DECL_EXTERNAL (decl) = 0;
887 /* We should never get deferred shape arrays here. We used to because of
889 gcc_assert (sym->as->type != AS_DEFERRED);
891 if (packed == PACKED_PARTIAL)
892 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
893 else if (packed == PACKED_FULL)
894 GFC_DECL_PACKED_ARRAY (decl) = 1;
896 gfc_build_qualified_array (decl, sym);
898 if (DECL_LANG_SPECIFIC (dummy))
899 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
901 gfc_allocate_lang_decl (decl);
903 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
905 if (sym->ns->proc_name->backend_decl == current_function_decl
906 || sym->attr.contained)
907 gfc_add_decl_to_function (decl);
909 gfc_add_decl_to_parent_function (decl);
914 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
915 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
916 pointing to the artificial variable for debug info purposes. */
919 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
923 if (! nonlocal_dummy_decl_pset)
924 nonlocal_dummy_decl_pset = pointer_set_create ();
926 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
929 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
930 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
931 TREE_TYPE (sym->backend_decl));
932 DECL_ARTIFICIAL (decl) = 0;
933 TREE_USED (decl) = 1;
934 TREE_PUBLIC (decl) = 0;
935 TREE_STATIC (decl) = 0;
936 DECL_EXTERNAL (decl) = 0;
937 if (DECL_BY_REFERENCE (dummy))
938 DECL_BY_REFERENCE (decl) = 1;
939 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
940 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
941 DECL_HAS_VALUE_EXPR_P (decl) = 1;
942 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
943 DECL_CHAIN (decl) = nonlocal_dummy_decls;
944 nonlocal_dummy_decls = decl;
947 /* Return a constant or a variable to use as a string length. Does not
948 add the decl to the current scope. */
951 gfc_create_string_length (gfc_symbol * sym)
953 gcc_assert (sym->ts.u.cl);
954 gfc_conv_const_charlen (sym->ts.u.cl);
956 if (sym->ts.u.cl->backend_decl == NULL_TREE)
959 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
961 /* Also prefix the mangled name. */
962 strcpy (&name[1], sym->name);
964 length = build_decl (input_location,
965 VAR_DECL, get_identifier (name),
966 gfc_charlen_type_node);
967 DECL_ARTIFICIAL (length) = 1;
968 TREE_USED (length) = 1;
969 if (sym->ns->proc_name->tlink != NULL)
970 gfc_defer_symbol_init (sym);
972 sym->ts.u.cl->backend_decl = length;
975 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
976 return sym->ts.u.cl->backend_decl;
979 /* If a variable is assigned a label, we add another two auxiliary
983 gfc_add_assign_aux_vars (gfc_symbol * sym)
989 gcc_assert (sym->backend_decl);
991 decl = sym->backend_decl;
992 gfc_allocate_lang_decl (decl);
993 GFC_DECL_ASSIGN (decl) = 1;
994 length = build_decl (input_location,
995 VAR_DECL, create_tmp_var_name (sym->name),
996 gfc_charlen_type_node);
997 addr = build_decl (input_location,
998 VAR_DECL, create_tmp_var_name (sym->name),
1000 gfc_finish_var_decl (length, sym);
1001 gfc_finish_var_decl (addr, sym);
1002 /* STRING_LENGTH is also used as flag. Less than -1 means that
1003 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1004 target label's address. Otherwise, value is the length of a format string
1005 and ASSIGN_ADDR is its address. */
1006 if (TREE_STATIC (length))
1007 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1009 gfc_defer_symbol_init (sym);
1011 GFC_DECL_STRING_LEN (decl) = length;
1012 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1017 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1022 for (id = 0; id < EXT_ATTR_NUM; id++)
1023 if (sym_attr.ext_attr & (1 << id))
1025 attr = build_tree_list (
1026 get_identifier (ext_attr_list[id].middle_end_name),
1028 list = chainon (list, attr);
1035 static void build_function_decl (gfc_symbol * sym, bool global);
1038 /* Return the decl for a gfc_symbol, create it if it doesn't already
1042 gfc_get_symbol_decl (gfc_symbol * sym)
1045 tree length = NULL_TREE;
1048 bool intrinsic_array_parameter = false;
1050 gcc_assert (sym->attr.referenced
1051 || sym->attr.use_assoc
1052 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1053 || (sym->module && sym->attr.if_source != IFSRC_DECL
1054 && sym->backend_decl));
1056 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1057 byref = gfc_return_by_reference (sym->ns->proc_name);
1061 /* Make sure that the vtab for the declared type is completed. */
1062 if (sym->ts.type == BT_CLASS)
1064 gfc_component *c = CLASS_DATA (sym);
1065 if (!c->ts.u.derived->backend_decl)
1066 gfc_find_derived_vtab (c->ts.u.derived);
1069 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1071 /* Return via extra parameter. */
1072 if (sym->attr.result && byref
1073 && !sym->backend_decl)
1076 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1077 /* For entry master function skip over the __entry
1079 if (sym->ns->proc_name->attr.entry_master)
1080 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1083 /* Dummy variables should already have been created. */
1084 gcc_assert (sym->backend_decl);
1086 /* Create a character length variable. */
1087 if (sym->ts.type == BT_CHARACTER)
1089 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1090 length = gfc_create_string_length (sym);
1092 length = sym->ts.u.cl->backend_decl;
1093 if (TREE_CODE (length) == VAR_DECL
1094 && DECL_FILE_SCOPE_P (length))
1096 /* Add the string length to the same context as the symbol. */
1097 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1098 gfc_add_decl_to_function (length);
1100 gfc_add_decl_to_parent_function (length);
1102 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1103 DECL_CONTEXT (length));
1105 gfc_defer_symbol_init (sym);
1109 /* Use a copy of the descriptor for dummy arrays. */
1110 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1112 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1113 /* Prevent the dummy from being detected as unused if it is copied. */
1114 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1115 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1116 sym->backend_decl = decl;
1119 TREE_USED (sym->backend_decl) = 1;
1120 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1122 gfc_add_assign_aux_vars (sym);
1125 if (sym->attr.dimension
1126 && DECL_LANG_SPECIFIC (sym->backend_decl)
1127 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1128 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1129 gfc_nonlocal_dummy_array_decl (sym);
1131 return sym->backend_decl;
1134 if (sym->backend_decl)
1135 return sym->backend_decl;
1137 /* Special case for array-valued named constants from intrinsic
1138 procedures; those are inlined. */
1139 if (sym->attr.use_assoc && sym->from_intmod
1140 && sym->attr.flavor == FL_PARAMETER)
1141 intrinsic_array_parameter = true;
1143 /* If use associated and whole file compilation, use the module
1145 if (gfc_option.flag_whole_file
1146 && (sym->attr.flavor == FL_VARIABLE
1147 || sym->attr.flavor == FL_PARAMETER)
1148 && sym->attr.use_assoc && !intrinsic_array_parameter
1153 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1154 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1158 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1159 if (s && s->backend_decl)
1161 if (sym->ts.type == BT_DERIVED)
1162 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1164 if (sym->ts.type == BT_CHARACTER)
1165 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1166 sym->backend_decl = s->backend_decl;
1167 return sym->backend_decl;
1172 if (sym->attr.flavor == FL_PROCEDURE)
1174 /* Catch function declarations. Only used for actual parameters,
1175 procedure pointers and procptr initialization targets. */
1176 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1178 decl = gfc_get_extern_function_decl (sym);
1179 gfc_set_decl_location (decl, &sym->declared_at);
1183 if (!sym->backend_decl)
1184 build_function_decl (sym, false);
1185 decl = sym->backend_decl;
1190 if (sym->attr.intrinsic)
1191 internal_error ("intrinsic variable which isn't a procedure");
1193 /* Create string length decl first so that they can be used in the
1194 type declaration. */
1195 if (sym->ts.type == BT_CHARACTER)
1196 length = gfc_create_string_length (sym);
1198 /* Create the decl for the variable. */
1199 decl = build_decl (sym->declared_at.lb->location,
1200 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1202 /* Add attributes to variables. Functions are handled elsewhere. */
1203 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1204 decl_attributes (&decl, attributes, 0);
1206 /* Symbols from modules should have their assembler names mangled.
1207 This is done here rather than in gfc_finish_var_decl because it
1208 is different for string length variables. */
1211 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1212 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1213 DECL_IGNORED_P (decl) = 1;
1216 if (sym->attr.dimension)
1218 /* Create variables to hold the non-constant bits of array info. */
1219 gfc_build_qualified_array (decl, sym);
1221 if (sym->attr.contiguous
1222 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1223 GFC_DECL_PACKED_ARRAY (decl) = 1;
1226 /* Remember this variable for allocation/cleanup. */
1227 if (sym->attr.dimension || sym->attr.allocatable
1228 || (sym->ts.type == BT_CLASS &&
1229 (CLASS_DATA (sym)->attr.dimension
1230 || CLASS_DATA (sym)->attr.allocatable))
1231 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1232 /* This applies a derived type default initializer. */
1233 || (sym->ts.type == BT_DERIVED
1234 && sym->attr.save == SAVE_NONE
1236 && !sym->attr.allocatable
1237 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1238 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1239 gfc_defer_symbol_init (sym);
1241 gfc_finish_var_decl (decl, sym);
1243 if (sym->ts.type == BT_CHARACTER)
1245 /* Character variables need special handling. */
1246 gfc_allocate_lang_decl (decl);
1248 if (TREE_CODE (length) != INTEGER_CST)
1250 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1254 /* Also prefix the mangled name for symbols from modules. */
1255 strcpy (&name[1], sym->name);
1258 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1259 gfc_set_decl_assembler_name (decl, get_identifier (name));
1261 gfc_finish_var_decl (length, sym);
1262 gcc_assert (!sym->value);
1265 else if (sym->attr.subref_array_pointer)
1267 /* We need the span for these beasts. */
1268 gfc_allocate_lang_decl (decl);
1271 if (sym->attr.subref_array_pointer)
1274 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1275 span = build_decl (input_location,
1276 VAR_DECL, create_tmp_var_name ("span"),
1277 gfc_array_index_type);
1278 gfc_finish_var_decl (span, sym);
1279 TREE_STATIC (span) = TREE_STATIC (decl);
1280 DECL_ARTIFICIAL (span) = 1;
1281 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1283 GFC_DECL_SPAN (decl) = span;
1284 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1287 sym->backend_decl = decl;
1289 if (sym->attr.assign)
1290 gfc_add_assign_aux_vars (sym);
1292 if (intrinsic_array_parameter)
1294 TREE_STATIC (decl) = 1;
1295 DECL_EXTERNAL (decl) = 0;
1298 if (TREE_STATIC (decl)
1299 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1300 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1301 || gfc_option.flag_max_stack_var_size == 0
1302 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1304 /* Add static initializer. For procedures, it is only needed if
1305 SAVE is specified otherwise they need to be reinitialized
1306 every time the procedure is entered. The TREE_STATIC is
1307 in this case due to -fmax-stack-var-size=. */
1308 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1310 sym->attr.dimension,
1312 || sym->attr.allocatable,
1313 sym->attr.proc_pointer);
1316 if (!TREE_STATIC (decl)
1317 && POINTER_TYPE_P (TREE_TYPE (decl))
1318 && !sym->attr.pointer
1319 && !sym->attr.allocatable
1320 && !sym->attr.proc_pointer)
1321 DECL_BY_REFERENCE (decl) = 1;
1327 /* Substitute a temporary variable in place of the real one. */
1330 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1332 save->attr = sym->attr;
1333 save->decl = sym->backend_decl;
1335 gfc_clear_attr (&sym->attr);
1336 sym->attr.referenced = 1;
1337 sym->attr.flavor = FL_VARIABLE;
1339 sym->backend_decl = decl;
1343 /* Restore the original variable. */
1346 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1348 sym->attr = save->attr;
1349 sym->backend_decl = save->decl;
1353 /* Declare a procedure pointer. */
1356 get_proc_pointer_decl (gfc_symbol *sym)
1361 decl = sym->backend_decl;
1365 decl = build_decl (input_location,
1366 VAR_DECL, get_identifier (sym->name),
1367 build_pointer_type (gfc_get_function_type (sym)));
1369 if ((sym->ns->proc_name
1370 && sym->ns->proc_name->backend_decl == current_function_decl)
1371 || sym->attr.contained)
1372 gfc_add_decl_to_function (decl);
1373 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1374 gfc_add_decl_to_parent_function (decl);
1376 sym->backend_decl = decl;
1378 /* If a variable is USE associated, it's always external. */
1379 if (sym->attr.use_assoc)
1381 DECL_EXTERNAL (decl) = 1;
1382 TREE_PUBLIC (decl) = 1;
1384 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1386 /* This is the declaration of a module variable. */
1387 TREE_PUBLIC (decl) = 1;
1388 TREE_STATIC (decl) = 1;
1391 if (!sym->attr.use_assoc
1392 && (sym->attr.save != SAVE_NONE || sym->attr.data
1393 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1394 TREE_STATIC (decl) = 1;
1396 if (TREE_STATIC (decl) && sym->value)
1398 /* Add static initializer. */
1399 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1401 sym->attr.dimension,
1405 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1406 decl_attributes (&decl, attributes, 0);
1412 /* Get a basic decl for an external function. */
1415 gfc_get_extern_function_decl (gfc_symbol * sym)
1421 gfc_intrinsic_sym *isym;
1423 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1428 if (sym->backend_decl)
1429 return sym->backend_decl;
1431 /* We should never be creating external decls for alternate entry points.
1432 The procedure may be an alternate entry point, but we don't want/need
1434 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1436 if (sym->attr.proc_pointer)
1437 return get_proc_pointer_decl (sym);
1439 /* See if this is an external procedure from the same file. If so,
1440 return the backend_decl. */
1441 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1443 if (gfc_option.flag_whole_file
1444 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1445 && !sym->backend_decl
1447 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1448 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1450 if (!gsym->ns->proc_name->backend_decl)
1452 /* By construction, the external function cannot be
1453 a contained procedure. */
1455 tree save_fn_decl = current_function_decl;
1457 current_function_decl = NULL_TREE;
1458 gfc_save_backend_locus (&old_loc);
1461 gfc_create_function_decl (gsym->ns, true);
1464 gfc_restore_backend_locus (&old_loc);
1465 current_function_decl = save_fn_decl;
1468 /* If the namespace has entries, the proc_name is the
1469 entry master. Find the entry and use its backend_decl.
1470 otherwise, use the proc_name backend_decl. */
1471 if (gsym->ns->entries)
1473 gfc_entry_list *entry = gsym->ns->entries;
1475 for (; entry; entry = entry->next)
1477 if (strcmp (gsym->name, entry->sym->name) == 0)
1479 sym->backend_decl = entry->sym->backend_decl;
1485 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1487 if (sym->backend_decl)
1489 /* Avoid problems of double deallocation of the backend declaration
1490 later in gfc_trans_use_stmts; cf. PR 45087. */
1491 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1492 sym->attr.use_assoc = 0;
1494 return sym->backend_decl;
1498 /* See if this is a module procedure from the same file. If so,
1499 return the backend_decl. */
1501 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1503 if (gfc_option.flag_whole_file
1505 && gsym->type == GSYM_MODULE)
1510 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1511 if (s && s->backend_decl)
1513 sym->backend_decl = s->backend_decl;
1514 return sym->backend_decl;
1518 if (sym->attr.intrinsic)
1520 /* Call the resolution function to get the actual name. This is
1521 a nasty hack which relies on the resolution functions only looking
1522 at the first argument. We pass NULL for the second argument
1523 otherwise things like AINT get confused. */
1524 isym = gfc_find_function (sym->name);
1525 gcc_assert (isym->resolve.f0 != NULL);
1527 memset (&e, 0, sizeof (e));
1528 e.expr_type = EXPR_FUNCTION;
1530 memset (&argexpr, 0, sizeof (argexpr));
1531 gcc_assert (isym->formal);
1532 argexpr.ts = isym->formal->ts;
1534 if (isym->formal->next == NULL)
1535 isym->resolve.f1 (&e, &argexpr);
1538 if (isym->formal->next->next == NULL)
1539 isym->resolve.f2 (&e, &argexpr, NULL);
1542 if (isym->formal->next->next->next == NULL)
1543 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1546 /* All specific intrinsics take less than 5 arguments. */
1547 gcc_assert (isym->formal->next->next->next->next == NULL);
1548 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1553 if (gfc_option.flag_f2c
1554 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1555 || e.ts.type == BT_COMPLEX))
1557 /* Specific which needs a different implementation if f2c
1558 calling conventions are used. */
1559 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1562 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1564 name = get_identifier (s);
1565 mangled_name = name;
1569 name = gfc_sym_identifier (sym);
1570 mangled_name = gfc_sym_mangled_function_id (sym);
1573 type = gfc_get_function_type (sym);
1574 fndecl = build_decl (input_location,
1575 FUNCTION_DECL, name, type);
1577 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1578 decl_attributes (&fndecl, attributes, 0);
1580 gfc_set_decl_assembler_name (fndecl, mangled_name);
1582 /* Set the context of this decl. */
1583 if (0 && sym->ns && sym->ns->proc_name)
1585 /* TODO: Add external decls to the appropriate scope. */
1586 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1590 /* Global declaration, e.g. intrinsic subroutine. */
1591 DECL_CONTEXT (fndecl) = NULL_TREE;
1594 DECL_EXTERNAL (fndecl) = 1;
1596 /* This specifies if a function is globally addressable, i.e. it is
1597 the opposite of declaring static in C. */
1598 TREE_PUBLIC (fndecl) = 1;
1600 /* Set attributes for PURE functions. A call to PURE function in the
1601 Fortran 95 sense is both pure and without side effects in the C
1603 if (sym->attr.pure || sym->attr.elemental)
1605 if (sym->attr.function && !gfc_return_by_reference (sym))
1606 DECL_PURE_P (fndecl) = 1;
1607 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1608 parameters and don't use alternate returns (is this
1609 allowed?). In that case, calls to them are meaningless, and
1610 can be optimized away. See also in build_function_decl(). */
1611 TREE_SIDE_EFFECTS (fndecl) = 0;
1614 /* Mark non-returning functions. */
1615 if (sym->attr.noreturn)
1616 TREE_THIS_VOLATILE(fndecl) = 1;
1618 sym->backend_decl = fndecl;
1620 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1621 pushdecl_top_level (fndecl);
1627 /* Create a declaration for a procedure. For external functions (in the C
1628 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1629 a master function with alternate entry points. */
1632 build_function_decl (gfc_symbol * sym, bool global)
1634 tree fndecl, type, attributes;
1635 symbol_attribute attr;
1637 gfc_formal_arglist *f;
1639 gcc_assert (!sym->attr.external);
1641 if (sym->backend_decl)
1644 /* Set the line and filename. sym->declared_at seems to point to the
1645 last statement for subroutines, but it'll do for now. */
1646 gfc_set_backend_locus (&sym->declared_at);
1648 /* Allow only one nesting level. Allow public declarations. */
1649 gcc_assert (current_function_decl == NULL_TREE
1650 || DECL_FILE_SCOPE_P (current_function_decl)
1651 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1652 == NAMESPACE_DECL));
1654 type = gfc_get_function_type (sym);
1655 fndecl = build_decl (input_location,
1656 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1660 attributes = add_attributes_to_decl (attr, NULL_TREE);
1661 decl_attributes (&fndecl, attributes, 0);
1663 /* Figure out the return type of the declared function, and build a
1664 RESULT_DECL for it. If this is a subroutine with alternate
1665 returns, build a RESULT_DECL for it. */
1666 result_decl = NULL_TREE;
1667 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1670 if (gfc_return_by_reference (sym))
1671 type = void_type_node;
1674 if (sym->result != sym)
1675 result_decl = gfc_sym_identifier (sym->result);
1677 type = TREE_TYPE (TREE_TYPE (fndecl));
1682 /* Look for alternate return placeholders. */
1683 int has_alternate_returns = 0;
1684 for (f = sym->formal; f; f = f->next)
1688 has_alternate_returns = 1;
1693 if (has_alternate_returns)
1694 type = integer_type_node;
1696 type = void_type_node;
1699 result_decl = build_decl (input_location,
1700 RESULT_DECL, result_decl, type);
1701 DECL_ARTIFICIAL (result_decl) = 1;
1702 DECL_IGNORED_P (result_decl) = 1;
1703 DECL_CONTEXT (result_decl) = fndecl;
1704 DECL_RESULT (fndecl) = result_decl;
1706 /* Don't call layout_decl for a RESULT_DECL.
1707 layout_decl (result_decl, 0); */
1709 /* Set up all attributes for the function. */
1710 DECL_EXTERNAL (fndecl) = 0;
1712 /* This specifies if a function is globally visible, i.e. it is
1713 the opposite of declaring static in C. */
1714 if (!current_function_decl
1715 && !sym->attr.entry_master && !sym->attr.is_main_program)
1716 TREE_PUBLIC (fndecl) = 1;
1718 /* TREE_STATIC means the function body is defined here. */
1719 TREE_STATIC (fndecl) = 1;
1721 /* Set attributes for PURE functions. A call to a PURE function in the
1722 Fortran 95 sense is both pure and without side effects in the C
1724 if (attr.pure || attr.elemental)
1726 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1727 including an alternate return. In that case it can also be
1728 marked as PURE. See also in gfc_get_extern_function_decl(). */
1729 if (attr.function && !gfc_return_by_reference (sym))
1730 DECL_PURE_P (fndecl) = 1;
1731 TREE_SIDE_EFFECTS (fndecl) = 0;
1735 /* Layout the function declaration and put it in the binding level
1736 of the current function. */
1739 pushdecl_top_level (fndecl);
1743 /* Perform name mangling if this is a top level or module procedure. */
1744 if (current_function_decl == NULL_TREE)
1745 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1747 sym->backend_decl = fndecl;
1751 /* Create the DECL_ARGUMENTS for a procedure. */
1754 create_function_arglist (gfc_symbol * sym)
1757 gfc_formal_arglist *f;
1758 tree typelist, hidden_typelist;
1759 tree arglist, hidden_arglist;
1763 fndecl = sym->backend_decl;
1765 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1766 the new FUNCTION_DECL node. */
1767 arglist = NULL_TREE;
1768 hidden_arglist = NULL_TREE;
1769 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1771 if (sym->attr.entry_master)
1773 type = TREE_VALUE (typelist);
1774 parm = build_decl (input_location,
1775 PARM_DECL, get_identifier ("__entry"), type);
1777 DECL_CONTEXT (parm) = fndecl;
1778 DECL_ARG_TYPE (parm) = type;
1779 TREE_READONLY (parm) = 1;
1780 gfc_finish_decl (parm);
1781 DECL_ARTIFICIAL (parm) = 1;
1783 arglist = chainon (arglist, parm);
1784 typelist = TREE_CHAIN (typelist);
1787 if (gfc_return_by_reference (sym))
1789 tree type = TREE_VALUE (typelist), length = NULL;
1791 if (sym->ts.type == BT_CHARACTER)
1793 /* Length of character result. */
1794 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1795 gcc_assert (len_type == gfc_charlen_type_node);
1797 length = build_decl (input_location,
1799 get_identifier (".__result"),
1801 if (!sym->ts.u.cl->length)
1803 sym->ts.u.cl->backend_decl = length;
1804 TREE_USED (length) = 1;
1806 gcc_assert (TREE_CODE (length) == PARM_DECL);
1807 DECL_CONTEXT (length) = fndecl;
1808 DECL_ARG_TYPE (length) = len_type;
1809 TREE_READONLY (length) = 1;
1810 DECL_ARTIFICIAL (length) = 1;
1811 gfc_finish_decl (length);
1812 if (sym->ts.u.cl->backend_decl == NULL
1813 || sym->ts.u.cl->backend_decl == length)
1818 if (sym->ts.u.cl->backend_decl == NULL)
1820 tree len = build_decl (input_location,
1822 get_identifier ("..__result"),
1823 gfc_charlen_type_node);
1824 DECL_ARTIFICIAL (len) = 1;
1825 TREE_USED (len) = 1;
1826 sym->ts.u.cl->backend_decl = len;
1829 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1830 arg = sym->result ? sym->result : sym;
1831 backend_decl = arg->backend_decl;
1832 /* Temporary clear it, so that gfc_sym_type creates complete
1834 arg->backend_decl = NULL;
1835 type = gfc_sym_type (arg);
1836 arg->backend_decl = backend_decl;
1837 type = build_reference_type (type);
1841 parm = build_decl (input_location,
1842 PARM_DECL, get_identifier ("__result"), type);
1844 DECL_CONTEXT (parm) = fndecl;
1845 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1846 TREE_READONLY (parm) = 1;
1847 DECL_ARTIFICIAL (parm) = 1;
1848 gfc_finish_decl (parm);
1850 arglist = chainon (arglist, parm);
1851 typelist = TREE_CHAIN (typelist);
1853 if (sym->ts.type == BT_CHARACTER)
1855 gfc_allocate_lang_decl (parm);
1856 arglist = chainon (arglist, length);
1857 typelist = TREE_CHAIN (typelist);
1861 hidden_typelist = typelist;
1862 for (f = sym->formal; f; f = f->next)
1863 if (f->sym != NULL) /* Ignore alternate returns. */
1864 hidden_typelist = TREE_CHAIN (hidden_typelist);
1866 for (f = sym->formal; f; f = f->next)
1868 char name[GFC_MAX_SYMBOL_LEN + 2];
1870 /* Ignore alternate returns. */
1874 type = TREE_VALUE (typelist);
1876 if (f->sym->ts.type == BT_CHARACTER
1877 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1879 tree len_type = TREE_VALUE (hidden_typelist);
1880 tree length = NULL_TREE;
1881 gcc_assert (len_type == gfc_charlen_type_node);
1883 strcpy (&name[1], f->sym->name);
1885 length = build_decl (input_location,
1886 PARM_DECL, get_identifier (name), len_type);
1888 hidden_arglist = chainon (hidden_arglist, length);
1889 DECL_CONTEXT (length) = fndecl;
1890 DECL_ARTIFICIAL (length) = 1;
1891 DECL_ARG_TYPE (length) = len_type;
1892 TREE_READONLY (length) = 1;
1893 gfc_finish_decl (length);
1895 /* Remember the passed value. */
1896 if (f->sym->ts.u.cl->passed_length != NULL)
1898 /* This can happen if the same type is used for multiple
1899 arguments. We need to copy cl as otherwise
1900 cl->passed_length gets overwritten. */
1901 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1903 f->sym->ts.u.cl->passed_length = length;
1905 /* Use the passed value for assumed length variables. */
1906 if (!f->sym->ts.u.cl->length)
1908 TREE_USED (length) = 1;
1909 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1910 f->sym->ts.u.cl->backend_decl = length;
1913 hidden_typelist = TREE_CHAIN (hidden_typelist);
1915 if (f->sym->ts.u.cl->backend_decl == NULL
1916 || f->sym->ts.u.cl->backend_decl == length)
1918 if (f->sym->ts.u.cl->backend_decl == NULL)
1919 gfc_create_string_length (f->sym);
1921 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1922 if (f->sym->attr.flavor == FL_PROCEDURE)
1923 type = build_pointer_type (gfc_get_function_type (f->sym));
1925 type = gfc_sym_type (f->sym);
1929 /* For non-constant length array arguments, make sure they use
1930 a different type node from TYPE_ARG_TYPES type. */
1931 if (f->sym->attr.dimension
1932 && type == TREE_VALUE (typelist)
1933 && TREE_CODE (type) == POINTER_TYPE
1934 && GFC_ARRAY_TYPE_P (type)
1935 && f->sym->as->type != AS_ASSUMED_SIZE
1936 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1938 if (f->sym->attr.flavor == FL_PROCEDURE)
1939 type = build_pointer_type (gfc_get_function_type (f->sym));
1941 type = gfc_sym_type (f->sym);
1944 if (f->sym->attr.proc_pointer)
1945 type = build_pointer_type (type);
1947 /* Build the argument declaration. */
1948 parm = build_decl (input_location,
1949 PARM_DECL, gfc_sym_identifier (f->sym), type);
1951 /* Fill in arg stuff. */
1952 DECL_CONTEXT (parm) = fndecl;
1953 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1954 /* All implementation args are read-only. */
1955 TREE_READONLY (parm) = 1;
1956 if (POINTER_TYPE_P (type)
1957 && (!f->sym->attr.proc_pointer
1958 && f->sym->attr.flavor != FL_PROCEDURE))
1959 DECL_BY_REFERENCE (parm) = 1;
1961 gfc_finish_decl (parm);
1963 f->sym->backend_decl = parm;
1965 arglist = chainon (arglist, parm);
1966 typelist = TREE_CHAIN (typelist);
1969 /* Add the hidden string length parameters, unless the procedure
1971 if (!sym->attr.is_bind_c)
1972 arglist = chainon (arglist, hidden_arglist);
1974 gcc_assert (hidden_typelist == NULL_TREE
1975 || TREE_VALUE (hidden_typelist) == void_type_node);
1976 DECL_ARGUMENTS (fndecl) = arglist;
1979 /* Do the setup necessary before generating the body of a function. */
1982 trans_function_start (gfc_symbol * sym)
1986 fndecl = sym->backend_decl;
1988 /* Let GCC know the current scope is this function. */
1989 current_function_decl = fndecl;
1991 /* Let the world know what we're about to do. */
1992 announce_function (fndecl);
1994 if (DECL_FILE_SCOPE_P (fndecl))
1996 /* Create RTL for function declaration. */
1997 rest_of_decl_compilation (fndecl, 1, 0);
2000 /* Create RTL for function definition. */
2001 make_decl_rtl (fndecl);
2003 init_function_start (fndecl);
2005 /* Even though we're inside a function body, we still don't want to
2006 call expand_expr to calculate the size of a variable-sized array.
2007 We haven't necessarily assigned RTL to all variables yet, so it's
2008 not safe to try to expand expressions involving them. */
2009 cfun->dont_save_pending_sizes_p = 1;
2011 /* function.c requires a push at the start of the function. */
2015 /* Create thunks for alternate entry points. */
2018 build_entry_thunks (gfc_namespace * ns, bool global)
2020 gfc_formal_arglist *formal;
2021 gfc_formal_arglist *thunk_formal;
2023 gfc_symbol *thunk_sym;
2029 /* This should always be a toplevel function. */
2030 gcc_assert (current_function_decl == NULL_TREE);
2032 gfc_save_backend_locus (&old_loc);
2033 for (el = ns->entries; el; el = el->next)
2035 VEC(tree,gc) *args = NULL;
2036 VEC(tree,gc) *string_args = NULL;
2038 thunk_sym = el->sym;
2040 build_function_decl (thunk_sym, global);
2041 create_function_arglist (thunk_sym);
2043 trans_function_start (thunk_sym);
2045 thunk_fndecl = thunk_sym->backend_decl;
2047 gfc_init_block (&body);
2049 /* Pass extra parameter identifying this entry point. */
2050 tmp = build_int_cst (gfc_array_index_type, el->id);
2051 VEC_safe_push (tree, gc, args, tmp);
2053 if (thunk_sym->attr.function)
2055 if (gfc_return_by_reference (ns->proc_name))
2057 tree ref = DECL_ARGUMENTS (current_function_decl);
2058 VEC_safe_push (tree, gc, args, ref);
2059 if (ns->proc_name->ts.type == BT_CHARACTER)
2060 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2064 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2066 /* Ignore alternate returns. */
2067 if (formal->sym == NULL)
2070 /* We don't have a clever way of identifying arguments, so resort to
2071 a brute-force search. */
2072 for (thunk_formal = thunk_sym->formal;
2074 thunk_formal = thunk_formal->next)
2076 if (thunk_formal->sym == formal->sym)
2082 /* Pass the argument. */
2083 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2084 VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2085 if (formal->sym->ts.type == BT_CHARACTER)
2087 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2088 VEC_safe_push (tree, gc, string_args, tmp);
2093 /* Pass NULL for a missing argument. */
2094 VEC_safe_push (tree, gc, args, null_pointer_node);
2095 if (formal->sym->ts.type == BT_CHARACTER)
2097 tmp = build_int_cst (gfc_charlen_type_node, 0);
2098 VEC_safe_push (tree, gc, string_args, tmp);
2103 /* Call the master function. */
2104 VEC_safe_splice (tree, gc, args, string_args);
2105 tmp = ns->proc_name->backend_decl;
2106 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2107 if (ns->proc_name->attr.mixed_entry_master)
2109 tree union_decl, field;
2110 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2112 union_decl = build_decl (input_location,
2113 VAR_DECL, get_identifier ("__result"),
2114 TREE_TYPE (master_type));
2115 DECL_ARTIFICIAL (union_decl) = 1;
2116 DECL_EXTERNAL (union_decl) = 0;
2117 TREE_PUBLIC (union_decl) = 0;
2118 TREE_USED (union_decl) = 1;
2119 layout_decl (union_decl, 0);
2120 pushdecl (union_decl);
2122 DECL_CONTEXT (union_decl) = current_function_decl;
2123 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2124 TREE_TYPE (union_decl), union_decl, tmp);
2125 gfc_add_expr_to_block (&body, tmp);
2127 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2128 field; field = DECL_CHAIN (field))
2129 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2130 thunk_sym->result->name) == 0)
2132 gcc_assert (field != NULL_TREE);
2133 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2134 TREE_TYPE (field), union_decl, field,
2136 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2137 TREE_TYPE (DECL_RESULT (current_function_decl)),
2138 DECL_RESULT (current_function_decl), tmp);
2139 tmp = build1_v (RETURN_EXPR, tmp);
2141 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2144 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2145 TREE_TYPE (DECL_RESULT (current_function_decl)),
2146 DECL_RESULT (current_function_decl), tmp);
2147 tmp = build1_v (RETURN_EXPR, tmp);
2149 gfc_add_expr_to_block (&body, tmp);
2151 /* Finish off this function and send it for code generation. */
2152 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2155 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2156 DECL_SAVED_TREE (thunk_fndecl)
2157 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2158 DECL_INITIAL (thunk_fndecl));
2160 /* Output the GENERIC tree. */
2161 dump_function (TDI_original, thunk_fndecl);
2163 /* Store the end of the function, so that we get good line number
2164 info for the epilogue. */
2165 cfun->function_end_locus = input_location;
2167 /* We're leaving the context of this function, so zap cfun.
2168 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2169 tree_rest_of_compilation. */
2172 current_function_decl = NULL_TREE;
2174 cgraph_finalize_function (thunk_fndecl, true);
2176 /* We share the symbols in the formal argument list with other entry
2177 points and the master function. Clear them so that they are
2178 recreated for each function. */
2179 for (formal = thunk_sym->formal; formal; formal = formal->next)
2180 if (formal->sym != NULL) /* Ignore alternate returns. */
2182 formal->sym->backend_decl = NULL_TREE;
2183 if (formal->sym->ts.type == BT_CHARACTER)
2184 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2187 if (thunk_sym->attr.function)
2189 if (thunk_sym->ts.type == BT_CHARACTER)
2190 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2191 if (thunk_sym->result->ts.type == BT_CHARACTER)
2192 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2196 gfc_restore_backend_locus (&old_loc);
2200 /* Create a decl for a function, and create any thunks for alternate entry
2201 points. If global is true, generate the function in the global binding
2202 level, otherwise in the current binding level (which can be global). */
2205 gfc_create_function_decl (gfc_namespace * ns, bool global)
2207 /* Create a declaration for the master function. */
2208 build_function_decl (ns->proc_name, global);
2210 /* Compile the entry thunks. */
2212 build_entry_thunks (ns, global);
2214 /* Now create the read argument list. */
2215 create_function_arglist (ns->proc_name);
2218 /* Return the decl used to hold the function return value. If
2219 parent_flag is set, the context is the parent_scope. */
2222 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2226 tree this_fake_result_decl;
2227 tree this_function_decl;
2229 char name[GFC_MAX_SYMBOL_LEN + 10];
2233 this_fake_result_decl = parent_fake_result_decl;
2234 this_function_decl = DECL_CONTEXT (current_function_decl);
2238 this_fake_result_decl = current_fake_result_decl;
2239 this_function_decl = current_function_decl;
2243 && sym->ns->proc_name->backend_decl == this_function_decl
2244 && sym->ns->proc_name->attr.entry_master
2245 && sym != sym->ns->proc_name)
2248 if (this_fake_result_decl != NULL)
2249 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2250 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2253 return TREE_VALUE (t);
2254 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2257 this_fake_result_decl = parent_fake_result_decl;
2259 this_fake_result_decl = current_fake_result_decl;
2261 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2265 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2266 field; field = DECL_CHAIN (field))
2267 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2271 gcc_assert (field != NULL_TREE);
2272 decl = fold_build3_loc (input_location, COMPONENT_REF,
2273 TREE_TYPE (field), decl, field, NULL_TREE);
2276 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2278 gfc_add_decl_to_parent_function (var);
2280 gfc_add_decl_to_function (var);
2282 SET_DECL_VALUE_EXPR (var, decl);
2283 DECL_HAS_VALUE_EXPR_P (var) = 1;
2284 GFC_DECL_RESULT (var) = 1;
2286 TREE_CHAIN (this_fake_result_decl)
2287 = tree_cons (get_identifier (sym->name), var,
2288 TREE_CHAIN (this_fake_result_decl));
2292 if (this_fake_result_decl != NULL_TREE)
2293 return TREE_VALUE (this_fake_result_decl);
2295 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2300 if (sym->ts.type == BT_CHARACTER)
2302 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2303 length = gfc_create_string_length (sym);
2305 length = sym->ts.u.cl->backend_decl;
2306 if (TREE_CODE (length) == VAR_DECL
2307 && DECL_CONTEXT (length) == NULL_TREE)
2308 gfc_add_decl_to_function (length);
2311 if (gfc_return_by_reference (sym))
2313 decl = DECL_ARGUMENTS (this_function_decl);
2315 if (sym->ns->proc_name->backend_decl == this_function_decl
2316 && sym->ns->proc_name->attr.entry_master)
2317 decl = DECL_CHAIN (decl);
2319 TREE_USED (decl) = 1;
2321 decl = gfc_build_dummy_array_decl (sym, decl);
2325 sprintf (name, "__result_%.20s",
2326 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2328 if (!sym->attr.mixed_entry_master && sym->attr.function)
2329 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2330 VAR_DECL, get_identifier (name),
2331 gfc_sym_type (sym));
2333 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2334 VAR_DECL, get_identifier (name),
2335 TREE_TYPE (TREE_TYPE (this_function_decl)));
2336 DECL_ARTIFICIAL (decl) = 1;
2337 DECL_EXTERNAL (decl) = 0;
2338 TREE_PUBLIC (decl) = 0;
2339 TREE_USED (decl) = 1;
2340 GFC_DECL_RESULT (decl) = 1;
2341 TREE_ADDRESSABLE (decl) = 1;
2343 layout_decl (decl, 0);
2346 gfc_add_decl_to_parent_function (decl);
2348 gfc_add_decl_to_function (decl);
2352 parent_fake_result_decl = build_tree_list (NULL, decl);
2354 current_fake_result_decl = build_tree_list (NULL, decl);
2360 /* Builds a function decl. The remaining parameters are the types of the
2361 function arguments. Negative nargs indicates a varargs function. */
2364 build_library_function_decl_1 (tree name, const char *spec,
2365 tree rettype, int nargs, va_list p)
2373 /* Library functions must be declared with global scope. */
2374 gcc_assert (current_function_decl == NULL_TREE);
2376 /* Create a list of the argument types. */
2377 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2379 argtype = va_arg (p, tree);
2380 arglist = gfc_chainon_list (arglist, argtype);
2385 /* Terminate the list. */
2386 arglist = chainon (arglist, void_list_node);
2389 /* Build the function type and decl. */
2390 fntype = build_function_type (rettype, arglist);
2393 tree attr_args = build_tree_list (NULL_TREE,
2394 build_string (strlen (spec), spec));
2395 tree attrs = tree_cons (get_identifier ("fn spec"),
2396 attr_args, TYPE_ATTRIBUTES (fntype));
2397 fntype = build_type_attribute_variant (fntype, attrs);
2399 fndecl = build_decl (input_location,
2400 FUNCTION_DECL, name, fntype);
2402 /* Mark this decl as external. */
2403 DECL_EXTERNAL (fndecl) = 1;
2404 TREE_PUBLIC (fndecl) = 1;
2408 rest_of_decl_compilation (fndecl, 1, 0);
2413 /* Builds a function decl. The remaining parameters are the types of the
2414 function arguments. Negative nargs indicates a varargs function. */
2417 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2421 va_start (args, nargs);
2422 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2427 /* Builds a function decl. The remaining parameters are the types of the
2428 function arguments. Negative nargs indicates a varargs function.
2429 The SPEC parameter specifies the function argument and return type
2430 specification according to the fnspec function type attribute. */
2433 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2434 tree rettype, int nargs, ...)
2438 va_start (args, nargs);
2439 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2445 gfc_build_intrinsic_function_decls (void)
2447 tree gfc_int4_type_node = gfc_get_int_type (4);
2448 tree gfc_int8_type_node = gfc_get_int_type (8);
2449 tree gfc_int16_type_node = gfc_get_int_type (16);
2450 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2451 tree pchar1_type_node = gfc_get_pchar_type (1);
2452 tree pchar4_type_node = gfc_get_pchar_type (4);
2454 /* String functions. */
2455 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2456 get_identifier (PREFIX("compare_string")), "..R.R",
2457 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2458 gfc_charlen_type_node, pchar1_type_node);
2459 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2460 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2462 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2463 get_identifier (PREFIX("concat_string")), "..W.R.R",
2464 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2465 gfc_charlen_type_node, pchar1_type_node,
2466 gfc_charlen_type_node, pchar1_type_node);
2467 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2469 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2470 get_identifier (PREFIX("string_len_trim")), "..R",
2471 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2472 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2473 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2475 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2476 get_identifier (PREFIX("string_index")), "..R.R.",
2477 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2478 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2479 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2480 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2482 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2483 get_identifier (PREFIX("string_scan")), "..R.R.",
2484 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2485 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2486 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2487 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2489 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2490 get_identifier (PREFIX("string_verify")), "..R.R.",
2491 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2492 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2493 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2494 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2496 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2497 get_identifier (PREFIX("string_trim")), ".Ww.R",
2498 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2499 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2502 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2503 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2504 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2505 build_pointer_type (pchar1_type_node), integer_type_node,
2508 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2509 get_identifier (PREFIX("adjustl")), ".W.R",
2510 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2512 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2514 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2515 get_identifier (PREFIX("adjustr")), ".W.R",
2516 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2518 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2520 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2521 get_identifier (PREFIX("select_string")), ".R.R.",
2522 integer_type_node, 4, pvoid_type_node, integer_type_node,
2523 pchar1_type_node, gfc_charlen_type_node);
2524 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2525 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2527 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2528 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2529 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2530 gfc_charlen_type_node, pchar4_type_node);
2531 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2532 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2534 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2535 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2536 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2537 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2539 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2541 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2542 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2543 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2544 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2545 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2547 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2548 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2549 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2550 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2551 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2552 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2554 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2555 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2556 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2557 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2558 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2559 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2561 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2562 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2563 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2564 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2565 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2566 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2568 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2569 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2570 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2571 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2574 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2575 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2576 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2577 build_pointer_type (pchar4_type_node), integer_type_node,
2580 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2581 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2582 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2584 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2586 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2587 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2588 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2590 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2592 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2593 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2594 integer_type_node, 4, pvoid_type_node, integer_type_node,
2595 pvoid_type_node, gfc_charlen_type_node);
2596 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2597 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2600 /* Conversion between character kinds. */
2602 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2603 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2604 void_type_node, 3, build_pointer_type (pchar4_type_node),
2605 gfc_charlen_type_node, pchar1_type_node);
2607 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2608 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2609 void_type_node, 3, build_pointer_type (pchar1_type_node),
2610 gfc_charlen_type_node, pchar4_type_node);
2612 /* Misc. functions. */
2614 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2615 get_identifier (PREFIX("ttynam")), ".W",
2616 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2619 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2620 get_identifier (PREFIX("fdate")), ".W",
2621 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2623 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2624 get_identifier (PREFIX("ctime")), ".W",
2625 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2626 gfc_int8_type_node);
2628 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2629 get_identifier (PREFIX("selected_char_kind")), "..R",
2630 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2631 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2632 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2634 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2635 get_identifier (PREFIX("selected_int_kind")), ".R",
2636 gfc_int4_type_node, 1, pvoid_type_node);
2637 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2638 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2640 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2641 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2642 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2644 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2645 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2647 /* Power functions. */
2649 tree ctype, rtype, itype, jtype;
2650 int rkind, ikind, jkind;
2653 static int ikinds[NIKINDS] = {4, 8, 16};
2654 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2655 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2657 for (ikind=0; ikind < NIKINDS; ikind++)
2659 itype = gfc_get_int_type (ikinds[ikind]);
2661 for (jkind=0; jkind < NIKINDS; jkind++)
2663 jtype = gfc_get_int_type (ikinds[jkind]);
2666 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2668 gfor_fndecl_math_powi[jkind][ikind].integer =
2669 gfc_build_library_function_decl (get_identifier (name),
2670 jtype, 2, jtype, itype);
2671 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2672 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2676 for (rkind = 0; rkind < NRKINDS; rkind ++)
2678 rtype = gfc_get_real_type (rkinds[rkind]);
2681 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2683 gfor_fndecl_math_powi[rkind][ikind].real =
2684 gfc_build_library_function_decl (get_identifier (name),
2685 rtype, 2, rtype, itype);
2686 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2687 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2690 ctype = gfc_get_complex_type (rkinds[rkind]);
2693 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2695 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2696 gfc_build_library_function_decl (get_identifier (name),
2697 ctype, 2,ctype, itype);
2698 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2699 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2707 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2708 get_identifier (PREFIX("ishftc4")),
2709 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2710 gfc_int4_type_node);
2711 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2712 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2714 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2715 get_identifier (PREFIX("ishftc8")),
2716 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2717 gfc_int4_type_node);
2718 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2719 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2721 if (gfc_int16_type_node)
2723 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2724 get_identifier (PREFIX("ishftc16")),
2725 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2726 gfc_int4_type_node);
2727 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2728 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2731 /* BLAS functions. */
2733 tree pint = build_pointer_type (integer_type_node);
2734 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2735 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2736 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2737 tree pz = build_pointer_type
2738 (gfc_get_complex_type (gfc_default_double_kind));
2740 gfor_fndecl_sgemm = gfc_build_library_function_decl
2742 (gfc_option.flag_underscoring ? "sgemm_"
2744 void_type_node, 15, pchar_type_node,
2745 pchar_type_node, pint, pint, pint, ps, ps, pint,
2746 ps, pint, ps, ps, pint, integer_type_node,
2748 gfor_fndecl_dgemm = gfc_build_library_function_decl
2750 (gfc_option.flag_underscoring ? "dgemm_"
2752 void_type_node, 15, pchar_type_node,
2753 pchar_type_node, pint, pint, pint, pd, pd, pint,
2754 pd, pint, pd, pd, pint, integer_type_node,
2756 gfor_fndecl_cgemm = gfc_build_library_function_decl
2758 (gfc_option.flag_underscoring ? "cgemm_"
2760 void_type_node, 15, pchar_type_node,
2761 pchar_type_node, pint, pint, pint, pc, pc, pint,
2762 pc, pint, pc, pc, pint, integer_type_node,
2764 gfor_fndecl_zgemm = gfc_build_library_function_decl
2766 (gfc_option.flag_underscoring ? "zgemm_"
2768 void_type_node, 15, pchar_type_node,
2769 pchar_type_node, pint, pint, pint, pz, pz, pint,
2770 pz, pint, pz, pz, pint, integer_type_node,
2774 /* Other functions. */
2775 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
2776 get_identifier (PREFIX("size0")), ".R",
2777 gfc_array_index_type, 1, pvoid_type_node);
2778 DECL_PURE_P (gfor_fndecl_size0) = 1;
2779 TREE_NOTHROW (gfor_fndecl_size0) = 1;
2781 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
2782 get_identifier (PREFIX("size1")), ".R",
2783 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
2784 DECL_PURE_P (gfor_fndecl_size1) = 1;
2785 TREE_NOTHROW (gfor_fndecl_size1) = 1;
2787 gfor_fndecl_iargc = gfc_build_library_function_decl (
2788 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
2789 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
2793 /* Make prototypes for runtime library functions. */
2796 gfc_build_builtin_function_decls (void)
2798 tree gfc_int4_type_node = gfc_get_int_type (4);
2800 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
2801 get_identifier (PREFIX("stop_numeric")),
2802 void_type_node, 1, gfc_int4_type_node);
2803 /* STOP doesn't return. */
2804 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2806 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
2807 get_identifier (PREFIX("stop_numeric_f08")),
2808 void_type_node, 1, gfc_int4_type_node);
2809 /* STOP doesn't return. */
2810 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
2812 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
2813 get_identifier (PREFIX("stop_string")), ".R.",
2814 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2815 /* STOP doesn't return. */
2816 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2818 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
2819 get_identifier (PREFIX("error_stop_numeric")),
2820 void_type_node, 1, gfc_int4_type_node);
2821 /* ERROR STOP doesn't return. */
2822 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2824 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
2825 get_identifier (PREFIX("error_stop_string")), ".R.",
2826 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2827 /* ERROR STOP doesn't return. */
2828 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2830 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
2831 get_identifier (PREFIX("pause_numeric")),
2832 void_type_node, 1, gfc_int4_type_node);
2834 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
2835 get_identifier (PREFIX("pause_string")), ".R.",
2836 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
2838 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
2839 get_identifier (PREFIX("runtime_error")), ".R",
2840 void_type_node, -1, pchar_type_node);
2841 /* The runtime_error function does not return. */
2842 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2844 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
2845 get_identifier (PREFIX("runtime_error_at")), ".RR",
2846 void_type_node, -2, pchar_type_node, pchar_type_node);
2847 /* The runtime_error_at function does not return. */
2848 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2850 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
2851 get_identifier (PREFIX("runtime_warning_at")), ".RR",
2852 void_type_node, -2, pchar_type_node, pchar_type_node);
2854 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
2855 get_identifier (PREFIX("generate_error")), ".R.R",
2856 void_type_node, 3, pvoid_type_node, integer_type_node,
2859 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
2860 get_identifier (PREFIX("os_error")), ".R",
2861 void_type_node, 1, pchar_type_node);
2862 /* The runtime_error function does not return. */
2863 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2865 gfor_fndecl_set_args = gfc_build_library_function_decl (
2866 get_identifier (PREFIX("set_args")),
2867 void_type_node, 2, integer_type_node,
2868 build_pointer_type (pchar_type_node));
2870 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
2871 get_identifier (PREFIX("set_fpe")),
2872 void_type_node, 1, integer_type_node);
2874 /* Keep the array dimension in sync with the call, later in this file. */
2875 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
2876 get_identifier (PREFIX("set_options")), "..R",
2877 void_type_node, 2, integer_type_node,
2878 build_pointer_type (integer_type_node));
2880 gfor_fndecl_set_convert = gfc_build_library_function_decl (
2881 get_identifier (PREFIX("set_convert")),
2882 void_type_node, 1, integer_type_node);
2884 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
2885 get_identifier (PREFIX("set_record_marker")),
2886 void_type_node, 1, integer_type_node);
2888 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
2889 get_identifier (PREFIX("set_max_subrecord_length")),
2890 void_type_node, 1, integer_type_node);
2892 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2893 get_identifier (PREFIX("internal_pack")), ".r",
2894 pvoid_type_node, 1, pvoid_type_node);
2896 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2897 get_identifier (PREFIX("internal_unpack")), ".wR",
2898 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2900 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
2901 get_identifier (PREFIX("associated")), ".RR",
2902 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
2903 DECL_PURE_P (gfor_fndecl_associated) = 1;
2904 TREE_NOTHROW (gfor_fndecl_associated) = 1;
2906 gfc_build_intrinsic_function_decls ();
2907 gfc_build_intrinsic_lib_fndecls ();
2908 gfc_build_io_library_fndecls ();
2912 /* Evaluate the length of dummy character variables. */
2915 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
2916 gfc_wrapped_block *block)
2920 gfc_finish_decl (cl->backend_decl);
2922 gfc_start_block (&init);
2924 /* Evaluate the string length expression. */
2925 gfc_conv_string_length (cl, NULL, &init);
2927 gfc_trans_vla_type_sizes (sym, &init);
2929 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2933 /* Allocate and cleanup an automatic character variable. */
2936 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
2942 gcc_assert (sym->backend_decl);
2943 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2945 gfc_start_block (&init);
2947 /* Evaluate the string length expression. */
2948 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
2950 gfc_trans_vla_type_sizes (sym, &init);
2952 decl = sym->backend_decl;
2954 /* Emit a DECL_EXPR for this variable, which will cause the
2955 gimplifier to allocate storage, and all that good stuff. */
2956 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
2957 gfc_add_expr_to_block (&init, tmp);
2959 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2962 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2965 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
2969 gcc_assert (sym->backend_decl);
2970 gfc_start_block (&init);
2972 /* Set the initial value to length. See the comments in
2973 function gfc_add_assign_aux_vars in this file. */
2974 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
2975 build_int_cst (NULL_TREE, -2));
2977 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
2981 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2983 tree t = *tp, var, val;
2985 if (t == NULL || t == error_mark_node)
2987 if (TREE_CONSTANT (t) || DECL_P (t))
2990 if (TREE_CODE (t) == SAVE_EXPR)
2992 if (SAVE_EXPR_RESOLVED_P (t))
2994 *tp = TREE_OPERAND (t, 0);
2997 val = TREE_OPERAND (t, 0);
3002 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3003 gfc_add_decl_to_function (var);
3004 gfc_add_modify (body, var, val);
3005 if (TREE_CODE (t) == SAVE_EXPR)
3006 TREE_OPERAND (t, 0) = var;
3011 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3015 if (type == NULL || type == error_mark_node)
3018 type = TYPE_MAIN_VARIANT (type);
3020 if (TREE_CODE (type) == INTEGER_TYPE)
3022 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3023 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3025 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3027 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3028 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3031 else if (TREE_CODE (type) == ARRAY_TYPE)
3033 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3034 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3035 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3036 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3038 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3040 TYPE_SIZE (t) = TYPE_SIZE (type);
3041 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3046 /* Make sure all type sizes and array domains are either constant,
3047 or variable or parameter decls. This is a simplified variant
3048 of gimplify_type_sizes, but we can't use it here, as none of the
3049 variables in the expressions have been gimplified yet.
3050 As type sizes and domains for various variable length arrays
3051 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3052 time, without this routine gimplify_type_sizes in the middle-end
3053 could result in the type sizes being gimplified earlier than where
3054 those variables are initialized. */
3057 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3059 tree type = TREE_TYPE (sym->backend_decl);
3061 if (TREE_CODE (type) == FUNCTION_TYPE
3062 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3064 if (! current_fake_result_decl)
3067 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3070 while (POINTER_TYPE_P (type))
3071 type = TREE_TYPE (type);
3073 if (GFC_DESCRIPTOR_TYPE_P (type))
3075 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3077 while (POINTER_TYPE_P (etype))
3078 etype = TREE_TYPE (etype);
3080 gfc_trans_vla_type_sizes_1 (etype, body);
3083 gfc_trans_vla_type_sizes_1 (type, body);
3087 /* Initialize a derived type by building an lvalue from the symbol
3088 and using trans_assignment to do the work. Set dealloc to false
3089 if no deallocation prior the assignment is needed. */
3091 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3099 gcc_assert (!sym->attr.allocatable);
3100 gfc_set_sym_referenced (sym);
3101 e = gfc_lval_expr_from_sym (sym);
3102 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3103 if (sym->attr.dummy && (sym->attr.optional
3104 || sym->ns->proc_name->attr.entry_master))
3106 present = gfc_conv_expr_present (sym);
3107 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3108 tmp, build_empty_stmt (input_location));
3110 gfc_add_expr_to_block (block, tmp);
3115 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3116 them their default initializer, if they do not have allocatable
3117 components, they have their allocatable components deallocated. */
3120 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3123 gfc_formal_arglist *f;
3127 gfc_init_block (&init);
3128 for (f = proc_sym->formal; f; f = f->next)
3129 if (f->sym && f->sym->attr.intent == INTENT_OUT
3130 && !f->sym->attr.pointer
3131 && f->sym->ts.type == BT_DERIVED)
3133 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3135 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3136 f->sym->backend_decl,
3137 f->sym->as ? f->sym->as->rank : 0);
3139 if (f->sym->attr.optional
3140 || f->sym->ns->proc_name->attr.entry_master)
3142 present = gfc_conv_expr_present (f->sym);
3143 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3145 build_empty_stmt (input_location));
3148 gfc_add_expr_to_block (&init, tmp);
3150 else if (f->sym->value)
3151 gfc_init_default_dt (f->sym, &init, true);
3154 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3158 /* Do proper initialization for ASSOCIATE names. */
3161 trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
3166 gcc_assert (sym->assoc);
3167 e = sym->assoc->target;
3169 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
3170 to array temporary) for arrays with either unknown shape or if associating
3172 if (sym->attr.dimension
3173 && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
3179 desc = sym->backend_decl;
3181 /* If association is to an expression, evaluate it and create temporary.
3182 Otherwise, get descriptor of target for pointer assignment. */
3183 gfc_init_se (&se, NULL);
3184 ss = gfc_walk_expr (e);
3185 if (sym->assoc->variable)
3187 se.direct_byref = 1;
3190 gfc_conv_expr_descriptor (&se, e, ss);
3192 /* If we didn't already do the pointer assignment, set associate-name
3193 descriptor to the one generated for the temporary. */
3194 if (!sym->assoc->variable)
3198 gfc_add_modify (&se.pre, desc, se.expr);
3200 /* The generated descriptor has lower bound zero (as array
3201 temporary), shift bounds so we get lower bounds of 1. */
3202 for (dim = 0; dim < e->rank; ++dim)
3203 gfc_conv_shift_descriptor_lbound (&se.pre, desc,
3204 dim, gfc_index_one_node);
3207 /* Done, register stuff as init / cleanup code. */
3208 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
3209 gfc_finish_block (&se.post));
3212 /* Do a scalar pointer assignment; this is for scalar variable targets. */
3213 else if (gfc_is_associate_pointer (sym))
3217 gcc_assert (!sym->attr.dimension);
3219 gfc_init_se (&se, NULL);
3220 gfc_conv_expr (&se, e);
3222 tmp = TREE_TYPE (sym->backend_decl);
3223 tmp = gfc_build_addr_expr (tmp, se.expr);
3224 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
3226 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
3227 gfc_finish_block (&se.post));
3230 /* Do a simple assignment. This is for scalar expressions, where we
3231 can simply use expression assignment. */
3236 lhs = gfc_lval_expr_from_sym (sym);
3237 tmp = gfc_trans_assignment (lhs, e, false, true);
3238 gfc_add_init_cleanup (block, tmp, NULL_TREE);
3243 /* Generate function entry and exit code, and add it to the function body.
3245 Allocation and initialization of array variables.
3246 Allocation of character string variables.
3247 Initialization and possibly repacking of dummy arrays.
3248 Initialization of ASSIGN statement auxiliary variable.
3249 Initialization of ASSOCIATE names.
3250 Automatic deallocation. */
3253 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3257 gfc_formal_arglist *f;
3258 stmtblock_t tmpblock;
3259 bool seen_trans_deferred_array = false;
3261 /* Deal with implicit return variables. Explicit return variables will
3262 already have been added. */
3263 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3265 if (!current_fake_result_decl)
3267 gfc_entry_list *el = NULL;
3268 if (proc_sym->attr.entry_master)
3270 for (el = proc_sym->ns->entries; el; el = el->next)
3271 if (el->sym != el->sym->result)
3274 /* TODO: move to the appropriate place in resolve.c. */
3275 if (warn_return_type && el == NULL)
3276 gfc_warning ("Return value of function '%s' at %L not set",
3277 proc_sym->name, &proc_sym->declared_at);
3279 else if (proc_sym->as)
3281 tree result = TREE_VALUE (current_fake_result_decl);
3282 gfc_trans_dummy_array_bias (proc_sym, result, block);
3284 /* An automatic character length, pointer array result. */
3285 if (proc_sym->ts.type == BT_CHARACTER
3286 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3287 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3289 else if (proc_sym->ts.type == BT_CHARACTER)
3291 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3292 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3295 gcc_assert (gfc_option.flag_f2c
3296 && proc_sym->ts.type == BT_COMPLEX);
3299 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3300 should be done here so that the offsets and lbounds of arrays
3302 init_intent_out_dt (proc_sym, block);
3304 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3306 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3307 && sym->ts.u.derived->attr.alloc_comp;
3309 trans_associate_var (sym, block);
3310 else if (sym->attr.dimension)
3312 switch (sym->as->type)
3315 if (sym->attr.dummy || sym->attr.result)
3316 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3317 else if (sym->attr.pointer || sym->attr.allocatable)
3319 if (TREE_STATIC (sym->backend_decl))
3320 gfc_trans_static_array_pointer (sym);
3323 seen_trans_deferred_array = true;
3324 gfc_trans_deferred_array (sym, block);
3329 if (sym_has_alloc_comp)
3331 seen_trans_deferred_array = true;
3332 gfc_trans_deferred_array (sym, block);
3334 else if (sym->ts.type == BT_DERIVED
3337 && sym->attr.save == SAVE_NONE)
3339 gfc_start_block (&tmpblock);
3340 gfc_init_default_dt (sym, &tmpblock, false);
3341 gfc_add_init_cleanup (block,
3342 gfc_finish_block (&tmpblock),
3346 gfc_save_backend_locus (&loc);
3347 gfc_set_backend_locus (&sym->declared_at);
3348 gfc_trans_auto_array_allocation (sym->backend_decl,
3350 gfc_restore_backend_locus (&loc);
3354 case AS_ASSUMED_SIZE:
3355 /* Must be a dummy parameter. */
3356 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3358 /* We should always pass assumed size arrays the g77 way. */
3359 if (sym->attr.dummy)
3360 gfc_trans_g77_array (sym, block);
3363 case AS_ASSUMED_SHAPE:
3364 /* Must be a dummy parameter. */
3365 gcc_assert (sym->attr.dummy);
3367 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3371 seen_trans_deferred_array = true;
3372 gfc_trans_deferred_array (sym, block);
3378 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3379 gfc_trans_deferred_array (sym, block);
3381 else if (sym->attr.allocatable
3382 || (sym->ts.type == BT_CLASS
3383 && CLASS_DATA (sym)->attr.allocatable))
3385 if (!sym->attr.save)
3387 /* Nullify and automatic deallocation of allocatable
3394 e = gfc_lval_expr_from_sym (sym);
3395 if (sym->ts.type == BT_CLASS)
3396 gfc_add_component_ref (e, "$data");
3398 gfc_init_se (&se, NULL);
3399 se.want_pointer = 1;
3400 gfc_conv_expr (&se, e);
3403 /* Nullify when entering the scope. */
3404 gfc_start_block (&init);
3405 gfc_add_modify (&init, se.expr,
3406 fold_convert (TREE_TYPE (se.expr),
3407 null_pointer_node));
3409 /* Deallocate when leaving the scope. Nullifying is not
3411 if (!sym->attr.result)
3412 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3416 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3419 else if (sym->ts.deferred)
3420 gfc_fatal_error ("Deferred type parameter not yet supported");
3421 else if (sym_has_alloc_comp)
3422 gfc_trans_deferred_array (sym, block);
3423 else if (sym->ts.type == BT_CHARACTER)
3425 gfc_save_backend_locus (&loc);
3426 gfc_set_backend_locus (&sym->declared_at);
3427 if (sym->attr.dummy || sym->attr.result)
3428 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3430 gfc_trans_auto_character_variable (sym, block);
3431 gfc_restore_backend_locus (&loc);
3433 else if (sym->attr.assign)
3435 gfc_save_backend_locus (&loc);
3436 gfc_set_backend_locus (&sym->declared_at);
3437 gfc_trans_assign_aux_var (sym, block);
3438 gfc_restore_backend_locus (&loc);
3440 else if (sym->ts.type == BT_DERIVED
3443 && sym->attr.save == SAVE_NONE)
3445 gfc_start_block (&tmpblock);
3446 gfc_init_default_dt (sym, &tmpblock, false);
3447 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3454 gfc_init_block (&tmpblock);
3456 for (f = proc_sym->formal; f; f = f->next)
3458 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3460 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3461 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3462 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3466 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3467 && current_fake_result_decl != NULL)
3469 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3470 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3471 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3474 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3477 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3479 /* Hash and equality functions for module_htab. */
3482 module_htab_do_hash (const void *x)
3484 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3488 module_htab_eq (const void *x1, const void *x2)
3490 return strcmp ((((const struct module_htab_entry *)x1)->name),
3491 (const char *)x2) == 0;
3494 /* Hash and equality functions for module_htab's decls. */
3497 module_htab_decls_hash (const void *x)
3499 const_tree t = (const_tree) x;
3500 const_tree n = DECL_NAME (t);
3502 n = TYPE_NAME (TREE_TYPE (t));
3503 return htab_hash_string (IDENTIFIER_POINTER (n));
3507 module_htab_decls_eq (const void *x1, const void *x2)
3509 const_tree t1 = (const_tree) x1;
3510 const_tree n1 = DECL_NAME (t1);
3511 if (n1 == NULL_TREE)
3512 n1 = TYPE_NAME (TREE_TYPE (t1));
3513 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3516 struct module_htab_entry *
3517 gfc_find_module (const char *name)
3522 module_htab = htab_create_ggc (10, module_htab_do_hash,
3523 module_htab_eq, NULL);
3525 slot = htab_find_slot_with_hash (module_htab, name,
3526 htab_hash_string (name), INSERT);
3529 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3531 entry->name = gfc_get_string (name);
3532 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3533 module_htab_decls_eq, NULL);
3534 *slot = (void *) entry;
3536 return (struct module_htab_entry *) *slot;
3540 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3545 if (DECL_NAME (decl))
3546 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3549 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3550 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3552 slot = htab_find_slot_with_hash (entry->decls, name,
3553 htab_hash_string (name), INSERT);
3555 *slot = (void *) decl;
3558 static struct module_htab_entry *cur_module;
3560 /* Output an initialized decl for a module variable. */
3563 gfc_create_module_variable (gfc_symbol * sym)
3567 /* Module functions with alternate entries are dealt with later and
3568 would get caught by the next condition. */
3569 if (sym->attr.entry)
3572 /* Make sure we convert the types of the derived types from iso_c_binding
3574 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3575 && sym->ts.type == BT_DERIVED)
3576 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3578 if (sym->attr.flavor == FL_DERIVED
3579 && sym->backend_decl
3580 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3582 decl = sym->backend_decl;
3583 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3585 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3586 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3588 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3589 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3590 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3591 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3592 == sym->ns->proc_name->backend_decl);
3594 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3595 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3596 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3599 /* Only output variables, procedure pointers and array valued,
3600 or derived type, parameters. */
3601 if (sym->attr.flavor != FL_VARIABLE
3602 && !(sym->attr.flavor == FL_PARAMETER
3603 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3604 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3607 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3609 decl = sym->backend_decl;
3610 gcc_assert (DECL_FILE_SCOPE_P (decl));
3611 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3612 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3613 gfc_module_add_decl (cur_module, decl);
3616 /* Don't generate variables from other modules. Variables from
3617 COMMONs will already have been generated. */
3618 if (sym->attr.use_assoc || sym->attr.in_common)
3621 /* Equivalenced variables arrive here after creation. */
3622 if (sym->backend_decl
3623 && (sym->equiv_built || sym->attr.in_equivalence))
3626 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
3627 internal_error ("backend decl for module variable %s already exists",
3630 /* We always want module variables to be created. */
3631 sym->attr.referenced = 1;
3632 /* Create the decl. */
3633 decl = gfc_get_symbol_decl (sym);
3635 /* Create the variable. */
3637 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3638 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3639 rest_of_decl_compilation (decl, 1, 0);
3640 gfc_module_add_decl (cur_module, decl);
3642 /* Also add length of strings. */
3643 if (sym->ts.type == BT_CHARACTER)
3647 length = sym->ts.u.cl->backend_decl;
3648 gcc_assert (length || sym->attr.proc_pointer);
3649 if (length && !INTEGER_CST_P (length))
3652 rest_of_decl_compilation (length, 1, 0);
3657 /* Emit debug information for USE statements. */
3660 gfc_trans_use_stmts (gfc_namespace * ns)
3662 gfc_use_list *use_stmt;
3663 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3665 struct module_htab_entry *entry
3666 = gfc_find_module (use_stmt->module_name);
3667 gfc_use_rename *rent;
3669 if (entry->namespace_decl == NULL)
3671 entry->namespace_decl
3672 = build_decl (input_location,
3674 get_identifier (use_stmt->module_name),
3676 DECL_EXTERNAL (entry->namespace_decl) = 1;
3678 gfc_set_backend_locus (&use_stmt->where);
3679 if (!use_stmt->only_flag)
3680 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3682 ns->proc_name->backend_decl,
3684 for (rent = use_stmt->rename; rent; rent = rent->next)
3686 tree decl, local_name;
3689 if (rent->op != INTRINSIC_NONE)
3692 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3693 htab_hash_string (rent->use_name),
3699 st = gfc_find_symtree (ns->sym_root,
3701 ? rent->local_name : rent->use_name);
3704 /* Sometimes, generic interfaces wind up being over-ruled by a
3705 local symbol (see PR41062). */
3706 if (!st->n.sym->attr.use_assoc)
3709 if (st->n.sym->backend_decl
3710 && DECL_P (st->n.sym->backend_decl)
3711 && st->n.sym->module
3712 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3714 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3715 || (TREE_CODE (st->n.sym->backend_decl)
3717 decl = copy_node (st->n.sym->backend_decl);
3718 DECL_CONTEXT (decl) = entry->namespace_decl;
3719 DECL_EXTERNAL (decl) = 1;
3720 DECL_IGNORED_P (decl) = 0;
3721 DECL_INITIAL (decl) = NULL_TREE;
3725 *slot = error_mark_node;
3726 htab_clear_slot (entry->decls, slot);
3731 decl = (tree) *slot;
3732 if (rent->local_name[0])
3733 local_name = get_identifier (rent->local_name);
3735 local_name = NULL_TREE;
3736 gfc_set_backend_locus (&rent->where);
3737 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3738 ns->proc_name->backend_decl,
3739 !use_stmt->only_flag);
3745 /* Return true if expr is a constant initializer that gfc_conv_initializer
3749 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3759 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3761 else if (expr->expr_type == EXPR_STRUCTURE)
3762 return check_constant_initializer (expr, ts, false, false);
3763 else if (expr->expr_type != EXPR_ARRAY)
3765 for (c = gfc_constructor_first (expr->value.constructor);
3766 c; c = gfc_constructor_next (c))
3770 if (c->expr->expr_type == EXPR_STRUCTURE)
3772 if (!check_constant_initializer (c->expr, ts, false, false))
3775 else if (c->expr->expr_type != EXPR_CONSTANT)
3780 else switch (ts->type)
3783 if (expr->expr_type != EXPR_STRUCTURE)
3785 cm = expr->ts.u.derived->components;
3786 for (c = gfc_constructor_first (expr->value.constructor);
3787 c; c = gfc_constructor_next (c), cm = cm->next)
3789 if (!c->expr || cm->attr.allocatable)
3791 if (!check_constant_initializer (c->expr, &cm->ts,
3798 return expr->expr_type == EXPR_CONSTANT;
3802 /* Emit debug info for parameters and unreferenced variables with
3806 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3810 if (sym->attr.flavor != FL_PARAMETER
3811 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3814 if (sym->backend_decl != NULL
3815 || sym->value == NULL
3816 || sym->attr.use_assoc
3819 || sym->attr.function
3820 || sym->attr.intrinsic
3821 || sym->attr.pointer
3822 || sym->attr.allocatable
3823 || sym->attr.cray_pointee
3824 || sym->attr.threadprivate
3825 || sym->attr.is_bind_c
3826 || sym->attr.subref_array_pointer
3827 || sym->attr.assign)
3830 if (sym->ts.type == BT_CHARACTER)
3832 gfc_conv_const_charlen (sym->ts.u.cl);
3833 if (sym->ts.u.cl->backend_decl == NULL
3834 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3837 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3844 if (sym->as->type != AS_EXPLICIT)
3846 for (n = 0; n < sym->as->rank; n++)
3847 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3848 || sym->as->upper[n] == NULL
3849 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3853 if (!check_constant_initializer (sym->value, &sym->ts,
3854 sym->attr.dimension, false))
3857 /* Create the decl for the variable or constant. */
3858 decl = build_decl (input_location,
3859 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3860 gfc_sym_identifier (sym), gfc_sym_type (sym));
3861 if (sym->attr.flavor == FL_PARAMETER)
3862 TREE_READONLY (decl) = 1;
3863 gfc_set_decl_location (decl, &sym->declared_at);
3864 if (sym->attr.dimension)
3865 GFC_DECL_PACKED_ARRAY (decl) = 1;
3866 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3867 TREE_STATIC (decl) = 1;
3868 TREE_USED (decl) = 1;
3869 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3870 TREE_PUBLIC (decl) = 1;
3871 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
3873 sym->attr.dimension,
3875 debug_hooks->global_decl (decl);
3878 /* Generate all the required code for module variables. */
3881 gfc_generate_module_vars (gfc_namespace * ns)
3883 module_namespace = ns;
3884 cur_module = gfc_find_module (ns->proc_name->name);
3886 /* Check if the frontend left the namespace in a reasonable state. */
3887 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3889 /* Generate COMMON blocks. */
3890 gfc_trans_common (ns);
3892 /* Create decls for all the module variables. */
3893 gfc_traverse_ns (ns, gfc_create_module_variable);
3897 gfc_trans_use_stmts (ns);
3898 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3903 gfc_generate_contained_functions (gfc_namespace * parent)
3907 /* We create all the prototypes before generating any code. */
3908 for (ns = parent->contained; ns; ns = ns->sibling)
3910 /* Skip namespaces from used modules. */
3911 if (ns->parent != parent)
3914 gfc_create_function_decl (ns, false);
3917 for (ns = parent->contained; ns; ns = ns->sibling)
3919 /* Skip namespaces from used modules. */
3920 if (ns->parent != parent)
3923 gfc_generate_function_code (ns);
3928 /* Drill down through expressions for the array specification bounds and
3929 character length calling generate_local_decl for all those variables
3930 that have not already been declared. */
3933 generate_local_decl (gfc_symbol *);
3935 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3938 expr_decls (gfc_expr *e, gfc_symbol *sym,
3939 int *f ATTRIBUTE_UNUSED)
3941 if (e->expr_type != EXPR_VARIABLE
3942 || sym == e->symtree->n.sym
3943 || e->symtree->n.sym->mark
3944 || e->symtree->n.sym->ns != sym->ns)
3947 generate_local_decl (e->symtree->n.sym);
3952 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3954 gfc_traverse_expr (e, sym, expr_decls, 0);
3958 /* Check for dependencies in the character length and array spec. */
3961 generate_dependency_declarations (gfc_symbol *sym)
3965 if (sym->ts.type == BT_CHARACTER
3967 && sym->ts.u.cl->length
3968 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3969 generate_expr_decls (sym, sym->ts.u.cl->length);
3971 if (sym->as && sym->as->rank)
3973 for (i = 0; i < sym->as->rank; i++)
3975 generate_expr_decls (sym, sym->as->lower[i]);
3976 generate_expr_decls (sym, sym->as->upper[i]);
3982 /* Generate decls for all local variables. We do this to ensure correct
3983 handling of expressions which only appear in the specification of
3987 generate_local_decl (gfc_symbol * sym)
3989 if (sym->attr.flavor == FL_VARIABLE)
3991 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3992 generate_dependency_declarations (sym);
3994 if (sym->attr.referenced)
3995 gfc_get_symbol_decl (sym);
3997 /* Warnings for unused dummy arguments. */
3998 else if (sym->attr.dummy)
4000 /* INTENT(out) dummy arguments are likely meant to be set. */
4001 if (gfc_option.warn_unused_dummy_argument
4002 && sym->attr.intent == INTENT_OUT)
4004 if (sym->ts.type != BT_DERIVED)
4005 gfc_warning ("Dummy argument '%s' at %L was declared "
4006 "INTENT(OUT) but was not set", sym->name,
4008 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4009 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4010 "declared INTENT(OUT) but was not set and "
4011 "does not have a default initializer",
4012 sym->name, &sym->declared_at);
4014 else if (gfc_option.warn_unused_dummy_argument)
4015 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4019 /* Warn for unused variables, but not if they're inside a common
4020 block or are use-associated. */
4021 else if (warn_unused_variable
4022 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
4023 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4026 /* For variable length CHARACTER parameters, the PARM_DECL already
4027 references the length variable, so force gfc_get_symbol_decl
4028 even when not referenced. If optimize > 0, it will be optimized
4029 away anyway. But do this only after emitting -Wunused-parameter
4030 warning if requested. */
4031 if (sym->attr.dummy && !sym->attr.referenced
4032 && sym->ts.type == BT_CHARACTER
4033 && sym->ts.u.cl->backend_decl != NULL
4034 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4036 sym->attr.referenced = 1;
4037 gfc_get_symbol_decl (sym);
4040 /* INTENT(out) dummy arguments and result variables with allocatable
4041 components are reset by default and need to be set referenced to
4042 generate the code for nullification and automatic lengths. */
4043 if (!sym->attr.referenced
4044 && sym->ts.type == BT_DERIVED
4045 && sym->ts.u.derived->attr.alloc_comp
4046 && !sym->attr.pointer
4047 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4049 (sym->attr.result && sym != sym->result)))
4051 sym->attr.referenced = 1;
4052 gfc_get_symbol_decl (sym);
4055 /* Check for dependencies in the array specification and string
4056 length, adding the necessary declarations to the function. We
4057 mark the symbol now, as well as in traverse_ns, to prevent
4058 getting stuck in a circular dependency. */
4061 /* We do not want the middle-end to warn about unused parameters
4062 as this was already done above. */
4063 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4064 TREE_NO_WARNING(sym->backend_decl) = 1;
4066 else if (sym->attr.flavor == FL_PARAMETER)
4068 if (warn_unused_parameter
4069 && !sym->attr.referenced
4070 && !sym->attr.use_assoc)
4071 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4074 else if (sym->attr.flavor == FL_PROCEDURE)
4076 /* TODO: move to the appropriate place in resolve.c. */
4077 if (warn_return_type
4078 && sym->attr.function
4080 && sym != sym->result
4081 && !sym->result->attr.referenced
4082 && !sym->attr.use_assoc
4083 && sym->attr.if_source != IFSRC_IFBODY)
4085 gfc_warning ("Return value '%s' of function '%s' declared at "
4086 "%L not set", sym->result->name, sym->name,
4087 &sym->result->declared_at);
4089 /* Prevents "Unused variable" warning for RESULT variables. */
4090 sym->result->mark = 1;
4094 if (sym->attr.dummy == 1)
4096 /* Modify the tree type for scalar character dummy arguments of bind(c)
4097 procedures if they are passed by value. The tree type for them will
4098 be promoted to INTEGER_TYPE for the middle end, which appears to be
4099 what C would do with characters passed by-value. The value attribute
4100 implies the dummy is a scalar. */
4101 if (sym->attr.value == 1 && sym->backend_decl != NULL
4102 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4103 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4104 gfc_conv_scalar_char_value (sym, NULL, NULL);
4107 /* Make sure we convert the types of the derived types from iso_c_binding
4109 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4110 && sym->ts.type == BT_DERIVED)
4111 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4115 generate_local_vars (gfc_namespace * ns)
4117 gfc_traverse_ns (ns, generate_local_decl);
4121 /* Generate a switch statement to jump to the correct entry point. Also
4122 creates the label decls for the entry points. */
4125 gfc_trans_entry_master_switch (gfc_entry_list * el)
4132 gfc_init_block (&block);
4133 for (; el; el = el->next)
4135 /* Add the case label. */
4136 label = gfc_build_label_decl (NULL_TREE);
4137 val = build_int_cst (gfc_array_index_type, el->id);
4138 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4139 gfc_add_expr_to_block (&block, tmp);
4141 /* And jump to the actual entry point. */
4142 label = gfc_build_label_decl (NULL_TREE);
4143 tmp = build1_v (GOTO_EXPR, label);
4144 gfc_add_expr_to_block (&block, tmp);
4146 /* Save the label decl. */
4149 tmp = gfc_finish_block (&block);
4150 /* The first argument selects the entry point. */
4151 val = DECL_ARGUMENTS (current_function_decl);
4152 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4157 /* Add code to string lengths of actual arguments passed to a function against
4158 the expected lengths of the dummy arguments. */
4161 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4163 gfc_formal_arglist *formal;
4165 for (formal = sym->formal; formal; formal = formal->next)
4166 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4168 enum tree_code comparison;
4173 const char *message;
4179 gcc_assert (cl->passed_length != NULL_TREE);
4180 gcc_assert (cl->backend_decl != NULL_TREE);
4182 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4183 string lengths must match exactly. Otherwise, it is only required
4184 that the actual string length is *at least* the expected one.
4185 Sequence association allows for a mismatch of the string length
4186 if the actual argument is (part of) an array, but only if the
4187 dummy argument is an array. (See "Sequence association" in
4188 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4189 if (fsym->attr.pointer || fsym->attr.allocatable
4190 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4192 comparison = NE_EXPR;
4193 message = _("Actual string length does not match the declared one"
4194 " for dummy argument '%s' (%ld/%ld)");
4196 else if (fsym->as && fsym->as->rank != 0)
4200 comparison = LT_EXPR;
4201 message = _("Actual string length is shorter than the declared one"
4202 " for dummy argument '%s' (%ld/%ld)");
4205 /* Build the condition. For optional arguments, an actual length
4206 of 0 is also acceptable if the associated string is NULL, which
4207 means the argument was not passed. */
4208 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4209 cl->passed_length, cl->backend_decl);
4210 if (fsym->attr.optional)
4216 not_0length = fold_build2_loc (input_location, NE_EXPR,
4219 fold_convert (gfc_charlen_type_node,
4220 integer_zero_node));
4221 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4222 fsym->attr.referenced = 1;
4223 not_absent = gfc_conv_expr_present (fsym);
4225 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4226 boolean_type_node, not_0length,
4229 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4230 boolean_type_node, cond, absent_failed);
4233 /* Build the runtime check. */
4234 argname = gfc_build_cstring_const (fsym->name);
4235 argname = gfc_build_addr_expr (pchar_type_node, argname);
4236 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4238 fold_convert (long_integer_type_node,
4240 fold_convert (long_integer_type_node,
4247 create_main_function (tree fndecl)
4251 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4254 old_context = current_function_decl;
4258 push_function_context ();
4259 saved_parent_function_decls = saved_function_decls;
4260 saved_function_decls = NULL_TREE;
4263 /* main() function must be declared with global scope. */
4264 gcc_assert (current_function_decl == NULL_TREE);
4266 /* Declare the function. */
4267 tmp = build_function_type_list (integer_type_node, integer_type_node,
4268 build_pointer_type (pchar_type_node),
4270 main_identifier_node = get_identifier ("main");
4271 ftn_main = build_decl (input_location, FUNCTION_DECL,
4272 main_identifier_node, tmp);
4273 DECL_EXTERNAL (ftn_main) = 0;
4274 TREE_PUBLIC (ftn_main) = 1;
4275 TREE_STATIC (ftn_main) = 1;
4276 DECL_ATTRIBUTES (ftn_main)
4277 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4279 /* Setup the result declaration (for "return 0"). */
4280 result_decl = build_decl (input_location,
4281 RESULT_DECL, NULL_TREE, integer_type_node);
4282 DECL_ARTIFICIAL (result_decl) = 1;
4283 DECL_IGNORED_P (result_decl) = 1;
4284 DECL_CONTEXT (result_decl) = ftn_main;
4285 DECL_RESULT (ftn_main) = result_decl;
4287 pushdecl (ftn_main);
4289 /* Get the arguments. */
4291 arglist = NULL_TREE;
4292 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4294 tmp = TREE_VALUE (typelist);
4295 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4296 DECL_CONTEXT (argc) = ftn_main;
4297 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4298 TREE_READONLY (argc) = 1;
4299 gfc_finish_decl (argc);
4300 arglist = chainon (arglist, argc);
4302 typelist = TREE_CHAIN (typelist);
4303 tmp = TREE_VALUE (typelist);
4304 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4305 DECL_CONTEXT (argv) = ftn_main;
4306 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4307 TREE_READONLY (argv) = 1;
4308 DECL_BY_REFERENCE (argv) = 1;
4309 gfc_finish_decl (argv);
4310 arglist = chainon (arglist, argv);
4312 DECL_ARGUMENTS (ftn_main) = arglist;
4313 current_function_decl = ftn_main;
4314 announce_function (ftn_main);
4316 rest_of_decl_compilation (ftn_main, 1, 0);
4317 make_decl_rtl (ftn_main);
4318 init_function_start (ftn_main);
4321 gfc_init_block (&body);
4323 /* Call some libgfortran initialization routines, call then MAIN__(). */
4325 /* Call _gfortran_set_args (argc, argv). */
4326 TREE_USED (argc) = 1;
4327 TREE_USED (argv) = 1;
4328 tmp = build_call_expr_loc (input_location,
4329 gfor_fndecl_set_args, 2, argc, argv);
4330 gfc_add_expr_to_block (&body, tmp);
4332 /* Add a call to set_options to set up the runtime library Fortran
4333 language standard parameters. */
4335 tree array_type, array, var;
4336 VEC(constructor_elt,gc) *v = NULL;
4338 /* Passing a new option to the library requires four modifications:
4339 + add it to the tree_cons list below
4340 + change the array size in the call to build_array_type
4341 + change the first argument to the library call
4342 gfor_fndecl_set_options
4343 + modify the library (runtime/compile_options.c)! */
4345 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4346 build_int_cst (integer_type_node,
4347 gfc_option.warn_std));
4348 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4349 build_int_cst (integer_type_node,
4350 gfc_option.allow_std));
4351 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4352 build_int_cst (integer_type_node, pedantic));
4353 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4354 build_int_cst (integer_type_node,
4355 gfc_option.flag_dump_core));
4356 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4357 build_int_cst (integer_type_node,
4358 gfc_option.flag_backtrace));
4359 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4360 build_int_cst (integer_type_node,
4361 gfc_option.flag_sign_zero));
4362 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4363 build_int_cst (integer_type_node,
4365 & GFC_RTCHECK_BOUNDS)));
4366 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4367 build_int_cst (integer_type_node,
4368 gfc_option.flag_range_check));
4370 array_type = build_array_type (integer_type_node,
4371 build_index_type (build_int_cst (NULL_TREE, 7)));
4372 array = build_constructor (array_type, v);
4373 TREE_CONSTANT (array) = 1;
4374 TREE_STATIC (array) = 1;
4376 /* Create a static variable to hold the jump table. */
4377 var = gfc_create_var (array_type, "options");
4378 TREE_CONSTANT (var) = 1;
4379 TREE_STATIC (var) = 1;
4380 TREE_READONLY (var) = 1;
4381 DECL_INITIAL (var) = array;
4382 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4384 tmp = build_call_expr_loc (input_location,
4385 gfor_fndecl_set_options, 2,
4386 build_int_cst (integer_type_node, 8), var);
4387 gfc_add_expr_to_block (&body, tmp);
4390 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4391 the library will raise a FPE when needed. */
4392 if (gfc_option.fpe != 0)
4394 tmp = build_call_expr_loc (input_location,
4395 gfor_fndecl_set_fpe, 1,
4396 build_int_cst (integer_type_node,
4398 gfc_add_expr_to_block (&body, tmp);
4401 /* If this is the main program and an -fconvert option was provided,
4402 add a call to set_convert. */
4404 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4406 tmp = build_call_expr_loc (input_location,
4407 gfor_fndecl_set_convert, 1,
4408 build_int_cst (integer_type_node,
4409 gfc_option.convert));
4410 gfc_add_expr_to_block (&body, tmp);
4413 /* If this is the main program and an -frecord-marker option was provided,
4414 add a call to set_record_marker. */
4416 if (gfc_option.record_marker != 0)
4418 tmp = build_call_expr_loc (input_location,
4419 gfor_fndecl_set_record_marker, 1,
4420 build_int_cst (integer_type_node,
4421 gfc_option.record_marker));
4422 gfc_add_expr_to_block (&body, tmp);
4425 if (gfc_option.max_subrecord_length != 0)
4427 tmp = build_call_expr_loc (input_location,
4428 gfor_fndecl_set_max_subrecord_length, 1,
4429 build_int_cst (integer_type_node,
4430 gfc_option.max_subrecord_length));
4431 gfc_add_expr_to_block (&body, tmp);
4434 /* Call MAIN__(). */
4435 tmp = build_call_expr_loc (input_location,
4437 gfc_add_expr_to_block (&body, tmp);
4439 /* Mark MAIN__ as used. */
4440 TREE_USED (fndecl) = 1;
4443 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4444 DECL_RESULT (ftn_main),
4445 build_int_cst (integer_type_node, 0));
4446 tmp = build1_v (RETURN_EXPR, tmp);
4447 gfc_add_expr_to_block (&body, tmp);
4450 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4453 /* Finish off this function and send it for code generation. */
4455 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4457 DECL_SAVED_TREE (ftn_main)
4458 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4459 DECL_INITIAL (ftn_main));
4461 /* Output the GENERIC tree. */
4462 dump_function (TDI_original, ftn_main);
4464 cgraph_finalize_function (ftn_main, true);
4468 pop_function_context ();
4469 saved_function_decls = saved_parent_function_decls;
4471 current_function_decl = old_context;
4475 /* Get the result expression for a procedure. */
4478 get_proc_result (gfc_symbol* sym)
4480 if (sym->attr.subroutine || sym == sym->result)
4482 if (current_fake_result_decl != NULL)
4483 return TREE_VALUE (current_fake_result_decl);
4488 return sym->result->backend_decl;
4492 /* Generate an appropriate return-statement for a procedure. */
4495 gfc_generate_return (void)
4501 sym = current_procedure_symbol;
4502 fndecl = sym->backend_decl;
4504 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4508 result = get_proc_result (sym);
4510 /* Set the return value to the dummy result variable. The
4511 types may be different for scalar default REAL functions
4512 with -ff2c, therefore we have to convert. */
4513 if (result != NULL_TREE)
4515 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4516 result = fold_build2_loc (input_location, MODIFY_EXPR,
4517 TREE_TYPE (result), DECL_RESULT (fndecl),
4522 return build1_v (RETURN_EXPR, result);
4526 /* Generate code for a function. */
4529 gfc_generate_function_code (gfc_namespace * ns)
4535 stmtblock_t init, cleanup;
4537 gfc_wrapped_block try_block;
4538 tree recurcheckvar = NULL_TREE;
4540 gfc_symbol *previous_procedure_symbol;
4544 sym = ns->proc_name;
4545 previous_procedure_symbol = current_procedure_symbol;
4546 current_procedure_symbol = sym;
4548 /* Check that the frontend isn't still using this. */
4549 gcc_assert (sym->tlink == NULL);
4552 /* Create the declaration for functions with global scope. */
4553 if (!sym->backend_decl)
4554 gfc_create_function_decl (ns, false);
4556 fndecl = sym->backend_decl;
4557 old_context = current_function_decl;
4561 push_function_context ();
4562 saved_parent_function_decls = saved_function_decls;
4563 saved_function_decls = NULL_TREE;
4566 trans_function_start (sym);
4568 gfc_init_block (&init);
4570 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4572 /* Copy length backend_decls to all entry point result
4577 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4578 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4579 for (el = ns->entries; el; el = el->next)
4580 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4583 /* Translate COMMON blocks. */
4584 gfc_trans_common (ns);
4586 /* Null the parent fake result declaration if this namespace is
4587 a module function or an external procedures. */
4588 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4589 || ns->parent == NULL)
4590 parent_fake_result_decl = NULL_TREE;
4592 gfc_generate_contained_functions (ns);
4594 nonlocal_dummy_decls = NULL;
4595 nonlocal_dummy_decl_pset = NULL;
4597 generate_local_vars (ns);
4599 /* Keep the parent fake result declaration in module functions
4600 or external procedures. */
4601 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4602 || ns->parent == NULL)
4603 current_fake_result_decl = parent_fake_result_decl;
4605 current_fake_result_decl = NULL_TREE;
4607 is_recursive = sym->attr.recursive
4608 || (sym->attr.entry_master
4609 && sym->ns->entries->sym->attr.recursive);
4610 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4612 && !gfc_option.flag_recursive)
4616 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4618 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4619 TREE_STATIC (recurcheckvar) = 1;
4620 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4621 gfc_add_expr_to_block (&init, recurcheckvar);
4622 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4623 &sym->declared_at, msg);
4624 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
4628 /* Now generate the code for the body of this function. */
4629 gfc_init_block (&body);
4631 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4632 && sym->attr.subroutine)
4634 tree alternate_return;
4635 alternate_return = gfc_get_fake_result_decl (sym, 0);
4636 gfc_add_modify (&body, alternate_return, integer_zero_node);
4641 /* Jump to the correct entry point. */
4642 tmp = gfc_trans_entry_master_switch (ns->entries);
4643 gfc_add_expr_to_block (&body, tmp);
4646 /* If bounds-checking is enabled, generate code to check passed in actual
4647 arguments against the expected dummy argument attributes (e.g. string
4649 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4650 add_argument_checking (&body, sym);
4652 tmp = gfc_trans_code (ns->code);
4653 gfc_add_expr_to_block (&body, tmp);
4655 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4657 tree result = get_proc_result (sym);
4659 if (result != NULL_TREE
4660 && sym->attr.function
4661 && !sym->attr.pointer)
4663 if (sym->ts.type == BT_DERIVED
4664 && sym->ts.u.derived->attr.alloc_comp)
4666 rank = sym->as ? sym->as->rank : 0;
4667 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4668 gfc_add_expr_to_block (&init, tmp);
4670 else if (sym->attr.allocatable && sym->attr.dimension == 0)
4671 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4672 null_pointer_node));
4675 if (result == NULL_TREE)
4677 /* TODO: move to the appropriate place in resolve.c. */
4678 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4679 gfc_warning ("Return value of function '%s' at %L not set",
4680 sym->name, &sym->declared_at);
4682 TREE_NO_WARNING(sym->backend_decl) = 1;
4685 gfc_add_expr_to_block (&body, gfc_generate_return ());
4688 gfc_init_block (&cleanup);
4690 /* Reset recursion-check variable. */
4691 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4693 && !gfc_option.gfc_flag_openmp
4694 && recurcheckvar != NULL_TREE)
4696 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4697 recurcheckvar = NULL;
4700 /* Finish the function body and add init and cleanup code. */
4701 tmp = gfc_finish_block (&body);
4702 gfc_start_wrapped_block (&try_block, tmp);
4703 /* Add code to create and cleanup arrays. */
4704 gfc_trans_deferred_vars (sym, &try_block);
4705 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
4706 gfc_finish_block (&cleanup));
4708 /* Add all the decls we created during processing. */
4709 decl = saved_function_decls;
4714 next = DECL_CHAIN (decl);
4715 DECL_CHAIN (decl) = NULL_TREE;
4719 saved_function_decls = NULL_TREE;
4721 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
4724 /* Finish off this function and send it for code generation. */
4726 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4728 DECL_SAVED_TREE (fndecl)
4729 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4730 DECL_INITIAL (fndecl));
4732 if (nonlocal_dummy_decls)
4734 BLOCK_VARS (DECL_INITIAL (fndecl))
4735 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4736 pointer_set_destroy (nonlocal_dummy_decl_pset);
4737 nonlocal_dummy_decls = NULL;
4738 nonlocal_dummy_decl_pset = NULL;
4741 /* Output the GENERIC tree. */
4742 dump_function (TDI_original, fndecl);
4744 /* Store the end of the function, so that we get good line number
4745 info for the epilogue. */
4746 cfun->function_end_locus = input_location;
4748 /* We're leaving the context of this function, so zap cfun.
4749 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4750 tree_rest_of_compilation. */
4755 pop_function_context ();
4756 saved_function_decls = saved_parent_function_decls;
4758 current_function_decl = old_context;
4760 if (decl_function_context (fndecl))
4761 /* Register this function with cgraph just far enough to get it
4762 added to our parent's nested function list. */
4763 (void) cgraph_node (fndecl);
4765 cgraph_finalize_function (fndecl, true);
4767 gfc_trans_use_stmts (ns);
4768 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4770 if (sym->attr.is_main_program)
4771 create_main_function (fndecl);
4773 current_procedure_symbol = previous_procedure_symbol;
4778 gfc_generate_constructors (void)
4780 gcc_assert (gfc_static_ctors == NULL_TREE);
4788 if (gfc_static_ctors == NULL_TREE)
4791 fnname = get_file_function_name ("I");
4792 type = build_function_type_list (void_type_node, NULL_TREE);
4794 fndecl = build_decl (input_location,
4795 FUNCTION_DECL, fnname, type);
4796 TREE_PUBLIC (fndecl) = 1;
4798 decl = build_decl (input_location,
4799 RESULT_DECL, NULL_TREE, void_type_node);
4800 DECL_ARTIFICIAL (decl) = 1;
4801 DECL_IGNORED_P (decl) = 1;
4802 DECL_CONTEXT (decl) = fndecl;
4803 DECL_RESULT (fndecl) = decl;
4807 current_function_decl = fndecl;
4809 rest_of_decl_compilation (fndecl, 1, 0);
4811 make_decl_rtl (fndecl);
4813 init_function_start (fndecl);
4817 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4819 tmp = build_call_expr_loc (input_location,
4820 TREE_VALUE (gfc_static_ctors), 0);
4821 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4827 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4828 DECL_SAVED_TREE (fndecl)
4829 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4830 DECL_INITIAL (fndecl));
4832 free_after_parsing (cfun);
4833 free_after_compilation (cfun);
4835 tree_rest_of_compilation (fndecl);
4837 current_function_decl = NULL_TREE;
4841 /* Translates a BLOCK DATA program unit. This means emitting the
4842 commons contained therein plus their initializations. We also emit
4843 a globally visible symbol to make sure that each BLOCK DATA program
4844 unit remains unique. */
4847 gfc_generate_block_data (gfc_namespace * ns)
4852 /* Tell the backend the source location of the block data. */
4854 gfc_set_backend_locus (&ns->proc_name->declared_at);
4856 gfc_set_backend_locus (&gfc_current_locus);
4858 /* Process the DATA statements. */
4859 gfc_trans_common (ns);
4861 /* Create a global symbol with the mane of the block data. This is to
4862 generate linker errors if the same name is used twice. It is never
4865 id = gfc_sym_mangled_function_id (ns->proc_name);
4867 id = get_identifier ("__BLOCK_DATA__");
4869 decl = build_decl (input_location,
4870 VAR_DECL, id, gfc_array_index_type);
4871 TREE_PUBLIC (decl) = 1;
4872 TREE_STATIC (decl) = 1;
4873 DECL_IGNORED_P (decl) = 1;
4876 rest_of_decl_compilation (decl, 1, 0);
4880 /* Process the local variables of a BLOCK construct. */
4883 gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
4887 gcc_assert (saved_local_decls == NULL_TREE);
4888 generate_local_vars (ns);
4890 /* Mark associate names to be initialized. The symbol's namespace may not
4891 be the BLOCK's, we have to force this so that the deferring
4892 works as expected. */
4893 for (; assoc; assoc = assoc->next)
4895 assoc->st->n.sym->ns = ns;
4896 gfc_defer_symbol_init (assoc->st->n.sym);
4899 decl = saved_local_decls;
4904 next = DECL_CHAIN (decl);
4905 DECL_CHAIN (decl) = NULL_TREE;
4909 saved_local_decls = NULL_TREE;
4913 #include "gt-fortran-trans-decl.h"