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"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 #include "trans-const.h"
44 /* Only for gfc_trans_code. Shouldn't need to include this. */
45 #include "trans-stmt.h"
47 #define MAX_LABEL_VALUE 99999
50 /* Holds the result of the function if no result variable specified. */
52 static GTY(()) tree current_fake_result_decl;
53 static GTY(()) tree parent_fake_result_decl;
55 static GTY(()) tree current_function_return_label;
58 /* Holds the variable DECLs for the current function. */
60 static GTY(()) tree saved_function_decls;
61 static GTY(()) tree saved_parent_function_decls;
64 /* The namespace of the module we're currently generating. Only used while
65 outputting decls for module variables. Do not rely on this being set. */
67 static gfc_namespace *module_namespace;
70 /* List of static constructor functions. */
72 tree gfc_static_ctors;
75 /* Function declarations for builtin library functions. */
77 tree gfor_fndecl_pause_numeric;
78 tree gfor_fndecl_pause_string;
79 tree gfor_fndecl_stop_numeric;
80 tree gfor_fndecl_stop_string;
81 tree gfor_fndecl_runtime_error;
82 tree gfor_fndecl_runtime_error_at;
83 tree gfor_fndecl_runtime_warning_at;
84 tree gfor_fndecl_os_error;
85 tree gfor_fndecl_generate_error;
86 tree gfor_fndecl_set_fpe;
87 tree gfor_fndecl_set_options;
88 tree gfor_fndecl_set_convert;
89 tree gfor_fndecl_set_record_marker;
90 tree gfor_fndecl_set_max_subrecord_length;
91 tree gfor_fndecl_ctime;
92 tree gfor_fndecl_fdate;
93 tree gfor_fndecl_ttynam;
94 tree gfor_fndecl_in_pack;
95 tree gfor_fndecl_in_unpack;
96 tree gfor_fndecl_associated;
99 /* Math functions. Many other math functions are handled in
100 trans-intrinsic.c. */
102 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
103 tree gfor_fndecl_math_ishftc4;
104 tree gfor_fndecl_math_ishftc8;
105 tree gfor_fndecl_math_ishftc16;
108 /* String functions. */
110 tree gfor_fndecl_compare_string;
111 tree gfor_fndecl_concat_string;
112 tree gfor_fndecl_string_len_trim;
113 tree gfor_fndecl_string_index;
114 tree gfor_fndecl_string_scan;
115 tree gfor_fndecl_string_verify;
116 tree gfor_fndecl_string_trim;
117 tree gfor_fndecl_string_minmax;
118 tree gfor_fndecl_adjustl;
119 tree gfor_fndecl_adjustr;
120 tree gfor_fndecl_select_string;
121 tree gfor_fndecl_compare_string_char4;
122 tree gfor_fndecl_concat_string_char4;
123 tree gfor_fndecl_string_len_trim_char4;
124 tree gfor_fndecl_string_index_char4;
125 tree gfor_fndecl_string_scan_char4;
126 tree gfor_fndecl_string_verify_char4;
127 tree gfor_fndecl_string_trim_char4;
128 tree gfor_fndecl_string_minmax_char4;
129 tree gfor_fndecl_adjustl_char4;
130 tree gfor_fndecl_adjustr_char4;
131 tree gfor_fndecl_select_string_char4;
134 /* Conversion between character kinds. */
135 tree gfor_fndecl_convert_char1_to_char4;
136 tree gfor_fndecl_convert_char4_to_char1;
139 /* Other misc. runtime library functions. */
141 tree gfor_fndecl_size0;
142 tree gfor_fndecl_size1;
143 tree gfor_fndecl_iargc;
145 /* Intrinsic functions implemented in Fortran. */
146 tree gfor_fndecl_sc_kind;
147 tree gfor_fndecl_si_kind;
148 tree gfor_fndecl_sr_kind;
150 /* BLAS gemm functions. */
151 tree gfor_fndecl_sgemm;
152 tree gfor_fndecl_dgemm;
153 tree gfor_fndecl_cgemm;
154 tree gfor_fndecl_zgemm;
158 gfc_add_decl_to_parent_function (tree decl)
161 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
162 DECL_NONLOCAL (decl) = 1;
163 TREE_CHAIN (decl) = saved_parent_function_decls;
164 saved_parent_function_decls = decl;
168 gfc_add_decl_to_function (tree decl)
171 TREE_USED (decl) = 1;
172 DECL_CONTEXT (decl) = current_function_decl;
173 TREE_CHAIN (decl) = saved_function_decls;
174 saved_function_decls = decl;
178 /* Build a backend label declaration. Set TREE_USED for named labels.
179 The context of the label is always the current_function_decl. All
180 labels are marked artificial. */
183 gfc_build_label_decl (tree label_id)
185 /* 2^32 temporaries should be enough. */
186 static unsigned int tmp_num = 1;
190 if (label_id == NULL_TREE)
192 /* Build an internal label name. */
193 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
194 label_id = get_identifier (label_name);
199 /* Build the LABEL_DECL node. Labels have no type. */
200 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
201 DECL_CONTEXT (label_decl) = current_function_decl;
202 DECL_MODE (label_decl) = VOIDmode;
204 /* We always define the label as used, even if the original source
205 file never references the label. We don't want all kinds of
206 spurious warnings for old-style Fortran code with too many
208 TREE_USED (label_decl) = 1;
210 DECL_ARTIFICIAL (label_decl) = 1;
215 /* Returns the return label for the current function. */
218 gfc_get_return_label (void)
220 char name[GFC_MAX_SYMBOL_LEN + 10];
222 if (current_function_return_label)
223 return current_function_return_label;
225 sprintf (name, "__return_%s",
226 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
228 current_function_return_label =
229 gfc_build_label_decl (get_identifier (name));
231 DECL_ARTIFICIAL (current_function_return_label) = 1;
233 return current_function_return_label;
237 /* Set the backend source location of a decl. */
240 gfc_set_decl_location (tree decl, locus * loc)
242 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
246 /* Return the backend label declaration for a given label structure,
247 or create it if it doesn't exist yet. */
250 gfc_get_label_decl (gfc_st_label * lp)
252 if (lp->backend_decl)
253 return lp->backend_decl;
256 char label_name[GFC_MAX_SYMBOL_LEN + 1];
259 /* Validate the label declaration from the front end. */
260 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
262 /* Build a mangled name for the label. */
263 sprintf (label_name, "__label_%.6d", lp->value);
265 /* Build the LABEL_DECL node. */
266 label_decl = gfc_build_label_decl (get_identifier (label_name));
268 /* Tell the debugger where the label came from. */
269 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
270 gfc_set_decl_location (label_decl, &lp->where);
272 DECL_ARTIFICIAL (label_decl) = 1;
274 /* Store the label in the label list and return the LABEL_DECL. */
275 lp->backend_decl = label_decl;
281 /* Convert a gfc_symbol to an identifier of the same name. */
284 gfc_sym_identifier (gfc_symbol * sym)
286 return (get_identifier (sym->name));
290 /* Construct mangled name from symbol name. */
293 gfc_sym_mangled_identifier (gfc_symbol * sym)
295 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
297 /* Prevent the mangling of identifiers that have an assigned
298 binding label (mainly those that are bind(c)). */
299 if (sym->attr.is_bind_c == 1
300 && sym->binding_label[0] != '\0')
301 return get_identifier(sym->binding_label);
303 if (sym->module == NULL)
304 return gfc_sym_identifier (sym);
307 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
308 return get_identifier (name);
313 /* Construct mangled function name from symbol name. */
316 gfc_sym_mangled_function_id (gfc_symbol * sym)
319 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
321 /* It may be possible to simply use the binding label if it's
322 provided, and remove the other checks. Then we could use it
323 for other things if we wished. */
324 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
325 sym->binding_label[0] != '\0')
326 /* use the binding label rather than the mangled name */
327 return get_identifier (sym->binding_label);
329 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
330 || (sym->module != NULL && (sym->attr.external
331 || sym->attr.if_source == IFSRC_IFBODY)))
333 /* Main program is mangled into MAIN__. */
334 if (sym->attr.is_main_program)
335 return get_identifier ("MAIN__");
337 /* Intrinsic procedures are never mangled. */
338 if (sym->attr.proc == PROC_INTRINSIC)
339 return get_identifier (sym->name);
341 if (gfc_option.flag_underscoring)
343 has_underscore = strchr (sym->name, '_') != 0;
344 if (gfc_option.flag_second_underscore && has_underscore)
345 snprintf (name, sizeof name, "%s__", sym->name);
347 snprintf (name, sizeof name, "%s_", sym->name);
348 return get_identifier (name);
351 return get_identifier (sym->name);
355 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
356 return get_identifier (name);
361 /* Returns true if a variable of specified size should go on the stack. */
364 gfc_can_put_var_on_stack (tree size)
366 unsigned HOST_WIDE_INT low;
368 if (!INTEGER_CST_P (size))
371 if (gfc_option.flag_max_stack_var_size < 0)
374 if (TREE_INT_CST_HIGH (size) != 0)
377 low = TREE_INT_CST_LOW (size);
378 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
381 /* TODO: Set a per-function stack size limit. */
387 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
388 an expression involving its corresponding pointer. There are
389 2 cases; one for variable size arrays, and one for everything else,
390 because variable-sized arrays require one fewer level of
394 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
396 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
399 /* Parameters need to be dereferenced. */
400 if (sym->cp_pointer->attr.dummy)
401 ptr_decl = build_fold_indirect_ref (ptr_decl);
403 /* Check to see if we're dealing with a variable-sized array. */
404 if (sym->attr.dimension
405 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
407 /* These decls will be dereferenced later, so we don't dereference
409 value = convert (TREE_TYPE (decl), ptr_decl);
413 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
415 value = build_fold_indirect_ref (ptr_decl);
418 SET_DECL_VALUE_EXPR (decl, value);
419 DECL_HAS_VALUE_EXPR_P (decl) = 1;
420 GFC_DECL_CRAY_POINTEE (decl) = 1;
421 /* This is a fake variable just for debugging purposes. */
422 TREE_ASM_WRITTEN (decl) = 1;
426 /* Finish processing of a declaration without an initial value. */
429 gfc_finish_decl (tree decl)
431 gcc_assert (TREE_CODE (decl) == PARM_DECL
432 || DECL_INITIAL (decl) == NULL_TREE);
434 if (TREE_CODE (decl) != VAR_DECL)
437 if (DECL_SIZE (decl) == NULL_TREE
438 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
439 layout_decl (decl, 0);
441 /* A few consistency checks. */
442 /* A static variable with an incomplete type is an error if it is
443 initialized. Also if it is not file scope. Otherwise, let it
444 through, but if it is not `extern' then it may cause an error
446 /* An automatic variable with an incomplete type is an error. */
448 /* We should know the storage size. */
449 gcc_assert (DECL_SIZE (decl) != NULL_TREE
450 || (TREE_STATIC (decl)
451 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
452 : DECL_EXTERNAL (decl)));
454 /* The storage size should be constant. */
455 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
457 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
461 /* Apply symbol attributes to a variable, and add it to the function scope. */
464 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
467 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
468 This is the equivalent of the TARGET variables.
469 We also need to set this if the variable is passed by reference in a
472 /* Set DECL_VALUE_EXPR for Cray Pointees. */
473 if (sym->attr.cray_pointee)
474 gfc_finish_cray_pointee (decl, sym);
476 if (sym->attr.target)
477 TREE_ADDRESSABLE (decl) = 1;
478 /* If it wasn't used we wouldn't be getting it. */
479 TREE_USED (decl) = 1;
481 /* Chain this decl to the pending declarations. Don't do pushdecl()
482 because this would add them to the current scope rather than the
484 if (current_function_decl != NULL_TREE)
486 if (sym->ns->proc_name->backend_decl == current_function_decl
487 || sym->result == sym)
488 gfc_add_decl_to_function (decl);
490 gfc_add_decl_to_parent_function (decl);
493 if (sym->attr.cray_pointee)
496 if(sym->attr.is_bind_c == 1)
498 /* We need to put variables that are bind(c) into the common
499 segment of the object file, because this is what C would do.
500 gfortran would typically put them in either the BSS or
501 initialized data segments, and only mark them as common if
502 they were part of common blocks. However, if they are not put
503 into common space, then C cannot initialize global fortran
504 variables that it interoperates with and the draft says that
505 either Fortran or C should be able to initialize it (but not
506 both, of course.) (J3/04-007, section 15.3). */
507 TREE_PUBLIC(decl) = 1;
508 DECL_COMMON(decl) = 1;
511 /* If a variable is USE associated, it's always external. */
512 if (sym->attr.use_assoc)
514 DECL_EXTERNAL (decl) = 1;
515 TREE_PUBLIC (decl) = 1;
517 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
519 /* TODO: Don't set sym->module for result or dummy variables. */
520 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
521 /* This is the declaration of a module variable. */
522 TREE_PUBLIC (decl) = 1;
523 TREE_STATIC (decl) = 1;
526 /* Derived types are a bit peculiar because of the possibility of
527 a default initializer; this must be applied each time the variable
528 comes into scope it therefore need not be static. These variables
529 are SAVE_NONE but have an initializer. Otherwise explicitly
530 initialized variables are SAVE_IMPLICIT and explicitly saved are
532 if (!sym->attr.use_assoc
533 && (sym->attr.save != SAVE_NONE || sym->attr.data
534 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
535 TREE_STATIC (decl) = 1;
537 if (sym->attr.volatile_)
539 TREE_THIS_VOLATILE (decl) = 1;
540 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
541 TREE_TYPE (decl) = new_type;
544 /* Keep variables larger than max-stack-var-size off stack. */
545 if (!sym->ns->proc_name->attr.recursive
546 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
547 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
548 /* Put variable length auto array pointers always into stack. */
549 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
550 || sym->attr.dimension == 0
551 || sym->as->type != AS_EXPLICIT
553 || sym->attr.allocatable)
554 && !DECL_ARTIFICIAL (decl))
555 TREE_STATIC (decl) = 1;
557 /* Handle threadprivate variables. */
558 if (sym->attr.threadprivate
559 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
560 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
564 /* Allocate the lang-specific part of a decl. */
567 gfc_allocate_lang_decl (tree decl)
569 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
570 ggc_alloc_cleared (sizeof (struct lang_decl));
573 /* Remember a symbol to generate initialization/cleanup code at function
577 gfc_defer_symbol_init (gfc_symbol * sym)
583 /* Don't add a symbol twice. */
587 last = head = sym->ns->proc_name;
590 /* Make sure that setup code for dummy variables which are used in the
591 setup of other variables is generated first. */
594 /* Find the first dummy arg seen after us, or the first non-dummy arg.
595 This is a circular list, so don't go past the head. */
597 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
603 /* Insert in between last and p. */
609 /* Create an array index type variable with function scope. */
612 create_index_var (const char * pfx, int nest)
616 decl = gfc_create_var_np (gfc_array_index_type, pfx);
618 gfc_add_decl_to_parent_function (decl);
620 gfc_add_decl_to_function (decl);
625 /* Create variables to hold all the non-constant bits of info for a
626 descriptorless array. Remember these in the lang-specific part of the
630 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
636 type = TREE_TYPE (decl);
638 /* We just use the descriptor, if there is one. */
639 if (GFC_DESCRIPTOR_TYPE_P (type))
642 gcc_assert (GFC_ARRAY_TYPE_P (type));
643 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
644 && !sym->attr.contained;
646 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
648 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
650 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
651 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
653 /* Don't try to use the unknown bound for assumed shape arrays. */
654 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
655 && (sym->as->type != AS_ASSUMED_SIZE
656 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
658 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
659 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
662 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
664 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
665 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
668 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
670 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
672 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
675 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
677 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
680 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
681 && sym->as->type != AS_ASSUMED_SIZE)
683 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
684 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
687 if (POINTER_TYPE_P (type))
689 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
690 gcc_assert (TYPE_LANG_SPECIFIC (type)
691 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
692 type = TREE_TYPE (type);
695 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
699 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
700 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
701 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
703 TYPE_DOMAIN (type) = range;
707 if (write_symbols == NO_DEBUG)
710 if (TYPE_NAME (type) != NULL_TREE
711 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
712 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
714 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
716 for (dim = 0; dim < sym->as->rank - 1; dim++)
718 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
719 gtype = TREE_TYPE (gtype);
721 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
722 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
723 TYPE_NAME (type) = NULL_TREE;
726 if (TYPE_NAME (type) == NULL_TREE)
728 tree gtype = TREE_TYPE (type), rtype, type_decl;
730 for (dim = sym->as->rank - 1; dim >= 0; dim--)
732 rtype = build_range_type (gfc_array_index_type,
733 GFC_TYPE_ARRAY_LBOUND (type, dim),
734 GFC_TYPE_ARRAY_UBOUND (type, dim));
735 gtype = build_array_type (gtype, rtype);
736 /* Ensure the bound variables aren't optimized out at -O0. */
739 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
740 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
741 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
742 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
743 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
744 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
747 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
748 DECL_ORIGINAL_TYPE (type_decl) = gtype;
753 /* For some dummy arguments we don't use the actual argument directly.
754 Instead we create a local decl and use that. This allows us to perform
755 initialization, and construct full type information. */
758 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
768 if (sym->attr.pointer || sym->attr.allocatable)
771 /* Add to list of variables if not a fake result variable. */
772 if (sym->attr.result || sym->attr.dummy)
773 gfc_defer_symbol_init (sym);
775 type = TREE_TYPE (dummy);
776 gcc_assert (TREE_CODE (dummy) == PARM_DECL
777 && POINTER_TYPE_P (type));
779 /* Do we know the element size? */
780 known_size = sym->ts.type != BT_CHARACTER
781 || INTEGER_CST_P (sym->ts.cl->backend_decl);
783 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
785 /* For descriptorless arrays with known element size the actual
786 argument is sufficient. */
787 gcc_assert (GFC_ARRAY_TYPE_P (type));
788 gfc_build_qualified_array (dummy, sym);
792 type = TREE_TYPE (type);
793 if (GFC_DESCRIPTOR_TYPE_P (type))
795 /* Create a descriptorless array pointer. */
799 /* Even when -frepack-arrays is used, symbols with TARGET attribute
801 if (!gfc_option.flag_repack_arrays || sym->attr.target)
803 if (as->type == AS_ASSUMED_SIZE)
804 packed = PACKED_FULL;
808 if (as->type == AS_EXPLICIT)
810 packed = PACKED_FULL;
811 for (n = 0; n < as->rank; n++)
815 && as->upper[n]->expr_type == EXPR_CONSTANT
816 && as->lower[n]->expr_type == EXPR_CONSTANT))
817 packed = PACKED_PARTIAL;
821 packed = PACKED_PARTIAL;
824 type = gfc_typenode_for_spec (&sym->ts);
825 type = gfc_get_nodesc_array_type (type, sym->as, packed);
829 /* We now have an expression for the element size, so create a fully
830 qualified type. Reset sym->backend decl or this will just return the
832 DECL_ARTIFICIAL (sym->backend_decl) = 1;
833 sym->backend_decl = NULL_TREE;
834 type = gfc_sym_type (sym);
835 packed = PACKED_FULL;
838 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
839 decl = build_decl (VAR_DECL, get_identifier (name), type);
841 DECL_ARTIFICIAL (decl) = 1;
842 TREE_PUBLIC (decl) = 0;
843 TREE_STATIC (decl) = 0;
844 DECL_EXTERNAL (decl) = 0;
846 /* We should never get deferred shape arrays here. We used to because of
848 gcc_assert (sym->as->type != AS_DEFERRED);
850 if (packed == PACKED_PARTIAL)
851 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
852 else if (packed == PACKED_FULL)
853 GFC_DECL_PACKED_ARRAY (decl) = 1;
855 gfc_build_qualified_array (decl, sym);
857 if (DECL_LANG_SPECIFIC (dummy))
858 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
860 gfc_allocate_lang_decl (decl);
862 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
864 if (sym->ns->proc_name->backend_decl == current_function_decl
865 || sym->attr.contained)
866 gfc_add_decl_to_function (decl);
868 gfc_add_decl_to_parent_function (decl);
874 /* Return a constant or a variable to use as a string length. Does not
875 add the decl to the current scope. */
878 gfc_create_string_length (gfc_symbol * sym)
882 gcc_assert (sym->ts.cl);
883 gfc_conv_const_charlen (sym->ts.cl);
885 if (sym->ts.cl->backend_decl == NULL_TREE)
887 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
889 /* Also prefix the mangled name. */
890 strcpy (&name[1], sym->name);
892 length = build_decl (VAR_DECL, get_identifier (name),
893 gfc_charlen_type_node);
894 DECL_ARTIFICIAL (length) = 1;
895 TREE_USED (length) = 1;
896 if (sym->ns->proc_name->tlink != NULL)
897 gfc_defer_symbol_init (sym);
898 sym->ts.cl->backend_decl = length;
901 return sym->ts.cl->backend_decl;
904 /* If a variable is assigned a label, we add another two auxiliary
908 gfc_add_assign_aux_vars (gfc_symbol * sym)
914 gcc_assert (sym->backend_decl);
916 decl = sym->backend_decl;
917 gfc_allocate_lang_decl (decl);
918 GFC_DECL_ASSIGN (decl) = 1;
919 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
920 gfc_charlen_type_node);
921 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
923 gfc_finish_var_decl (length, sym);
924 gfc_finish_var_decl (addr, sym);
925 /* STRING_LENGTH is also used as flag. Less than -1 means that
926 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
927 target label's address. Otherwise, value is the length of a format string
928 and ASSIGN_ADDR is its address. */
929 if (TREE_STATIC (length))
930 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
932 gfc_defer_symbol_init (sym);
934 GFC_DECL_STRING_LEN (decl) = length;
935 GFC_DECL_ASSIGN_ADDR (decl) = addr;
938 /* Return the decl for a gfc_symbol, create it if it doesn't already
942 gfc_get_symbol_decl (gfc_symbol * sym)
945 tree length = NULL_TREE;
948 gcc_assert (sym->attr.referenced
949 || sym->attr.use_assoc
950 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
952 if (sym->ns && sym->ns->proc_name->attr.function)
953 byref = gfc_return_by_reference (sym->ns->proc_name);
957 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
959 /* Return via extra parameter. */
960 if (sym->attr.result && byref
961 && !sym->backend_decl)
964 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
965 /* For entry master function skip over the __entry
967 if (sym->ns->proc_name->attr.entry_master)
968 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
971 /* Dummy variables should already have been created. */
972 gcc_assert (sym->backend_decl);
974 /* Create a character length variable. */
975 if (sym->ts.type == BT_CHARACTER)
977 if (sym->ts.cl->backend_decl == NULL_TREE)
978 length = gfc_create_string_length (sym);
980 length = sym->ts.cl->backend_decl;
981 if (TREE_CODE (length) == VAR_DECL
982 && DECL_CONTEXT (length) == NULL_TREE)
984 /* Add the string length to the same context as the symbol. */
985 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
986 gfc_add_decl_to_function (length);
988 gfc_add_decl_to_parent_function (length);
990 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
991 DECL_CONTEXT (length));
993 gfc_defer_symbol_init (sym);
997 /* Use a copy of the descriptor for dummy arrays. */
998 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1000 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1001 /* Prevent the dummy from being detected as unused if it is copied. */
1002 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1003 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1004 sym->backend_decl = decl;
1007 TREE_USED (sym->backend_decl) = 1;
1008 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1010 gfc_add_assign_aux_vars (sym);
1012 return sym->backend_decl;
1015 if (sym->backend_decl)
1016 return sym->backend_decl;
1018 /* Catch function declarations. Only used for actual parameters. */
1019 if (sym->attr.flavor == FL_PROCEDURE)
1021 decl = gfc_get_extern_function_decl (sym);
1025 if (sym->attr.intrinsic)
1026 internal_error ("intrinsic variable which isn't a procedure");
1028 /* Create string length decl first so that they can be used in the
1029 type declaration. */
1030 if (sym->ts.type == BT_CHARACTER)
1031 length = gfc_create_string_length (sym);
1033 /* Create the decl for the variable. */
1034 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1036 gfc_set_decl_location (decl, &sym->declared_at);
1038 /* Symbols from modules should have their assembler names mangled.
1039 This is done here rather than in gfc_finish_var_decl because it
1040 is different for string length variables. */
1043 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1044 if (sym->attr.use_assoc)
1045 DECL_IGNORED_P (decl) = 1;
1048 if (sym->attr.dimension)
1050 /* Create variables to hold the non-constant bits of array info. */
1051 gfc_build_qualified_array (decl, sym);
1053 /* Remember this variable for allocation/cleanup. */
1054 gfc_defer_symbol_init (sym);
1056 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1057 GFC_DECL_PACKED_ARRAY (decl) = 1;
1060 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1061 gfc_defer_symbol_init (sym);
1062 /* This applies a derived type default initializer. */
1063 else if (sym->ts.type == BT_DERIVED
1064 && sym->attr.save == SAVE_NONE
1066 && !sym->attr.allocatable
1067 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1068 && !sym->attr.use_assoc)
1069 gfc_defer_symbol_init (sym);
1071 gfc_finish_var_decl (decl, sym);
1073 if (sym->ts.type == BT_CHARACTER)
1075 /* Character variables need special handling. */
1076 gfc_allocate_lang_decl (decl);
1078 if (TREE_CODE (length) != INTEGER_CST)
1080 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1084 /* Also prefix the mangled name for symbols from modules. */
1085 strcpy (&name[1], sym->name);
1088 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1089 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1091 gfc_finish_var_decl (length, sym);
1092 gcc_assert (!sym->value);
1095 else if (sym->attr.subref_array_pointer)
1097 /* We need the span for these beasts. */
1098 gfc_allocate_lang_decl (decl);
1101 if (sym->attr.subref_array_pointer)
1104 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1105 span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1106 gfc_array_index_type);
1107 gfc_finish_var_decl (span, sym);
1108 TREE_STATIC (span) = TREE_STATIC (decl);
1109 DECL_ARTIFICIAL (span) = 1;
1110 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1112 GFC_DECL_SPAN (decl) = span;
1113 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1116 sym->backend_decl = decl;
1118 if (sym->attr.assign)
1119 gfc_add_assign_aux_vars (sym);
1121 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1123 /* Add static initializer. */
1124 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1125 TREE_TYPE (decl), sym->attr.dimension,
1126 sym->attr.pointer || sym->attr.allocatable);
1133 /* Substitute a temporary variable in place of the real one. */
1136 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1138 save->attr = sym->attr;
1139 save->decl = sym->backend_decl;
1141 gfc_clear_attr (&sym->attr);
1142 sym->attr.referenced = 1;
1143 sym->attr.flavor = FL_VARIABLE;
1145 sym->backend_decl = decl;
1149 /* Restore the original variable. */
1152 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1154 sym->attr = save->attr;
1155 sym->backend_decl = save->decl;
1159 /* Declare a procedure pointer. */
1162 get_proc_pointer_decl (gfc_symbol *sym)
1166 decl = sym->backend_decl;
1170 decl = build_decl (VAR_DECL, get_identifier (sym->name),
1171 build_pointer_type (gfc_get_function_type (sym)));
1173 if ((sym->ns->proc_name
1174 && sym->ns->proc_name->backend_decl == current_function_decl)
1175 || sym->attr.contained)
1176 gfc_add_decl_to_function (decl);
1177 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1178 gfc_add_decl_to_parent_function (decl);
1180 sym->backend_decl = decl;
1182 /* If a variable is USE associated, it's always external. */
1183 if (sym->attr.use_assoc)
1185 DECL_EXTERNAL (decl) = 1;
1186 TREE_PUBLIC (decl) = 1;
1188 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1190 /* This is the declaration of a module variable. */
1191 TREE_PUBLIC (decl) = 1;
1192 TREE_STATIC (decl) = 1;
1195 if (!sym->attr.use_assoc
1196 && (sym->attr.save != SAVE_NONE || sym->attr.data
1197 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1198 TREE_STATIC (decl) = 1;
1200 if (TREE_STATIC (decl) && sym->value)
1202 /* Add static initializer. */
1203 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1204 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1211 /* Get a basic decl for an external function. */
1214 gfc_get_extern_function_decl (gfc_symbol * sym)
1219 gfc_intrinsic_sym *isym;
1221 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1226 if (sym->backend_decl)
1227 return sym->backend_decl;
1229 /* We should never be creating external decls for alternate entry points.
1230 The procedure may be an alternate entry point, but we don't want/need
1232 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1234 if (sym->attr.proc_pointer)
1235 return get_proc_pointer_decl (sym);
1237 /* See if this is an external procedure from the same file. If so,
1238 return the backend_decl. */
1239 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1241 if (gfc_option.flag_whole_file
1242 && !sym->backend_decl
1244 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1245 && gsym->ns->proc_name->backend_decl)
1247 /* If the namespace has entries, the proc_name is the
1248 entry master. Find the entry and use its backend_decl.
1249 otherwise, use the proc_name backend_decl. */
1250 if (gsym->ns->entries)
1252 gfc_entry_list *entry = gsym->ns->entries;
1254 for (; entry; entry = entry->next)
1256 if (strcmp (gsym->name, entry->sym->name) == 0)
1258 sym->backend_decl = entry->sym->backend_decl;
1265 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1268 if (sym->backend_decl)
1269 return sym->backend_decl;
1272 if (sym->attr.intrinsic)
1274 /* Call the resolution function to get the actual name. This is
1275 a nasty hack which relies on the resolution functions only looking
1276 at the first argument. We pass NULL for the second argument
1277 otherwise things like AINT get confused. */
1278 isym = gfc_find_function (sym->name);
1279 gcc_assert (isym->resolve.f0 != NULL);
1281 memset (&e, 0, sizeof (e));
1282 e.expr_type = EXPR_FUNCTION;
1284 memset (&argexpr, 0, sizeof (argexpr));
1285 gcc_assert (isym->formal);
1286 argexpr.ts = isym->formal->ts;
1288 if (isym->formal->next == NULL)
1289 isym->resolve.f1 (&e, &argexpr);
1292 if (isym->formal->next->next == NULL)
1293 isym->resolve.f2 (&e, &argexpr, NULL);
1296 if (isym->formal->next->next->next == NULL)
1297 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1300 /* All specific intrinsics take less than 5 arguments. */
1301 gcc_assert (isym->formal->next->next->next->next == NULL);
1302 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1307 if (gfc_option.flag_f2c
1308 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1309 || e.ts.type == BT_COMPLEX))
1311 /* Specific which needs a different implementation if f2c
1312 calling conventions are used. */
1313 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1316 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1318 name = get_identifier (s);
1319 mangled_name = name;
1323 name = gfc_sym_identifier (sym);
1324 mangled_name = gfc_sym_mangled_function_id (sym);
1327 type = gfc_get_function_type (sym);
1328 fndecl = build_decl (FUNCTION_DECL, name, type);
1330 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1331 /* If the return type is a pointer, avoid alias issues by setting
1332 DECL_IS_MALLOC to nonzero. This means that the function should be
1333 treated as if it were a malloc, meaning it returns a pointer that
1335 if (POINTER_TYPE_P (type))
1336 DECL_IS_MALLOC (fndecl) = 1;
1338 /* Set the context of this decl. */
1339 if (0 && sym->ns && sym->ns->proc_name)
1341 /* TODO: Add external decls to the appropriate scope. */
1342 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1346 /* Global declaration, e.g. intrinsic subroutine. */
1347 DECL_CONTEXT (fndecl) = NULL_TREE;
1350 DECL_EXTERNAL (fndecl) = 1;
1352 /* This specifies if a function is globally addressable, i.e. it is
1353 the opposite of declaring static in C. */
1354 TREE_PUBLIC (fndecl) = 1;
1356 /* Set attributes for PURE functions. A call to PURE function in the
1357 Fortran 95 sense is both pure and without side effects in the C
1359 if (sym->attr.pure || sym->attr.elemental)
1361 if (sym->attr.function && !gfc_return_by_reference (sym))
1362 DECL_PURE_P (fndecl) = 1;
1363 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1364 parameters and don't use alternate returns (is this
1365 allowed?). In that case, calls to them are meaningless, and
1366 can be optimized away. See also in build_function_decl(). */
1367 TREE_SIDE_EFFECTS (fndecl) = 0;
1370 /* Mark non-returning functions. */
1371 if (sym->attr.noreturn)
1372 TREE_THIS_VOLATILE(fndecl) = 1;
1374 sym->backend_decl = fndecl;
1376 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1377 pushdecl_top_level (fndecl);
1383 /* Create a declaration for a procedure. For external functions (in the C
1384 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1385 a master function with alternate entry points. */
1388 build_function_decl (gfc_symbol * sym)
1391 symbol_attribute attr;
1393 gfc_formal_arglist *f;
1395 gcc_assert (!sym->backend_decl);
1396 gcc_assert (!sym->attr.external);
1398 /* Set the line and filename. sym->declared_at seems to point to the
1399 last statement for subroutines, but it'll do for now. */
1400 gfc_set_backend_locus (&sym->declared_at);
1402 /* Allow only one nesting level. Allow public declarations. */
1403 gcc_assert (current_function_decl == NULL_TREE
1404 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1405 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1408 type = gfc_get_function_type (sym);
1409 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1411 /* Perform name mangling if this is a top level or module procedure. */
1412 if (current_function_decl == NULL_TREE)
1413 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1415 /* Figure out the return type of the declared function, and build a
1416 RESULT_DECL for it. If this is a subroutine with alternate
1417 returns, build a RESULT_DECL for it. */
1420 result_decl = NULL_TREE;
1421 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1424 if (gfc_return_by_reference (sym))
1425 type = void_type_node;
1428 if (sym->result != sym)
1429 result_decl = gfc_sym_identifier (sym->result);
1431 type = TREE_TYPE (TREE_TYPE (fndecl));
1436 /* Look for alternate return placeholders. */
1437 int has_alternate_returns = 0;
1438 for (f = sym->formal; f; f = f->next)
1442 has_alternate_returns = 1;
1447 if (has_alternate_returns)
1448 type = integer_type_node;
1450 type = void_type_node;
1453 result_decl = build_decl (RESULT_DECL, result_decl, type);
1454 DECL_ARTIFICIAL (result_decl) = 1;
1455 DECL_IGNORED_P (result_decl) = 1;
1456 DECL_CONTEXT (result_decl) = fndecl;
1457 DECL_RESULT (fndecl) = result_decl;
1459 /* Don't call layout_decl for a RESULT_DECL.
1460 layout_decl (result_decl, 0); */
1462 /* If the return type is a pointer, avoid alias issues by setting
1463 DECL_IS_MALLOC to nonzero. This means that the function should be
1464 treated as if it were a malloc, meaning it returns a pointer that
1466 if (POINTER_TYPE_P (type))
1467 DECL_IS_MALLOC (fndecl) = 1;
1469 /* Set up all attributes for the function. */
1470 DECL_CONTEXT (fndecl) = current_function_decl;
1471 DECL_EXTERNAL (fndecl) = 0;
1473 /* This specifies if a function is globally visible, i.e. it is
1474 the opposite of declaring static in C. */
1475 if (DECL_CONTEXT (fndecl) == NULL_TREE
1476 && !sym->attr.entry_master)
1477 TREE_PUBLIC (fndecl) = 1;
1479 /* TREE_STATIC means the function body is defined here. */
1480 TREE_STATIC (fndecl) = 1;
1482 /* Set attributes for PURE functions. A call to a PURE function in the
1483 Fortran 95 sense is both pure and without side effects in the C
1485 if (attr.pure || attr.elemental)
1487 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1488 including an alternate return. In that case it can also be
1489 marked as PURE. See also in gfc_get_extern_function_decl(). */
1490 if (attr.function && !gfc_return_by_reference (sym))
1491 DECL_PURE_P (fndecl) = 1;
1492 TREE_SIDE_EFFECTS (fndecl) = 0;
1495 /* For -fwhole-program to work well, the main program needs to have the
1496 "externally_visible" attribute. */
1497 if (attr.is_main_program)
1498 DECL_ATTRIBUTES (fndecl)
1499 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
1501 /* Layout the function declaration and put it in the binding level
1502 of the current function. */
1505 sym->backend_decl = fndecl;
1509 /* Create the DECL_ARGUMENTS for a procedure. */
1512 create_function_arglist (gfc_symbol * sym)
1515 gfc_formal_arglist *f;
1516 tree typelist, hidden_typelist;
1517 tree arglist, hidden_arglist;
1521 fndecl = sym->backend_decl;
1523 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1524 the new FUNCTION_DECL node. */
1525 arglist = NULL_TREE;
1526 hidden_arglist = NULL_TREE;
1527 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1529 if (sym->attr.entry_master)
1531 type = TREE_VALUE (typelist);
1532 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1534 DECL_CONTEXT (parm) = fndecl;
1535 DECL_ARG_TYPE (parm) = type;
1536 TREE_READONLY (parm) = 1;
1537 gfc_finish_decl (parm);
1538 DECL_ARTIFICIAL (parm) = 1;
1540 arglist = chainon (arglist, parm);
1541 typelist = TREE_CHAIN (typelist);
1544 if (gfc_return_by_reference (sym))
1546 tree type = TREE_VALUE (typelist), length = NULL;
1548 if (sym->ts.type == BT_CHARACTER)
1550 /* Length of character result. */
1551 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1552 gcc_assert (len_type == gfc_charlen_type_node);
1554 length = build_decl (PARM_DECL,
1555 get_identifier (".__result"),
1557 if (!sym->ts.cl->length)
1559 sym->ts.cl->backend_decl = length;
1560 TREE_USED (length) = 1;
1562 gcc_assert (TREE_CODE (length) == PARM_DECL);
1563 DECL_CONTEXT (length) = fndecl;
1564 DECL_ARG_TYPE (length) = len_type;
1565 TREE_READONLY (length) = 1;
1566 DECL_ARTIFICIAL (length) = 1;
1567 gfc_finish_decl (length);
1568 if (sym->ts.cl->backend_decl == NULL
1569 || sym->ts.cl->backend_decl == length)
1574 if (sym->ts.cl->backend_decl == NULL)
1576 tree len = build_decl (VAR_DECL,
1577 get_identifier ("..__result"),
1578 gfc_charlen_type_node);
1579 DECL_ARTIFICIAL (len) = 1;
1580 TREE_USED (len) = 1;
1581 sym->ts.cl->backend_decl = len;
1584 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1585 arg = sym->result ? sym->result : sym;
1586 backend_decl = arg->backend_decl;
1587 /* Temporary clear it, so that gfc_sym_type creates complete
1589 arg->backend_decl = NULL;
1590 type = gfc_sym_type (arg);
1591 arg->backend_decl = backend_decl;
1592 type = build_reference_type (type);
1596 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1598 DECL_CONTEXT (parm) = fndecl;
1599 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1600 TREE_READONLY (parm) = 1;
1601 DECL_ARTIFICIAL (parm) = 1;
1602 gfc_finish_decl (parm);
1604 arglist = chainon (arglist, parm);
1605 typelist = TREE_CHAIN (typelist);
1607 if (sym->ts.type == BT_CHARACTER)
1609 gfc_allocate_lang_decl (parm);
1610 arglist = chainon (arglist, length);
1611 typelist = TREE_CHAIN (typelist);
1615 hidden_typelist = typelist;
1616 for (f = sym->formal; f; f = f->next)
1617 if (f->sym != NULL) /* Ignore alternate returns. */
1618 hidden_typelist = TREE_CHAIN (hidden_typelist);
1620 for (f = sym->formal; f; f = f->next)
1622 char name[GFC_MAX_SYMBOL_LEN + 2];
1624 /* Ignore alternate returns. */
1628 type = TREE_VALUE (typelist);
1630 if (f->sym->ts.type == BT_CHARACTER)
1632 tree len_type = TREE_VALUE (hidden_typelist);
1633 tree length = NULL_TREE;
1634 gcc_assert (len_type == gfc_charlen_type_node);
1636 strcpy (&name[1], f->sym->name);
1638 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1640 hidden_arglist = chainon (hidden_arglist, length);
1641 DECL_CONTEXT (length) = fndecl;
1642 DECL_ARTIFICIAL (length) = 1;
1643 DECL_ARG_TYPE (length) = len_type;
1644 TREE_READONLY (length) = 1;
1645 gfc_finish_decl (length);
1647 /* TODO: Check string lengths when -fbounds-check. */
1649 /* Use the passed value for assumed length variables. */
1650 if (!f->sym->ts.cl->length)
1652 TREE_USED (length) = 1;
1653 gcc_assert (!f->sym->ts.cl->backend_decl);
1654 f->sym->ts.cl->backend_decl = length;
1657 hidden_typelist = TREE_CHAIN (hidden_typelist);
1659 if (f->sym->ts.cl->backend_decl == NULL
1660 || f->sym->ts.cl->backend_decl == length)
1662 if (f->sym->ts.cl->backend_decl == NULL)
1663 gfc_create_string_length (f->sym);
1665 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1666 if (f->sym->attr.flavor == FL_PROCEDURE)
1667 type = build_pointer_type (gfc_get_function_type (f->sym));
1669 type = gfc_sym_type (f->sym);
1673 /* For non-constant length array arguments, make sure they use
1674 a different type node from TYPE_ARG_TYPES type. */
1675 if (f->sym->attr.dimension
1676 && type == TREE_VALUE (typelist)
1677 && TREE_CODE (type) == POINTER_TYPE
1678 && GFC_ARRAY_TYPE_P (type)
1679 && f->sym->as->type != AS_ASSUMED_SIZE
1680 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1682 if (f->sym->attr.flavor == FL_PROCEDURE)
1683 type = build_pointer_type (gfc_get_function_type (f->sym));
1685 type = gfc_sym_type (f->sym);
1688 if (f->sym->attr.proc_pointer)
1689 type = build_pointer_type (type);
1691 /* Build the argument declaration. */
1692 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1694 /* Fill in arg stuff. */
1695 DECL_CONTEXT (parm) = fndecl;
1696 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1697 /* All implementation args are read-only. */
1698 TREE_READONLY (parm) = 1;
1699 if (POINTER_TYPE_P (type)
1700 && (!f->sym->attr.proc_pointer
1701 && f->sym->attr.flavor != FL_PROCEDURE))
1702 DECL_BY_REFERENCE (parm) = 1;
1704 gfc_finish_decl (parm);
1706 f->sym->backend_decl = parm;
1708 arglist = chainon (arglist, parm);
1709 typelist = TREE_CHAIN (typelist);
1712 /* Add the hidden string length parameters, unless the procedure
1714 if (!sym->attr.is_bind_c)
1715 arglist = chainon (arglist, hidden_arglist);
1717 gcc_assert (hidden_typelist == NULL_TREE
1718 || TREE_VALUE (hidden_typelist) == void_type_node);
1719 DECL_ARGUMENTS (fndecl) = arglist;
1722 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1725 gfc_gimplify_function (tree fndecl)
1727 struct cgraph_node *cgn;
1729 gimplify_function_tree (fndecl);
1730 dump_function (TDI_generic, fndecl);
1732 /* Generate errors for structured block violations. */
1733 /* ??? Could be done as part of resolve_labels. */
1735 diagnose_omp_structured_block_errors (fndecl);
1737 /* Convert all nested functions to GIMPLE now. We do things in this order
1738 so that items like VLA sizes are expanded properly in the context of the
1739 correct function. */
1740 cgn = cgraph_node (fndecl);
1741 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1742 gfc_gimplify_function (cgn->decl);
1746 /* Do the setup necessary before generating the body of a function. */
1749 trans_function_start (gfc_symbol * sym)
1753 fndecl = sym->backend_decl;
1755 /* Let GCC know the current scope is this function. */
1756 current_function_decl = fndecl;
1758 /* Let the world know what we're about to do. */
1759 announce_function (fndecl);
1761 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1763 /* Create RTL for function declaration. */
1764 rest_of_decl_compilation (fndecl, 1, 0);
1767 /* Create RTL for function definition. */
1768 make_decl_rtl (fndecl);
1770 init_function_start (fndecl);
1772 /* Even though we're inside a function body, we still don't want to
1773 call expand_expr to calculate the size of a variable-sized array.
1774 We haven't necessarily assigned RTL to all variables yet, so it's
1775 not safe to try to expand expressions involving them. */
1776 cfun->dont_save_pending_sizes_p = 1;
1778 /* function.c requires a push at the start of the function. */
1782 /* Create thunks for alternate entry points. */
1785 build_entry_thunks (gfc_namespace * ns)
1787 gfc_formal_arglist *formal;
1788 gfc_formal_arglist *thunk_formal;
1790 gfc_symbol *thunk_sym;
1798 /* This should always be a toplevel function. */
1799 gcc_assert (current_function_decl == NULL_TREE);
1801 gfc_get_backend_locus (&old_loc);
1802 for (el = ns->entries; el; el = el->next)
1804 thunk_sym = el->sym;
1806 build_function_decl (thunk_sym);
1807 create_function_arglist (thunk_sym);
1809 trans_function_start (thunk_sym);
1811 thunk_fndecl = thunk_sym->backend_decl;
1813 gfc_init_block (&body);
1815 /* Pass extra parameter identifying this entry point. */
1816 tmp = build_int_cst (gfc_array_index_type, el->id);
1817 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1818 string_args = NULL_TREE;
1820 if (thunk_sym->attr.function)
1822 if (gfc_return_by_reference (ns->proc_name))
1824 tree ref = DECL_ARGUMENTS (current_function_decl);
1825 args = tree_cons (NULL_TREE, ref, args);
1826 if (ns->proc_name->ts.type == BT_CHARACTER)
1827 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1832 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1834 /* Ignore alternate returns. */
1835 if (formal->sym == NULL)
1838 /* We don't have a clever way of identifying arguments, so resort to
1839 a brute-force search. */
1840 for (thunk_formal = thunk_sym->formal;
1842 thunk_formal = thunk_formal->next)
1844 if (thunk_formal->sym == formal->sym)
1850 /* Pass the argument. */
1851 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1852 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1854 if (formal->sym->ts.type == BT_CHARACTER)
1856 tmp = thunk_formal->sym->ts.cl->backend_decl;
1857 string_args = tree_cons (NULL_TREE, tmp, string_args);
1862 /* Pass NULL for a missing argument. */
1863 args = tree_cons (NULL_TREE, null_pointer_node, args);
1864 if (formal->sym->ts.type == BT_CHARACTER)
1866 tmp = build_int_cst (gfc_charlen_type_node, 0);
1867 string_args = tree_cons (NULL_TREE, tmp, string_args);
1872 /* Call the master function. */
1873 args = nreverse (args);
1874 args = chainon (args, nreverse (string_args));
1875 tmp = ns->proc_name->backend_decl;
1876 tmp = build_function_call_expr (tmp, args);
1877 if (ns->proc_name->attr.mixed_entry_master)
1879 tree union_decl, field;
1880 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1882 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1883 TREE_TYPE (master_type));
1884 DECL_ARTIFICIAL (union_decl) = 1;
1885 DECL_EXTERNAL (union_decl) = 0;
1886 TREE_PUBLIC (union_decl) = 0;
1887 TREE_USED (union_decl) = 1;
1888 layout_decl (union_decl, 0);
1889 pushdecl (union_decl);
1891 DECL_CONTEXT (union_decl) = current_function_decl;
1892 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1894 gfc_add_expr_to_block (&body, tmp);
1896 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1897 field; field = TREE_CHAIN (field))
1898 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1899 thunk_sym->result->name) == 0)
1901 gcc_assert (field != NULL_TREE);
1902 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1903 union_decl, field, NULL_TREE);
1904 tmp = fold_build2 (MODIFY_EXPR,
1905 TREE_TYPE (DECL_RESULT (current_function_decl)),
1906 DECL_RESULT (current_function_decl), tmp);
1907 tmp = build1_v (RETURN_EXPR, tmp);
1909 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1912 tmp = fold_build2 (MODIFY_EXPR,
1913 TREE_TYPE (DECL_RESULT (current_function_decl)),
1914 DECL_RESULT (current_function_decl), tmp);
1915 tmp = build1_v (RETURN_EXPR, tmp);
1917 gfc_add_expr_to_block (&body, tmp);
1919 /* Finish off this function and send it for code generation. */
1920 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1923 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1924 DECL_SAVED_TREE (thunk_fndecl)
1925 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1926 DECL_INITIAL (thunk_fndecl));
1928 /* Output the GENERIC tree. */
1929 dump_function (TDI_original, thunk_fndecl);
1931 /* Store the end of the function, so that we get good line number
1932 info for the epilogue. */
1933 cfun->function_end_locus = input_location;
1935 /* We're leaving the context of this function, so zap cfun.
1936 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1937 tree_rest_of_compilation. */
1940 current_function_decl = NULL_TREE;
1942 gfc_gimplify_function (thunk_fndecl);
1943 cgraph_finalize_function (thunk_fndecl, false);
1945 /* We share the symbols in the formal argument list with other entry
1946 points and the master function. Clear them so that they are
1947 recreated for each function. */
1948 for (formal = thunk_sym->formal; formal; formal = formal->next)
1949 if (formal->sym != NULL) /* Ignore alternate returns. */
1951 formal->sym->backend_decl = NULL_TREE;
1952 if (formal->sym->ts.type == BT_CHARACTER)
1953 formal->sym->ts.cl->backend_decl = NULL_TREE;
1956 if (thunk_sym->attr.function)
1958 if (thunk_sym->ts.type == BT_CHARACTER)
1959 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1960 if (thunk_sym->result->ts.type == BT_CHARACTER)
1961 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1965 gfc_set_backend_locus (&old_loc);
1969 /* Create a decl for a function, and create any thunks for alternate entry
1973 gfc_create_function_decl (gfc_namespace * ns)
1975 /* Create a declaration for the master function. */
1976 build_function_decl (ns->proc_name);
1978 /* Compile the entry thunks. */
1980 build_entry_thunks (ns);
1982 /* Now create the read argument list. */
1983 create_function_arglist (ns->proc_name);
1986 /* Return the decl used to hold the function return value. If
1987 parent_flag is set, the context is the parent_scope. */
1990 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1994 tree this_fake_result_decl;
1995 tree this_function_decl;
1997 char name[GFC_MAX_SYMBOL_LEN + 10];
2001 this_fake_result_decl = parent_fake_result_decl;
2002 this_function_decl = DECL_CONTEXT (current_function_decl);
2006 this_fake_result_decl = current_fake_result_decl;
2007 this_function_decl = current_function_decl;
2011 && sym->ns->proc_name->backend_decl == this_function_decl
2012 && sym->ns->proc_name->attr.entry_master
2013 && sym != sym->ns->proc_name)
2016 if (this_fake_result_decl != NULL)
2017 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2018 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2021 return TREE_VALUE (t);
2022 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2025 this_fake_result_decl = parent_fake_result_decl;
2027 this_fake_result_decl = current_fake_result_decl;
2029 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2033 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2034 field; field = TREE_CHAIN (field))
2035 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2039 gcc_assert (field != NULL_TREE);
2040 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2041 decl, field, NULL_TREE);
2044 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2046 gfc_add_decl_to_parent_function (var);
2048 gfc_add_decl_to_function (var);
2050 SET_DECL_VALUE_EXPR (var, decl);
2051 DECL_HAS_VALUE_EXPR_P (var) = 1;
2052 GFC_DECL_RESULT (var) = 1;
2054 TREE_CHAIN (this_fake_result_decl)
2055 = tree_cons (get_identifier (sym->name), var,
2056 TREE_CHAIN (this_fake_result_decl));
2060 if (this_fake_result_decl != NULL_TREE)
2061 return TREE_VALUE (this_fake_result_decl);
2063 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2068 if (sym->ts.type == BT_CHARACTER)
2070 if (sym->ts.cl->backend_decl == NULL_TREE)
2071 length = gfc_create_string_length (sym);
2073 length = sym->ts.cl->backend_decl;
2074 if (TREE_CODE (length) == VAR_DECL
2075 && DECL_CONTEXT (length) == NULL_TREE)
2076 gfc_add_decl_to_function (length);
2079 if (gfc_return_by_reference (sym))
2081 decl = DECL_ARGUMENTS (this_function_decl);
2083 if (sym->ns->proc_name->backend_decl == this_function_decl
2084 && sym->ns->proc_name->attr.entry_master)
2085 decl = TREE_CHAIN (decl);
2087 TREE_USED (decl) = 1;
2089 decl = gfc_build_dummy_array_decl (sym, decl);
2093 sprintf (name, "__result_%.20s",
2094 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2096 if (!sym->attr.mixed_entry_master && sym->attr.function)
2097 decl = build_decl (VAR_DECL, get_identifier (name),
2098 gfc_sym_type (sym));
2100 decl = build_decl (VAR_DECL, get_identifier (name),
2101 TREE_TYPE (TREE_TYPE (this_function_decl)));
2102 DECL_ARTIFICIAL (decl) = 1;
2103 DECL_EXTERNAL (decl) = 0;
2104 TREE_PUBLIC (decl) = 0;
2105 TREE_USED (decl) = 1;
2106 GFC_DECL_RESULT (decl) = 1;
2107 TREE_ADDRESSABLE (decl) = 1;
2109 layout_decl (decl, 0);
2112 gfc_add_decl_to_parent_function (decl);
2114 gfc_add_decl_to_function (decl);
2118 parent_fake_result_decl = build_tree_list (NULL, decl);
2120 current_fake_result_decl = build_tree_list (NULL, decl);
2126 /* Builds a function decl. The remaining parameters are the types of the
2127 function arguments. Negative nargs indicates a varargs function. */
2130 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2139 /* Library functions must be declared with global scope. */
2140 gcc_assert (current_function_decl == NULL_TREE);
2142 va_start (p, nargs);
2145 /* Create a list of the argument types. */
2146 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2148 argtype = va_arg (p, tree);
2149 arglist = gfc_chainon_list (arglist, argtype);
2154 /* Terminate the list. */
2155 arglist = gfc_chainon_list (arglist, void_type_node);
2158 /* Build the function type and decl. */
2159 fntype = build_function_type (rettype, arglist);
2160 fndecl = build_decl (FUNCTION_DECL, name, fntype);
2162 /* Mark this decl as external. */
2163 DECL_EXTERNAL (fndecl) = 1;
2164 TREE_PUBLIC (fndecl) = 1;
2170 rest_of_decl_compilation (fndecl, 1, 0);
2176 gfc_build_intrinsic_function_decls (void)
2178 tree gfc_int4_type_node = gfc_get_int_type (4);
2179 tree gfc_int8_type_node = gfc_get_int_type (8);
2180 tree gfc_int16_type_node = gfc_get_int_type (16);
2181 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2182 tree pchar1_type_node = gfc_get_pchar_type (1);
2183 tree pchar4_type_node = gfc_get_pchar_type (4);
2185 /* String functions. */
2186 gfor_fndecl_compare_string =
2187 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2188 integer_type_node, 4,
2189 gfc_charlen_type_node, pchar1_type_node,
2190 gfc_charlen_type_node, pchar1_type_node);
2192 gfor_fndecl_concat_string =
2193 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2195 gfc_charlen_type_node, pchar1_type_node,
2196 gfc_charlen_type_node, pchar1_type_node,
2197 gfc_charlen_type_node, pchar1_type_node);
2199 gfor_fndecl_string_len_trim =
2200 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2201 gfc_int4_type_node, 2,
2202 gfc_charlen_type_node, pchar1_type_node);
2204 gfor_fndecl_string_index =
2205 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2206 gfc_int4_type_node, 5,
2207 gfc_charlen_type_node, pchar1_type_node,
2208 gfc_charlen_type_node, pchar1_type_node,
2209 gfc_logical4_type_node);
2211 gfor_fndecl_string_scan =
2212 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2213 gfc_int4_type_node, 5,
2214 gfc_charlen_type_node, pchar1_type_node,
2215 gfc_charlen_type_node, pchar1_type_node,
2216 gfc_logical4_type_node);
2218 gfor_fndecl_string_verify =
2219 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2220 gfc_int4_type_node, 5,
2221 gfc_charlen_type_node, pchar1_type_node,
2222 gfc_charlen_type_node, pchar1_type_node,
2223 gfc_logical4_type_node);
2225 gfor_fndecl_string_trim =
2226 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2228 build_pointer_type (gfc_charlen_type_node),
2229 build_pointer_type (pchar1_type_node),
2230 gfc_charlen_type_node, pchar1_type_node);
2232 gfor_fndecl_string_minmax =
2233 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2235 build_pointer_type (gfc_charlen_type_node),
2236 build_pointer_type (pchar1_type_node),
2237 integer_type_node, integer_type_node);
2239 gfor_fndecl_adjustl =
2240 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2241 void_type_node, 3, pchar1_type_node,
2242 gfc_charlen_type_node, pchar1_type_node);
2244 gfor_fndecl_adjustr =
2245 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2246 void_type_node, 3, pchar1_type_node,
2247 gfc_charlen_type_node, pchar1_type_node);
2249 gfor_fndecl_select_string =
2250 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2251 integer_type_node, 4, pvoid_type_node,
2252 integer_type_node, pchar1_type_node,
2253 gfc_charlen_type_node);
2255 gfor_fndecl_compare_string_char4 =
2256 gfc_build_library_function_decl (get_identifier
2257 (PREFIX("compare_string_char4")),
2258 integer_type_node, 4,
2259 gfc_charlen_type_node, pchar4_type_node,
2260 gfc_charlen_type_node, pchar4_type_node);
2262 gfor_fndecl_concat_string_char4 =
2263 gfc_build_library_function_decl (get_identifier
2264 (PREFIX("concat_string_char4")),
2266 gfc_charlen_type_node, pchar4_type_node,
2267 gfc_charlen_type_node, pchar4_type_node,
2268 gfc_charlen_type_node, pchar4_type_node);
2270 gfor_fndecl_string_len_trim_char4 =
2271 gfc_build_library_function_decl (get_identifier
2272 (PREFIX("string_len_trim_char4")),
2273 gfc_charlen_type_node, 2,
2274 gfc_charlen_type_node, pchar4_type_node);
2276 gfor_fndecl_string_index_char4 =
2277 gfc_build_library_function_decl (get_identifier
2278 (PREFIX("string_index_char4")),
2279 gfc_charlen_type_node, 5,
2280 gfc_charlen_type_node, pchar4_type_node,
2281 gfc_charlen_type_node, pchar4_type_node,
2282 gfc_logical4_type_node);
2284 gfor_fndecl_string_scan_char4 =
2285 gfc_build_library_function_decl (get_identifier
2286 (PREFIX("string_scan_char4")),
2287 gfc_charlen_type_node, 5,
2288 gfc_charlen_type_node, pchar4_type_node,
2289 gfc_charlen_type_node, pchar4_type_node,
2290 gfc_logical4_type_node);
2292 gfor_fndecl_string_verify_char4 =
2293 gfc_build_library_function_decl (get_identifier
2294 (PREFIX("string_verify_char4")),
2295 gfc_charlen_type_node, 5,
2296 gfc_charlen_type_node, pchar4_type_node,
2297 gfc_charlen_type_node, pchar4_type_node,
2298 gfc_logical4_type_node);
2300 gfor_fndecl_string_trim_char4 =
2301 gfc_build_library_function_decl (get_identifier
2302 (PREFIX("string_trim_char4")),
2304 build_pointer_type (gfc_charlen_type_node),
2305 build_pointer_type (pchar4_type_node),
2306 gfc_charlen_type_node, pchar4_type_node);
2308 gfor_fndecl_string_minmax_char4 =
2309 gfc_build_library_function_decl (get_identifier
2310 (PREFIX("string_minmax_char4")),
2312 build_pointer_type (gfc_charlen_type_node),
2313 build_pointer_type (pchar4_type_node),
2314 integer_type_node, integer_type_node);
2316 gfor_fndecl_adjustl_char4 =
2317 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2318 void_type_node, 3, pchar4_type_node,
2319 gfc_charlen_type_node, pchar4_type_node);
2321 gfor_fndecl_adjustr_char4 =
2322 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2323 void_type_node, 3, pchar4_type_node,
2324 gfc_charlen_type_node, pchar4_type_node);
2326 gfor_fndecl_select_string_char4 =
2327 gfc_build_library_function_decl (get_identifier
2328 (PREFIX("select_string_char4")),
2329 integer_type_node, 4, pvoid_type_node,
2330 integer_type_node, pvoid_type_node,
2331 gfc_charlen_type_node);
2334 /* Conversion between character kinds. */
2336 gfor_fndecl_convert_char1_to_char4 =
2337 gfc_build_library_function_decl (get_identifier
2338 (PREFIX("convert_char1_to_char4")),
2340 build_pointer_type (pchar4_type_node),
2341 gfc_charlen_type_node, pchar1_type_node);
2343 gfor_fndecl_convert_char4_to_char1 =
2344 gfc_build_library_function_decl (get_identifier
2345 (PREFIX("convert_char4_to_char1")),
2347 build_pointer_type (pchar1_type_node),
2348 gfc_charlen_type_node, pchar4_type_node);
2350 /* Misc. functions. */
2352 gfor_fndecl_ttynam =
2353 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2357 gfc_charlen_type_node,
2361 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2365 gfc_charlen_type_node);
2368 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2372 gfc_charlen_type_node,
2373 gfc_int8_type_node);
2375 gfor_fndecl_sc_kind =
2376 gfc_build_library_function_decl (get_identifier
2377 (PREFIX("selected_char_kind")),
2378 gfc_int4_type_node, 2,
2379 gfc_charlen_type_node, pchar_type_node);
2381 gfor_fndecl_si_kind =
2382 gfc_build_library_function_decl (get_identifier
2383 (PREFIX("selected_int_kind")),
2384 gfc_int4_type_node, 1, pvoid_type_node);
2386 gfor_fndecl_sr_kind =
2387 gfc_build_library_function_decl (get_identifier
2388 (PREFIX("selected_real_kind")),
2389 gfc_int4_type_node, 2,
2390 pvoid_type_node, pvoid_type_node);
2392 /* Power functions. */
2394 tree ctype, rtype, itype, jtype;
2395 int rkind, ikind, jkind;
2398 static int ikinds[NIKINDS] = {4, 8, 16};
2399 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2400 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2402 for (ikind=0; ikind < NIKINDS; ikind++)
2404 itype = gfc_get_int_type (ikinds[ikind]);
2406 for (jkind=0; jkind < NIKINDS; jkind++)
2408 jtype = gfc_get_int_type (ikinds[jkind]);
2411 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2413 gfor_fndecl_math_powi[jkind][ikind].integer =
2414 gfc_build_library_function_decl (get_identifier (name),
2415 jtype, 2, jtype, itype);
2416 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2420 for (rkind = 0; rkind < NRKINDS; rkind ++)
2422 rtype = gfc_get_real_type (rkinds[rkind]);
2425 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2427 gfor_fndecl_math_powi[rkind][ikind].real =
2428 gfc_build_library_function_decl (get_identifier (name),
2429 rtype, 2, rtype, itype);
2430 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2433 ctype = gfc_get_complex_type (rkinds[rkind]);
2436 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2438 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2439 gfc_build_library_function_decl (get_identifier (name),
2440 ctype, 2,ctype, itype);
2441 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2449 gfor_fndecl_math_ishftc4 =
2450 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2452 3, gfc_int4_type_node,
2453 gfc_int4_type_node, gfc_int4_type_node);
2454 gfor_fndecl_math_ishftc8 =
2455 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2457 3, gfc_int8_type_node,
2458 gfc_int4_type_node, gfc_int4_type_node);
2459 if (gfc_int16_type_node)
2460 gfor_fndecl_math_ishftc16 =
2461 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2462 gfc_int16_type_node, 3,
2463 gfc_int16_type_node,
2465 gfc_int4_type_node);
2467 /* BLAS functions. */
2469 tree pint = build_pointer_type (integer_type_node);
2470 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2471 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2472 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2473 tree pz = build_pointer_type
2474 (gfc_get_complex_type (gfc_default_double_kind));
2476 gfor_fndecl_sgemm = gfc_build_library_function_decl
2478 (gfc_option.flag_underscoring ? "sgemm_"
2480 void_type_node, 15, pchar_type_node,
2481 pchar_type_node, pint, pint, pint, ps, ps, pint,
2482 ps, pint, ps, ps, pint, integer_type_node,
2484 gfor_fndecl_dgemm = gfc_build_library_function_decl
2486 (gfc_option.flag_underscoring ? "dgemm_"
2488 void_type_node, 15, pchar_type_node,
2489 pchar_type_node, pint, pint, pint, pd, pd, pint,
2490 pd, pint, pd, pd, pint, integer_type_node,
2492 gfor_fndecl_cgemm = gfc_build_library_function_decl
2494 (gfc_option.flag_underscoring ? "cgemm_"
2496 void_type_node, 15, pchar_type_node,
2497 pchar_type_node, pint, pint, pint, pc, pc, pint,
2498 pc, pint, pc, pc, pint, integer_type_node,
2500 gfor_fndecl_zgemm = gfc_build_library_function_decl
2502 (gfc_option.flag_underscoring ? "zgemm_"
2504 void_type_node, 15, pchar_type_node,
2505 pchar_type_node, pint, pint, pint, pz, pz, pint,
2506 pz, pint, pz, pz, pint, integer_type_node,
2510 /* Other functions. */
2512 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2513 gfc_array_index_type,
2514 1, pvoid_type_node);
2516 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2517 gfc_array_index_type,
2519 gfc_array_index_type);
2522 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2528 /* Make prototypes for runtime library functions. */
2531 gfc_build_builtin_function_decls (void)
2533 tree gfc_int4_type_node = gfc_get_int_type (4);
2535 gfor_fndecl_stop_numeric =
2536 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2537 void_type_node, 1, gfc_int4_type_node);
2538 /* Stop doesn't return. */
2539 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2541 gfor_fndecl_stop_string =
2542 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2543 void_type_node, 2, pchar_type_node,
2544 gfc_int4_type_node);
2545 /* Stop doesn't return. */
2546 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2548 gfor_fndecl_pause_numeric =
2549 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2550 void_type_node, 1, gfc_int4_type_node);
2552 gfor_fndecl_pause_string =
2553 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2554 void_type_node, 2, pchar_type_node,
2555 gfc_int4_type_node);
2557 gfor_fndecl_runtime_error =
2558 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2559 void_type_node, -1, pchar_type_node);
2560 /* The runtime_error function does not return. */
2561 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2563 gfor_fndecl_runtime_error_at =
2564 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2565 void_type_node, -2, pchar_type_node,
2567 /* The runtime_error_at function does not return. */
2568 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2570 gfor_fndecl_runtime_warning_at =
2571 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2572 void_type_node, -2, pchar_type_node,
2574 gfor_fndecl_generate_error =
2575 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2576 void_type_node, 3, pvoid_type_node,
2577 integer_type_node, pchar_type_node);
2579 gfor_fndecl_os_error =
2580 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2581 void_type_node, 1, pchar_type_node);
2582 /* The runtime_error function does not return. */
2583 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2585 gfor_fndecl_set_fpe =
2586 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2587 void_type_node, 1, integer_type_node);
2589 /* Keep the array dimension in sync with the call, later in this file. */
2590 gfor_fndecl_set_options =
2591 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2592 void_type_node, 2, integer_type_node,
2595 gfor_fndecl_set_convert =
2596 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2597 void_type_node, 1, integer_type_node);
2599 gfor_fndecl_set_record_marker =
2600 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2601 void_type_node, 1, integer_type_node);
2603 gfor_fndecl_set_max_subrecord_length =
2604 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2605 void_type_node, 1, integer_type_node);
2607 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2608 get_identifier (PREFIX("internal_pack")),
2609 pvoid_type_node, 1, pvoid_type_node);
2611 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2612 get_identifier (PREFIX("internal_unpack")),
2613 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2615 gfor_fndecl_associated =
2616 gfc_build_library_function_decl (
2617 get_identifier (PREFIX("associated")),
2618 integer_type_node, 2, ppvoid_type_node,
2621 gfc_build_intrinsic_function_decls ();
2622 gfc_build_intrinsic_lib_fndecls ();
2623 gfc_build_io_library_fndecls ();
2627 /* Evaluate the length of dummy character variables. */
2630 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2634 gfc_finish_decl (cl->backend_decl);
2636 gfc_start_block (&body);
2638 /* Evaluate the string length expression. */
2639 gfc_conv_string_length (cl, NULL, &body);
2641 gfc_trans_vla_type_sizes (sym, &body);
2643 gfc_add_expr_to_block (&body, fnbody);
2644 return gfc_finish_block (&body);
2648 /* Allocate and cleanup an automatic character variable. */
2651 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2657 gcc_assert (sym->backend_decl);
2658 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2660 gfc_start_block (&body);
2662 /* Evaluate the string length expression. */
2663 gfc_conv_string_length (sym->ts.cl, NULL, &body);
2665 gfc_trans_vla_type_sizes (sym, &body);
2667 decl = sym->backend_decl;
2669 /* Emit a DECL_EXPR for this variable, which will cause the
2670 gimplifier to allocate storage, and all that good stuff. */
2671 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2672 gfc_add_expr_to_block (&body, tmp);
2674 gfc_add_expr_to_block (&body, fnbody);
2675 return gfc_finish_block (&body);
2678 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2681 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2685 gcc_assert (sym->backend_decl);
2686 gfc_start_block (&body);
2688 /* Set the initial value to length. See the comments in
2689 function gfc_add_assign_aux_vars in this file. */
2690 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2691 build_int_cst (NULL_TREE, -2));
2693 gfc_add_expr_to_block (&body, fnbody);
2694 return gfc_finish_block (&body);
2698 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2700 tree t = *tp, var, val;
2702 if (t == NULL || t == error_mark_node)
2704 if (TREE_CONSTANT (t) || DECL_P (t))
2707 if (TREE_CODE (t) == SAVE_EXPR)
2709 if (SAVE_EXPR_RESOLVED_P (t))
2711 *tp = TREE_OPERAND (t, 0);
2714 val = TREE_OPERAND (t, 0);
2719 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2720 gfc_add_decl_to_function (var);
2721 gfc_add_modify (body, var, val);
2722 if (TREE_CODE (t) == SAVE_EXPR)
2723 TREE_OPERAND (t, 0) = var;
2728 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2732 if (type == NULL || type == error_mark_node)
2735 type = TYPE_MAIN_VARIANT (type);
2737 if (TREE_CODE (type) == INTEGER_TYPE)
2739 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2740 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2742 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2744 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2745 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2748 else if (TREE_CODE (type) == ARRAY_TYPE)
2750 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2751 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2752 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2753 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2755 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2757 TYPE_SIZE (t) = TYPE_SIZE (type);
2758 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2763 /* Make sure all type sizes and array domains are either constant,
2764 or variable or parameter decls. This is a simplified variant
2765 of gimplify_type_sizes, but we can't use it here, as none of the
2766 variables in the expressions have been gimplified yet.
2767 As type sizes and domains for various variable length arrays
2768 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2769 time, without this routine gimplify_type_sizes in the middle-end
2770 could result in the type sizes being gimplified earlier than where
2771 those variables are initialized. */
2774 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2776 tree type = TREE_TYPE (sym->backend_decl);
2778 if (TREE_CODE (type) == FUNCTION_TYPE
2779 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2781 if (! current_fake_result_decl)
2784 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2787 while (POINTER_TYPE_P (type))
2788 type = TREE_TYPE (type);
2790 if (GFC_DESCRIPTOR_TYPE_P (type))
2792 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2794 while (POINTER_TYPE_P (etype))
2795 etype = TREE_TYPE (etype);
2797 gfc_trans_vla_type_sizes_1 (etype, body);
2800 gfc_trans_vla_type_sizes_1 (type, body);
2804 /* Initialize a derived type by building an lvalue from the symbol
2805 and using trans_assignment to do the work. */
2807 gfc_init_default_dt (gfc_symbol * sym, tree body)
2809 stmtblock_t fnblock;
2814 gfc_init_block (&fnblock);
2815 gcc_assert (!sym->attr.allocatable);
2816 gfc_set_sym_referenced (sym);
2817 e = gfc_lval_expr_from_sym (sym);
2818 tmp = gfc_trans_assignment (e, sym->value, false);
2819 if (sym->attr.dummy)
2821 present = gfc_conv_expr_present (sym);
2822 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2823 tmp, build_empty_stmt ());
2825 gfc_add_expr_to_block (&fnblock, tmp);
2828 gfc_add_expr_to_block (&fnblock, body);
2829 return gfc_finish_block (&fnblock);
2833 /* Initialize INTENT(OUT) derived type dummies. As well as giving
2834 them their default initializer, if they do not have allocatable
2835 components, they have their allocatable components deallocated. */
2838 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2840 stmtblock_t fnblock;
2841 gfc_formal_arglist *f;
2845 gfc_init_block (&fnblock);
2846 for (f = proc_sym->formal; f; f = f->next)
2847 if (f->sym && f->sym->attr.intent == INTENT_OUT
2848 && f->sym->ts.type == BT_DERIVED)
2850 if (f->sym->ts.derived->attr.alloc_comp)
2852 tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2853 f->sym->backend_decl,
2854 f->sym->as ? f->sym->as->rank : 0);
2856 present = gfc_conv_expr_present (f->sym);
2857 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2858 tmp, build_empty_stmt ());
2860 gfc_add_expr_to_block (&fnblock, tmp);
2863 if (!f->sym->ts.derived->attr.alloc_comp
2865 body = gfc_init_default_dt (f->sym, body);
2868 gfc_add_expr_to_block (&fnblock, body);
2869 return gfc_finish_block (&fnblock);
2873 /* Generate function entry and exit code, and add it to the function body.
2875 Allocation and initialization of array variables.
2876 Allocation of character string variables.
2877 Initialization and possibly repacking of dummy arrays.
2878 Initialization of ASSIGN statement auxiliary variable. */
2881 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2885 gfc_formal_arglist *f;
2887 bool seen_trans_deferred_array = false;
2889 /* Deal with implicit return variables. Explicit return variables will
2890 already have been added. */
2891 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2893 if (!current_fake_result_decl)
2895 gfc_entry_list *el = NULL;
2896 if (proc_sym->attr.entry_master)
2898 for (el = proc_sym->ns->entries; el; el = el->next)
2899 if (el->sym != el->sym->result)
2902 /* TODO: move to the appropriate place in resolve.c. */
2903 if (warn_return_type && el == NULL)
2904 gfc_warning ("Return value of function '%s' at %L not set",
2905 proc_sym->name, &proc_sym->declared_at);
2907 else if (proc_sym->as)
2909 tree result = TREE_VALUE (current_fake_result_decl);
2910 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2912 /* An automatic character length, pointer array result. */
2913 if (proc_sym->ts.type == BT_CHARACTER
2914 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2915 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2918 else if (proc_sym->ts.type == BT_CHARACTER)
2920 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2921 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2925 gcc_assert (gfc_option.flag_f2c
2926 && proc_sym->ts.type == BT_COMPLEX);
2929 /* Initialize the INTENT(OUT) derived type dummy arguments. This
2930 should be done here so that the offsets and lbounds of arrays
2932 fnbody = init_intent_out_dt (proc_sym, fnbody);
2934 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2936 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2937 && sym->ts.derived->attr.alloc_comp;
2938 if (sym->attr.dimension)
2940 switch (sym->as->type)
2943 if (sym->attr.dummy || sym->attr.result)
2945 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2946 else if (sym->attr.pointer || sym->attr.allocatable)
2948 if (TREE_STATIC (sym->backend_decl))
2949 gfc_trans_static_array_pointer (sym);
2952 seen_trans_deferred_array = true;
2953 fnbody = gfc_trans_deferred_array (sym, fnbody);
2958 if (sym_has_alloc_comp)
2960 seen_trans_deferred_array = true;
2961 fnbody = gfc_trans_deferred_array (sym, fnbody);
2963 else if (sym->ts.type == BT_DERIVED
2966 && sym->attr.save == SAVE_NONE)
2967 fnbody = gfc_init_default_dt (sym, fnbody);
2969 gfc_get_backend_locus (&loc);
2970 gfc_set_backend_locus (&sym->declared_at);
2971 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2973 gfc_set_backend_locus (&loc);
2977 case AS_ASSUMED_SIZE:
2978 /* Must be a dummy parameter. */
2979 gcc_assert (sym->attr.dummy);
2981 /* We should always pass assumed size arrays the g77 way. */
2982 fnbody = gfc_trans_g77_array (sym, fnbody);
2985 case AS_ASSUMED_SHAPE:
2986 /* Must be a dummy parameter. */
2987 gcc_assert (sym->attr.dummy);
2989 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2994 seen_trans_deferred_array = true;
2995 fnbody = gfc_trans_deferred_array (sym, fnbody);
3001 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3002 fnbody = gfc_trans_deferred_array (sym, fnbody);
3004 else if (sym_has_alloc_comp)
3005 fnbody = gfc_trans_deferred_array (sym, fnbody);
3006 else if (sym->ts.type == BT_CHARACTER)
3008 gfc_get_backend_locus (&loc);
3009 gfc_set_backend_locus (&sym->declared_at);
3010 if (sym->attr.dummy || sym->attr.result)
3011 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
3013 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3014 gfc_set_backend_locus (&loc);
3016 else if (sym->attr.assign)
3018 gfc_get_backend_locus (&loc);
3019 gfc_set_backend_locus (&sym->declared_at);
3020 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3021 gfc_set_backend_locus (&loc);
3023 else if (sym->ts.type == BT_DERIVED
3026 && sym->attr.save == SAVE_NONE)
3027 fnbody = gfc_init_default_dt (sym, fnbody);
3032 gfc_init_block (&body);
3034 for (f = proc_sym->formal; f; f = f->next)
3036 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3038 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3039 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3040 gfc_trans_vla_type_sizes (f->sym, &body);
3044 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3045 && current_fake_result_decl != NULL)
3047 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3048 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3049 gfc_trans_vla_type_sizes (proc_sym, &body);
3052 gfc_add_expr_to_block (&body, fnbody);
3053 return gfc_finish_block (&body);
3056 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3058 /* Hash and equality functions for module_htab. */
3061 module_htab_do_hash (const void *x)
3063 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3067 module_htab_eq (const void *x1, const void *x2)
3069 return strcmp ((((const struct module_htab_entry *)x1)->name),
3070 (const char *)x2) == 0;
3073 /* Hash and equality functions for module_htab's decls. */
3076 module_htab_decls_hash (const void *x)
3078 const_tree t = (const_tree) x;
3079 const_tree n = DECL_NAME (t);
3081 n = TYPE_NAME (TREE_TYPE (t));
3082 return htab_hash_string (IDENTIFIER_POINTER (n));
3086 module_htab_decls_eq (const void *x1, const void *x2)
3088 const_tree t1 = (const_tree) x1;
3089 const_tree n1 = DECL_NAME (t1);
3090 if (n1 == NULL_TREE)
3091 n1 = TYPE_NAME (TREE_TYPE (t1));
3092 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3095 struct module_htab_entry *
3096 gfc_find_module (const char *name)
3101 module_htab = htab_create_ggc (10, module_htab_do_hash,
3102 module_htab_eq, NULL);
3104 slot = htab_find_slot_with_hash (module_htab, name,
3105 htab_hash_string (name), INSERT);
3108 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3110 entry->name = gfc_get_string (name);
3111 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3112 module_htab_decls_eq, NULL);
3113 *slot = (void *) entry;
3115 return (struct module_htab_entry *) *slot;
3119 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3124 if (DECL_NAME (decl))
3125 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3128 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3129 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3131 slot = htab_find_slot_with_hash (entry->decls, name,
3132 htab_hash_string (name), INSERT);
3134 *slot = (void *) decl;
3137 static struct module_htab_entry *cur_module;
3139 /* Output an initialized decl for a module variable. */
3142 gfc_create_module_variable (gfc_symbol * sym)
3146 /* Module functions with alternate entries are dealt with later and
3147 would get caught by the next condition. */
3148 if (sym->attr.entry)
3151 /* Make sure we convert the types of the derived types from iso_c_binding
3153 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3154 && sym->ts.type == BT_DERIVED)
3155 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3157 if (sym->attr.flavor == FL_DERIVED
3158 && sym->backend_decl
3159 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3161 decl = sym->backend_decl;
3162 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3163 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3164 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3165 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3166 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3167 == sym->ns->proc_name->backend_decl);
3168 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3169 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3170 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3173 /* Only output variables, procedure pointers and array valued,
3174 or derived type, parameters. */
3175 if (sym->attr.flavor != FL_VARIABLE
3176 && !(sym->attr.flavor == FL_PARAMETER
3177 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3178 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3181 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3183 decl = sym->backend_decl;
3184 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3185 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3186 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3187 gfc_module_add_decl (cur_module, decl);
3190 /* Don't generate variables from other modules. Variables from
3191 COMMONs will already have been generated. */
3192 if (sym->attr.use_assoc || sym->attr.in_common)
3195 /* Equivalenced variables arrive here after creation. */
3196 if (sym->backend_decl
3197 && (sym->equiv_built || sym->attr.in_equivalence))
3200 if (sym->backend_decl)
3201 internal_error ("backend decl for module variable %s already exists",
3204 /* We always want module variables to be created. */
3205 sym->attr.referenced = 1;
3206 /* Create the decl. */
3207 decl = gfc_get_symbol_decl (sym);
3209 /* Create the variable. */
3211 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3212 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3213 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3214 rest_of_decl_compilation (decl, 1, 0);
3215 gfc_module_add_decl (cur_module, decl);
3217 /* Also add length of strings. */
3218 if (sym->ts.type == BT_CHARACTER)
3222 length = sym->ts.cl->backend_decl;
3223 if (!INTEGER_CST_P (length))
3226 rest_of_decl_compilation (length, 1, 0);
3231 /* Emit debug information for USE statements. */
3234 gfc_trans_use_stmts (gfc_namespace * ns)
3236 gfc_use_list *use_stmt;
3237 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3239 struct module_htab_entry *entry
3240 = gfc_find_module (use_stmt->module_name);
3241 gfc_use_rename *rent;
3243 if (entry->namespace_decl == NULL)
3245 entry->namespace_decl
3246 = build_decl (NAMESPACE_DECL,
3247 get_identifier (use_stmt->module_name),
3249 DECL_EXTERNAL (entry->namespace_decl) = 1;
3251 gfc_set_backend_locus (&use_stmt->where);
3252 if (!use_stmt->only_flag)
3253 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3255 ns->proc_name->backend_decl,
3257 for (rent = use_stmt->rename; rent; rent = rent->next)
3259 tree decl, local_name;
3262 if (rent->op != INTRINSIC_NONE)
3265 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3266 htab_hash_string (rent->use_name),
3272 st = gfc_find_symtree (ns->sym_root,
3274 ? rent->local_name : rent->use_name);
3275 gcc_assert (st && st->n.sym->attr.use_assoc);
3276 if (st->n.sym->backend_decl
3277 && DECL_P (st->n.sym->backend_decl)
3278 && st->n.sym->module
3279 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3281 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3282 || (TREE_CODE (st->n.sym->backend_decl)
3284 decl = copy_node (st->n.sym->backend_decl);
3285 DECL_CONTEXT (decl) = entry->namespace_decl;
3286 DECL_EXTERNAL (decl) = 1;
3287 DECL_IGNORED_P (decl) = 0;
3288 DECL_INITIAL (decl) = NULL_TREE;
3292 *slot = error_mark_node;
3293 htab_clear_slot (entry->decls, slot);
3298 decl = (tree) *slot;
3299 if (rent->local_name[0])
3300 local_name = get_identifier (rent->local_name);
3302 local_name = NULL_TREE;
3303 gfc_set_backend_locus (&rent->where);
3304 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3305 ns->proc_name->backend_decl,
3306 !use_stmt->only_flag);
3312 /* Return true if expr is a constant initializer that gfc_conv_initializer
3316 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3326 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3328 else if (expr->expr_type == EXPR_STRUCTURE)
3329 return check_constant_initializer (expr, ts, false, false);
3330 else if (expr->expr_type != EXPR_ARRAY)
3332 for (c = expr->value.constructor; c; c = c->next)
3336 if (c->expr->expr_type == EXPR_STRUCTURE)
3338 if (!check_constant_initializer (c->expr, ts, false, false))
3341 else if (c->expr->expr_type != EXPR_CONSTANT)
3346 else switch (ts->type)
3349 if (expr->expr_type != EXPR_STRUCTURE)
3351 cm = expr->ts.derived->components;
3352 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3354 if (!c->expr || cm->attr.allocatable)
3356 if (!check_constant_initializer (c->expr, &cm->ts,
3363 return expr->expr_type == EXPR_CONSTANT;
3367 /* Emit debug info for parameters and unreferenced variables with
3371 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3375 if (sym->attr.flavor != FL_PARAMETER
3376 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3379 if (sym->backend_decl != NULL
3380 || sym->value == NULL
3381 || sym->attr.use_assoc
3384 || sym->attr.function
3385 || sym->attr.intrinsic
3386 || sym->attr.pointer
3387 || sym->attr.allocatable
3388 || sym->attr.cray_pointee
3389 || sym->attr.threadprivate
3390 || sym->attr.is_bind_c
3391 || sym->attr.subref_array_pointer
3392 || sym->attr.assign)
3395 if (sym->ts.type == BT_CHARACTER)
3397 gfc_conv_const_charlen (sym->ts.cl);
3398 if (sym->ts.cl->backend_decl == NULL
3399 || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3402 else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3409 if (sym->as->type != AS_EXPLICIT)
3411 for (n = 0; n < sym->as->rank; n++)
3412 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3413 || sym->as->upper[n] == NULL
3414 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3418 if (!check_constant_initializer (sym->value, &sym->ts,
3419 sym->attr.dimension, false))
3422 /* Create the decl for the variable or constant. */
3423 decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3424 gfc_sym_identifier (sym), gfc_sym_type (sym));
3425 if (sym->attr.flavor == FL_PARAMETER)
3426 TREE_READONLY (decl) = 1;
3427 gfc_set_decl_location (decl, &sym->declared_at);
3428 if (sym->attr.dimension)
3429 GFC_DECL_PACKED_ARRAY (decl) = 1;
3430 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3431 TREE_STATIC (decl) = 1;
3432 TREE_USED (decl) = 1;
3433 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3434 TREE_PUBLIC (decl) = 1;
3436 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3437 sym->attr.dimension, 0);
3438 debug_hooks->global_decl (decl);
3441 /* Generate all the required code for module variables. */
3444 gfc_generate_module_vars (gfc_namespace * ns)
3446 module_namespace = ns;
3447 cur_module = gfc_find_module (ns->proc_name->name);
3449 /* Check if the frontend left the namespace in a reasonable state. */
3450 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3452 /* Generate COMMON blocks. */
3453 gfc_trans_common (ns);
3455 /* Create decls for all the module variables. */
3456 gfc_traverse_ns (ns, gfc_create_module_variable);
3460 gfc_trans_use_stmts (ns);
3461 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3466 gfc_generate_contained_functions (gfc_namespace * parent)
3470 /* We create all the prototypes before generating any code. */
3471 for (ns = parent->contained; ns; ns = ns->sibling)
3473 /* Skip namespaces from used modules. */
3474 if (ns->parent != parent)
3477 gfc_create_function_decl (ns);
3480 for (ns = parent->contained; ns; ns = ns->sibling)
3482 /* Skip namespaces from used modules. */
3483 if (ns->parent != parent)
3486 gfc_generate_function_code (ns);
3491 /* Drill down through expressions for the array specification bounds and
3492 character length calling generate_local_decl for all those variables
3493 that have not already been declared. */
3496 generate_local_decl (gfc_symbol *);
3498 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3501 expr_decls (gfc_expr *e, gfc_symbol *sym,
3502 int *f ATTRIBUTE_UNUSED)
3504 if (e->expr_type != EXPR_VARIABLE
3505 || sym == e->symtree->n.sym
3506 || e->symtree->n.sym->mark
3507 || e->symtree->n.sym->ns != sym->ns)
3510 generate_local_decl (e->symtree->n.sym);
3515 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3517 gfc_traverse_expr (e, sym, expr_decls, 0);
3521 /* Check for dependencies in the character length and array spec. */
3524 generate_dependency_declarations (gfc_symbol *sym)
3528 if (sym->ts.type == BT_CHARACTER
3530 && sym->ts.cl->length
3531 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3532 generate_expr_decls (sym, sym->ts.cl->length);
3534 if (sym->as && sym->as->rank)
3536 for (i = 0; i < sym->as->rank; i++)
3538 generate_expr_decls (sym, sym->as->lower[i]);
3539 generate_expr_decls (sym, sym->as->upper[i]);
3545 /* Generate decls for all local variables. We do this to ensure correct
3546 handling of expressions which only appear in the specification of
3550 generate_local_decl (gfc_symbol * sym)
3552 if (sym->attr.flavor == FL_VARIABLE)
3554 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3555 generate_dependency_declarations (sym);
3557 if (sym->attr.referenced)
3558 gfc_get_symbol_decl (sym);
3559 /* INTENT(out) dummy arguments are likely meant to be set. */
3560 else if (warn_unused_variable
3562 && sym->attr.intent == INTENT_OUT)
3563 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3564 sym->name, &sym->declared_at);
3565 /* Specific warning for unused dummy arguments. */
3566 else if (warn_unused_variable && sym->attr.dummy)
3567 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3569 /* Warn for unused variables, but not if they're inside a common
3570 block or are use-associated. */
3571 else if (warn_unused_variable
3572 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3573 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3576 /* For variable length CHARACTER parameters, the PARM_DECL already
3577 references the length variable, so force gfc_get_symbol_decl
3578 even when not referenced. If optimize > 0, it will be optimized
3579 away anyway. But do this only after emitting -Wunused-parameter
3580 warning if requested. */
3581 if (sym->attr.dummy && !sym->attr.referenced
3582 && sym->ts.type == BT_CHARACTER
3583 && sym->ts.cl->backend_decl != NULL
3584 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3586 sym->attr.referenced = 1;
3587 gfc_get_symbol_decl (sym);
3590 /* INTENT(out) dummy arguments with allocatable components are reset
3591 by default and need to be set referenced to generate the code for
3592 automatic lengths. */
3593 if (sym->attr.dummy && !sym->attr.referenced
3594 && sym->ts.type == BT_DERIVED
3595 && sym->ts.derived->attr.alloc_comp
3596 && sym->attr.intent == INTENT_OUT)
3598 sym->attr.referenced = 1;
3599 gfc_get_symbol_decl (sym);
3603 /* Check for dependencies in the array specification and string
3604 length, adding the necessary declarations to the function. We
3605 mark the symbol now, as well as in traverse_ns, to prevent
3606 getting stuck in a circular dependency. */
3609 /* We do not want the middle-end to warn about unused parameters
3610 as this was already done above. */
3611 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3612 TREE_NO_WARNING(sym->backend_decl) = 1;
3614 else if (sym->attr.flavor == FL_PARAMETER)
3616 if (warn_unused_parameter
3617 && !sym->attr.referenced
3618 && !sym->attr.use_assoc)
3619 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3622 else if (sym->attr.flavor == FL_PROCEDURE)
3624 /* TODO: move to the appropriate place in resolve.c. */
3625 if (warn_return_type
3626 && sym->attr.function
3628 && sym != sym->result
3629 && !sym->result->attr.referenced
3630 && !sym->attr.use_assoc
3631 && sym->attr.if_source != IFSRC_IFBODY)
3633 gfc_warning ("Return value '%s' of function '%s' declared at "
3634 "%L not set", sym->result->name, sym->name,
3635 &sym->result->declared_at);
3637 /* Prevents "Unused variable" warning for RESULT variables. */
3638 sym->result->mark = 1;
3642 if (sym->attr.dummy == 1)
3644 /* Modify the tree type for scalar character dummy arguments of bind(c)
3645 procedures if they are passed by value. The tree type for them will
3646 be promoted to INTEGER_TYPE for the middle end, which appears to be
3647 what C would do with characters passed by-value. The value attribute
3648 implies the dummy is a scalar. */
3649 if (sym->attr.value == 1 && sym->backend_decl != NULL
3650 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3651 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3652 gfc_conv_scalar_char_value (sym, NULL, NULL);
3655 /* Make sure we convert the types of the derived types from iso_c_binding
3657 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3658 && sym->ts.type == BT_DERIVED)
3659 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3663 generate_local_vars (gfc_namespace * ns)
3665 gfc_traverse_ns (ns, generate_local_decl);
3669 /* Generate a switch statement to jump to the correct entry point. Also
3670 creates the label decls for the entry points. */
3673 gfc_trans_entry_master_switch (gfc_entry_list * el)
3680 gfc_init_block (&block);
3681 for (; el; el = el->next)
3683 /* Add the case label. */
3684 label = gfc_build_label_decl (NULL_TREE);
3685 val = build_int_cst (gfc_array_index_type, el->id);
3686 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3687 gfc_add_expr_to_block (&block, tmp);
3689 /* And jump to the actual entry point. */
3690 label = gfc_build_label_decl (NULL_TREE);
3691 tmp = build1_v (GOTO_EXPR, label);
3692 gfc_add_expr_to_block (&block, tmp);
3694 /* Save the label decl. */
3697 tmp = gfc_finish_block (&block);
3698 /* The first argument selects the entry point. */
3699 val = DECL_ARGUMENTS (current_function_decl);
3700 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3705 /* Generate code for a function. */
3708 gfc_generate_function_code (gfc_namespace * ns)
3718 tree recurcheckvar = NULL;
3722 sym = ns->proc_name;
3724 /* Check that the frontend isn't still using this. */
3725 gcc_assert (sym->tlink == NULL);
3728 /* Create the declaration for functions with global scope. */
3729 if (!sym->backend_decl)
3730 gfc_create_function_decl (ns);
3732 fndecl = sym->backend_decl;
3733 old_context = current_function_decl;
3737 push_function_context ();
3738 saved_parent_function_decls = saved_function_decls;
3739 saved_function_decls = NULL_TREE;
3742 trans_function_start (sym);
3744 gfc_init_block (&block);
3746 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3748 /* Copy length backend_decls to all entry point result
3753 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3754 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3755 for (el = ns->entries; el; el = el->next)
3756 el->sym->result->ts.cl->backend_decl = backend_decl;
3759 /* Translate COMMON blocks. */
3760 gfc_trans_common (ns);
3762 /* Null the parent fake result declaration if this namespace is
3763 a module function or an external procedures. */
3764 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3765 || ns->parent == NULL)
3766 parent_fake_result_decl = NULL_TREE;
3768 gfc_generate_contained_functions (ns);
3770 generate_local_vars (ns);
3772 /* Keep the parent fake result declaration in module functions
3773 or external procedures. */
3774 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3775 || ns->parent == NULL)
3776 current_fake_result_decl = parent_fake_result_decl;
3778 current_fake_result_decl = NULL_TREE;
3780 current_function_return_label = NULL;
3782 /* Now generate the code for the body of this function. */
3783 gfc_init_block (&body);
3785 /* If this is the main program, add a call to set_options to set up the
3786 runtime library Fortran language standard parameters. */
3787 if (sym->attr.is_main_program)
3789 tree array_type, array, var;
3791 /* Passing a new option to the library requires four modifications:
3792 + add it to the tree_cons list below
3793 + change the array size in the call to build_array_type
3794 + change the first argument to the library call
3795 gfor_fndecl_set_options
3796 + modify the library (runtime/compile_options.c)! */
3797 array = tree_cons (NULL_TREE,
3798 build_int_cst (integer_type_node,
3799 gfc_option.warn_std), NULL_TREE);
3800 array = tree_cons (NULL_TREE,
3801 build_int_cst (integer_type_node,
3802 gfc_option.allow_std), array);
3803 array = tree_cons (NULL_TREE,
3804 build_int_cst (integer_type_node, pedantic), array);
3805 array = tree_cons (NULL_TREE,
3806 build_int_cst (integer_type_node,
3807 gfc_option.flag_dump_core), array);
3808 array = tree_cons (NULL_TREE,
3809 build_int_cst (integer_type_node,
3810 gfc_option.flag_backtrace), array);
3811 array = tree_cons (NULL_TREE,
3812 build_int_cst (integer_type_node,
3813 gfc_option.flag_sign_zero), array);
3815 array = tree_cons (NULL_TREE,
3816 build_int_cst (integer_type_node,
3818 & GFC_RTCHECK_BOUNDS)), array);
3820 array = tree_cons (NULL_TREE,
3821 build_int_cst (integer_type_node,
3822 gfc_option.flag_range_check), array);
3824 array_type = build_array_type (integer_type_node,
3825 build_index_type (build_int_cst (NULL_TREE,
3827 array = build_constructor_from_list (array_type, nreverse (array));
3828 TREE_CONSTANT (array) = 1;
3829 TREE_STATIC (array) = 1;
3831 /* Create a static variable to hold the jump table. */
3832 var = gfc_create_var (array_type, "options");
3833 TREE_CONSTANT (var) = 1;
3834 TREE_STATIC (var) = 1;
3835 TREE_READONLY (var) = 1;
3836 DECL_INITIAL (var) = array;
3837 var = gfc_build_addr_expr (pvoid_type_node, var);
3839 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3840 build_int_cst (integer_type_node, 8), var);
3841 gfc_add_expr_to_block (&body, tmp);
3844 /* If this is the main program and a -ffpe-trap option was provided,
3845 add a call to set_fpe so that the library will raise a FPE when
3847 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3849 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3850 build_int_cst (integer_type_node,
3852 gfc_add_expr_to_block (&body, tmp);
3855 /* If this is the main program and an -fconvert option was provided,
3856 add a call to set_convert. */
3858 if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3860 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3861 build_int_cst (integer_type_node,
3862 gfc_option.convert));
3863 gfc_add_expr_to_block (&body, tmp);
3866 /* If this is the main program and an -frecord-marker option was provided,
3867 add a call to set_record_marker. */
3869 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3871 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3872 build_int_cst (integer_type_node,
3873 gfc_option.record_marker));
3874 gfc_add_expr_to_block (&body, tmp);
3877 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3879 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3881 build_int_cst (integer_type_node,
3882 gfc_option.max_subrecord_length));
3883 gfc_add_expr_to_block (&body, tmp);
3886 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive)
3890 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
3892 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
3893 TREE_STATIC (recurcheckvar) = 1;
3894 DECL_INITIAL (recurcheckvar) = boolean_false_node;
3895 gfc_add_expr_to_block (&block, recurcheckvar);
3896 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
3897 &sym->declared_at, msg);
3898 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
3902 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3903 && sym->attr.subroutine)
3905 tree alternate_return;
3906 alternate_return = gfc_get_fake_result_decl (sym, 0);
3907 gfc_add_modify (&body, alternate_return, integer_zero_node);
3912 /* Jump to the correct entry point. */
3913 tmp = gfc_trans_entry_master_switch (ns->entries);
3914 gfc_add_expr_to_block (&body, tmp);
3917 tmp = gfc_trans_code (ns->code);
3918 gfc_add_expr_to_block (&body, tmp);
3920 /* Add a return label if needed. */
3921 if (current_function_return_label)
3923 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3924 gfc_add_expr_to_block (&body, tmp);
3927 tmp = gfc_finish_block (&body);
3928 /* Add code to create and cleanup arrays. */
3929 tmp = gfc_trans_deferred_vars (sym, tmp);
3931 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3933 if (sym->attr.subroutine || sym == sym->result)
3935 if (current_fake_result_decl != NULL)
3936 result = TREE_VALUE (current_fake_result_decl);
3939 current_fake_result_decl = NULL_TREE;
3942 result = sym->result->backend_decl;
3944 if (result != NULL_TREE && sym->attr.function
3945 && sym->ts.type == BT_DERIVED
3946 && sym->ts.derived->attr.alloc_comp
3947 && !sym->attr.pointer)
3949 rank = sym->as ? sym->as->rank : 0;
3950 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3951 gfc_add_expr_to_block (&block, tmp2);
3954 gfc_add_expr_to_block (&block, tmp);
3956 if (result == NULL_TREE)
3958 /* TODO: move to the appropriate place in resolve.c. */
3959 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
3960 gfc_warning ("Return value of function '%s' at %L not set",
3961 sym->name, &sym->declared_at);
3963 TREE_NO_WARNING(sym->backend_decl) = 1;
3967 /* Set the return value to the dummy result variable. The
3968 types may be different for scalar default REAL functions
3969 with -ff2c, therefore we have to convert. */
3970 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3971 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3972 DECL_RESULT (fndecl), tmp);
3973 tmp = build1_v (RETURN_EXPR, tmp);
3974 gfc_add_expr_to_block (&block, tmp);
3978 gfc_add_expr_to_block (&block, tmp);
3980 /* Reset recursion-check variable. */
3981 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive)
3982 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
3984 /* Add all the decls we created during processing. */
3985 decl = saved_function_decls;
3990 next = TREE_CHAIN (decl);
3991 TREE_CHAIN (decl) = NULL_TREE;
3995 saved_function_decls = NULL_TREE;
3997 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4000 /* Finish off this function and send it for code generation. */
4002 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4004 DECL_SAVED_TREE (fndecl)
4005 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4006 DECL_INITIAL (fndecl));
4008 /* Output the GENERIC tree. */
4009 dump_function (TDI_original, fndecl);
4011 /* Store the end of the function, so that we get good line number
4012 info for the epilogue. */
4013 cfun->function_end_locus = input_location;
4015 /* We're leaving the context of this function, so zap cfun.
4016 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4017 tree_rest_of_compilation. */
4022 pop_function_context ();
4023 saved_function_decls = saved_parent_function_decls;
4025 current_function_decl = old_context;
4027 if (decl_function_context (fndecl))
4028 /* Register this function with cgraph just far enough to get it
4029 added to our parent's nested function list. */
4030 (void) cgraph_node (fndecl);
4033 gfc_gimplify_function (fndecl);
4034 cgraph_finalize_function (fndecl, false);
4037 gfc_trans_use_stmts (ns);
4038 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4042 gfc_generate_constructors (void)
4044 gcc_assert (gfc_static_ctors == NULL_TREE);
4052 if (gfc_static_ctors == NULL_TREE)
4055 fnname = get_file_function_name ("I");
4056 type = build_function_type (void_type_node,
4057 gfc_chainon_list (NULL_TREE, void_type_node));
4059 fndecl = build_decl (FUNCTION_DECL, fnname, type);
4060 TREE_PUBLIC (fndecl) = 1;
4062 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
4063 DECL_ARTIFICIAL (decl) = 1;
4064 DECL_IGNORED_P (decl) = 1;
4065 DECL_CONTEXT (decl) = fndecl;
4066 DECL_RESULT (fndecl) = decl;
4070 current_function_decl = fndecl;
4072 rest_of_decl_compilation (fndecl, 1, 0);
4074 make_decl_rtl (fndecl);
4076 init_function_start (fndecl);
4080 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4082 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4083 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4089 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4090 DECL_SAVED_TREE (fndecl)
4091 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4092 DECL_INITIAL (fndecl));
4094 free_after_parsing (cfun);
4095 free_after_compilation (cfun);
4097 tree_rest_of_compilation (fndecl);
4099 current_function_decl = NULL_TREE;
4103 /* Translates a BLOCK DATA program unit. This means emitting the
4104 commons contained therein plus their initializations. We also emit
4105 a globally visible symbol to make sure that each BLOCK DATA program
4106 unit remains unique. */
4109 gfc_generate_block_data (gfc_namespace * ns)
4114 /* Tell the backend the source location of the block data. */
4116 gfc_set_backend_locus (&ns->proc_name->declared_at);
4118 gfc_set_backend_locus (&gfc_current_locus);
4120 /* Process the DATA statements. */
4121 gfc_trans_common (ns);
4123 /* Create a global symbol with the mane of the block data. This is to
4124 generate linker errors if the same name is used twice. It is never
4127 id = gfc_sym_mangled_function_id (ns->proc_name);
4129 id = get_identifier ("__BLOCK_DATA__");
4131 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4132 TREE_PUBLIC (decl) = 1;
4133 TREE_STATIC (decl) = 1;
4134 DECL_IGNORED_P (decl) = 1;
4137 rest_of_decl_compilation (decl, 1, 0);
4141 #include "gt-fortran-trans-decl.h"