1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
40 #include "pointer-set.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
48 #define MAX_LABEL_VALUE 99999
51 /* Holds the result of the function if no result variable specified. */
53 static GTY(()) tree current_fake_result_decl;
54 static GTY(()) tree parent_fake_result_decl;
56 static GTY(()) tree current_function_return_label;
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 /* The namespace of the module we're currently generating. Only used while
68 outputting decls for module variables. Do not rely on this being set. */
70 static gfc_namespace *module_namespace;
73 /* List of static constructor functions. */
75 tree gfc_static_ctors;
78 /* Function declarations for builtin library functions. */
80 tree gfor_fndecl_pause_numeric;
81 tree gfor_fndecl_pause_string;
82 tree gfor_fndecl_stop_numeric;
83 tree gfor_fndecl_stop_string;
84 tree gfor_fndecl_runtime_error;
85 tree gfor_fndecl_runtime_error_at;
86 tree gfor_fndecl_runtime_warning_at;
87 tree gfor_fndecl_os_error;
88 tree gfor_fndecl_generate_error;
89 tree gfor_fndecl_set_args;
90 tree gfor_fndecl_set_fpe;
91 tree gfor_fndecl_set_options;
92 tree gfor_fndecl_set_convert;
93 tree gfor_fndecl_set_record_marker;
94 tree gfor_fndecl_set_max_subrecord_length;
95 tree gfor_fndecl_ctime;
96 tree gfor_fndecl_fdate;
97 tree gfor_fndecl_ttynam;
98 tree gfor_fndecl_in_pack;
99 tree gfor_fndecl_in_unpack;
100 tree gfor_fndecl_associated;
103 /* Math functions. Many other math functions are handled in
104 trans-intrinsic.c. */
106 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
107 tree gfor_fndecl_math_ishftc4;
108 tree gfor_fndecl_math_ishftc8;
109 tree gfor_fndecl_math_ishftc16;
112 /* String functions. */
114 tree gfor_fndecl_compare_string;
115 tree gfor_fndecl_concat_string;
116 tree gfor_fndecl_string_len_trim;
117 tree gfor_fndecl_string_index;
118 tree gfor_fndecl_string_scan;
119 tree gfor_fndecl_string_verify;
120 tree gfor_fndecl_string_trim;
121 tree gfor_fndecl_string_minmax;
122 tree gfor_fndecl_adjustl;
123 tree gfor_fndecl_adjustr;
124 tree gfor_fndecl_select_string;
125 tree gfor_fndecl_compare_string_char4;
126 tree gfor_fndecl_concat_string_char4;
127 tree gfor_fndecl_string_len_trim_char4;
128 tree gfor_fndecl_string_index_char4;
129 tree gfor_fndecl_string_scan_char4;
130 tree gfor_fndecl_string_verify_char4;
131 tree gfor_fndecl_string_trim_char4;
132 tree gfor_fndecl_string_minmax_char4;
133 tree gfor_fndecl_adjustl_char4;
134 tree gfor_fndecl_adjustr_char4;
135 tree gfor_fndecl_select_string_char4;
138 /* Conversion between character kinds. */
139 tree gfor_fndecl_convert_char1_to_char4;
140 tree gfor_fndecl_convert_char4_to_char1;
143 /* Other misc. runtime library functions. */
145 tree gfor_fndecl_size0;
146 tree gfor_fndecl_size1;
147 tree gfor_fndecl_iargc;
148 tree gfor_fndecl_clz128;
149 tree gfor_fndecl_ctz128;
151 /* Intrinsic functions implemented in Fortran. */
152 tree gfor_fndecl_sc_kind;
153 tree gfor_fndecl_si_kind;
154 tree gfor_fndecl_sr_kind;
156 /* BLAS gemm functions. */
157 tree gfor_fndecl_sgemm;
158 tree gfor_fndecl_dgemm;
159 tree gfor_fndecl_cgemm;
160 tree gfor_fndecl_zgemm;
164 gfc_add_decl_to_parent_function (tree decl)
167 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
168 DECL_NONLOCAL (decl) = 1;
169 TREE_CHAIN (decl) = saved_parent_function_decls;
170 saved_parent_function_decls = decl;
174 gfc_add_decl_to_function (tree decl)
177 TREE_USED (decl) = 1;
178 DECL_CONTEXT (decl) = current_function_decl;
179 TREE_CHAIN (decl) = saved_function_decls;
180 saved_function_decls = decl;
184 /* Build a backend label declaration. Set TREE_USED for named labels.
185 The context of the label is always the current_function_decl. All
186 labels are marked artificial. */
189 gfc_build_label_decl (tree label_id)
191 /* 2^32 temporaries should be enough. */
192 static unsigned int tmp_num = 1;
196 if (label_id == NULL_TREE)
198 /* Build an internal label name. */
199 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
200 label_id = get_identifier (label_name);
205 /* Build the LABEL_DECL node. Labels have no type. */
206 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
207 DECL_CONTEXT (label_decl) = current_function_decl;
208 DECL_MODE (label_decl) = VOIDmode;
210 /* We always define the label as used, even if the original source
211 file never references the label. We don't want all kinds of
212 spurious warnings for old-style Fortran code with too many
214 TREE_USED (label_decl) = 1;
216 DECL_ARTIFICIAL (label_decl) = 1;
221 /* Returns the return label for the current function. */
224 gfc_get_return_label (void)
226 char name[GFC_MAX_SYMBOL_LEN + 10];
228 if (current_function_return_label)
229 return current_function_return_label;
231 sprintf (name, "__return_%s",
232 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
234 current_function_return_label =
235 gfc_build_label_decl (get_identifier (name));
237 DECL_ARTIFICIAL (current_function_return_label) = 1;
239 return current_function_return_label;
243 /* Set the backend source location of a decl. */
246 gfc_set_decl_location (tree decl, locus * loc)
248 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
252 /* Return the backend label declaration for a given label structure,
253 or create it if it doesn't exist yet. */
256 gfc_get_label_decl (gfc_st_label * lp)
258 if (lp->backend_decl)
259 return lp->backend_decl;
262 char label_name[GFC_MAX_SYMBOL_LEN + 1];
265 /* Validate the label declaration from the front end. */
266 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
268 /* Build a mangled name for the label. */
269 sprintf (label_name, "__label_%.6d", lp->value);
271 /* Build the LABEL_DECL node. */
272 label_decl = gfc_build_label_decl (get_identifier (label_name));
274 /* Tell the debugger where the label came from. */
275 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
276 gfc_set_decl_location (label_decl, &lp->where);
278 DECL_ARTIFICIAL (label_decl) = 1;
280 /* Store the label in the label list and return the LABEL_DECL. */
281 lp->backend_decl = label_decl;
287 /* Convert a gfc_symbol to an identifier of the same name. */
290 gfc_sym_identifier (gfc_symbol * sym)
292 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
293 return (get_identifier ("MAIN__"));
295 return (get_identifier (sym->name));
299 /* Construct mangled name from symbol name. */
302 gfc_sym_mangled_identifier (gfc_symbol * sym)
304 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
306 /* Prevent the mangling of identifiers that have an assigned
307 binding label (mainly those that are bind(c)). */
308 if (sym->attr.is_bind_c == 1
309 && sym->binding_label[0] != '\0')
310 return get_identifier(sym->binding_label);
312 if (sym->module == NULL)
313 return gfc_sym_identifier (sym);
316 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
317 return get_identifier (name);
322 /* Construct mangled function name from symbol name. */
325 gfc_sym_mangled_function_id (gfc_symbol * sym)
328 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
330 /* It may be possible to simply use the binding label if it's
331 provided, and remove the other checks. Then we could use it
332 for other things if we wished. */
333 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
334 sym->binding_label[0] != '\0')
335 /* use the binding label rather than the mangled name */
336 return get_identifier (sym->binding_label);
338 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
339 || (sym->module != NULL && (sym->attr.external
340 || sym->attr.if_source == IFSRC_IFBODY)))
342 /* Main program is mangled into MAIN__. */
343 if (sym->attr.is_main_program)
344 return get_identifier ("MAIN__");
346 /* Intrinsic procedures are never mangled. */
347 if (sym->attr.proc == PROC_INTRINSIC)
348 return get_identifier (sym->name);
350 if (gfc_option.flag_underscoring)
352 has_underscore = strchr (sym->name, '_') != 0;
353 if (gfc_option.flag_second_underscore && has_underscore)
354 snprintf (name, sizeof name, "%s__", sym->name);
356 snprintf (name, sizeof name, "%s_", sym->name);
357 return get_identifier (name);
360 return get_identifier (sym->name);
364 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
365 return get_identifier (name);
370 /* Returns true if a variable of specified size should go on the stack. */
373 gfc_can_put_var_on_stack (tree size)
375 unsigned HOST_WIDE_INT low;
377 if (!INTEGER_CST_P (size))
380 if (gfc_option.flag_max_stack_var_size < 0)
383 if (TREE_INT_CST_HIGH (size) != 0)
386 low = TREE_INT_CST_LOW (size);
387 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
390 /* TODO: Set a per-function stack size limit. */
396 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
397 an expression involving its corresponding pointer. There are
398 2 cases; one for variable size arrays, and one for everything else,
399 because variable-sized arrays require one fewer level of
403 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
405 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
408 /* Parameters need to be dereferenced. */
409 if (sym->cp_pointer->attr.dummy)
410 ptr_decl = build_fold_indirect_ref (ptr_decl);
412 /* Check to see if we're dealing with a variable-sized array. */
413 if (sym->attr.dimension
414 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
416 /* These decls will be dereferenced later, so we don't dereference
418 value = convert (TREE_TYPE (decl), ptr_decl);
422 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
424 value = build_fold_indirect_ref (ptr_decl);
427 SET_DECL_VALUE_EXPR (decl, value);
428 DECL_HAS_VALUE_EXPR_P (decl) = 1;
429 GFC_DECL_CRAY_POINTEE (decl) = 1;
430 /* This is a fake variable just for debugging purposes. */
431 TREE_ASM_WRITTEN (decl) = 1;
435 /* Finish processing of a declaration without an initial value. */
438 gfc_finish_decl (tree decl)
440 gcc_assert (TREE_CODE (decl) == PARM_DECL
441 || DECL_INITIAL (decl) == NULL_TREE);
443 if (TREE_CODE (decl) != VAR_DECL)
446 if (DECL_SIZE (decl) == NULL_TREE
447 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
448 layout_decl (decl, 0);
450 /* A few consistency checks. */
451 /* A static variable with an incomplete type is an error if it is
452 initialized. Also if it is not file scope. Otherwise, let it
453 through, but if it is not `extern' then it may cause an error
455 /* An automatic variable with an incomplete type is an error. */
457 /* We should know the storage size. */
458 gcc_assert (DECL_SIZE (decl) != NULL_TREE
459 || (TREE_STATIC (decl)
460 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
461 : DECL_EXTERNAL (decl)));
463 /* The storage size should be constant. */
464 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
466 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
470 /* Apply symbol attributes to a variable, and add it to the function scope. */
473 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
476 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
477 This is the equivalent of the TARGET variables.
478 We also need to set this if the variable is passed by reference in a
481 /* Set DECL_VALUE_EXPR for Cray Pointees. */
482 if (sym->attr.cray_pointee)
483 gfc_finish_cray_pointee (decl, sym);
485 if (sym->attr.target)
486 TREE_ADDRESSABLE (decl) = 1;
487 /* If it wasn't used we wouldn't be getting it. */
488 TREE_USED (decl) = 1;
490 /* Chain this decl to the pending declarations. Don't do pushdecl()
491 because this would add them to the current scope rather than the
493 if (current_function_decl != NULL_TREE)
495 if (sym->ns->proc_name->backend_decl == current_function_decl
496 || sym->result == sym)
497 gfc_add_decl_to_function (decl);
499 gfc_add_decl_to_parent_function (decl);
502 if (sym->attr.cray_pointee)
505 if(sym->attr.is_bind_c == 1)
507 /* We need to put variables that are bind(c) into the common
508 segment of the object file, because this is what C would do.
509 gfortran would typically put them in either the BSS or
510 initialized data segments, and only mark them as common if
511 they were part of common blocks. However, if they are not put
512 into common space, then C cannot initialize global fortran
513 variables that it interoperates with and the draft says that
514 either Fortran or C should be able to initialize it (but not
515 both, of course.) (J3/04-007, section 15.3). */
516 TREE_PUBLIC(decl) = 1;
517 DECL_COMMON(decl) = 1;
520 /* If a variable is USE associated, it's always external. */
521 if (sym->attr.use_assoc)
523 DECL_EXTERNAL (decl) = 1;
524 TREE_PUBLIC (decl) = 1;
526 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
528 /* TODO: Don't set sym->module for result or dummy variables. */
529 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
530 /* This is the declaration of a module variable. */
531 TREE_PUBLIC (decl) = 1;
532 TREE_STATIC (decl) = 1;
535 /* Derived types are a bit peculiar because of the possibility of
536 a default initializer; this must be applied each time the variable
537 comes into scope it therefore need not be static. These variables
538 are SAVE_NONE but have an initializer. Otherwise explicitly
539 initialized variables are SAVE_IMPLICIT and explicitly saved are
541 if (!sym->attr.use_assoc
542 && (sym->attr.save != SAVE_NONE || sym->attr.data
543 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
544 TREE_STATIC (decl) = 1;
546 if (sym->attr.volatile_)
548 TREE_THIS_VOLATILE (decl) = 1;
549 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
550 TREE_TYPE (decl) = new_type;
553 /* Keep variables larger than max-stack-var-size off stack. */
554 if (!sym->ns->proc_name->attr.recursive
555 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
556 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
557 /* Put variable length auto array pointers always into stack. */
558 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
559 || sym->attr.dimension == 0
560 || sym->as->type != AS_EXPLICIT
562 || sym->attr.allocatable)
563 && !DECL_ARTIFICIAL (decl))
564 TREE_STATIC (decl) = 1;
566 /* Handle threadprivate variables. */
567 if (sym->attr.threadprivate
568 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
569 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
573 /* Allocate the lang-specific part of a decl. */
576 gfc_allocate_lang_decl (tree decl)
578 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
579 ggc_alloc_cleared (sizeof (struct lang_decl));
582 /* Remember a symbol to generate initialization/cleanup code at function
586 gfc_defer_symbol_init (gfc_symbol * sym)
592 /* Don't add a symbol twice. */
596 last = head = sym->ns->proc_name;
599 /* Make sure that setup code for dummy variables which are used in the
600 setup of other variables is generated first. */
603 /* Find the first dummy arg seen after us, or the first non-dummy arg.
604 This is a circular list, so don't go past the head. */
606 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
612 /* Insert in between last and p. */
618 /* Create an array index type variable with function scope. */
621 create_index_var (const char * pfx, int nest)
625 decl = gfc_create_var_np (gfc_array_index_type, pfx);
627 gfc_add_decl_to_parent_function (decl);
629 gfc_add_decl_to_function (decl);
634 /* Create variables to hold all the non-constant bits of info for a
635 descriptorless array. Remember these in the lang-specific part of the
639 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
645 type = TREE_TYPE (decl);
647 /* We just use the descriptor, if there is one. */
648 if (GFC_DESCRIPTOR_TYPE_P (type))
651 gcc_assert (GFC_ARRAY_TYPE_P (type));
652 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
653 && !sym->attr.contained;
655 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
657 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
659 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
660 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
662 /* Don't try to use the unknown bound for assumed shape arrays. */
663 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
664 && (sym->as->type != AS_ASSUMED_SIZE
665 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
667 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
668 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
671 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
673 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
674 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
677 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
679 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
681 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
684 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
686 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
689 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
690 && sym->as->type != AS_ASSUMED_SIZE)
692 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
693 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
696 if (POINTER_TYPE_P (type))
698 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
699 gcc_assert (TYPE_LANG_SPECIFIC (type)
700 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
701 type = TREE_TYPE (type);
704 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
708 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
709 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
710 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
712 TYPE_DOMAIN (type) = range;
716 if (write_symbols == NO_DEBUG)
719 if (TYPE_NAME (type) != NULL_TREE
720 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
721 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
723 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
725 for (dim = 0; dim < sym->as->rank - 1; dim++)
727 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
728 gtype = TREE_TYPE (gtype);
730 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
731 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
732 TYPE_NAME (type) = NULL_TREE;
735 if (TYPE_NAME (type) == NULL_TREE)
737 tree gtype = TREE_TYPE (type), rtype, type_decl;
739 for (dim = sym->as->rank - 1; dim >= 0; dim--)
741 rtype = build_range_type (gfc_array_index_type,
742 GFC_TYPE_ARRAY_LBOUND (type, dim),
743 GFC_TYPE_ARRAY_UBOUND (type, dim));
744 gtype = build_array_type (gtype, rtype);
745 /* Ensure the bound variables aren't optimized out at -O0. */
748 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
749 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
750 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
751 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
752 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
753 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
756 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
757 DECL_ORIGINAL_TYPE (type_decl) = gtype;
762 /* For some dummy arguments we don't use the actual argument directly.
763 Instead we create a local decl and use that. This allows us to perform
764 initialization, and construct full type information. */
767 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
777 if (sym->attr.pointer || sym->attr.allocatable)
780 /* Add to list of variables if not a fake result variable. */
781 if (sym->attr.result || sym->attr.dummy)
782 gfc_defer_symbol_init (sym);
784 type = TREE_TYPE (dummy);
785 gcc_assert (TREE_CODE (dummy) == PARM_DECL
786 && POINTER_TYPE_P (type));
788 /* Do we know the element size? */
789 known_size = sym->ts.type != BT_CHARACTER
790 || INTEGER_CST_P (sym->ts.cl->backend_decl);
792 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
794 /* For descriptorless arrays with known element size the actual
795 argument is sufficient. */
796 gcc_assert (GFC_ARRAY_TYPE_P (type));
797 gfc_build_qualified_array (dummy, sym);
801 type = TREE_TYPE (type);
802 if (GFC_DESCRIPTOR_TYPE_P (type))
804 /* Create a descriptorless array pointer. */
808 /* Even when -frepack-arrays is used, symbols with TARGET attribute
810 if (!gfc_option.flag_repack_arrays || sym->attr.target)
812 if (as->type == AS_ASSUMED_SIZE)
813 packed = PACKED_FULL;
817 if (as->type == AS_EXPLICIT)
819 packed = PACKED_FULL;
820 for (n = 0; n < as->rank; n++)
824 && as->upper[n]->expr_type == EXPR_CONSTANT
825 && as->lower[n]->expr_type == EXPR_CONSTANT))
826 packed = PACKED_PARTIAL;
830 packed = PACKED_PARTIAL;
833 type = gfc_typenode_for_spec (&sym->ts);
834 type = gfc_get_nodesc_array_type (type, sym->as, packed);
838 /* We now have an expression for the element size, so create a fully
839 qualified type. Reset sym->backend decl or this will just return the
841 DECL_ARTIFICIAL (sym->backend_decl) = 1;
842 sym->backend_decl = NULL_TREE;
843 type = gfc_sym_type (sym);
844 packed = PACKED_FULL;
847 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
848 decl = build_decl (VAR_DECL, get_identifier (name), type);
850 DECL_ARTIFICIAL (decl) = 1;
851 TREE_PUBLIC (decl) = 0;
852 TREE_STATIC (decl) = 0;
853 DECL_EXTERNAL (decl) = 0;
855 /* We should never get deferred shape arrays here. We used to because of
857 gcc_assert (sym->as->type != AS_DEFERRED);
859 if (packed == PACKED_PARTIAL)
860 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
861 else if (packed == PACKED_FULL)
862 GFC_DECL_PACKED_ARRAY (decl) = 1;
864 gfc_build_qualified_array (decl, sym);
866 if (DECL_LANG_SPECIFIC (dummy))
867 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
869 gfc_allocate_lang_decl (decl);
871 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
873 if (sym->ns->proc_name->backend_decl == current_function_decl
874 || sym->attr.contained)
875 gfc_add_decl_to_function (decl);
877 gfc_add_decl_to_parent_function (decl);
882 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
883 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
884 pointing to the artificial variable for debug info purposes. */
887 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
891 if (! nonlocal_dummy_decl_pset)
892 nonlocal_dummy_decl_pset = pointer_set_create ();
894 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
897 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
898 decl = build_decl (VAR_DECL, DECL_NAME (dummy),
899 TREE_TYPE (sym->backend_decl));
900 DECL_ARTIFICIAL (decl) = 0;
901 TREE_USED (decl) = 1;
902 TREE_PUBLIC (decl) = 0;
903 TREE_STATIC (decl) = 0;
904 DECL_EXTERNAL (decl) = 0;
905 if (DECL_BY_REFERENCE (dummy))
906 DECL_BY_REFERENCE (decl) = 1;
907 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
908 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
909 DECL_HAS_VALUE_EXPR_P (decl) = 1;
910 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
911 TREE_CHAIN (decl) = nonlocal_dummy_decls;
912 nonlocal_dummy_decls = decl;
915 /* Return a constant or a variable to use as a string length. Does not
916 add the decl to the current scope. */
919 gfc_create_string_length (gfc_symbol * sym)
921 gcc_assert (sym->ts.cl);
922 gfc_conv_const_charlen (sym->ts.cl);
924 if (sym->ts.cl->backend_decl == NULL_TREE)
927 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
929 /* Also prefix the mangled name. */
930 strcpy (&name[1], sym->name);
932 length = build_decl (VAR_DECL, get_identifier (name),
933 gfc_charlen_type_node);
934 DECL_ARTIFICIAL (length) = 1;
935 TREE_USED (length) = 1;
936 if (sym->ns->proc_name->tlink != NULL)
937 gfc_defer_symbol_init (sym);
939 sym->ts.cl->backend_decl = length;
942 gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
943 return sym->ts.cl->backend_decl;
946 /* If a variable is assigned a label, we add another two auxiliary
950 gfc_add_assign_aux_vars (gfc_symbol * sym)
956 gcc_assert (sym->backend_decl);
958 decl = sym->backend_decl;
959 gfc_allocate_lang_decl (decl);
960 GFC_DECL_ASSIGN (decl) = 1;
961 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
962 gfc_charlen_type_node);
963 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
965 gfc_finish_var_decl (length, sym);
966 gfc_finish_var_decl (addr, sym);
967 /* STRING_LENGTH is also used as flag. Less than -1 means that
968 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
969 target label's address. Otherwise, value is the length of a format string
970 and ASSIGN_ADDR is its address. */
971 if (TREE_STATIC (length))
972 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
974 gfc_defer_symbol_init (sym);
976 GFC_DECL_STRING_LEN (decl) = length;
977 GFC_DECL_ASSIGN_ADDR (decl) = addr;
980 /* Return the decl for a gfc_symbol, create it if it doesn't already
984 gfc_get_symbol_decl (gfc_symbol * sym)
987 tree length = NULL_TREE;
990 gcc_assert (sym->attr.referenced
991 || sym->attr.use_assoc
992 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
994 if (sym->ns && sym->ns->proc_name->attr.function)
995 byref = gfc_return_by_reference (sym->ns->proc_name);
999 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1001 /* Return via extra parameter. */
1002 if (sym->attr.result && byref
1003 && !sym->backend_decl)
1006 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1007 /* For entry master function skip over the __entry
1009 if (sym->ns->proc_name->attr.entry_master)
1010 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1013 /* Dummy variables should already have been created. */
1014 gcc_assert (sym->backend_decl);
1016 /* Create a character length variable. */
1017 if (sym->ts.type == BT_CHARACTER)
1019 if (sym->ts.cl->backend_decl == NULL_TREE)
1020 length = gfc_create_string_length (sym);
1022 length = sym->ts.cl->backend_decl;
1023 if (TREE_CODE (length) == VAR_DECL
1024 && DECL_CONTEXT (length) == NULL_TREE)
1026 /* Add the string length to the same context as the symbol. */
1027 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1028 gfc_add_decl_to_function (length);
1030 gfc_add_decl_to_parent_function (length);
1032 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1033 DECL_CONTEXT (length));
1035 gfc_defer_symbol_init (sym);
1039 /* Use a copy of the descriptor for dummy arrays. */
1040 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1042 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1043 /* Prevent the dummy from being detected as unused if it is copied. */
1044 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1045 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1046 sym->backend_decl = decl;
1049 TREE_USED (sym->backend_decl) = 1;
1050 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1052 gfc_add_assign_aux_vars (sym);
1055 if (sym->attr.dimension
1056 && DECL_LANG_SPECIFIC (sym->backend_decl)
1057 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1058 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1059 gfc_nonlocal_dummy_array_decl (sym);
1061 return sym->backend_decl;
1064 if (sym->backend_decl)
1065 return sym->backend_decl;
1067 /* Catch function declarations. Only used for actual parameters and
1068 procedure pointers. */
1069 if (sym->attr.flavor == FL_PROCEDURE)
1071 decl = gfc_get_extern_function_decl (sym);
1072 gfc_set_decl_location (decl, &sym->declared_at);
1076 if (sym->attr.intrinsic)
1077 internal_error ("intrinsic variable which isn't a procedure");
1079 /* Create string length decl first so that they can be used in the
1080 type declaration. */
1081 if (sym->ts.type == BT_CHARACTER)
1082 length = gfc_create_string_length (sym);
1084 /* Create the decl for the variable. */
1085 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1087 gfc_set_decl_location (decl, &sym->declared_at);
1089 /* Symbols from modules should have their assembler names mangled.
1090 This is done here rather than in gfc_finish_var_decl because it
1091 is different for string length variables. */
1094 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1095 if (sym->attr.use_assoc)
1096 DECL_IGNORED_P (decl) = 1;
1099 if (sym->attr.dimension)
1101 /* Create variables to hold the non-constant bits of array info. */
1102 gfc_build_qualified_array (decl, sym);
1104 /* Remember this variable for allocation/cleanup. */
1105 gfc_defer_symbol_init (sym);
1107 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1108 GFC_DECL_PACKED_ARRAY (decl) = 1;
1111 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1112 gfc_defer_symbol_init (sym);
1113 /* This applies a derived type default initializer. */
1114 else if (sym->ts.type == BT_DERIVED
1115 && sym->attr.save == SAVE_NONE
1117 && !sym->attr.allocatable
1118 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1119 && !sym->attr.use_assoc)
1120 gfc_defer_symbol_init (sym);
1122 gfc_finish_var_decl (decl, sym);
1124 if (sym->ts.type == BT_CHARACTER)
1126 /* Character variables need special handling. */
1127 gfc_allocate_lang_decl (decl);
1129 if (TREE_CODE (length) != INTEGER_CST)
1131 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1135 /* Also prefix the mangled name for symbols from modules. */
1136 strcpy (&name[1], sym->name);
1139 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1140 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1142 gfc_finish_var_decl (length, sym);
1143 gcc_assert (!sym->value);
1146 else if (sym->attr.subref_array_pointer)
1148 /* We need the span for these beasts. */
1149 gfc_allocate_lang_decl (decl);
1152 if (sym->attr.subref_array_pointer)
1155 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1156 span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1157 gfc_array_index_type);
1158 gfc_finish_var_decl (span, sym);
1159 TREE_STATIC (span) = TREE_STATIC (decl);
1160 DECL_ARTIFICIAL (span) = 1;
1161 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1163 GFC_DECL_SPAN (decl) = span;
1164 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1167 sym->backend_decl = decl;
1169 if (sym->attr.assign)
1170 gfc_add_assign_aux_vars (sym);
1172 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1174 /* Add static initializer. */
1175 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1176 TREE_TYPE (decl), sym->attr.dimension,
1177 sym->attr.pointer || sym->attr.allocatable);
1180 if (!TREE_STATIC (decl)
1181 && POINTER_TYPE_P (TREE_TYPE (decl))
1182 && !sym->attr.pointer
1183 && !sym->attr.allocatable
1184 && !sym->attr.proc_pointer)
1185 DECL_BY_REFERENCE (decl) = 1;
1191 /* Substitute a temporary variable in place of the real one. */
1194 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1196 save->attr = sym->attr;
1197 save->decl = sym->backend_decl;
1199 gfc_clear_attr (&sym->attr);
1200 sym->attr.referenced = 1;
1201 sym->attr.flavor = FL_VARIABLE;
1203 sym->backend_decl = decl;
1207 /* Restore the original variable. */
1210 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1212 sym->attr = save->attr;
1213 sym->backend_decl = save->decl;
1217 /* Declare a procedure pointer. */
1220 get_proc_pointer_decl (gfc_symbol *sym)
1224 decl = sym->backend_decl;
1228 decl = build_decl (VAR_DECL, get_identifier (sym->name),
1229 build_pointer_type (gfc_get_function_type (sym)));
1231 if ((sym->ns->proc_name
1232 && sym->ns->proc_name->backend_decl == current_function_decl)
1233 || sym->attr.contained)
1234 gfc_add_decl_to_function (decl);
1235 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1236 gfc_add_decl_to_parent_function (decl);
1238 sym->backend_decl = decl;
1240 /* If a variable is USE associated, it's always external. */
1241 if (sym->attr.use_assoc)
1243 DECL_EXTERNAL (decl) = 1;
1244 TREE_PUBLIC (decl) = 1;
1246 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1248 /* This is the declaration of a module variable. */
1249 TREE_PUBLIC (decl) = 1;
1250 TREE_STATIC (decl) = 1;
1253 if (!sym->attr.use_assoc
1254 && (sym->attr.save != SAVE_NONE || sym->attr.data
1255 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1256 TREE_STATIC (decl) = 1;
1258 if (TREE_STATIC (decl) && sym->value)
1260 /* Add static initializer. */
1261 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1262 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1269 /* Get a basic decl for an external function. */
1272 gfc_get_extern_function_decl (gfc_symbol * sym)
1277 gfc_intrinsic_sym *isym;
1279 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1284 if (sym->backend_decl)
1285 return sym->backend_decl;
1287 /* We should never be creating external decls for alternate entry points.
1288 The procedure may be an alternate entry point, but we don't want/need
1290 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1292 if (sym->attr.proc_pointer)
1293 return get_proc_pointer_decl (sym);
1295 /* See if this is an external procedure from the same file. If so,
1296 return the backend_decl. */
1297 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1299 if (gfc_option.flag_whole_file
1300 && !sym->backend_decl
1302 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1303 && gsym->ns->proc_name->backend_decl)
1305 /* If the namespace has entries, the proc_name is the
1306 entry master. Find the entry and use its backend_decl.
1307 otherwise, use the proc_name backend_decl. */
1308 if (gsym->ns->entries)
1310 gfc_entry_list *entry = gsym->ns->entries;
1312 for (; entry; entry = entry->next)
1314 if (strcmp (gsym->name, entry->sym->name) == 0)
1316 sym->backend_decl = entry->sym->backend_decl;
1323 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1326 if (sym->backend_decl)
1327 return sym->backend_decl;
1330 if (sym->attr.intrinsic)
1332 /* Call the resolution function to get the actual name. This is
1333 a nasty hack which relies on the resolution functions only looking
1334 at the first argument. We pass NULL for the second argument
1335 otherwise things like AINT get confused. */
1336 isym = gfc_find_function (sym->name);
1337 gcc_assert (isym->resolve.f0 != NULL);
1339 memset (&e, 0, sizeof (e));
1340 e.expr_type = EXPR_FUNCTION;
1342 memset (&argexpr, 0, sizeof (argexpr));
1343 gcc_assert (isym->formal);
1344 argexpr.ts = isym->formal->ts;
1346 if (isym->formal->next == NULL)
1347 isym->resolve.f1 (&e, &argexpr);
1350 if (isym->formal->next->next == NULL)
1351 isym->resolve.f2 (&e, &argexpr, NULL);
1354 if (isym->formal->next->next->next == NULL)
1355 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1358 /* All specific intrinsics take less than 5 arguments. */
1359 gcc_assert (isym->formal->next->next->next->next == NULL);
1360 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1365 if (gfc_option.flag_f2c
1366 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1367 || e.ts.type == BT_COMPLEX))
1369 /* Specific which needs a different implementation if f2c
1370 calling conventions are used. */
1371 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1374 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1376 name = get_identifier (s);
1377 mangled_name = name;
1381 name = gfc_sym_identifier (sym);
1382 mangled_name = gfc_sym_mangled_function_id (sym);
1385 type = gfc_get_function_type (sym);
1386 fndecl = build_decl (FUNCTION_DECL, name, type);
1388 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1389 /* If the return type is a pointer, avoid alias issues by setting
1390 DECL_IS_MALLOC to nonzero. This means that the function should be
1391 treated as if it were a malloc, meaning it returns a pointer that
1393 if (POINTER_TYPE_P (type))
1394 DECL_IS_MALLOC (fndecl) = 1;
1396 /* Set the context of this decl. */
1397 if (0 && sym->ns && sym->ns->proc_name)
1399 /* TODO: Add external decls to the appropriate scope. */
1400 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1404 /* Global declaration, e.g. intrinsic subroutine. */
1405 DECL_CONTEXT (fndecl) = NULL_TREE;
1408 DECL_EXTERNAL (fndecl) = 1;
1410 /* This specifies if a function is globally addressable, i.e. it is
1411 the opposite of declaring static in C. */
1412 TREE_PUBLIC (fndecl) = 1;
1414 /* Set attributes for PURE functions. A call to PURE function in the
1415 Fortran 95 sense is both pure and without side effects in the C
1417 if (sym->attr.pure || sym->attr.elemental)
1419 if (sym->attr.function && !gfc_return_by_reference (sym))
1420 DECL_PURE_P (fndecl) = 1;
1421 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1422 parameters and don't use alternate returns (is this
1423 allowed?). In that case, calls to them are meaningless, and
1424 can be optimized away. See also in build_function_decl(). */
1425 TREE_SIDE_EFFECTS (fndecl) = 0;
1428 /* Mark non-returning functions. */
1429 if (sym->attr.noreturn)
1430 TREE_THIS_VOLATILE(fndecl) = 1;
1432 sym->backend_decl = fndecl;
1434 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1435 pushdecl_top_level (fndecl);
1441 /* Create a declaration for a procedure. For external functions (in the C
1442 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1443 a master function with alternate entry points. */
1446 build_function_decl (gfc_symbol * sym)
1449 symbol_attribute attr;
1451 gfc_formal_arglist *f;
1453 gcc_assert (!sym->backend_decl);
1454 gcc_assert (!sym->attr.external);
1456 /* Set the line and filename. sym->declared_at seems to point to the
1457 last statement for subroutines, but it'll do for now. */
1458 gfc_set_backend_locus (&sym->declared_at);
1460 /* Allow only one nesting level. Allow public declarations. */
1461 gcc_assert (current_function_decl == NULL_TREE
1462 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1463 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1466 type = gfc_get_function_type (sym);
1467 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1469 /* Perform name mangling if this is a top level or module procedure. */
1470 if (current_function_decl == NULL_TREE)
1471 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1473 /* Figure out the return type of the declared function, and build a
1474 RESULT_DECL for it. If this is a subroutine with alternate
1475 returns, build a RESULT_DECL for it. */
1478 result_decl = NULL_TREE;
1479 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1482 if (gfc_return_by_reference (sym))
1483 type = void_type_node;
1486 if (sym->result != sym)
1487 result_decl = gfc_sym_identifier (sym->result);
1489 type = TREE_TYPE (TREE_TYPE (fndecl));
1494 /* Look for alternate return placeholders. */
1495 int has_alternate_returns = 0;
1496 for (f = sym->formal; f; f = f->next)
1500 has_alternate_returns = 1;
1505 if (has_alternate_returns)
1506 type = integer_type_node;
1508 type = void_type_node;
1511 result_decl = build_decl (RESULT_DECL, result_decl, type);
1512 DECL_ARTIFICIAL (result_decl) = 1;
1513 DECL_IGNORED_P (result_decl) = 1;
1514 DECL_CONTEXT (result_decl) = fndecl;
1515 DECL_RESULT (fndecl) = result_decl;
1517 /* Don't call layout_decl for a RESULT_DECL.
1518 layout_decl (result_decl, 0); */
1520 /* If the return type is a pointer, avoid alias issues by setting
1521 DECL_IS_MALLOC to nonzero. This means that the function should be
1522 treated as if it were a malloc, meaning it returns a pointer that
1524 if (POINTER_TYPE_P (type))
1525 DECL_IS_MALLOC (fndecl) = 1;
1527 /* Set up all attributes for the function. */
1528 DECL_CONTEXT (fndecl) = current_function_decl;
1529 DECL_EXTERNAL (fndecl) = 0;
1531 /* This specifies if a function is globally visible, i.e. it is
1532 the opposite of declaring static in C. */
1533 if (DECL_CONTEXT (fndecl) == NULL_TREE
1534 && !sym->attr.entry_master && !sym->attr.is_main_program)
1535 TREE_PUBLIC (fndecl) = 1;
1537 /* TREE_STATIC means the function body is defined here. */
1538 TREE_STATIC (fndecl) = 1;
1540 /* Set attributes for PURE functions. A call to a PURE function in the
1541 Fortran 95 sense is both pure and without side effects in the C
1543 if (attr.pure || attr.elemental)
1545 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1546 including an alternate return. In that case it can also be
1547 marked as PURE. See also in gfc_get_extern_function_decl(). */
1548 if (attr.function && !gfc_return_by_reference (sym))
1549 DECL_PURE_P (fndecl) = 1;
1550 TREE_SIDE_EFFECTS (fndecl) = 0;
1553 /* Layout the function declaration and put it in the binding level
1554 of the current function. */
1557 sym->backend_decl = fndecl;
1561 /* Create the DECL_ARGUMENTS for a procedure. */
1564 create_function_arglist (gfc_symbol * sym)
1567 gfc_formal_arglist *f;
1568 tree typelist, hidden_typelist;
1569 tree arglist, hidden_arglist;
1573 fndecl = sym->backend_decl;
1575 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1576 the new FUNCTION_DECL node. */
1577 arglist = NULL_TREE;
1578 hidden_arglist = NULL_TREE;
1579 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1581 if (sym->attr.entry_master)
1583 type = TREE_VALUE (typelist);
1584 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1586 DECL_CONTEXT (parm) = fndecl;
1587 DECL_ARG_TYPE (parm) = type;
1588 TREE_READONLY (parm) = 1;
1589 gfc_finish_decl (parm);
1590 DECL_ARTIFICIAL (parm) = 1;
1592 arglist = chainon (arglist, parm);
1593 typelist = TREE_CHAIN (typelist);
1596 if (gfc_return_by_reference (sym))
1598 tree type = TREE_VALUE (typelist), length = NULL;
1600 if (sym->ts.type == BT_CHARACTER)
1602 /* Length of character result. */
1603 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1604 gcc_assert (len_type == gfc_charlen_type_node);
1606 length = build_decl (PARM_DECL,
1607 get_identifier (".__result"),
1609 if (!sym->ts.cl->length)
1611 sym->ts.cl->backend_decl = length;
1612 TREE_USED (length) = 1;
1614 gcc_assert (TREE_CODE (length) == PARM_DECL);
1615 DECL_CONTEXT (length) = fndecl;
1616 DECL_ARG_TYPE (length) = len_type;
1617 TREE_READONLY (length) = 1;
1618 DECL_ARTIFICIAL (length) = 1;
1619 gfc_finish_decl (length);
1620 if (sym->ts.cl->backend_decl == NULL
1621 || sym->ts.cl->backend_decl == length)
1626 if (sym->ts.cl->backend_decl == NULL)
1628 tree len = build_decl (VAR_DECL,
1629 get_identifier ("..__result"),
1630 gfc_charlen_type_node);
1631 DECL_ARTIFICIAL (len) = 1;
1632 TREE_USED (len) = 1;
1633 sym->ts.cl->backend_decl = len;
1636 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1637 arg = sym->result ? sym->result : sym;
1638 backend_decl = arg->backend_decl;
1639 /* Temporary clear it, so that gfc_sym_type creates complete
1641 arg->backend_decl = NULL;
1642 type = gfc_sym_type (arg);
1643 arg->backend_decl = backend_decl;
1644 type = build_reference_type (type);
1648 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1650 DECL_CONTEXT (parm) = fndecl;
1651 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1652 TREE_READONLY (parm) = 1;
1653 DECL_ARTIFICIAL (parm) = 1;
1654 gfc_finish_decl (parm);
1656 arglist = chainon (arglist, parm);
1657 typelist = TREE_CHAIN (typelist);
1659 if (sym->ts.type == BT_CHARACTER)
1661 gfc_allocate_lang_decl (parm);
1662 arglist = chainon (arglist, length);
1663 typelist = TREE_CHAIN (typelist);
1667 hidden_typelist = typelist;
1668 for (f = sym->formal; f; f = f->next)
1669 if (f->sym != NULL) /* Ignore alternate returns. */
1670 hidden_typelist = TREE_CHAIN (hidden_typelist);
1672 for (f = sym->formal; f; f = f->next)
1674 char name[GFC_MAX_SYMBOL_LEN + 2];
1676 /* Ignore alternate returns. */
1680 type = TREE_VALUE (typelist);
1682 if (f->sym->ts.type == BT_CHARACTER)
1684 tree len_type = TREE_VALUE (hidden_typelist);
1685 tree length = NULL_TREE;
1686 gcc_assert (len_type == gfc_charlen_type_node);
1688 strcpy (&name[1], f->sym->name);
1690 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1692 hidden_arglist = chainon (hidden_arglist, length);
1693 DECL_CONTEXT (length) = fndecl;
1694 DECL_ARTIFICIAL (length) = 1;
1695 DECL_ARG_TYPE (length) = len_type;
1696 TREE_READONLY (length) = 1;
1697 gfc_finish_decl (length);
1699 /* Remember the passed value. */
1700 f->sym->ts.cl->passed_length = length;
1702 /* Use the passed value for assumed length variables. */
1703 if (!f->sym->ts.cl->length)
1705 TREE_USED (length) = 1;
1706 gcc_assert (!f->sym->ts.cl->backend_decl);
1707 f->sym->ts.cl->backend_decl = length;
1710 hidden_typelist = TREE_CHAIN (hidden_typelist);
1712 if (f->sym->ts.cl->backend_decl == NULL
1713 || f->sym->ts.cl->backend_decl == length)
1715 if (f->sym->ts.cl->backend_decl == NULL)
1716 gfc_create_string_length (f->sym);
1718 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1719 if (f->sym->attr.flavor == FL_PROCEDURE)
1720 type = build_pointer_type (gfc_get_function_type (f->sym));
1722 type = gfc_sym_type (f->sym);
1726 /* For non-constant length array arguments, make sure they use
1727 a different type node from TYPE_ARG_TYPES type. */
1728 if (f->sym->attr.dimension
1729 && type == TREE_VALUE (typelist)
1730 && TREE_CODE (type) == POINTER_TYPE
1731 && GFC_ARRAY_TYPE_P (type)
1732 && f->sym->as->type != AS_ASSUMED_SIZE
1733 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1735 if (f->sym->attr.flavor == FL_PROCEDURE)
1736 type = build_pointer_type (gfc_get_function_type (f->sym));
1738 type = gfc_sym_type (f->sym);
1741 if (f->sym->attr.proc_pointer)
1742 type = build_pointer_type (type);
1744 /* Build the argument declaration. */
1745 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1747 /* Fill in arg stuff. */
1748 DECL_CONTEXT (parm) = fndecl;
1749 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1750 /* All implementation args are read-only. */
1751 TREE_READONLY (parm) = 1;
1752 if (POINTER_TYPE_P (type)
1753 && (!f->sym->attr.proc_pointer
1754 && f->sym->attr.flavor != FL_PROCEDURE))
1755 DECL_BY_REFERENCE (parm) = 1;
1757 gfc_finish_decl (parm);
1759 f->sym->backend_decl = parm;
1761 arglist = chainon (arglist, parm);
1762 typelist = TREE_CHAIN (typelist);
1765 /* Add the hidden string length parameters, unless the procedure
1767 if (!sym->attr.is_bind_c)
1768 arglist = chainon (arglist, hidden_arglist);
1770 gcc_assert (hidden_typelist == NULL_TREE
1771 || TREE_VALUE (hidden_typelist) == void_type_node);
1772 DECL_ARGUMENTS (fndecl) = arglist;
1775 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1778 gfc_gimplify_function (tree fndecl)
1780 struct cgraph_node *cgn;
1782 gimplify_function_tree (fndecl);
1783 dump_function (TDI_generic, fndecl);
1785 /* Generate errors for structured block violations. */
1786 /* ??? Could be done as part of resolve_labels. */
1788 diagnose_omp_structured_block_errors (fndecl);
1790 /* Convert all nested functions to GIMPLE now. We do things in this order
1791 so that items like VLA sizes are expanded properly in the context of the
1792 correct function. */
1793 cgn = cgraph_node (fndecl);
1794 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1795 gfc_gimplify_function (cgn->decl);
1799 /* Do the setup necessary before generating the body of a function. */
1802 trans_function_start (gfc_symbol * sym)
1806 fndecl = sym->backend_decl;
1808 /* Let GCC know the current scope is this function. */
1809 current_function_decl = fndecl;
1811 /* Let the world know what we're about to do. */
1812 announce_function (fndecl);
1814 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1816 /* Create RTL for function declaration. */
1817 rest_of_decl_compilation (fndecl, 1, 0);
1820 /* Create RTL for function definition. */
1821 make_decl_rtl (fndecl);
1823 init_function_start (fndecl);
1825 /* Even though we're inside a function body, we still don't want to
1826 call expand_expr to calculate the size of a variable-sized array.
1827 We haven't necessarily assigned RTL to all variables yet, so it's
1828 not safe to try to expand expressions involving them. */
1829 cfun->dont_save_pending_sizes_p = 1;
1831 /* function.c requires a push at the start of the function. */
1835 /* Create thunks for alternate entry points. */
1838 build_entry_thunks (gfc_namespace * ns)
1840 gfc_formal_arglist *formal;
1841 gfc_formal_arglist *thunk_formal;
1843 gfc_symbol *thunk_sym;
1851 /* This should always be a toplevel function. */
1852 gcc_assert (current_function_decl == NULL_TREE);
1854 gfc_get_backend_locus (&old_loc);
1855 for (el = ns->entries; el; el = el->next)
1857 thunk_sym = el->sym;
1859 build_function_decl (thunk_sym);
1860 create_function_arglist (thunk_sym);
1862 trans_function_start (thunk_sym);
1864 thunk_fndecl = thunk_sym->backend_decl;
1866 gfc_init_block (&body);
1868 /* Pass extra parameter identifying this entry point. */
1869 tmp = build_int_cst (gfc_array_index_type, el->id);
1870 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1871 string_args = NULL_TREE;
1873 if (thunk_sym->attr.function)
1875 if (gfc_return_by_reference (ns->proc_name))
1877 tree ref = DECL_ARGUMENTS (current_function_decl);
1878 args = tree_cons (NULL_TREE, ref, args);
1879 if (ns->proc_name->ts.type == BT_CHARACTER)
1880 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1885 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1887 /* Ignore alternate returns. */
1888 if (formal->sym == NULL)
1891 /* We don't have a clever way of identifying arguments, so resort to
1892 a brute-force search. */
1893 for (thunk_formal = thunk_sym->formal;
1895 thunk_formal = thunk_formal->next)
1897 if (thunk_formal->sym == formal->sym)
1903 /* Pass the argument. */
1904 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1905 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1907 if (formal->sym->ts.type == BT_CHARACTER)
1909 tmp = thunk_formal->sym->ts.cl->backend_decl;
1910 string_args = tree_cons (NULL_TREE, tmp, string_args);
1915 /* Pass NULL for a missing argument. */
1916 args = tree_cons (NULL_TREE, null_pointer_node, args);
1917 if (formal->sym->ts.type == BT_CHARACTER)
1919 tmp = build_int_cst (gfc_charlen_type_node, 0);
1920 string_args = tree_cons (NULL_TREE, tmp, string_args);
1925 /* Call the master function. */
1926 args = nreverse (args);
1927 args = chainon (args, nreverse (string_args));
1928 tmp = ns->proc_name->backend_decl;
1929 tmp = build_function_call_expr (tmp, args);
1930 if (ns->proc_name->attr.mixed_entry_master)
1932 tree union_decl, field;
1933 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1935 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1936 TREE_TYPE (master_type));
1937 DECL_ARTIFICIAL (union_decl) = 1;
1938 DECL_EXTERNAL (union_decl) = 0;
1939 TREE_PUBLIC (union_decl) = 0;
1940 TREE_USED (union_decl) = 1;
1941 layout_decl (union_decl, 0);
1942 pushdecl (union_decl);
1944 DECL_CONTEXT (union_decl) = current_function_decl;
1945 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1947 gfc_add_expr_to_block (&body, tmp);
1949 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1950 field; field = TREE_CHAIN (field))
1951 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1952 thunk_sym->result->name) == 0)
1954 gcc_assert (field != NULL_TREE);
1955 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1956 union_decl, field, NULL_TREE);
1957 tmp = fold_build2 (MODIFY_EXPR,
1958 TREE_TYPE (DECL_RESULT (current_function_decl)),
1959 DECL_RESULT (current_function_decl), tmp);
1960 tmp = build1_v (RETURN_EXPR, tmp);
1962 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1965 tmp = fold_build2 (MODIFY_EXPR,
1966 TREE_TYPE (DECL_RESULT (current_function_decl)),
1967 DECL_RESULT (current_function_decl), tmp);
1968 tmp = build1_v (RETURN_EXPR, tmp);
1970 gfc_add_expr_to_block (&body, tmp);
1972 /* Finish off this function and send it for code generation. */
1973 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1976 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1977 DECL_SAVED_TREE (thunk_fndecl)
1978 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1979 DECL_INITIAL (thunk_fndecl));
1981 /* Output the GENERIC tree. */
1982 dump_function (TDI_original, thunk_fndecl);
1984 /* Store the end of the function, so that we get good line number
1985 info for the epilogue. */
1986 cfun->function_end_locus = input_location;
1988 /* We're leaving the context of this function, so zap cfun.
1989 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1990 tree_rest_of_compilation. */
1993 current_function_decl = NULL_TREE;
1995 gfc_gimplify_function (thunk_fndecl);
1996 cgraph_finalize_function (thunk_fndecl, false);
1998 /* We share the symbols in the formal argument list with other entry
1999 points and the master function. Clear them so that they are
2000 recreated for each function. */
2001 for (formal = thunk_sym->formal; formal; formal = formal->next)
2002 if (formal->sym != NULL) /* Ignore alternate returns. */
2004 formal->sym->backend_decl = NULL_TREE;
2005 if (formal->sym->ts.type == BT_CHARACTER)
2006 formal->sym->ts.cl->backend_decl = NULL_TREE;
2009 if (thunk_sym->attr.function)
2011 if (thunk_sym->ts.type == BT_CHARACTER)
2012 thunk_sym->ts.cl->backend_decl = NULL_TREE;
2013 if (thunk_sym->result->ts.type == BT_CHARACTER)
2014 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
2018 gfc_set_backend_locus (&old_loc);
2022 /* Create a decl for a function, and create any thunks for alternate entry
2026 gfc_create_function_decl (gfc_namespace * ns)
2028 /* Create a declaration for the master function. */
2029 build_function_decl (ns->proc_name);
2031 /* Compile the entry thunks. */
2033 build_entry_thunks (ns);
2035 /* Now create the read argument list. */
2036 create_function_arglist (ns->proc_name);
2039 /* Return the decl used to hold the function return value. If
2040 parent_flag is set, the context is the parent_scope. */
2043 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2047 tree this_fake_result_decl;
2048 tree this_function_decl;
2050 char name[GFC_MAX_SYMBOL_LEN + 10];
2054 this_fake_result_decl = parent_fake_result_decl;
2055 this_function_decl = DECL_CONTEXT (current_function_decl);
2059 this_fake_result_decl = current_fake_result_decl;
2060 this_function_decl = current_function_decl;
2064 && sym->ns->proc_name->backend_decl == this_function_decl
2065 && sym->ns->proc_name->attr.entry_master
2066 && sym != sym->ns->proc_name)
2069 if (this_fake_result_decl != NULL)
2070 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2071 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2074 return TREE_VALUE (t);
2075 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2078 this_fake_result_decl = parent_fake_result_decl;
2080 this_fake_result_decl = current_fake_result_decl;
2082 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2086 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2087 field; field = TREE_CHAIN (field))
2088 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2092 gcc_assert (field != NULL_TREE);
2093 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2094 decl, field, NULL_TREE);
2097 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2099 gfc_add_decl_to_parent_function (var);
2101 gfc_add_decl_to_function (var);
2103 SET_DECL_VALUE_EXPR (var, decl);
2104 DECL_HAS_VALUE_EXPR_P (var) = 1;
2105 GFC_DECL_RESULT (var) = 1;
2107 TREE_CHAIN (this_fake_result_decl)
2108 = tree_cons (get_identifier (sym->name), var,
2109 TREE_CHAIN (this_fake_result_decl));
2113 if (this_fake_result_decl != NULL_TREE)
2114 return TREE_VALUE (this_fake_result_decl);
2116 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2121 if (sym->ts.type == BT_CHARACTER)
2123 if (sym->ts.cl->backend_decl == NULL_TREE)
2124 length = gfc_create_string_length (sym);
2126 length = sym->ts.cl->backend_decl;
2127 if (TREE_CODE (length) == VAR_DECL
2128 && DECL_CONTEXT (length) == NULL_TREE)
2129 gfc_add_decl_to_function (length);
2132 if (gfc_return_by_reference (sym))
2134 decl = DECL_ARGUMENTS (this_function_decl);
2136 if (sym->ns->proc_name->backend_decl == this_function_decl
2137 && sym->ns->proc_name->attr.entry_master)
2138 decl = TREE_CHAIN (decl);
2140 TREE_USED (decl) = 1;
2142 decl = gfc_build_dummy_array_decl (sym, decl);
2146 sprintf (name, "__result_%.20s",
2147 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2149 if (!sym->attr.mixed_entry_master && sym->attr.function)
2150 decl = build_decl (VAR_DECL, get_identifier (name),
2151 gfc_sym_type (sym));
2153 decl = build_decl (VAR_DECL, get_identifier (name),
2154 TREE_TYPE (TREE_TYPE (this_function_decl)));
2155 DECL_ARTIFICIAL (decl) = 1;
2156 DECL_EXTERNAL (decl) = 0;
2157 TREE_PUBLIC (decl) = 0;
2158 TREE_USED (decl) = 1;
2159 GFC_DECL_RESULT (decl) = 1;
2160 TREE_ADDRESSABLE (decl) = 1;
2162 layout_decl (decl, 0);
2165 gfc_add_decl_to_parent_function (decl);
2167 gfc_add_decl_to_function (decl);
2171 parent_fake_result_decl = build_tree_list (NULL, decl);
2173 current_fake_result_decl = build_tree_list (NULL, decl);
2179 /* Builds a function decl. The remaining parameters are the types of the
2180 function arguments. Negative nargs indicates a varargs function. */
2183 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2192 /* Library functions must be declared with global scope. */
2193 gcc_assert (current_function_decl == NULL_TREE);
2195 va_start (p, nargs);
2198 /* Create a list of the argument types. */
2199 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2201 argtype = va_arg (p, tree);
2202 arglist = gfc_chainon_list (arglist, argtype);
2207 /* Terminate the list. */
2208 arglist = gfc_chainon_list (arglist, void_type_node);
2211 /* Build the function type and decl. */
2212 fntype = build_function_type (rettype, arglist);
2213 fndecl = build_decl (FUNCTION_DECL, name, fntype);
2215 /* Mark this decl as external. */
2216 DECL_EXTERNAL (fndecl) = 1;
2217 TREE_PUBLIC (fndecl) = 1;
2223 rest_of_decl_compilation (fndecl, 1, 0);
2229 gfc_build_intrinsic_function_decls (void)
2231 tree gfc_int4_type_node = gfc_get_int_type (4);
2232 tree gfc_int8_type_node = gfc_get_int_type (8);
2233 tree gfc_int16_type_node = gfc_get_int_type (16);
2234 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2235 tree pchar1_type_node = gfc_get_pchar_type (1);
2236 tree pchar4_type_node = gfc_get_pchar_type (4);
2238 /* String functions. */
2239 gfor_fndecl_compare_string =
2240 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2241 integer_type_node, 4,
2242 gfc_charlen_type_node, pchar1_type_node,
2243 gfc_charlen_type_node, pchar1_type_node);
2245 gfor_fndecl_concat_string =
2246 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2248 gfc_charlen_type_node, pchar1_type_node,
2249 gfc_charlen_type_node, pchar1_type_node,
2250 gfc_charlen_type_node, pchar1_type_node);
2252 gfor_fndecl_string_len_trim =
2253 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2254 gfc_int4_type_node, 2,
2255 gfc_charlen_type_node, pchar1_type_node);
2257 gfor_fndecl_string_index =
2258 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2259 gfc_int4_type_node, 5,
2260 gfc_charlen_type_node, pchar1_type_node,
2261 gfc_charlen_type_node, pchar1_type_node,
2262 gfc_logical4_type_node);
2264 gfor_fndecl_string_scan =
2265 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2266 gfc_int4_type_node, 5,
2267 gfc_charlen_type_node, pchar1_type_node,
2268 gfc_charlen_type_node, pchar1_type_node,
2269 gfc_logical4_type_node);
2271 gfor_fndecl_string_verify =
2272 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2273 gfc_int4_type_node, 5,
2274 gfc_charlen_type_node, pchar1_type_node,
2275 gfc_charlen_type_node, pchar1_type_node,
2276 gfc_logical4_type_node);
2278 gfor_fndecl_string_trim =
2279 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2281 build_pointer_type (gfc_charlen_type_node),
2282 build_pointer_type (pchar1_type_node),
2283 gfc_charlen_type_node, pchar1_type_node);
2285 gfor_fndecl_string_minmax =
2286 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2288 build_pointer_type (gfc_charlen_type_node),
2289 build_pointer_type (pchar1_type_node),
2290 integer_type_node, integer_type_node);
2292 gfor_fndecl_adjustl =
2293 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2294 void_type_node, 3, pchar1_type_node,
2295 gfc_charlen_type_node, pchar1_type_node);
2297 gfor_fndecl_adjustr =
2298 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2299 void_type_node, 3, pchar1_type_node,
2300 gfc_charlen_type_node, pchar1_type_node);
2302 gfor_fndecl_select_string =
2303 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2304 integer_type_node, 4, pvoid_type_node,
2305 integer_type_node, pchar1_type_node,
2306 gfc_charlen_type_node);
2308 gfor_fndecl_compare_string_char4 =
2309 gfc_build_library_function_decl (get_identifier
2310 (PREFIX("compare_string_char4")),
2311 integer_type_node, 4,
2312 gfc_charlen_type_node, pchar4_type_node,
2313 gfc_charlen_type_node, pchar4_type_node);
2315 gfor_fndecl_concat_string_char4 =
2316 gfc_build_library_function_decl (get_identifier
2317 (PREFIX("concat_string_char4")),
2319 gfc_charlen_type_node, pchar4_type_node,
2320 gfc_charlen_type_node, pchar4_type_node,
2321 gfc_charlen_type_node, pchar4_type_node);
2323 gfor_fndecl_string_len_trim_char4 =
2324 gfc_build_library_function_decl (get_identifier
2325 (PREFIX("string_len_trim_char4")),
2326 gfc_charlen_type_node, 2,
2327 gfc_charlen_type_node, pchar4_type_node);
2329 gfor_fndecl_string_index_char4 =
2330 gfc_build_library_function_decl (get_identifier
2331 (PREFIX("string_index_char4")),
2332 gfc_charlen_type_node, 5,
2333 gfc_charlen_type_node, pchar4_type_node,
2334 gfc_charlen_type_node, pchar4_type_node,
2335 gfc_logical4_type_node);
2337 gfor_fndecl_string_scan_char4 =
2338 gfc_build_library_function_decl (get_identifier
2339 (PREFIX("string_scan_char4")),
2340 gfc_charlen_type_node, 5,
2341 gfc_charlen_type_node, pchar4_type_node,
2342 gfc_charlen_type_node, pchar4_type_node,
2343 gfc_logical4_type_node);
2345 gfor_fndecl_string_verify_char4 =
2346 gfc_build_library_function_decl (get_identifier
2347 (PREFIX("string_verify_char4")),
2348 gfc_charlen_type_node, 5,
2349 gfc_charlen_type_node, pchar4_type_node,
2350 gfc_charlen_type_node, pchar4_type_node,
2351 gfc_logical4_type_node);
2353 gfor_fndecl_string_trim_char4 =
2354 gfc_build_library_function_decl (get_identifier
2355 (PREFIX("string_trim_char4")),
2357 build_pointer_type (gfc_charlen_type_node),
2358 build_pointer_type (pchar4_type_node),
2359 gfc_charlen_type_node, pchar4_type_node);
2361 gfor_fndecl_string_minmax_char4 =
2362 gfc_build_library_function_decl (get_identifier
2363 (PREFIX("string_minmax_char4")),
2365 build_pointer_type (gfc_charlen_type_node),
2366 build_pointer_type (pchar4_type_node),
2367 integer_type_node, integer_type_node);
2369 gfor_fndecl_adjustl_char4 =
2370 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2371 void_type_node, 3, pchar4_type_node,
2372 gfc_charlen_type_node, pchar4_type_node);
2374 gfor_fndecl_adjustr_char4 =
2375 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2376 void_type_node, 3, pchar4_type_node,
2377 gfc_charlen_type_node, pchar4_type_node);
2379 gfor_fndecl_select_string_char4 =
2380 gfc_build_library_function_decl (get_identifier
2381 (PREFIX("select_string_char4")),
2382 integer_type_node, 4, pvoid_type_node,
2383 integer_type_node, pvoid_type_node,
2384 gfc_charlen_type_node);
2387 /* Conversion between character kinds. */
2389 gfor_fndecl_convert_char1_to_char4 =
2390 gfc_build_library_function_decl (get_identifier
2391 (PREFIX("convert_char1_to_char4")),
2393 build_pointer_type (pchar4_type_node),
2394 gfc_charlen_type_node, pchar1_type_node);
2396 gfor_fndecl_convert_char4_to_char1 =
2397 gfc_build_library_function_decl (get_identifier
2398 (PREFIX("convert_char4_to_char1")),
2400 build_pointer_type (pchar1_type_node),
2401 gfc_charlen_type_node, pchar4_type_node);
2403 /* Misc. functions. */
2405 gfor_fndecl_ttynam =
2406 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2410 gfc_charlen_type_node,
2414 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2418 gfc_charlen_type_node);
2421 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2425 gfc_charlen_type_node,
2426 gfc_int8_type_node);
2428 gfor_fndecl_sc_kind =
2429 gfc_build_library_function_decl (get_identifier
2430 (PREFIX("selected_char_kind")),
2431 gfc_int4_type_node, 2,
2432 gfc_charlen_type_node, pchar_type_node);
2434 gfor_fndecl_si_kind =
2435 gfc_build_library_function_decl (get_identifier
2436 (PREFIX("selected_int_kind")),
2437 gfc_int4_type_node, 1, pvoid_type_node);
2439 gfor_fndecl_sr_kind =
2440 gfc_build_library_function_decl (get_identifier
2441 (PREFIX("selected_real_kind")),
2442 gfc_int4_type_node, 2,
2443 pvoid_type_node, pvoid_type_node);
2445 /* Power functions. */
2447 tree ctype, rtype, itype, jtype;
2448 int rkind, ikind, jkind;
2451 static int ikinds[NIKINDS] = {4, 8, 16};
2452 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2453 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2455 for (ikind=0; ikind < NIKINDS; ikind++)
2457 itype = gfc_get_int_type (ikinds[ikind]);
2459 for (jkind=0; jkind < NIKINDS; jkind++)
2461 jtype = gfc_get_int_type (ikinds[jkind]);
2464 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2466 gfor_fndecl_math_powi[jkind][ikind].integer =
2467 gfc_build_library_function_decl (get_identifier (name),
2468 jtype, 2, jtype, itype);
2469 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2473 for (rkind = 0; rkind < NRKINDS; rkind ++)
2475 rtype = gfc_get_real_type (rkinds[rkind]);
2478 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2480 gfor_fndecl_math_powi[rkind][ikind].real =
2481 gfc_build_library_function_decl (get_identifier (name),
2482 rtype, 2, rtype, itype);
2483 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2486 ctype = gfc_get_complex_type (rkinds[rkind]);
2489 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2491 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2492 gfc_build_library_function_decl (get_identifier (name),
2493 ctype, 2,ctype, itype);
2494 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2502 gfor_fndecl_math_ishftc4 =
2503 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2505 3, gfc_int4_type_node,
2506 gfc_int4_type_node, gfc_int4_type_node);
2507 gfor_fndecl_math_ishftc8 =
2508 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2510 3, gfc_int8_type_node,
2511 gfc_int4_type_node, gfc_int4_type_node);
2512 if (gfc_int16_type_node)
2513 gfor_fndecl_math_ishftc16 =
2514 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2515 gfc_int16_type_node, 3,
2516 gfc_int16_type_node,
2518 gfc_int4_type_node);
2520 /* BLAS functions. */
2522 tree pint = build_pointer_type (integer_type_node);
2523 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2524 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2525 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2526 tree pz = build_pointer_type
2527 (gfc_get_complex_type (gfc_default_double_kind));
2529 gfor_fndecl_sgemm = gfc_build_library_function_decl
2531 (gfc_option.flag_underscoring ? "sgemm_"
2533 void_type_node, 15, pchar_type_node,
2534 pchar_type_node, pint, pint, pint, ps, ps, pint,
2535 ps, pint, ps, ps, pint, integer_type_node,
2537 gfor_fndecl_dgemm = gfc_build_library_function_decl
2539 (gfc_option.flag_underscoring ? "dgemm_"
2541 void_type_node, 15, pchar_type_node,
2542 pchar_type_node, pint, pint, pint, pd, pd, pint,
2543 pd, pint, pd, pd, pint, integer_type_node,
2545 gfor_fndecl_cgemm = gfc_build_library_function_decl
2547 (gfc_option.flag_underscoring ? "cgemm_"
2549 void_type_node, 15, pchar_type_node,
2550 pchar_type_node, pint, pint, pint, pc, pc, pint,
2551 pc, pint, pc, pc, pint, integer_type_node,
2553 gfor_fndecl_zgemm = gfc_build_library_function_decl
2555 (gfc_option.flag_underscoring ? "zgemm_"
2557 void_type_node, 15, pchar_type_node,
2558 pchar_type_node, pint, pint, pint, pz, pz, pint,
2559 pz, pint, pz, pz, pint, integer_type_node,
2563 /* Other functions. */
2565 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2566 gfc_array_index_type,
2567 1, pvoid_type_node);
2569 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2570 gfc_array_index_type,
2572 gfc_array_index_type);
2575 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2579 if (gfc_type_for_size (128, true))
2581 tree uint128 = gfc_type_for_size (128, true);
2583 gfor_fndecl_clz128 =
2584 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2585 integer_type_node, 1, uint128);
2587 gfor_fndecl_ctz128 =
2588 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2589 integer_type_node, 1, uint128);
2594 /* Make prototypes for runtime library functions. */
2597 gfc_build_builtin_function_decls (void)
2599 tree gfc_int4_type_node = gfc_get_int_type (4);
2601 gfor_fndecl_stop_numeric =
2602 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2603 void_type_node, 1, gfc_int4_type_node);
2604 /* Stop doesn't return. */
2605 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2607 gfor_fndecl_stop_string =
2608 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2609 void_type_node, 2, pchar_type_node,
2610 gfc_int4_type_node);
2611 /* Stop doesn't return. */
2612 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2614 gfor_fndecl_pause_numeric =
2615 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2616 void_type_node, 1, gfc_int4_type_node);
2618 gfor_fndecl_pause_string =
2619 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2620 void_type_node, 2, pchar_type_node,
2621 gfc_int4_type_node);
2623 gfor_fndecl_runtime_error =
2624 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2625 void_type_node, -1, pchar_type_node);
2626 /* The runtime_error function does not return. */
2627 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2629 gfor_fndecl_runtime_error_at =
2630 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2631 void_type_node, -2, pchar_type_node,
2633 /* The runtime_error_at function does not return. */
2634 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2636 gfor_fndecl_runtime_warning_at =
2637 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2638 void_type_node, -2, pchar_type_node,
2640 gfor_fndecl_generate_error =
2641 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2642 void_type_node, 3, pvoid_type_node,
2643 integer_type_node, pchar_type_node);
2645 gfor_fndecl_os_error =
2646 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2647 void_type_node, 1, pchar_type_node);
2648 /* The runtime_error function does not return. */
2649 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2651 gfor_fndecl_set_args =
2652 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2653 void_type_node, 2, integer_type_node,
2654 build_pointer_type (pchar_type_node));
2656 gfor_fndecl_set_fpe =
2657 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2658 void_type_node, 1, integer_type_node);
2660 /* Keep the array dimension in sync with the call, later in this file. */
2661 gfor_fndecl_set_options =
2662 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2663 void_type_node, 2, integer_type_node,
2664 build_pointer_type (integer_type_node));
2666 gfor_fndecl_set_convert =
2667 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2668 void_type_node, 1, integer_type_node);
2670 gfor_fndecl_set_record_marker =
2671 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2672 void_type_node, 1, integer_type_node);
2674 gfor_fndecl_set_max_subrecord_length =
2675 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2676 void_type_node, 1, integer_type_node);
2678 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2679 get_identifier (PREFIX("internal_pack")),
2680 pvoid_type_node, 1, pvoid_type_node);
2682 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2683 get_identifier (PREFIX("internal_unpack")),
2684 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2686 gfor_fndecl_associated =
2687 gfc_build_library_function_decl (
2688 get_identifier (PREFIX("associated")),
2689 integer_type_node, 2, ppvoid_type_node,
2692 gfc_build_intrinsic_function_decls ();
2693 gfc_build_intrinsic_lib_fndecls ();
2694 gfc_build_io_library_fndecls ();
2698 /* Evaluate the length of dummy character variables. */
2701 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2705 gfc_finish_decl (cl->backend_decl);
2707 gfc_start_block (&body);
2709 /* Evaluate the string length expression. */
2710 gfc_conv_string_length (cl, NULL, &body);
2712 gfc_trans_vla_type_sizes (sym, &body);
2714 gfc_add_expr_to_block (&body, fnbody);
2715 return gfc_finish_block (&body);
2719 /* Allocate and cleanup an automatic character variable. */
2722 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2728 gcc_assert (sym->backend_decl);
2729 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2731 gfc_start_block (&body);
2733 /* Evaluate the string length expression. */
2734 gfc_conv_string_length (sym->ts.cl, NULL, &body);
2736 gfc_trans_vla_type_sizes (sym, &body);
2738 decl = sym->backend_decl;
2740 /* Emit a DECL_EXPR for this variable, which will cause the
2741 gimplifier to allocate storage, and all that good stuff. */
2742 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2743 gfc_add_expr_to_block (&body, tmp);
2745 gfc_add_expr_to_block (&body, fnbody);
2746 return gfc_finish_block (&body);
2749 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2752 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2756 gcc_assert (sym->backend_decl);
2757 gfc_start_block (&body);
2759 /* Set the initial value to length. See the comments in
2760 function gfc_add_assign_aux_vars in this file. */
2761 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2762 build_int_cst (NULL_TREE, -2));
2764 gfc_add_expr_to_block (&body, fnbody);
2765 return gfc_finish_block (&body);
2769 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2771 tree t = *tp, var, val;
2773 if (t == NULL || t == error_mark_node)
2775 if (TREE_CONSTANT (t) || DECL_P (t))
2778 if (TREE_CODE (t) == SAVE_EXPR)
2780 if (SAVE_EXPR_RESOLVED_P (t))
2782 *tp = TREE_OPERAND (t, 0);
2785 val = TREE_OPERAND (t, 0);
2790 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2791 gfc_add_decl_to_function (var);
2792 gfc_add_modify (body, var, val);
2793 if (TREE_CODE (t) == SAVE_EXPR)
2794 TREE_OPERAND (t, 0) = var;
2799 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2803 if (type == NULL || type == error_mark_node)
2806 type = TYPE_MAIN_VARIANT (type);
2808 if (TREE_CODE (type) == INTEGER_TYPE)
2810 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2811 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2813 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2815 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2816 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2819 else if (TREE_CODE (type) == ARRAY_TYPE)
2821 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2822 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2823 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2824 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2826 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2828 TYPE_SIZE (t) = TYPE_SIZE (type);
2829 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2834 /* Make sure all type sizes and array domains are either constant,
2835 or variable or parameter decls. This is a simplified variant
2836 of gimplify_type_sizes, but we can't use it here, as none of the
2837 variables in the expressions have been gimplified yet.
2838 As type sizes and domains for various variable length arrays
2839 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2840 time, without this routine gimplify_type_sizes in the middle-end
2841 could result in the type sizes being gimplified earlier than where
2842 those variables are initialized. */
2845 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2847 tree type = TREE_TYPE (sym->backend_decl);
2849 if (TREE_CODE (type) == FUNCTION_TYPE
2850 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2852 if (! current_fake_result_decl)
2855 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2858 while (POINTER_TYPE_P (type))
2859 type = TREE_TYPE (type);
2861 if (GFC_DESCRIPTOR_TYPE_P (type))
2863 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2865 while (POINTER_TYPE_P (etype))
2866 etype = TREE_TYPE (etype);
2868 gfc_trans_vla_type_sizes_1 (etype, body);
2871 gfc_trans_vla_type_sizes_1 (type, body);
2875 /* Initialize a derived type by building an lvalue from the symbol
2876 and using trans_assignment to do the work. */
2878 gfc_init_default_dt (gfc_symbol * sym, tree body)
2880 stmtblock_t fnblock;
2885 gfc_init_block (&fnblock);
2886 gcc_assert (!sym->attr.allocatable);
2887 gfc_set_sym_referenced (sym);
2888 e = gfc_lval_expr_from_sym (sym);
2889 tmp = gfc_trans_assignment (e, sym->value, false);
2890 if (sym->attr.dummy)
2892 present = gfc_conv_expr_present (sym);
2893 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2894 tmp, build_empty_stmt ());
2896 gfc_add_expr_to_block (&fnblock, tmp);
2899 gfc_add_expr_to_block (&fnblock, body);
2900 return gfc_finish_block (&fnblock);
2904 /* Initialize INTENT(OUT) derived type dummies. As well as giving
2905 them their default initializer, if they do not have allocatable
2906 components, they have their allocatable components deallocated. */
2909 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2911 stmtblock_t fnblock;
2912 gfc_formal_arglist *f;
2916 gfc_init_block (&fnblock);
2917 for (f = proc_sym->formal; f; f = f->next)
2918 if (f->sym && f->sym->attr.intent == INTENT_OUT
2919 && f->sym->ts.type == BT_DERIVED)
2921 if (f->sym->ts.derived->attr.alloc_comp)
2923 tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2924 f->sym->backend_decl,
2925 f->sym->as ? f->sym->as->rank : 0);
2927 present = gfc_conv_expr_present (f->sym);
2928 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2929 tmp, build_empty_stmt ());
2931 gfc_add_expr_to_block (&fnblock, tmp);
2934 if (!f->sym->ts.derived->attr.alloc_comp
2936 body = gfc_init_default_dt (f->sym, body);
2939 gfc_add_expr_to_block (&fnblock, body);
2940 return gfc_finish_block (&fnblock);
2944 /* Generate function entry and exit code, and add it to the function body.
2946 Allocation and initialization of array variables.
2947 Allocation of character string variables.
2948 Initialization and possibly repacking of dummy arrays.
2949 Initialization of ASSIGN statement auxiliary variable. */
2952 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2956 gfc_formal_arglist *f;
2958 bool seen_trans_deferred_array = false;
2960 /* Deal with implicit return variables. Explicit return variables will
2961 already have been added. */
2962 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2964 if (!current_fake_result_decl)
2966 gfc_entry_list *el = NULL;
2967 if (proc_sym->attr.entry_master)
2969 for (el = proc_sym->ns->entries; el; el = el->next)
2970 if (el->sym != el->sym->result)
2973 /* TODO: move to the appropriate place in resolve.c. */
2974 if (warn_return_type && el == NULL)
2975 gfc_warning ("Return value of function '%s' at %L not set",
2976 proc_sym->name, &proc_sym->declared_at);
2978 else if (proc_sym->as)
2980 tree result = TREE_VALUE (current_fake_result_decl);
2981 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2983 /* An automatic character length, pointer array result. */
2984 if (proc_sym->ts.type == BT_CHARACTER
2985 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2986 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2989 else if (proc_sym->ts.type == BT_CHARACTER)
2991 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2992 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2996 gcc_assert (gfc_option.flag_f2c
2997 && proc_sym->ts.type == BT_COMPLEX);
3000 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3001 should be done here so that the offsets and lbounds of arrays
3003 fnbody = init_intent_out_dt (proc_sym, fnbody);
3005 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3007 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3008 && sym->ts.derived->attr.alloc_comp;
3009 if (sym->attr.dimension)
3011 switch (sym->as->type)
3014 if (sym->attr.dummy || sym->attr.result)
3016 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3017 else if (sym->attr.pointer || sym->attr.allocatable)
3019 if (TREE_STATIC (sym->backend_decl))
3020 gfc_trans_static_array_pointer (sym);
3023 seen_trans_deferred_array = true;
3024 fnbody = gfc_trans_deferred_array (sym, fnbody);
3029 if (sym_has_alloc_comp)
3031 seen_trans_deferred_array = true;
3032 fnbody = gfc_trans_deferred_array (sym, fnbody);
3034 else if (sym->ts.type == BT_DERIVED
3037 && sym->attr.save == SAVE_NONE)
3038 fnbody = gfc_init_default_dt (sym, fnbody);
3040 gfc_get_backend_locus (&loc);
3041 gfc_set_backend_locus (&sym->declared_at);
3042 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3044 gfc_set_backend_locus (&loc);
3048 case AS_ASSUMED_SIZE:
3049 /* Must be a dummy parameter. */
3050 gcc_assert (sym->attr.dummy);
3052 /* We should always pass assumed size arrays the g77 way. */
3053 fnbody = gfc_trans_g77_array (sym, fnbody);
3056 case AS_ASSUMED_SHAPE:
3057 /* Must be a dummy parameter. */
3058 gcc_assert (sym->attr.dummy);
3060 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3065 seen_trans_deferred_array = true;
3066 fnbody = gfc_trans_deferred_array (sym, fnbody);
3072 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3073 fnbody = gfc_trans_deferred_array (sym, fnbody);
3075 else if (sym_has_alloc_comp)
3076 fnbody = gfc_trans_deferred_array (sym, fnbody);
3077 else if (sym->ts.type == BT_CHARACTER)
3079 gfc_get_backend_locus (&loc);
3080 gfc_set_backend_locus (&sym->declared_at);
3081 if (sym->attr.dummy || sym->attr.result)
3082 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
3084 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3085 gfc_set_backend_locus (&loc);
3087 else if (sym->attr.assign)
3089 gfc_get_backend_locus (&loc);
3090 gfc_set_backend_locus (&sym->declared_at);
3091 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3092 gfc_set_backend_locus (&loc);
3094 else if (sym->ts.type == BT_DERIVED
3097 && sym->attr.save == SAVE_NONE)
3098 fnbody = gfc_init_default_dt (sym, fnbody);
3103 gfc_init_block (&body);
3105 for (f = proc_sym->formal; f; f = f->next)
3107 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3109 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3110 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3111 gfc_trans_vla_type_sizes (f->sym, &body);
3115 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3116 && current_fake_result_decl != NULL)
3118 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3119 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3120 gfc_trans_vla_type_sizes (proc_sym, &body);
3123 gfc_add_expr_to_block (&body, fnbody);
3124 return gfc_finish_block (&body);
3127 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3129 /* Hash and equality functions for module_htab. */
3132 module_htab_do_hash (const void *x)
3134 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3138 module_htab_eq (const void *x1, const void *x2)
3140 return strcmp ((((const struct module_htab_entry *)x1)->name),
3141 (const char *)x2) == 0;
3144 /* Hash and equality functions for module_htab's decls. */
3147 module_htab_decls_hash (const void *x)
3149 const_tree t = (const_tree) x;
3150 const_tree n = DECL_NAME (t);
3152 n = TYPE_NAME (TREE_TYPE (t));
3153 return htab_hash_string (IDENTIFIER_POINTER (n));
3157 module_htab_decls_eq (const void *x1, const void *x2)
3159 const_tree t1 = (const_tree) x1;
3160 const_tree n1 = DECL_NAME (t1);
3161 if (n1 == NULL_TREE)
3162 n1 = TYPE_NAME (TREE_TYPE (t1));
3163 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3166 struct module_htab_entry *
3167 gfc_find_module (const char *name)
3172 module_htab = htab_create_ggc (10, module_htab_do_hash,
3173 module_htab_eq, NULL);
3175 slot = htab_find_slot_with_hash (module_htab, name,
3176 htab_hash_string (name), INSERT);
3179 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3181 entry->name = gfc_get_string (name);
3182 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3183 module_htab_decls_eq, NULL);
3184 *slot = (void *) entry;
3186 return (struct module_htab_entry *) *slot;
3190 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3195 if (DECL_NAME (decl))
3196 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3199 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3200 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3202 slot = htab_find_slot_with_hash (entry->decls, name,
3203 htab_hash_string (name), INSERT);
3205 *slot = (void *) decl;
3208 static struct module_htab_entry *cur_module;
3210 /* Output an initialized decl for a module variable. */
3213 gfc_create_module_variable (gfc_symbol * sym)
3217 /* Module functions with alternate entries are dealt with later and
3218 would get caught by the next condition. */
3219 if (sym->attr.entry)
3222 /* Make sure we convert the types of the derived types from iso_c_binding
3224 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3225 && sym->ts.type == BT_DERIVED)
3226 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3228 if (sym->attr.flavor == FL_DERIVED
3229 && sym->backend_decl
3230 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3232 decl = sym->backend_decl;
3233 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3234 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3235 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3236 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3237 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3238 == sym->ns->proc_name->backend_decl);
3239 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3240 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3241 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3244 /* Only output variables, procedure pointers and array valued,
3245 or derived type, parameters. */
3246 if (sym->attr.flavor != FL_VARIABLE
3247 && !(sym->attr.flavor == FL_PARAMETER
3248 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3249 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3252 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3254 decl = sym->backend_decl;
3255 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3256 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3257 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3258 gfc_module_add_decl (cur_module, decl);
3261 /* Don't generate variables from other modules. Variables from
3262 COMMONs will already have been generated. */
3263 if (sym->attr.use_assoc || sym->attr.in_common)
3266 /* Equivalenced variables arrive here after creation. */
3267 if (sym->backend_decl
3268 && (sym->equiv_built || sym->attr.in_equivalence))
3271 if (sym->backend_decl)
3272 internal_error ("backend decl for module variable %s already exists",
3275 /* We always want module variables to be created. */
3276 sym->attr.referenced = 1;
3277 /* Create the decl. */
3278 decl = gfc_get_symbol_decl (sym);
3280 /* Create the variable. */
3282 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3283 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3284 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3285 rest_of_decl_compilation (decl, 1, 0);
3286 gfc_module_add_decl (cur_module, decl);
3288 /* Also add length of strings. */
3289 if (sym->ts.type == BT_CHARACTER)
3293 length = sym->ts.cl->backend_decl;
3294 if (!INTEGER_CST_P (length))
3297 rest_of_decl_compilation (length, 1, 0);
3302 /* Emit debug information for USE statements. */
3305 gfc_trans_use_stmts (gfc_namespace * ns)
3307 gfc_use_list *use_stmt;
3308 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3310 struct module_htab_entry *entry
3311 = gfc_find_module (use_stmt->module_name);
3312 gfc_use_rename *rent;
3314 if (entry->namespace_decl == NULL)
3316 entry->namespace_decl
3317 = build_decl (NAMESPACE_DECL,
3318 get_identifier (use_stmt->module_name),
3320 DECL_EXTERNAL (entry->namespace_decl) = 1;
3322 gfc_set_backend_locus (&use_stmt->where);
3323 if (!use_stmt->only_flag)
3324 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3326 ns->proc_name->backend_decl,
3328 for (rent = use_stmt->rename; rent; rent = rent->next)
3330 tree decl, local_name;
3333 if (rent->op != INTRINSIC_NONE)
3336 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3337 htab_hash_string (rent->use_name),
3343 st = gfc_find_symtree (ns->sym_root,
3345 ? rent->local_name : rent->use_name);
3346 gcc_assert (st && st->n.sym->attr.use_assoc);
3347 if (st->n.sym->backend_decl
3348 && DECL_P (st->n.sym->backend_decl)
3349 && st->n.sym->module
3350 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3352 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3353 || (TREE_CODE (st->n.sym->backend_decl)
3355 decl = copy_node (st->n.sym->backend_decl);
3356 DECL_CONTEXT (decl) = entry->namespace_decl;
3357 DECL_EXTERNAL (decl) = 1;
3358 DECL_IGNORED_P (decl) = 0;
3359 DECL_INITIAL (decl) = NULL_TREE;
3363 *slot = error_mark_node;
3364 htab_clear_slot (entry->decls, slot);
3369 decl = (tree) *slot;
3370 if (rent->local_name[0])
3371 local_name = get_identifier (rent->local_name);
3373 local_name = NULL_TREE;
3374 gfc_set_backend_locus (&rent->where);
3375 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3376 ns->proc_name->backend_decl,
3377 !use_stmt->only_flag);
3383 /* Return true if expr is a constant initializer that gfc_conv_initializer
3387 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3397 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3399 else if (expr->expr_type == EXPR_STRUCTURE)
3400 return check_constant_initializer (expr, ts, false, false);
3401 else if (expr->expr_type != EXPR_ARRAY)
3403 for (c = expr->value.constructor; c; c = c->next)
3407 if (c->expr->expr_type == EXPR_STRUCTURE)
3409 if (!check_constant_initializer (c->expr, ts, false, false))
3412 else if (c->expr->expr_type != EXPR_CONSTANT)
3417 else switch (ts->type)
3420 if (expr->expr_type != EXPR_STRUCTURE)
3422 cm = expr->ts.derived->components;
3423 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3425 if (!c->expr || cm->attr.allocatable)
3427 if (!check_constant_initializer (c->expr, &cm->ts,
3434 return expr->expr_type == EXPR_CONSTANT;
3438 /* Emit debug info for parameters and unreferenced variables with
3442 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3446 if (sym->attr.flavor != FL_PARAMETER
3447 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3450 if (sym->backend_decl != NULL
3451 || sym->value == NULL
3452 || sym->attr.use_assoc
3455 || sym->attr.function
3456 || sym->attr.intrinsic
3457 || sym->attr.pointer
3458 || sym->attr.allocatable
3459 || sym->attr.cray_pointee
3460 || sym->attr.threadprivate
3461 || sym->attr.is_bind_c
3462 || sym->attr.subref_array_pointer
3463 || sym->attr.assign)
3466 if (sym->ts.type == BT_CHARACTER)
3468 gfc_conv_const_charlen (sym->ts.cl);
3469 if (sym->ts.cl->backend_decl == NULL
3470 || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3473 else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3480 if (sym->as->type != AS_EXPLICIT)
3482 for (n = 0; n < sym->as->rank; n++)
3483 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3484 || sym->as->upper[n] == NULL
3485 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3489 if (!check_constant_initializer (sym->value, &sym->ts,
3490 sym->attr.dimension, false))
3493 /* Create the decl for the variable or constant. */
3494 decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3495 gfc_sym_identifier (sym), gfc_sym_type (sym));
3496 if (sym->attr.flavor == FL_PARAMETER)
3497 TREE_READONLY (decl) = 1;
3498 gfc_set_decl_location (decl, &sym->declared_at);
3499 if (sym->attr.dimension)
3500 GFC_DECL_PACKED_ARRAY (decl) = 1;
3501 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3502 TREE_STATIC (decl) = 1;
3503 TREE_USED (decl) = 1;
3504 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3505 TREE_PUBLIC (decl) = 1;
3507 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3508 sym->attr.dimension, 0);
3509 debug_hooks->global_decl (decl);
3512 /* Generate all the required code for module variables. */
3515 gfc_generate_module_vars (gfc_namespace * ns)
3517 module_namespace = ns;
3518 cur_module = gfc_find_module (ns->proc_name->name);
3520 /* Check if the frontend left the namespace in a reasonable state. */
3521 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3523 /* Generate COMMON blocks. */
3524 gfc_trans_common (ns);
3526 /* Create decls for all the module variables. */
3527 gfc_traverse_ns (ns, gfc_create_module_variable);
3531 gfc_trans_use_stmts (ns);
3532 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3537 gfc_generate_contained_functions (gfc_namespace * parent)
3541 /* We create all the prototypes before generating any code. */
3542 for (ns = parent->contained; ns; ns = ns->sibling)
3544 /* Skip namespaces from used modules. */
3545 if (ns->parent != parent)
3548 gfc_create_function_decl (ns);
3551 for (ns = parent->contained; ns; ns = ns->sibling)
3553 /* Skip namespaces from used modules. */
3554 if (ns->parent != parent)
3557 gfc_generate_function_code (ns);
3562 /* Drill down through expressions for the array specification bounds and
3563 character length calling generate_local_decl for all those variables
3564 that have not already been declared. */
3567 generate_local_decl (gfc_symbol *);
3569 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3572 expr_decls (gfc_expr *e, gfc_symbol *sym,
3573 int *f ATTRIBUTE_UNUSED)
3575 if (e->expr_type != EXPR_VARIABLE
3576 || sym == e->symtree->n.sym
3577 || e->symtree->n.sym->mark
3578 || e->symtree->n.sym->ns != sym->ns)
3581 generate_local_decl (e->symtree->n.sym);
3586 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3588 gfc_traverse_expr (e, sym, expr_decls, 0);
3592 /* Check for dependencies in the character length and array spec. */
3595 generate_dependency_declarations (gfc_symbol *sym)
3599 if (sym->ts.type == BT_CHARACTER
3601 && sym->ts.cl->length
3602 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3603 generate_expr_decls (sym, sym->ts.cl->length);
3605 if (sym->as && sym->as->rank)
3607 for (i = 0; i < sym->as->rank; i++)
3609 generate_expr_decls (sym, sym->as->lower[i]);
3610 generate_expr_decls (sym, sym->as->upper[i]);
3616 /* Generate decls for all local variables. We do this to ensure correct
3617 handling of expressions which only appear in the specification of
3621 generate_local_decl (gfc_symbol * sym)
3623 if (sym->attr.flavor == FL_VARIABLE)
3625 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3626 generate_dependency_declarations (sym);
3628 if (sym->attr.referenced)
3629 gfc_get_symbol_decl (sym);
3630 /* INTENT(out) dummy arguments are likely meant to be set. */
3631 else if (warn_unused_variable
3633 && sym->attr.intent == INTENT_OUT)
3634 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3635 sym->name, &sym->declared_at);
3636 /* Specific warning for unused dummy arguments. */
3637 else if (warn_unused_variable && sym->attr.dummy)
3638 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3640 /* Warn for unused variables, but not if they're inside a common
3641 block or are use-associated. */
3642 else if (warn_unused_variable
3643 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3644 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3647 /* For variable length CHARACTER parameters, the PARM_DECL already
3648 references the length variable, so force gfc_get_symbol_decl
3649 even when not referenced. If optimize > 0, it will be optimized
3650 away anyway. But do this only after emitting -Wunused-parameter
3651 warning if requested. */
3652 if (sym->attr.dummy && !sym->attr.referenced
3653 && sym->ts.type == BT_CHARACTER
3654 && sym->ts.cl->backend_decl != NULL
3655 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3657 sym->attr.referenced = 1;
3658 gfc_get_symbol_decl (sym);
3661 /* INTENT(out) dummy arguments with allocatable components are reset
3662 by default and need to be set referenced to generate the code for
3663 automatic lengths. */
3664 if (sym->attr.dummy && !sym->attr.referenced
3665 && sym->ts.type == BT_DERIVED
3666 && sym->ts.derived->attr.alloc_comp
3667 && sym->attr.intent == INTENT_OUT)
3669 sym->attr.referenced = 1;
3670 gfc_get_symbol_decl (sym);
3674 /* Check for dependencies in the array specification and string
3675 length, adding the necessary declarations to the function. We
3676 mark the symbol now, as well as in traverse_ns, to prevent
3677 getting stuck in a circular dependency. */
3680 /* We do not want the middle-end to warn about unused parameters
3681 as this was already done above. */
3682 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3683 TREE_NO_WARNING(sym->backend_decl) = 1;
3685 else if (sym->attr.flavor == FL_PARAMETER)
3687 if (warn_unused_parameter
3688 && !sym->attr.referenced
3689 && !sym->attr.use_assoc)
3690 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3693 else if (sym->attr.flavor == FL_PROCEDURE)
3695 /* TODO: move to the appropriate place in resolve.c. */
3696 if (warn_return_type
3697 && sym->attr.function
3699 && sym != sym->result
3700 && !sym->result->attr.referenced
3701 && !sym->attr.use_assoc
3702 && sym->attr.if_source != IFSRC_IFBODY)
3704 gfc_warning ("Return value '%s' of function '%s' declared at "
3705 "%L not set", sym->result->name, sym->name,
3706 &sym->result->declared_at);
3708 /* Prevents "Unused variable" warning for RESULT variables. */
3709 sym->result->mark = 1;
3713 if (sym->attr.dummy == 1)
3715 /* Modify the tree type for scalar character dummy arguments of bind(c)
3716 procedures if they are passed by value. The tree type for them will
3717 be promoted to INTEGER_TYPE for the middle end, which appears to be
3718 what C would do with characters passed by-value. The value attribute
3719 implies the dummy is a scalar. */
3720 if (sym->attr.value == 1 && sym->backend_decl != NULL
3721 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3722 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3723 gfc_conv_scalar_char_value (sym, NULL, NULL);
3726 /* Make sure we convert the types of the derived types from iso_c_binding
3728 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3729 && sym->ts.type == BT_DERIVED)
3730 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3734 generate_local_vars (gfc_namespace * ns)
3736 gfc_traverse_ns (ns, generate_local_decl);
3740 /* Generate a switch statement to jump to the correct entry point. Also
3741 creates the label decls for the entry points. */
3744 gfc_trans_entry_master_switch (gfc_entry_list * el)
3751 gfc_init_block (&block);
3752 for (; el; el = el->next)
3754 /* Add the case label. */
3755 label = gfc_build_label_decl (NULL_TREE);
3756 val = build_int_cst (gfc_array_index_type, el->id);
3757 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3758 gfc_add_expr_to_block (&block, tmp);
3760 /* And jump to the actual entry point. */
3761 label = gfc_build_label_decl (NULL_TREE);
3762 tmp = build1_v (GOTO_EXPR, label);
3763 gfc_add_expr_to_block (&block, tmp);
3765 /* Save the label decl. */
3768 tmp = gfc_finish_block (&block);
3769 /* The first argument selects the entry point. */
3770 val = DECL_ARGUMENTS (current_function_decl);
3771 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3776 /* Add code to string lengths of actual arguments passed to a function against
3777 the expected lengths of the dummy arguments. */
3780 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3782 gfc_formal_arglist *formal;
3784 for (formal = sym->formal; formal; formal = formal->next)
3785 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3787 enum tree_code comparison;
3792 const char *message;
3798 gcc_assert (cl->passed_length != NULL_TREE);
3799 gcc_assert (cl->backend_decl != NULL_TREE);
3801 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3802 string lengths must match exactly. Otherwise, it is only required
3803 that the actual string length is *at least* the expected one. */
3804 if (fsym->attr.pointer || fsym->attr.allocatable
3805 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3807 comparison = NE_EXPR;
3808 message = _("Actual string length does not match the declared one"
3809 " for dummy argument '%s' (%ld/%ld)");
3813 comparison = LT_EXPR;
3814 message = _("Actual string length is shorter than the declared one"
3815 " for dummy argument '%s' (%ld/%ld)");
3818 /* Build the condition. For optional arguments, an actual length
3819 of 0 is also acceptable if the associated string is NULL, which
3820 means the argument was not passed. */
3821 cond = fold_build2 (comparison, boolean_type_node,
3822 cl->passed_length, cl->backend_decl);
3823 if (fsym->attr.optional)
3829 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3831 fold_convert (gfc_charlen_type_node,
3832 integer_zero_node));
3833 not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3834 fsym->backend_decl, null_pointer_node);
3836 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3837 not_0length, not_absent);
3839 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3840 cond, absent_failed);
3843 /* Build the runtime check. */
3844 argname = gfc_build_cstring_const (fsym->name);
3845 argname = gfc_build_addr_expr (pchar_type_node, argname);
3846 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3848 fold_convert (long_integer_type_node,
3850 fold_convert (long_integer_type_node,
3857 create_main_function (tree fndecl)
3861 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3864 old_context = current_function_decl;
3868 push_function_context ();
3869 saved_parent_function_decls = saved_function_decls;
3870 saved_function_decls = NULL_TREE;
3873 /* main() function must be declared with global scope. */
3874 gcc_assert (current_function_decl == NULL_TREE);
3876 /* Declare the function. */
3877 tmp = build_function_type_list (integer_type_node, integer_type_node,
3878 build_pointer_type (pchar_type_node),
3880 main_identifier_node = get_identifier ("main");
3881 ftn_main = build_decl (FUNCTION_DECL, main_identifier_node, tmp);
3882 ftn_main = build_decl (FUNCTION_DECL, get_identifier ("main"), tmp);
3883 DECL_EXTERNAL (ftn_main) = 0;
3884 TREE_PUBLIC (ftn_main) = 1;
3885 TREE_STATIC (ftn_main) = 1;
3886 DECL_ATTRIBUTES (ftn_main)
3887 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
3889 /* Setup the result declaration (for "return 0"). */
3890 result_decl = build_decl (RESULT_DECL, NULL_TREE, integer_type_node);
3891 DECL_ARTIFICIAL (result_decl) = 1;
3892 DECL_IGNORED_P (result_decl) = 1;
3893 DECL_CONTEXT (result_decl) = ftn_main;
3894 DECL_RESULT (ftn_main) = result_decl;
3896 pushdecl (ftn_main);
3898 /* Get the arguments. */
3900 arglist = NULL_TREE;
3901 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
3903 tmp = TREE_VALUE (typelist);
3904 argc = build_decl (PARM_DECL, get_identifier ("argc"), tmp);
3905 DECL_CONTEXT (argc) = ftn_main;
3906 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
3907 TREE_READONLY (argc) = 1;
3908 gfc_finish_decl (argc);
3909 arglist = chainon (arglist, argc);
3911 typelist = TREE_CHAIN (typelist);
3912 tmp = TREE_VALUE (typelist);
3913 argv = build_decl (PARM_DECL, get_identifier ("argv"), tmp);
3914 DECL_CONTEXT (argv) = ftn_main;
3915 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
3916 TREE_READONLY (argv) = 1;
3917 DECL_BY_REFERENCE (argv) = 1;
3918 gfc_finish_decl (argv);
3919 arglist = chainon (arglist, argv);
3921 DECL_ARGUMENTS (ftn_main) = arglist;
3922 current_function_decl = ftn_main;
3923 announce_function (ftn_main);
3925 rest_of_decl_compilation (ftn_main, 1, 0);
3926 make_decl_rtl (ftn_main);
3927 init_function_start (ftn_main);
3930 gfc_init_block (&body);
3932 /* Call some libgfortran initialization routines, call then MAIN__(). */
3934 /* Call _gfortran_set_args (argc, argv). */
3935 TREE_USED (argc) = 1;
3936 TREE_USED (argv) = 1;
3937 tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
3938 gfc_add_expr_to_block (&body, tmp);
3940 /* Add a call to set_options to set up the runtime library Fortran
3941 language standard parameters. */
3943 tree array_type, array, var;
3945 /* Passing a new option to the library requires four modifications:
3946 + add it to the tree_cons list below
3947 + change the array size in the call to build_array_type
3948 + change the first argument to the library call
3949 gfor_fndecl_set_options
3950 + modify the library (runtime/compile_options.c)! */
3952 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3953 gfc_option.warn_std), NULL_TREE);
3954 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3955 gfc_option.allow_std), array);
3956 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
3958 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3959 gfc_option.flag_dump_core), array);
3960 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3961 gfc_option.flag_backtrace), array);
3962 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3963 gfc_option.flag_sign_zero), array);
3965 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3966 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
3968 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3969 gfc_option.flag_range_check), array);
3971 array_type = build_array_type (integer_type_node,
3972 build_index_type (build_int_cst (NULL_TREE, 7)));
3973 array = build_constructor_from_list (array_type, nreverse (array));
3974 TREE_CONSTANT (array) = 1;
3975 TREE_STATIC (array) = 1;
3977 /* Create a static variable to hold the jump table. */
3978 var = gfc_create_var (array_type, "options");
3979 TREE_CONSTANT (var) = 1;
3980 TREE_STATIC (var) = 1;
3981 TREE_READONLY (var) = 1;
3982 DECL_INITIAL (var) = array;
3983 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
3985 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3986 build_int_cst (integer_type_node, 8), var);
3987 gfc_add_expr_to_block (&body, tmp);
3990 /* If -ffpe-trap option was provided, add a call to set_fpe so that
3991 the library will raise a FPE when needed. */
3992 if (gfc_option.fpe != 0)
3994 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3995 build_int_cst (integer_type_node,
3997 gfc_add_expr_to_block (&body, tmp);
4000 /* If this is the main program and an -fconvert option was provided,
4001 add a call to set_convert. */
4003 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4005 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
4006 build_int_cst (integer_type_node,
4007 gfc_option.convert));
4008 gfc_add_expr_to_block (&body, tmp);
4011 /* If this is the main program and an -frecord-marker option was provided,
4012 add a call to set_record_marker. */
4014 if (gfc_option.record_marker != 0)
4016 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
4017 build_int_cst (integer_type_node,
4018 gfc_option.record_marker));
4019 gfc_add_expr_to_block (&body, tmp);
4022 if (gfc_option.max_subrecord_length != 0)
4024 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
4025 build_int_cst (integer_type_node,
4026 gfc_option.max_subrecord_length));
4027 gfc_add_expr_to_block (&body, tmp);
4030 /* Call MAIN__(). */
4031 tmp = build_call_expr (fndecl, 0);
4032 gfc_add_expr_to_block (&body, tmp);
4034 /* Mark MAIN__ as used. */
4035 TREE_USED (fndecl) = 1;
4038 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4039 build_int_cst (integer_type_node, 0));
4040 tmp = build1_v (RETURN_EXPR, tmp);
4041 gfc_add_expr_to_block (&body, tmp);
4044 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4047 /* Finish off this function and send it for code generation. */
4049 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4051 DECL_SAVED_TREE (ftn_main)
4052 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4053 DECL_INITIAL (ftn_main));
4055 /* Output the GENERIC tree. */
4056 dump_function (TDI_original, ftn_main);
4058 gfc_gimplify_function (ftn_main);
4059 cgraph_finalize_function (ftn_main, false);
4063 pop_function_context ();
4064 saved_function_decls = saved_parent_function_decls;
4066 current_function_decl = old_context;
4070 /* Generate code for a function. */
4073 gfc_generate_function_code (gfc_namespace * ns)
4083 tree recurcheckvar = NULL;
4088 sym = ns->proc_name;
4090 /* Check that the frontend isn't still using this. */
4091 gcc_assert (sym->tlink == NULL);
4094 /* Create the declaration for functions with global scope. */
4095 if (!sym->backend_decl)
4096 gfc_create_function_decl (ns);
4098 fndecl = sym->backend_decl;
4099 old_context = current_function_decl;
4103 push_function_context ();
4104 saved_parent_function_decls = saved_function_decls;
4105 saved_function_decls = NULL_TREE;
4108 trans_function_start (sym);
4110 gfc_init_block (&block);
4112 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4114 /* Copy length backend_decls to all entry point result
4119 gfc_conv_const_charlen (ns->proc_name->ts.cl);
4120 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4121 for (el = ns->entries; el; el = el->next)
4122 el->sym->result->ts.cl->backend_decl = backend_decl;
4125 /* Translate COMMON blocks. */
4126 gfc_trans_common (ns);
4128 /* Null the parent fake result declaration if this namespace is
4129 a module function or an external procedures. */
4130 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4131 || ns->parent == NULL)
4132 parent_fake_result_decl = NULL_TREE;
4134 gfc_generate_contained_functions (ns);
4136 nonlocal_dummy_decls = NULL;
4137 nonlocal_dummy_decl_pset = NULL;
4139 generate_local_vars (ns);
4141 /* Keep the parent fake result declaration in module functions
4142 or external procedures. */
4143 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4144 || ns->parent == NULL)
4145 current_fake_result_decl = parent_fake_result_decl;
4147 current_fake_result_decl = NULL_TREE;
4149 current_function_return_label = NULL;
4151 /* Now generate the code for the body of this function. */
4152 gfc_init_block (&body);
4154 is_recursive = sym->attr.recursive
4155 || (sym->attr.entry_master
4156 && sym->ns->entries->sym->attr.recursive);
4157 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4161 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4163 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4164 TREE_STATIC (recurcheckvar) = 1;
4165 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4166 gfc_add_expr_to_block (&block, recurcheckvar);
4167 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4168 &sym->declared_at, msg);
4169 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4173 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4174 && sym->attr.subroutine)
4176 tree alternate_return;
4177 alternate_return = gfc_get_fake_result_decl (sym, 0);
4178 gfc_add_modify (&body, alternate_return, integer_zero_node);
4183 /* Jump to the correct entry point. */
4184 tmp = gfc_trans_entry_master_switch (ns->entries);
4185 gfc_add_expr_to_block (&body, tmp);
4188 /* If bounds-checking is enabled, generate code to check passed in actual
4189 arguments against the expected dummy argument attributes (e.g. string
4191 if (flag_bounds_check)
4192 add_argument_checking (&body, sym);
4194 tmp = gfc_trans_code (ns->code);
4195 gfc_add_expr_to_block (&body, tmp);
4197 /* Add a return label if needed. */
4198 if (current_function_return_label)
4200 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4201 gfc_add_expr_to_block (&body, tmp);
4204 tmp = gfc_finish_block (&body);
4205 /* Add code to create and cleanup arrays. */
4206 tmp = gfc_trans_deferred_vars (sym, tmp);
4208 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4210 if (sym->attr.subroutine || sym == sym->result)
4212 if (current_fake_result_decl != NULL)
4213 result = TREE_VALUE (current_fake_result_decl);
4216 current_fake_result_decl = NULL_TREE;
4219 result = sym->result->backend_decl;
4221 if (result != NULL_TREE && sym->attr.function
4222 && sym->ts.type == BT_DERIVED
4223 && sym->ts.derived->attr.alloc_comp
4224 && !sym->attr.pointer)
4226 rank = sym->as ? sym->as->rank : 0;
4227 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4228 gfc_add_expr_to_block (&block, tmp2);
4231 gfc_add_expr_to_block (&block, tmp);
4233 /* Reset recursion-check variable. */
4234 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4236 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4237 recurcheckvar = NULL;
4240 if (result == NULL_TREE)
4242 /* TODO: move to the appropriate place in resolve.c. */
4243 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4244 gfc_warning ("Return value of function '%s' at %L not set",
4245 sym->name, &sym->declared_at);
4247 TREE_NO_WARNING(sym->backend_decl) = 1;
4251 /* Set the return value to the dummy result variable. The
4252 types may be different for scalar default REAL functions
4253 with -ff2c, therefore we have to convert. */
4254 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4255 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4256 DECL_RESULT (fndecl), tmp);
4257 tmp = build1_v (RETURN_EXPR, tmp);
4258 gfc_add_expr_to_block (&block, tmp);
4263 gfc_add_expr_to_block (&block, tmp);
4264 /* Reset recursion-check variable. */
4265 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4267 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4268 recurcheckvar = NULL;
4273 /* Add all the decls we created during processing. */
4274 decl = saved_function_decls;
4279 next = TREE_CHAIN (decl);
4280 TREE_CHAIN (decl) = NULL_TREE;
4284 saved_function_decls = NULL_TREE;
4286 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4289 /* Finish off this function and send it for code generation. */
4291 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4293 DECL_SAVED_TREE (fndecl)
4294 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4295 DECL_INITIAL (fndecl));
4297 if (nonlocal_dummy_decls)
4299 BLOCK_VARS (DECL_INITIAL (fndecl))
4300 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4301 pointer_set_destroy (nonlocal_dummy_decl_pset);
4302 nonlocal_dummy_decls = NULL;
4303 nonlocal_dummy_decl_pset = NULL;
4306 /* Output the GENERIC tree. */
4307 dump_function (TDI_original, fndecl);
4309 /* Store the end of the function, so that we get good line number
4310 info for the epilogue. */
4311 cfun->function_end_locus = input_location;
4313 /* We're leaving the context of this function, so zap cfun.
4314 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4315 tree_rest_of_compilation. */
4320 pop_function_context ();
4321 saved_function_decls = saved_parent_function_decls;
4323 current_function_decl = old_context;
4325 if (decl_function_context (fndecl))
4326 /* Register this function with cgraph just far enough to get it
4327 added to our parent's nested function list. */
4328 (void) cgraph_node (fndecl);
4331 gfc_gimplify_function (fndecl);
4332 cgraph_finalize_function (fndecl, false);
4335 gfc_trans_use_stmts (ns);
4336 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4338 if (sym->attr.is_main_program)
4339 create_main_function (fndecl);
4344 gfc_generate_constructors (void)
4346 gcc_assert (gfc_static_ctors == NULL_TREE);
4354 if (gfc_static_ctors == NULL_TREE)
4357 fnname = get_file_function_name ("I");
4358 type = build_function_type (void_type_node,
4359 gfc_chainon_list (NULL_TREE, void_type_node));
4361 fndecl = build_decl (FUNCTION_DECL, fnname, type);
4362 TREE_PUBLIC (fndecl) = 1;
4364 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
4365 DECL_ARTIFICIAL (decl) = 1;
4366 DECL_IGNORED_P (decl) = 1;
4367 DECL_CONTEXT (decl) = fndecl;
4368 DECL_RESULT (fndecl) = decl;
4372 current_function_decl = fndecl;
4374 rest_of_decl_compilation (fndecl, 1, 0);
4376 make_decl_rtl (fndecl);
4378 init_function_start (fndecl);
4382 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4384 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4385 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4391 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4392 DECL_SAVED_TREE (fndecl)
4393 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4394 DECL_INITIAL (fndecl));
4396 free_after_parsing (cfun);
4397 free_after_compilation (cfun);
4399 tree_rest_of_compilation (fndecl);
4401 current_function_decl = NULL_TREE;
4405 /* Translates a BLOCK DATA program unit. This means emitting the
4406 commons contained therein plus their initializations. We also emit
4407 a globally visible symbol to make sure that each BLOCK DATA program
4408 unit remains unique. */
4411 gfc_generate_block_data (gfc_namespace * ns)
4416 /* Tell the backend the source location of the block data. */
4418 gfc_set_backend_locus (&ns->proc_name->declared_at);
4420 gfc_set_backend_locus (&gfc_current_locus);
4422 /* Process the DATA statements. */
4423 gfc_trans_common (ns);
4425 /* Create a global symbol with the mane of the block data. This is to
4426 generate linker errors if the same name is used twice. It is never
4429 id = gfc_sym_mangled_function_id (ns->proc_name);
4431 id = get_identifier ("__BLOCK_DATA__");
4433 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4434 TREE_PUBLIC (decl) = 1;
4435 TREE_STATIC (decl) = 1;
4436 DECL_IGNORED_P (decl) = 1;
4439 rest_of_decl_compilation (decl, 1, 0);
4443 #include "gt-fortran-trans-decl.h"