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'. */
1225 if (sym->backend_decl)
1226 return sym->backend_decl;
1228 /* We should never be creating external decls for alternate entry points.
1229 The procedure may be an alternate entry point, but we don't want/need
1231 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1233 if (sym->attr.proc_pointer)
1234 return get_proc_pointer_decl (sym);
1236 if (sym->attr.intrinsic)
1238 /* Call the resolution function to get the actual name. This is
1239 a nasty hack which relies on the resolution functions only looking
1240 at the first argument. We pass NULL for the second argument
1241 otherwise things like AINT get confused. */
1242 isym = gfc_find_function (sym->name);
1243 gcc_assert (isym->resolve.f0 != NULL);
1245 memset (&e, 0, sizeof (e));
1246 e.expr_type = EXPR_FUNCTION;
1248 memset (&argexpr, 0, sizeof (argexpr));
1249 gcc_assert (isym->formal);
1250 argexpr.ts = isym->formal->ts;
1252 if (isym->formal->next == NULL)
1253 isym->resolve.f1 (&e, &argexpr);
1256 if (isym->formal->next->next == NULL)
1257 isym->resolve.f2 (&e, &argexpr, NULL);
1260 if (isym->formal->next->next->next == NULL)
1261 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1264 /* All specific intrinsics take less than 5 arguments. */
1265 gcc_assert (isym->formal->next->next->next->next == NULL);
1266 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1271 if (gfc_option.flag_f2c
1272 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1273 || e.ts.type == BT_COMPLEX))
1275 /* Specific which needs a different implementation if f2c
1276 calling conventions are used. */
1277 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1280 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1282 name = get_identifier (s);
1283 mangled_name = name;
1287 name = gfc_sym_identifier (sym);
1288 mangled_name = gfc_sym_mangled_function_id (sym);
1291 type = gfc_get_function_type (sym);
1292 fndecl = build_decl (FUNCTION_DECL, name, type);
1294 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1295 /* If the return type is a pointer, avoid alias issues by setting
1296 DECL_IS_MALLOC to nonzero. This means that the function should be
1297 treated as if it were a malloc, meaning it returns a pointer that
1299 if (POINTER_TYPE_P (type))
1300 DECL_IS_MALLOC (fndecl) = 1;
1302 /* Set the context of this decl. */
1303 if (0 && sym->ns && sym->ns->proc_name)
1305 /* TODO: Add external decls to the appropriate scope. */
1306 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1310 /* Global declaration, e.g. intrinsic subroutine. */
1311 DECL_CONTEXT (fndecl) = NULL_TREE;
1314 DECL_EXTERNAL (fndecl) = 1;
1316 /* This specifies if a function is globally addressable, i.e. it is
1317 the opposite of declaring static in C. */
1318 TREE_PUBLIC (fndecl) = 1;
1320 /* Set attributes for PURE functions. A call to PURE function in the
1321 Fortran 95 sense is both pure and without side effects in the C
1323 if (sym->attr.pure || sym->attr.elemental)
1325 if (sym->attr.function && !gfc_return_by_reference (sym))
1326 DECL_PURE_P (fndecl) = 1;
1327 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1328 parameters and don't use alternate returns (is this
1329 allowed?). In that case, calls to them are meaningless, and
1330 can be optimized away. See also in build_function_decl(). */
1331 TREE_SIDE_EFFECTS (fndecl) = 0;
1334 /* Mark non-returning functions. */
1335 if (sym->attr.noreturn)
1336 TREE_THIS_VOLATILE(fndecl) = 1;
1338 sym->backend_decl = fndecl;
1340 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1341 pushdecl_top_level (fndecl);
1347 /* Create a declaration for a procedure. For external functions (in the C
1348 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1349 a master function with alternate entry points. */
1352 build_function_decl (gfc_symbol * sym)
1355 symbol_attribute attr;
1357 gfc_formal_arglist *f;
1359 gcc_assert (!sym->backend_decl);
1360 gcc_assert (!sym->attr.external);
1362 /* Set the line and filename. sym->declared_at seems to point to the
1363 last statement for subroutines, but it'll do for now. */
1364 gfc_set_backend_locus (&sym->declared_at);
1366 /* Allow only one nesting level. Allow public declarations. */
1367 gcc_assert (current_function_decl == NULL_TREE
1368 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1369 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1372 type = gfc_get_function_type (sym);
1373 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1375 /* Perform name mangling if this is a top level or module procedure. */
1376 if (current_function_decl == NULL_TREE)
1377 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1379 /* Figure out the return type of the declared function, and build a
1380 RESULT_DECL for it. If this is a subroutine with alternate
1381 returns, build a RESULT_DECL for it. */
1384 result_decl = NULL_TREE;
1385 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1388 if (gfc_return_by_reference (sym))
1389 type = void_type_node;
1392 if (sym->result != sym)
1393 result_decl = gfc_sym_identifier (sym->result);
1395 type = TREE_TYPE (TREE_TYPE (fndecl));
1400 /* Look for alternate return placeholders. */
1401 int has_alternate_returns = 0;
1402 for (f = sym->formal; f; f = f->next)
1406 has_alternate_returns = 1;
1411 if (has_alternate_returns)
1412 type = integer_type_node;
1414 type = void_type_node;
1417 result_decl = build_decl (RESULT_DECL, result_decl, type);
1418 DECL_ARTIFICIAL (result_decl) = 1;
1419 DECL_IGNORED_P (result_decl) = 1;
1420 DECL_CONTEXT (result_decl) = fndecl;
1421 DECL_RESULT (fndecl) = result_decl;
1423 /* Don't call layout_decl for a RESULT_DECL.
1424 layout_decl (result_decl, 0); */
1426 /* If the return type is a pointer, avoid alias issues by setting
1427 DECL_IS_MALLOC to nonzero. This means that the function should be
1428 treated as if it were a malloc, meaning it returns a pointer that
1430 if (POINTER_TYPE_P (type))
1431 DECL_IS_MALLOC (fndecl) = 1;
1433 /* Set up all attributes for the function. */
1434 DECL_CONTEXT (fndecl) = current_function_decl;
1435 DECL_EXTERNAL (fndecl) = 0;
1437 /* This specifies if a function is globally visible, i.e. it is
1438 the opposite of declaring static in C. */
1439 if (DECL_CONTEXT (fndecl) == NULL_TREE
1440 && !sym->attr.entry_master)
1441 TREE_PUBLIC (fndecl) = 1;
1443 /* TREE_STATIC means the function body is defined here. */
1444 TREE_STATIC (fndecl) = 1;
1446 /* Set attributes for PURE functions. A call to a PURE function in the
1447 Fortran 95 sense is both pure and without side effects in the C
1449 if (attr.pure || attr.elemental)
1451 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1452 including an alternate return. In that case it can also be
1453 marked as PURE. See also in gfc_get_extern_function_decl(). */
1454 if (attr.function && !gfc_return_by_reference (sym))
1455 DECL_PURE_P (fndecl) = 1;
1456 TREE_SIDE_EFFECTS (fndecl) = 0;
1459 /* For -fwhole-program to work well, the main program needs to have the
1460 "externally_visible" attribute. */
1461 if (attr.is_main_program)
1462 DECL_ATTRIBUTES (fndecl)
1463 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
1465 /* Layout the function declaration and put it in the binding level
1466 of the current function. */
1469 sym->backend_decl = fndecl;
1473 /* Create the DECL_ARGUMENTS for a procedure. */
1476 create_function_arglist (gfc_symbol * sym)
1479 gfc_formal_arglist *f;
1480 tree typelist, hidden_typelist;
1481 tree arglist, hidden_arglist;
1485 fndecl = sym->backend_decl;
1487 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1488 the new FUNCTION_DECL node. */
1489 arglist = NULL_TREE;
1490 hidden_arglist = NULL_TREE;
1491 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1493 if (sym->attr.entry_master)
1495 type = TREE_VALUE (typelist);
1496 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1498 DECL_CONTEXT (parm) = fndecl;
1499 DECL_ARG_TYPE (parm) = type;
1500 TREE_READONLY (parm) = 1;
1501 gfc_finish_decl (parm);
1502 DECL_ARTIFICIAL (parm) = 1;
1504 arglist = chainon (arglist, parm);
1505 typelist = TREE_CHAIN (typelist);
1508 if (gfc_return_by_reference (sym))
1510 tree type = TREE_VALUE (typelist), length = NULL;
1512 if (sym->ts.type == BT_CHARACTER)
1514 /* Length of character result. */
1515 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1516 gcc_assert (len_type == gfc_charlen_type_node);
1518 length = build_decl (PARM_DECL,
1519 get_identifier (".__result"),
1521 if (!sym->ts.cl->length)
1523 sym->ts.cl->backend_decl = length;
1524 TREE_USED (length) = 1;
1526 gcc_assert (TREE_CODE (length) == PARM_DECL);
1527 DECL_CONTEXT (length) = fndecl;
1528 DECL_ARG_TYPE (length) = len_type;
1529 TREE_READONLY (length) = 1;
1530 DECL_ARTIFICIAL (length) = 1;
1531 gfc_finish_decl (length);
1532 if (sym->ts.cl->backend_decl == NULL
1533 || sym->ts.cl->backend_decl == length)
1538 if (sym->ts.cl->backend_decl == NULL)
1540 tree len = build_decl (VAR_DECL,
1541 get_identifier ("..__result"),
1542 gfc_charlen_type_node);
1543 DECL_ARTIFICIAL (len) = 1;
1544 TREE_USED (len) = 1;
1545 sym->ts.cl->backend_decl = len;
1548 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1549 arg = sym->result ? sym->result : sym;
1550 backend_decl = arg->backend_decl;
1551 /* Temporary clear it, so that gfc_sym_type creates complete
1553 arg->backend_decl = NULL;
1554 type = gfc_sym_type (arg);
1555 arg->backend_decl = backend_decl;
1556 type = build_reference_type (type);
1560 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1562 DECL_CONTEXT (parm) = fndecl;
1563 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1564 TREE_READONLY (parm) = 1;
1565 DECL_ARTIFICIAL (parm) = 1;
1566 gfc_finish_decl (parm);
1568 arglist = chainon (arglist, parm);
1569 typelist = TREE_CHAIN (typelist);
1571 if (sym->ts.type == BT_CHARACTER)
1573 gfc_allocate_lang_decl (parm);
1574 arglist = chainon (arglist, length);
1575 typelist = TREE_CHAIN (typelist);
1579 hidden_typelist = typelist;
1580 for (f = sym->formal; f; f = f->next)
1581 if (f->sym != NULL) /* Ignore alternate returns. */
1582 hidden_typelist = TREE_CHAIN (hidden_typelist);
1584 for (f = sym->formal; f; f = f->next)
1586 char name[GFC_MAX_SYMBOL_LEN + 2];
1588 /* Ignore alternate returns. */
1592 type = TREE_VALUE (typelist);
1594 if (f->sym->ts.type == BT_CHARACTER)
1596 tree len_type = TREE_VALUE (hidden_typelist);
1597 tree length = NULL_TREE;
1598 gcc_assert (len_type == gfc_charlen_type_node);
1600 strcpy (&name[1], f->sym->name);
1602 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1604 hidden_arglist = chainon (hidden_arglist, length);
1605 DECL_CONTEXT (length) = fndecl;
1606 DECL_ARTIFICIAL (length) = 1;
1607 DECL_ARG_TYPE (length) = len_type;
1608 TREE_READONLY (length) = 1;
1609 gfc_finish_decl (length);
1611 /* TODO: Check string lengths when -fbounds-check. */
1613 /* Use the passed value for assumed length variables. */
1614 if (!f->sym->ts.cl->length)
1616 TREE_USED (length) = 1;
1617 gcc_assert (!f->sym->ts.cl->backend_decl);
1618 f->sym->ts.cl->backend_decl = length;
1621 hidden_typelist = TREE_CHAIN (hidden_typelist);
1623 if (f->sym->ts.cl->backend_decl == NULL
1624 || f->sym->ts.cl->backend_decl == length)
1626 if (f->sym->ts.cl->backend_decl == NULL)
1627 gfc_create_string_length (f->sym);
1629 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1630 if (f->sym->attr.flavor == FL_PROCEDURE)
1631 type = build_pointer_type (gfc_get_function_type (f->sym));
1633 type = gfc_sym_type (f->sym);
1637 /* For non-constant length array arguments, make sure they use
1638 a different type node from TYPE_ARG_TYPES type. */
1639 if (f->sym->attr.dimension
1640 && type == TREE_VALUE (typelist)
1641 && TREE_CODE (type) == POINTER_TYPE
1642 && GFC_ARRAY_TYPE_P (type)
1643 && f->sym->as->type != AS_ASSUMED_SIZE
1644 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1646 if (f->sym->attr.flavor == FL_PROCEDURE)
1647 type = build_pointer_type (gfc_get_function_type (f->sym));
1649 type = gfc_sym_type (f->sym);
1652 if (f->sym->attr.proc_pointer)
1653 type = build_pointer_type (type);
1655 /* Build the argument declaration. */
1656 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1658 /* Fill in arg stuff. */
1659 DECL_CONTEXT (parm) = fndecl;
1660 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1661 /* All implementation args are read-only. */
1662 TREE_READONLY (parm) = 1;
1663 if (POINTER_TYPE_P (type)
1664 && (!f->sym->attr.proc_pointer
1665 && f->sym->attr.flavor != FL_PROCEDURE))
1666 DECL_BY_REFERENCE (parm) = 1;
1668 gfc_finish_decl (parm);
1670 f->sym->backend_decl = parm;
1672 arglist = chainon (arglist, parm);
1673 typelist = TREE_CHAIN (typelist);
1676 /* Add the hidden string length parameters, unless the procedure
1678 if (!sym->attr.is_bind_c)
1679 arglist = chainon (arglist, hidden_arglist);
1681 gcc_assert (hidden_typelist == NULL_TREE
1682 || TREE_VALUE (hidden_typelist) == void_type_node);
1683 DECL_ARGUMENTS (fndecl) = arglist;
1686 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1689 gfc_gimplify_function (tree fndecl)
1691 struct cgraph_node *cgn;
1693 gimplify_function_tree (fndecl);
1694 dump_function (TDI_generic, fndecl);
1696 /* Generate errors for structured block violations. */
1697 /* ??? Could be done as part of resolve_labels. */
1699 diagnose_omp_structured_block_errors (fndecl);
1701 /* Convert all nested functions to GIMPLE now. We do things in this order
1702 so that items like VLA sizes are expanded properly in the context of the
1703 correct function. */
1704 cgn = cgraph_node (fndecl);
1705 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1706 gfc_gimplify_function (cgn->decl);
1710 /* Do the setup necessary before generating the body of a function. */
1713 trans_function_start (gfc_symbol * sym)
1717 fndecl = sym->backend_decl;
1719 /* Let GCC know the current scope is this function. */
1720 current_function_decl = fndecl;
1722 /* Let the world know what we're about to do. */
1723 announce_function (fndecl);
1725 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1727 /* Create RTL for function declaration. */
1728 rest_of_decl_compilation (fndecl, 1, 0);
1731 /* Create RTL for function definition. */
1732 make_decl_rtl (fndecl);
1734 init_function_start (fndecl);
1736 /* Even though we're inside a function body, we still don't want to
1737 call expand_expr to calculate the size of a variable-sized array.
1738 We haven't necessarily assigned RTL to all variables yet, so it's
1739 not safe to try to expand expressions involving them. */
1740 cfun->dont_save_pending_sizes_p = 1;
1742 /* function.c requires a push at the start of the function. */
1746 /* Create thunks for alternate entry points. */
1749 build_entry_thunks (gfc_namespace * ns)
1751 gfc_formal_arglist *formal;
1752 gfc_formal_arglist *thunk_formal;
1754 gfc_symbol *thunk_sym;
1762 /* This should always be a toplevel function. */
1763 gcc_assert (current_function_decl == NULL_TREE);
1765 gfc_get_backend_locus (&old_loc);
1766 for (el = ns->entries; el; el = el->next)
1768 thunk_sym = el->sym;
1770 build_function_decl (thunk_sym);
1771 create_function_arglist (thunk_sym);
1773 trans_function_start (thunk_sym);
1775 thunk_fndecl = thunk_sym->backend_decl;
1777 gfc_init_block (&body);
1779 /* Pass extra parameter identifying this entry point. */
1780 tmp = build_int_cst (gfc_array_index_type, el->id);
1781 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1782 string_args = NULL_TREE;
1784 if (thunk_sym->attr.function)
1786 if (gfc_return_by_reference (ns->proc_name))
1788 tree ref = DECL_ARGUMENTS (current_function_decl);
1789 args = tree_cons (NULL_TREE, ref, args);
1790 if (ns->proc_name->ts.type == BT_CHARACTER)
1791 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1796 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1798 /* Ignore alternate returns. */
1799 if (formal->sym == NULL)
1802 /* We don't have a clever way of identifying arguments, so resort to
1803 a brute-force search. */
1804 for (thunk_formal = thunk_sym->formal;
1806 thunk_formal = thunk_formal->next)
1808 if (thunk_formal->sym == formal->sym)
1814 /* Pass the argument. */
1815 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1816 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1818 if (formal->sym->ts.type == BT_CHARACTER)
1820 tmp = thunk_formal->sym->ts.cl->backend_decl;
1821 string_args = tree_cons (NULL_TREE, tmp, string_args);
1826 /* Pass NULL for a missing argument. */
1827 args = tree_cons (NULL_TREE, null_pointer_node, args);
1828 if (formal->sym->ts.type == BT_CHARACTER)
1830 tmp = build_int_cst (gfc_charlen_type_node, 0);
1831 string_args = tree_cons (NULL_TREE, tmp, string_args);
1836 /* Call the master function. */
1837 args = nreverse (args);
1838 args = chainon (args, nreverse (string_args));
1839 tmp = ns->proc_name->backend_decl;
1840 tmp = build_function_call_expr (tmp, args);
1841 if (ns->proc_name->attr.mixed_entry_master)
1843 tree union_decl, field;
1844 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1846 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1847 TREE_TYPE (master_type));
1848 DECL_ARTIFICIAL (union_decl) = 1;
1849 DECL_EXTERNAL (union_decl) = 0;
1850 TREE_PUBLIC (union_decl) = 0;
1851 TREE_USED (union_decl) = 1;
1852 layout_decl (union_decl, 0);
1853 pushdecl (union_decl);
1855 DECL_CONTEXT (union_decl) = current_function_decl;
1856 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1858 gfc_add_expr_to_block (&body, tmp);
1860 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1861 field; field = TREE_CHAIN (field))
1862 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1863 thunk_sym->result->name) == 0)
1865 gcc_assert (field != NULL_TREE);
1866 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1867 union_decl, field, NULL_TREE);
1868 tmp = fold_build2 (MODIFY_EXPR,
1869 TREE_TYPE (DECL_RESULT (current_function_decl)),
1870 DECL_RESULT (current_function_decl), tmp);
1871 tmp = build1_v (RETURN_EXPR, tmp);
1873 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1876 tmp = fold_build2 (MODIFY_EXPR,
1877 TREE_TYPE (DECL_RESULT (current_function_decl)),
1878 DECL_RESULT (current_function_decl), tmp);
1879 tmp = build1_v (RETURN_EXPR, tmp);
1881 gfc_add_expr_to_block (&body, tmp);
1883 /* Finish off this function and send it for code generation. */
1884 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1887 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1888 DECL_SAVED_TREE (thunk_fndecl)
1889 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1890 DECL_INITIAL (thunk_fndecl));
1892 /* Output the GENERIC tree. */
1893 dump_function (TDI_original, thunk_fndecl);
1895 /* Store the end of the function, so that we get good line number
1896 info for the epilogue. */
1897 cfun->function_end_locus = input_location;
1899 /* We're leaving the context of this function, so zap cfun.
1900 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1901 tree_rest_of_compilation. */
1904 current_function_decl = NULL_TREE;
1906 gfc_gimplify_function (thunk_fndecl);
1907 cgraph_finalize_function (thunk_fndecl, false);
1909 /* We share the symbols in the formal argument list with other entry
1910 points and the master function. Clear them so that they are
1911 recreated for each function. */
1912 for (formal = thunk_sym->formal; formal; formal = formal->next)
1913 if (formal->sym != NULL) /* Ignore alternate returns. */
1915 formal->sym->backend_decl = NULL_TREE;
1916 if (formal->sym->ts.type == BT_CHARACTER)
1917 formal->sym->ts.cl->backend_decl = NULL_TREE;
1920 if (thunk_sym->attr.function)
1922 if (thunk_sym->ts.type == BT_CHARACTER)
1923 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1924 if (thunk_sym->result->ts.type == BT_CHARACTER)
1925 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1929 gfc_set_backend_locus (&old_loc);
1933 /* Create a decl for a function, and create any thunks for alternate entry
1937 gfc_create_function_decl (gfc_namespace * ns)
1939 /* Create a declaration for the master function. */
1940 build_function_decl (ns->proc_name);
1942 /* Compile the entry thunks. */
1944 build_entry_thunks (ns);
1946 /* Now create the read argument list. */
1947 create_function_arglist (ns->proc_name);
1950 /* Return the decl used to hold the function return value. If
1951 parent_flag is set, the context is the parent_scope. */
1954 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1958 tree this_fake_result_decl;
1959 tree this_function_decl;
1961 char name[GFC_MAX_SYMBOL_LEN + 10];
1965 this_fake_result_decl = parent_fake_result_decl;
1966 this_function_decl = DECL_CONTEXT (current_function_decl);
1970 this_fake_result_decl = current_fake_result_decl;
1971 this_function_decl = current_function_decl;
1975 && sym->ns->proc_name->backend_decl == this_function_decl
1976 && sym->ns->proc_name->attr.entry_master
1977 && sym != sym->ns->proc_name)
1980 if (this_fake_result_decl != NULL)
1981 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1982 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1985 return TREE_VALUE (t);
1986 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1989 this_fake_result_decl = parent_fake_result_decl;
1991 this_fake_result_decl = current_fake_result_decl;
1993 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1997 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1998 field; field = TREE_CHAIN (field))
1999 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2003 gcc_assert (field != NULL_TREE);
2004 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2005 decl, field, NULL_TREE);
2008 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2010 gfc_add_decl_to_parent_function (var);
2012 gfc_add_decl_to_function (var);
2014 SET_DECL_VALUE_EXPR (var, decl);
2015 DECL_HAS_VALUE_EXPR_P (var) = 1;
2016 GFC_DECL_RESULT (var) = 1;
2018 TREE_CHAIN (this_fake_result_decl)
2019 = tree_cons (get_identifier (sym->name), var,
2020 TREE_CHAIN (this_fake_result_decl));
2024 if (this_fake_result_decl != NULL_TREE)
2025 return TREE_VALUE (this_fake_result_decl);
2027 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2032 if (sym->ts.type == BT_CHARACTER)
2034 if (sym->ts.cl->backend_decl == NULL_TREE)
2035 length = gfc_create_string_length (sym);
2037 length = sym->ts.cl->backend_decl;
2038 if (TREE_CODE (length) == VAR_DECL
2039 && DECL_CONTEXT (length) == NULL_TREE)
2040 gfc_add_decl_to_function (length);
2043 if (gfc_return_by_reference (sym))
2045 decl = DECL_ARGUMENTS (this_function_decl);
2047 if (sym->ns->proc_name->backend_decl == this_function_decl
2048 && sym->ns->proc_name->attr.entry_master)
2049 decl = TREE_CHAIN (decl);
2051 TREE_USED (decl) = 1;
2053 decl = gfc_build_dummy_array_decl (sym, decl);
2057 sprintf (name, "__result_%.20s",
2058 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2060 if (!sym->attr.mixed_entry_master && sym->attr.function)
2061 decl = build_decl (VAR_DECL, get_identifier (name),
2062 gfc_sym_type (sym));
2064 decl = build_decl (VAR_DECL, get_identifier (name),
2065 TREE_TYPE (TREE_TYPE (this_function_decl)));
2066 DECL_ARTIFICIAL (decl) = 1;
2067 DECL_EXTERNAL (decl) = 0;
2068 TREE_PUBLIC (decl) = 0;
2069 TREE_USED (decl) = 1;
2070 GFC_DECL_RESULT (decl) = 1;
2071 TREE_ADDRESSABLE (decl) = 1;
2073 layout_decl (decl, 0);
2076 gfc_add_decl_to_parent_function (decl);
2078 gfc_add_decl_to_function (decl);
2082 parent_fake_result_decl = build_tree_list (NULL, decl);
2084 current_fake_result_decl = build_tree_list (NULL, decl);
2090 /* Builds a function decl. The remaining parameters are the types of the
2091 function arguments. Negative nargs indicates a varargs function. */
2094 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2103 /* Library functions must be declared with global scope. */
2104 gcc_assert (current_function_decl == NULL_TREE);
2106 va_start (p, nargs);
2109 /* Create a list of the argument types. */
2110 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2112 argtype = va_arg (p, tree);
2113 arglist = gfc_chainon_list (arglist, argtype);
2118 /* Terminate the list. */
2119 arglist = gfc_chainon_list (arglist, void_type_node);
2122 /* Build the function type and decl. */
2123 fntype = build_function_type (rettype, arglist);
2124 fndecl = build_decl (FUNCTION_DECL, name, fntype);
2126 /* Mark this decl as external. */
2127 DECL_EXTERNAL (fndecl) = 1;
2128 TREE_PUBLIC (fndecl) = 1;
2134 rest_of_decl_compilation (fndecl, 1, 0);
2140 gfc_build_intrinsic_function_decls (void)
2142 tree gfc_int4_type_node = gfc_get_int_type (4);
2143 tree gfc_int8_type_node = gfc_get_int_type (8);
2144 tree gfc_int16_type_node = gfc_get_int_type (16);
2145 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2146 tree pchar1_type_node = gfc_get_pchar_type (1);
2147 tree pchar4_type_node = gfc_get_pchar_type (4);
2149 /* String functions. */
2150 gfor_fndecl_compare_string =
2151 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2152 integer_type_node, 4,
2153 gfc_charlen_type_node, pchar1_type_node,
2154 gfc_charlen_type_node, pchar1_type_node);
2156 gfor_fndecl_concat_string =
2157 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2159 gfc_charlen_type_node, pchar1_type_node,
2160 gfc_charlen_type_node, pchar1_type_node,
2161 gfc_charlen_type_node, pchar1_type_node);
2163 gfor_fndecl_string_len_trim =
2164 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2165 gfc_int4_type_node, 2,
2166 gfc_charlen_type_node, pchar1_type_node);
2168 gfor_fndecl_string_index =
2169 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2170 gfc_int4_type_node, 5,
2171 gfc_charlen_type_node, pchar1_type_node,
2172 gfc_charlen_type_node, pchar1_type_node,
2173 gfc_logical4_type_node);
2175 gfor_fndecl_string_scan =
2176 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2177 gfc_int4_type_node, 5,
2178 gfc_charlen_type_node, pchar1_type_node,
2179 gfc_charlen_type_node, pchar1_type_node,
2180 gfc_logical4_type_node);
2182 gfor_fndecl_string_verify =
2183 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2184 gfc_int4_type_node, 5,
2185 gfc_charlen_type_node, pchar1_type_node,
2186 gfc_charlen_type_node, pchar1_type_node,
2187 gfc_logical4_type_node);
2189 gfor_fndecl_string_trim =
2190 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2192 build_pointer_type (gfc_charlen_type_node),
2193 build_pointer_type (pchar1_type_node),
2194 gfc_charlen_type_node, pchar1_type_node);
2196 gfor_fndecl_string_minmax =
2197 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2199 build_pointer_type (gfc_charlen_type_node),
2200 build_pointer_type (pchar1_type_node),
2201 integer_type_node, integer_type_node);
2203 gfor_fndecl_adjustl =
2204 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2205 void_type_node, 3, pchar1_type_node,
2206 gfc_charlen_type_node, pchar1_type_node);
2208 gfor_fndecl_adjustr =
2209 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2210 void_type_node, 3, pchar1_type_node,
2211 gfc_charlen_type_node, pchar1_type_node);
2213 gfor_fndecl_select_string =
2214 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2215 integer_type_node, 4, pvoid_type_node,
2216 integer_type_node, pchar1_type_node,
2217 gfc_charlen_type_node);
2219 gfor_fndecl_compare_string_char4 =
2220 gfc_build_library_function_decl (get_identifier
2221 (PREFIX("compare_string_char4")),
2222 integer_type_node, 4,
2223 gfc_charlen_type_node, pchar4_type_node,
2224 gfc_charlen_type_node, pchar4_type_node);
2226 gfor_fndecl_concat_string_char4 =
2227 gfc_build_library_function_decl (get_identifier
2228 (PREFIX("concat_string_char4")),
2230 gfc_charlen_type_node, pchar4_type_node,
2231 gfc_charlen_type_node, pchar4_type_node,
2232 gfc_charlen_type_node, pchar4_type_node);
2234 gfor_fndecl_string_len_trim_char4 =
2235 gfc_build_library_function_decl (get_identifier
2236 (PREFIX("string_len_trim_char4")),
2237 gfc_charlen_type_node, 2,
2238 gfc_charlen_type_node, pchar4_type_node);
2240 gfor_fndecl_string_index_char4 =
2241 gfc_build_library_function_decl (get_identifier
2242 (PREFIX("string_index_char4")),
2243 gfc_charlen_type_node, 5,
2244 gfc_charlen_type_node, pchar4_type_node,
2245 gfc_charlen_type_node, pchar4_type_node,
2246 gfc_logical4_type_node);
2248 gfor_fndecl_string_scan_char4 =
2249 gfc_build_library_function_decl (get_identifier
2250 (PREFIX("string_scan_char4")),
2251 gfc_charlen_type_node, 5,
2252 gfc_charlen_type_node, pchar4_type_node,
2253 gfc_charlen_type_node, pchar4_type_node,
2254 gfc_logical4_type_node);
2256 gfor_fndecl_string_verify_char4 =
2257 gfc_build_library_function_decl (get_identifier
2258 (PREFIX("string_verify_char4")),
2259 gfc_charlen_type_node, 5,
2260 gfc_charlen_type_node, pchar4_type_node,
2261 gfc_charlen_type_node, pchar4_type_node,
2262 gfc_logical4_type_node);
2264 gfor_fndecl_string_trim_char4 =
2265 gfc_build_library_function_decl (get_identifier
2266 (PREFIX("string_trim_char4")),
2268 build_pointer_type (gfc_charlen_type_node),
2269 build_pointer_type (pchar4_type_node),
2270 gfc_charlen_type_node, pchar4_type_node);
2272 gfor_fndecl_string_minmax_char4 =
2273 gfc_build_library_function_decl (get_identifier
2274 (PREFIX("string_minmax_char4")),
2276 build_pointer_type (gfc_charlen_type_node),
2277 build_pointer_type (pchar4_type_node),
2278 integer_type_node, integer_type_node);
2280 gfor_fndecl_adjustl_char4 =
2281 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2282 void_type_node, 3, pchar4_type_node,
2283 gfc_charlen_type_node, pchar4_type_node);
2285 gfor_fndecl_adjustr_char4 =
2286 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2287 void_type_node, 3, pchar4_type_node,
2288 gfc_charlen_type_node, pchar4_type_node);
2290 gfor_fndecl_select_string_char4 =
2291 gfc_build_library_function_decl (get_identifier
2292 (PREFIX("select_string_char4")),
2293 integer_type_node, 4, pvoid_type_node,
2294 integer_type_node, pvoid_type_node,
2295 gfc_charlen_type_node);
2298 /* Conversion between character kinds. */
2300 gfor_fndecl_convert_char1_to_char4 =
2301 gfc_build_library_function_decl (get_identifier
2302 (PREFIX("convert_char1_to_char4")),
2304 build_pointer_type (pchar4_type_node),
2305 gfc_charlen_type_node, pchar1_type_node);
2307 gfor_fndecl_convert_char4_to_char1 =
2308 gfc_build_library_function_decl (get_identifier
2309 (PREFIX("convert_char4_to_char1")),
2311 build_pointer_type (pchar1_type_node),
2312 gfc_charlen_type_node, pchar4_type_node);
2314 /* Misc. functions. */
2316 gfor_fndecl_ttynam =
2317 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2321 gfc_charlen_type_node,
2325 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2329 gfc_charlen_type_node);
2332 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2336 gfc_charlen_type_node,
2337 gfc_int8_type_node);
2339 gfor_fndecl_sc_kind =
2340 gfc_build_library_function_decl (get_identifier
2341 (PREFIX("selected_char_kind")),
2342 gfc_int4_type_node, 2,
2343 gfc_charlen_type_node, pchar_type_node);
2345 gfor_fndecl_si_kind =
2346 gfc_build_library_function_decl (get_identifier
2347 (PREFIX("selected_int_kind")),
2348 gfc_int4_type_node, 1, pvoid_type_node);
2350 gfor_fndecl_sr_kind =
2351 gfc_build_library_function_decl (get_identifier
2352 (PREFIX("selected_real_kind")),
2353 gfc_int4_type_node, 2,
2354 pvoid_type_node, pvoid_type_node);
2356 /* Power functions. */
2358 tree ctype, rtype, itype, jtype;
2359 int rkind, ikind, jkind;
2362 static int ikinds[NIKINDS] = {4, 8, 16};
2363 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2364 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2366 for (ikind=0; ikind < NIKINDS; ikind++)
2368 itype = gfc_get_int_type (ikinds[ikind]);
2370 for (jkind=0; jkind < NIKINDS; jkind++)
2372 jtype = gfc_get_int_type (ikinds[jkind]);
2375 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2377 gfor_fndecl_math_powi[jkind][ikind].integer =
2378 gfc_build_library_function_decl (get_identifier (name),
2379 jtype, 2, jtype, itype);
2380 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2384 for (rkind = 0; rkind < NRKINDS; rkind ++)
2386 rtype = gfc_get_real_type (rkinds[rkind]);
2389 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2391 gfor_fndecl_math_powi[rkind][ikind].real =
2392 gfc_build_library_function_decl (get_identifier (name),
2393 rtype, 2, rtype, itype);
2394 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2397 ctype = gfc_get_complex_type (rkinds[rkind]);
2400 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2402 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2403 gfc_build_library_function_decl (get_identifier (name),
2404 ctype, 2,ctype, itype);
2405 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2413 gfor_fndecl_math_ishftc4 =
2414 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2416 3, gfc_int4_type_node,
2417 gfc_int4_type_node, gfc_int4_type_node);
2418 gfor_fndecl_math_ishftc8 =
2419 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2421 3, gfc_int8_type_node,
2422 gfc_int4_type_node, gfc_int4_type_node);
2423 if (gfc_int16_type_node)
2424 gfor_fndecl_math_ishftc16 =
2425 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2426 gfc_int16_type_node, 3,
2427 gfc_int16_type_node,
2429 gfc_int4_type_node);
2431 /* BLAS functions. */
2433 tree pint = build_pointer_type (integer_type_node);
2434 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2435 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2436 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2437 tree pz = build_pointer_type
2438 (gfc_get_complex_type (gfc_default_double_kind));
2440 gfor_fndecl_sgemm = gfc_build_library_function_decl
2442 (gfc_option.flag_underscoring ? "sgemm_"
2444 void_type_node, 15, pchar_type_node,
2445 pchar_type_node, pint, pint, pint, ps, ps, pint,
2446 ps, pint, ps, ps, pint, integer_type_node,
2448 gfor_fndecl_dgemm = gfc_build_library_function_decl
2450 (gfc_option.flag_underscoring ? "dgemm_"
2452 void_type_node, 15, pchar_type_node,
2453 pchar_type_node, pint, pint, pint, pd, pd, pint,
2454 pd, pint, pd, pd, pint, integer_type_node,
2456 gfor_fndecl_cgemm = gfc_build_library_function_decl
2458 (gfc_option.flag_underscoring ? "cgemm_"
2460 void_type_node, 15, pchar_type_node,
2461 pchar_type_node, pint, pint, pint, pc, pc, pint,
2462 pc, pint, pc, pc, pint, integer_type_node,
2464 gfor_fndecl_zgemm = gfc_build_library_function_decl
2466 (gfc_option.flag_underscoring ? "zgemm_"
2468 void_type_node, 15, pchar_type_node,
2469 pchar_type_node, pint, pint, pint, pz, pz, pint,
2470 pz, pint, pz, pz, pint, integer_type_node,
2474 /* Other functions. */
2476 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2477 gfc_array_index_type,
2478 1, pvoid_type_node);
2480 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2481 gfc_array_index_type,
2483 gfc_array_index_type);
2486 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2492 /* Make prototypes for runtime library functions. */
2495 gfc_build_builtin_function_decls (void)
2497 tree gfc_int4_type_node = gfc_get_int_type (4);
2499 gfor_fndecl_stop_numeric =
2500 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2501 void_type_node, 1, gfc_int4_type_node);
2502 /* Stop doesn't return. */
2503 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2505 gfor_fndecl_stop_string =
2506 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2507 void_type_node, 2, pchar_type_node,
2508 gfc_int4_type_node);
2509 /* Stop doesn't return. */
2510 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2512 gfor_fndecl_pause_numeric =
2513 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2514 void_type_node, 1, gfc_int4_type_node);
2516 gfor_fndecl_pause_string =
2517 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2518 void_type_node, 2, pchar_type_node,
2519 gfc_int4_type_node);
2521 gfor_fndecl_runtime_error =
2522 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2523 void_type_node, -1, pchar_type_node);
2524 /* The runtime_error function does not return. */
2525 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2527 gfor_fndecl_runtime_error_at =
2528 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2529 void_type_node, -2, pchar_type_node,
2531 /* The runtime_error_at function does not return. */
2532 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2534 gfor_fndecl_runtime_warning_at =
2535 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2536 void_type_node, -2, pchar_type_node,
2538 gfor_fndecl_generate_error =
2539 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2540 void_type_node, 3, pvoid_type_node,
2541 integer_type_node, pchar_type_node);
2543 gfor_fndecl_os_error =
2544 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2545 void_type_node, 1, pchar_type_node);
2546 /* The runtime_error function does not return. */
2547 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2549 gfor_fndecl_set_fpe =
2550 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2551 void_type_node, 1, integer_type_node);
2553 /* Keep the array dimension in sync with the call, later in this file. */
2554 gfor_fndecl_set_options =
2555 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2556 void_type_node, 2, integer_type_node,
2559 gfor_fndecl_set_convert =
2560 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2561 void_type_node, 1, integer_type_node);
2563 gfor_fndecl_set_record_marker =
2564 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2565 void_type_node, 1, integer_type_node);
2567 gfor_fndecl_set_max_subrecord_length =
2568 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2569 void_type_node, 1, integer_type_node);
2571 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2572 get_identifier (PREFIX("internal_pack")),
2573 pvoid_type_node, 1, pvoid_type_node);
2575 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2576 get_identifier (PREFIX("internal_unpack")),
2577 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2579 gfor_fndecl_associated =
2580 gfc_build_library_function_decl (
2581 get_identifier (PREFIX("associated")),
2582 integer_type_node, 2, ppvoid_type_node,
2585 gfc_build_intrinsic_function_decls ();
2586 gfc_build_intrinsic_lib_fndecls ();
2587 gfc_build_io_library_fndecls ();
2591 /* Evaluate the length of dummy character variables. */
2594 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2598 gfc_finish_decl (cl->backend_decl);
2600 gfc_start_block (&body);
2602 /* Evaluate the string length expression. */
2603 gfc_conv_string_length (cl, NULL, &body);
2605 gfc_trans_vla_type_sizes (sym, &body);
2607 gfc_add_expr_to_block (&body, fnbody);
2608 return gfc_finish_block (&body);
2612 /* Allocate and cleanup an automatic character variable. */
2615 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2621 gcc_assert (sym->backend_decl);
2622 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2624 gfc_start_block (&body);
2626 /* Evaluate the string length expression. */
2627 gfc_conv_string_length (sym->ts.cl, NULL, &body);
2629 gfc_trans_vla_type_sizes (sym, &body);
2631 decl = sym->backend_decl;
2633 /* Emit a DECL_EXPR for this variable, which will cause the
2634 gimplifier to allocate storage, and all that good stuff. */
2635 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2636 gfc_add_expr_to_block (&body, tmp);
2638 gfc_add_expr_to_block (&body, fnbody);
2639 return gfc_finish_block (&body);
2642 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2645 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2649 gcc_assert (sym->backend_decl);
2650 gfc_start_block (&body);
2652 /* Set the initial value to length. See the comments in
2653 function gfc_add_assign_aux_vars in this file. */
2654 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2655 build_int_cst (NULL_TREE, -2));
2657 gfc_add_expr_to_block (&body, fnbody);
2658 return gfc_finish_block (&body);
2662 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2664 tree t = *tp, var, val;
2666 if (t == NULL || t == error_mark_node)
2668 if (TREE_CONSTANT (t) || DECL_P (t))
2671 if (TREE_CODE (t) == SAVE_EXPR)
2673 if (SAVE_EXPR_RESOLVED_P (t))
2675 *tp = TREE_OPERAND (t, 0);
2678 val = TREE_OPERAND (t, 0);
2683 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2684 gfc_add_decl_to_function (var);
2685 gfc_add_modify (body, var, val);
2686 if (TREE_CODE (t) == SAVE_EXPR)
2687 TREE_OPERAND (t, 0) = var;
2692 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2696 if (type == NULL || type == error_mark_node)
2699 type = TYPE_MAIN_VARIANT (type);
2701 if (TREE_CODE (type) == INTEGER_TYPE)
2703 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2704 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2706 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2708 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2709 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2712 else if (TREE_CODE (type) == ARRAY_TYPE)
2714 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2715 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2716 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2717 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2719 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2721 TYPE_SIZE (t) = TYPE_SIZE (type);
2722 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2727 /* Make sure all type sizes and array domains are either constant,
2728 or variable or parameter decls. This is a simplified variant
2729 of gimplify_type_sizes, but we can't use it here, as none of the
2730 variables in the expressions have been gimplified yet.
2731 As type sizes and domains for various variable length arrays
2732 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2733 time, without this routine gimplify_type_sizes in the middle-end
2734 could result in the type sizes being gimplified earlier than where
2735 those variables are initialized. */
2738 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2740 tree type = TREE_TYPE (sym->backend_decl);
2742 if (TREE_CODE (type) == FUNCTION_TYPE
2743 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2745 if (! current_fake_result_decl)
2748 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2751 while (POINTER_TYPE_P (type))
2752 type = TREE_TYPE (type);
2754 if (GFC_DESCRIPTOR_TYPE_P (type))
2756 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2758 while (POINTER_TYPE_P (etype))
2759 etype = TREE_TYPE (etype);
2761 gfc_trans_vla_type_sizes_1 (etype, body);
2764 gfc_trans_vla_type_sizes_1 (type, body);
2768 /* Initialize a derived type by building an lvalue from the symbol
2769 and using trans_assignment to do the work. */
2771 gfc_init_default_dt (gfc_symbol * sym, tree body)
2773 stmtblock_t fnblock;
2778 gfc_init_block (&fnblock);
2779 gcc_assert (!sym->attr.allocatable);
2780 gfc_set_sym_referenced (sym);
2781 e = gfc_lval_expr_from_sym (sym);
2782 tmp = gfc_trans_assignment (e, sym->value, false);
2783 if (sym->attr.dummy)
2785 present = gfc_conv_expr_present (sym);
2786 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2787 tmp, build_empty_stmt ());
2789 gfc_add_expr_to_block (&fnblock, tmp);
2792 gfc_add_expr_to_block (&fnblock, body);
2793 return gfc_finish_block (&fnblock);
2797 /* Initialize INTENT(OUT) derived type dummies. As well as giving
2798 them their default initializer, if they do not have allocatable
2799 components, they have their allocatable components deallocated. */
2802 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2804 stmtblock_t fnblock;
2805 gfc_formal_arglist *f;
2809 gfc_init_block (&fnblock);
2810 for (f = proc_sym->formal; f; f = f->next)
2811 if (f->sym && f->sym->attr.intent == INTENT_OUT
2812 && f->sym->ts.type == BT_DERIVED)
2814 if (f->sym->ts.derived->attr.alloc_comp)
2816 tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2817 f->sym->backend_decl,
2818 f->sym->as ? f->sym->as->rank : 0);
2820 present = gfc_conv_expr_present (f->sym);
2821 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2822 tmp, build_empty_stmt ());
2824 gfc_add_expr_to_block (&fnblock, tmp);
2827 if (!f->sym->ts.derived->attr.alloc_comp
2829 body = gfc_init_default_dt (f->sym, body);
2832 gfc_add_expr_to_block (&fnblock, body);
2833 return gfc_finish_block (&fnblock);
2837 /* Generate function entry and exit code, and add it to the function body.
2839 Allocation and initialization of array variables.
2840 Allocation of character string variables.
2841 Initialization and possibly repacking of dummy arrays.
2842 Initialization of ASSIGN statement auxiliary variable. */
2845 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2849 gfc_formal_arglist *f;
2851 bool seen_trans_deferred_array = false;
2853 /* Deal with implicit return variables. Explicit return variables will
2854 already have been added. */
2855 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2857 if (!current_fake_result_decl)
2859 gfc_entry_list *el = NULL;
2860 if (proc_sym->attr.entry_master)
2862 for (el = proc_sym->ns->entries; el; el = el->next)
2863 if (el->sym != el->sym->result)
2866 /* TODO: move to the appropriate place in resolve.c. */
2867 if (warn_return_type && el == NULL)
2868 gfc_warning ("Return value of function '%s' at %L not set",
2869 proc_sym->name, &proc_sym->declared_at);
2871 else if (proc_sym->as)
2873 tree result = TREE_VALUE (current_fake_result_decl);
2874 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2876 /* An automatic character length, pointer array result. */
2877 if (proc_sym->ts.type == BT_CHARACTER
2878 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2879 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2882 else if (proc_sym->ts.type == BT_CHARACTER)
2884 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2885 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2889 gcc_assert (gfc_option.flag_f2c
2890 && proc_sym->ts.type == BT_COMPLEX);
2893 /* Initialize the INTENT(OUT) derived type dummy arguments. This
2894 should be done here so that the offsets and lbounds of arrays
2896 fnbody = init_intent_out_dt (proc_sym, fnbody);
2898 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2900 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2901 && sym->ts.derived->attr.alloc_comp;
2902 if (sym->attr.dimension)
2904 switch (sym->as->type)
2907 if (sym->attr.dummy || sym->attr.result)
2909 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2910 else if (sym->attr.pointer || sym->attr.allocatable)
2912 if (TREE_STATIC (sym->backend_decl))
2913 gfc_trans_static_array_pointer (sym);
2916 seen_trans_deferred_array = true;
2917 fnbody = gfc_trans_deferred_array (sym, fnbody);
2922 if (sym_has_alloc_comp)
2924 seen_trans_deferred_array = true;
2925 fnbody = gfc_trans_deferred_array (sym, fnbody);
2927 else if (sym->ts.type == BT_DERIVED
2930 && sym->attr.save == SAVE_NONE)
2931 fnbody = gfc_init_default_dt (sym, fnbody);
2933 gfc_get_backend_locus (&loc);
2934 gfc_set_backend_locus (&sym->declared_at);
2935 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2937 gfc_set_backend_locus (&loc);
2941 case AS_ASSUMED_SIZE:
2942 /* Must be a dummy parameter. */
2943 gcc_assert (sym->attr.dummy);
2945 /* We should always pass assumed size arrays the g77 way. */
2946 fnbody = gfc_trans_g77_array (sym, fnbody);
2949 case AS_ASSUMED_SHAPE:
2950 /* Must be a dummy parameter. */
2951 gcc_assert (sym->attr.dummy);
2953 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2958 seen_trans_deferred_array = true;
2959 fnbody = gfc_trans_deferred_array (sym, fnbody);
2965 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2966 fnbody = gfc_trans_deferred_array (sym, fnbody);
2968 else if (sym_has_alloc_comp)
2969 fnbody = gfc_trans_deferred_array (sym, fnbody);
2970 else if (sym->ts.type == BT_CHARACTER)
2972 gfc_get_backend_locus (&loc);
2973 gfc_set_backend_locus (&sym->declared_at);
2974 if (sym->attr.dummy || sym->attr.result)
2975 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2977 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2978 gfc_set_backend_locus (&loc);
2980 else if (sym->attr.assign)
2982 gfc_get_backend_locus (&loc);
2983 gfc_set_backend_locus (&sym->declared_at);
2984 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2985 gfc_set_backend_locus (&loc);
2987 else if (sym->ts.type == BT_DERIVED
2990 && sym->attr.save == SAVE_NONE)
2991 fnbody = gfc_init_default_dt (sym, fnbody);
2996 gfc_init_block (&body);
2998 for (f = proc_sym->formal; f; f = f->next)
3000 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3002 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3003 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3004 gfc_trans_vla_type_sizes (f->sym, &body);
3008 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3009 && current_fake_result_decl != NULL)
3011 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3012 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3013 gfc_trans_vla_type_sizes (proc_sym, &body);
3016 gfc_add_expr_to_block (&body, fnbody);
3017 return gfc_finish_block (&body);
3020 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3022 /* Hash and equality functions for module_htab. */
3025 module_htab_do_hash (const void *x)
3027 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3031 module_htab_eq (const void *x1, const void *x2)
3033 return strcmp ((((const struct module_htab_entry *)x1)->name),
3034 (const char *)x2) == 0;
3037 /* Hash and equality functions for module_htab's decls. */
3040 module_htab_decls_hash (const void *x)
3042 const_tree t = (const_tree) x;
3043 const_tree n = DECL_NAME (t);
3045 n = TYPE_NAME (TREE_TYPE (t));
3046 return htab_hash_string (IDENTIFIER_POINTER (n));
3050 module_htab_decls_eq (const void *x1, const void *x2)
3052 const_tree t1 = (const_tree) x1;
3053 const_tree n1 = DECL_NAME (t1);
3054 if (n1 == NULL_TREE)
3055 n1 = TYPE_NAME (TREE_TYPE (t1));
3056 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3059 struct module_htab_entry *
3060 gfc_find_module (const char *name)
3065 module_htab = htab_create_ggc (10, module_htab_do_hash,
3066 module_htab_eq, NULL);
3068 slot = htab_find_slot_with_hash (module_htab, name,
3069 htab_hash_string (name), INSERT);
3072 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3074 entry->name = gfc_get_string (name);
3075 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3076 module_htab_decls_eq, NULL);
3077 *slot = (void *) entry;
3079 return (struct module_htab_entry *) *slot;
3083 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3088 if (DECL_NAME (decl))
3089 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3092 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3093 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3095 slot = htab_find_slot_with_hash (entry->decls, name,
3096 htab_hash_string (name), INSERT);
3098 *slot = (void *) decl;
3101 static struct module_htab_entry *cur_module;
3103 /* Output an initialized decl for a module variable. */
3106 gfc_create_module_variable (gfc_symbol * sym)
3110 /* Module functions with alternate entries are dealt with later and
3111 would get caught by the next condition. */
3112 if (sym->attr.entry)
3115 /* Make sure we convert the types of the derived types from iso_c_binding
3117 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3118 && sym->ts.type == BT_DERIVED)
3119 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3121 if (sym->attr.flavor == FL_DERIVED
3122 && sym->backend_decl
3123 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3125 decl = sym->backend_decl;
3126 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3127 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3128 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3129 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3130 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3131 == sym->ns->proc_name->backend_decl);
3132 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3133 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3134 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3137 /* Only output variables, procedure pointers and array valued,
3138 or derived type, parameters. */
3139 if (sym->attr.flavor != FL_VARIABLE
3140 && !(sym->attr.flavor == FL_PARAMETER
3141 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3142 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3145 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3147 decl = sym->backend_decl;
3148 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3149 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3150 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3151 gfc_module_add_decl (cur_module, decl);
3154 /* Don't generate variables from other modules. Variables from
3155 COMMONs will already have been generated. */
3156 if (sym->attr.use_assoc || sym->attr.in_common)
3159 /* Equivalenced variables arrive here after creation. */
3160 if (sym->backend_decl
3161 && (sym->equiv_built || sym->attr.in_equivalence))
3164 if (sym->backend_decl)
3165 internal_error ("backend decl for module variable %s already exists",
3168 /* We always want module variables to be created. */
3169 sym->attr.referenced = 1;
3170 /* Create the decl. */
3171 decl = gfc_get_symbol_decl (sym);
3173 /* Create the variable. */
3175 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3176 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3177 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3178 rest_of_decl_compilation (decl, 1, 0);
3179 gfc_module_add_decl (cur_module, decl);
3181 /* Also add length of strings. */
3182 if (sym->ts.type == BT_CHARACTER)
3186 length = sym->ts.cl->backend_decl;
3187 if (!INTEGER_CST_P (length))
3190 rest_of_decl_compilation (length, 1, 0);
3195 /* Emit debug information for USE statements. */
3198 gfc_trans_use_stmts (gfc_namespace * ns)
3200 gfc_use_list *use_stmt;
3201 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3203 struct module_htab_entry *entry
3204 = gfc_find_module (use_stmt->module_name);
3205 gfc_use_rename *rent;
3207 if (entry->namespace_decl == NULL)
3209 entry->namespace_decl
3210 = build_decl (NAMESPACE_DECL,
3211 get_identifier (use_stmt->module_name),
3213 DECL_EXTERNAL (entry->namespace_decl) = 1;
3215 gfc_set_backend_locus (&use_stmt->where);
3216 if (!use_stmt->only_flag)
3217 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3219 ns->proc_name->backend_decl,
3221 for (rent = use_stmt->rename; rent; rent = rent->next)
3223 tree decl, local_name;
3226 if (rent->op != INTRINSIC_NONE)
3229 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3230 htab_hash_string (rent->use_name),
3236 st = gfc_find_symtree (ns->sym_root,
3238 ? rent->local_name : rent->use_name);
3239 gcc_assert (st && st->n.sym->attr.use_assoc);
3240 if (st->n.sym->backend_decl
3241 && DECL_P (st->n.sym->backend_decl)
3242 && st->n.sym->module
3243 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3245 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3246 || (TREE_CODE (st->n.sym->backend_decl)
3248 decl = copy_node (st->n.sym->backend_decl);
3249 DECL_CONTEXT (decl) = entry->namespace_decl;
3250 DECL_EXTERNAL (decl) = 1;
3251 DECL_IGNORED_P (decl) = 0;
3252 DECL_INITIAL (decl) = NULL_TREE;
3256 *slot = error_mark_node;
3257 htab_clear_slot (entry->decls, slot);
3262 decl = (tree) *slot;
3263 if (rent->local_name[0])
3264 local_name = get_identifier (rent->local_name);
3266 local_name = NULL_TREE;
3267 gfc_set_backend_locus (&rent->where);
3268 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3269 ns->proc_name->backend_decl,
3270 !use_stmt->only_flag);
3276 /* Return true if expr is a constant initializer that gfc_conv_initializer
3280 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3290 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3292 else if (expr->expr_type == EXPR_STRUCTURE)
3293 return check_constant_initializer (expr, ts, false, false);
3294 else if (expr->expr_type != EXPR_ARRAY)
3296 for (c = expr->value.constructor; c; c = c->next)
3300 if (c->expr->expr_type == EXPR_STRUCTURE)
3302 if (!check_constant_initializer (c->expr, ts, false, false))
3305 else if (c->expr->expr_type != EXPR_CONSTANT)
3310 else switch (ts->type)
3313 if (expr->expr_type != EXPR_STRUCTURE)
3315 cm = expr->ts.derived->components;
3316 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3318 if (!c->expr || cm->attr.allocatable)
3320 if (!check_constant_initializer (c->expr, &cm->ts,
3327 return expr->expr_type == EXPR_CONSTANT;
3331 /* Emit debug info for parameters and unreferenced variables with
3335 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3339 if (sym->attr.flavor != FL_PARAMETER
3340 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3343 if (sym->backend_decl != NULL
3344 || sym->value == NULL
3345 || sym->attr.use_assoc
3348 || sym->attr.function
3349 || sym->attr.intrinsic
3350 || sym->attr.pointer
3351 || sym->attr.allocatable
3352 || sym->attr.cray_pointee
3353 || sym->attr.threadprivate
3354 || sym->attr.is_bind_c
3355 || sym->attr.subref_array_pointer
3356 || sym->attr.assign)
3359 if (sym->ts.type == BT_CHARACTER)
3361 gfc_conv_const_charlen (sym->ts.cl);
3362 if (sym->ts.cl->backend_decl == NULL
3363 || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3366 else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3373 if (sym->as->type != AS_EXPLICIT)
3375 for (n = 0; n < sym->as->rank; n++)
3376 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3377 || sym->as->upper[n] == NULL
3378 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3382 if (!check_constant_initializer (sym->value, &sym->ts,
3383 sym->attr.dimension, false))
3386 /* Create the decl for the variable or constant. */
3387 decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3388 gfc_sym_identifier (sym), gfc_sym_type (sym));
3389 if (sym->attr.flavor == FL_PARAMETER)
3390 TREE_READONLY (decl) = 1;
3391 gfc_set_decl_location (decl, &sym->declared_at);
3392 if (sym->attr.dimension)
3393 GFC_DECL_PACKED_ARRAY (decl) = 1;
3394 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3395 TREE_STATIC (decl) = 1;
3396 TREE_USED (decl) = 1;
3397 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3398 TREE_PUBLIC (decl) = 1;
3400 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3401 sym->attr.dimension, 0);
3402 debug_hooks->global_decl (decl);
3405 /* Generate all the required code for module variables. */
3408 gfc_generate_module_vars (gfc_namespace * ns)
3410 module_namespace = ns;
3411 cur_module = gfc_find_module (ns->proc_name->name);
3413 /* Check if the frontend left the namespace in a reasonable state. */
3414 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3416 /* Generate COMMON blocks. */
3417 gfc_trans_common (ns);
3419 /* Create decls for all the module variables. */
3420 gfc_traverse_ns (ns, gfc_create_module_variable);
3424 gfc_trans_use_stmts (ns);
3425 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3430 gfc_generate_contained_functions (gfc_namespace * parent)
3434 /* We create all the prototypes before generating any code. */
3435 for (ns = parent->contained; ns; ns = ns->sibling)
3437 /* Skip namespaces from used modules. */
3438 if (ns->parent != parent)
3441 gfc_create_function_decl (ns);
3444 for (ns = parent->contained; ns; ns = ns->sibling)
3446 /* Skip namespaces from used modules. */
3447 if (ns->parent != parent)
3450 gfc_generate_function_code (ns);
3455 /* Drill down through expressions for the array specification bounds and
3456 character length calling generate_local_decl for all those variables
3457 that have not already been declared. */
3460 generate_local_decl (gfc_symbol *);
3462 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3465 expr_decls (gfc_expr *e, gfc_symbol *sym,
3466 int *f ATTRIBUTE_UNUSED)
3468 if (e->expr_type != EXPR_VARIABLE
3469 || sym == e->symtree->n.sym
3470 || e->symtree->n.sym->mark
3471 || e->symtree->n.sym->ns != sym->ns)
3474 generate_local_decl (e->symtree->n.sym);
3479 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3481 gfc_traverse_expr (e, sym, expr_decls, 0);
3485 /* Check for dependencies in the character length and array spec. */
3488 generate_dependency_declarations (gfc_symbol *sym)
3492 if (sym->ts.type == BT_CHARACTER
3494 && sym->ts.cl->length
3495 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3496 generate_expr_decls (sym, sym->ts.cl->length);
3498 if (sym->as && sym->as->rank)
3500 for (i = 0; i < sym->as->rank; i++)
3502 generate_expr_decls (sym, sym->as->lower[i]);
3503 generate_expr_decls (sym, sym->as->upper[i]);
3509 /* Generate decls for all local variables. We do this to ensure correct
3510 handling of expressions which only appear in the specification of
3514 generate_local_decl (gfc_symbol * sym)
3516 if (sym->attr.flavor == FL_VARIABLE)
3518 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3519 generate_dependency_declarations (sym);
3521 if (sym->attr.referenced)
3522 gfc_get_symbol_decl (sym);
3523 /* INTENT(out) dummy arguments are likely meant to be set. */
3524 else if (warn_unused_variable
3526 && sym->attr.intent == INTENT_OUT)
3527 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3528 sym->name, &sym->declared_at);
3529 /* Specific warning for unused dummy arguments. */
3530 else if (warn_unused_variable && sym->attr.dummy)
3531 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3533 /* Warn for unused variables, but not if they're inside a common
3534 block or are use-associated. */
3535 else if (warn_unused_variable
3536 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3537 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3540 /* For variable length CHARACTER parameters, the PARM_DECL already
3541 references the length variable, so force gfc_get_symbol_decl
3542 even when not referenced. If optimize > 0, it will be optimized
3543 away anyway. But do this only after emitting -Wunused-parameter
3544 warning if requested. */
3545 if (sym->attr.dummy && !sym->attr.referenced
3546 && sym->ts.type == BT_CHARACTER
3547 && sym->ts.cl->backend_decl != NULL
3548 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3550 sym->attr.referenced = 1;
3551 gfc_get_symbol_decl (sym);
3554 /* INTENT(out) dummy arguments with allocatable components are reset
3555 by default and need to be set referenced to generate the code for
3556 automatic lengths. */
3557 if (sym->attr.dummy && !sym->attr.referenced
3558 && sym->ts.type == BT_DERIVED
3559 && sym->ts.derived->attr.alloc_comp
3560 && sym->attr.intent == INTENT_OUT)
3562 sym->attr.referenced = 1;
3563 gfc_get_symbol_decl (sym);
3567 /* Check for dependencies in the array specification and string
3568 length, adding the necessary declarations to the function. We
3569 mark the symbol now, as well as in traverse_ns, to prevent
3570 getting stuck in a circular dependency. */
3573 /* We do not want the middle-end to warn about unused parameters
3574 as this was already done above. */
3575 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3576 TREE_NO_WARNING(sym->backend_decl) = 1;
3578 else if (sym->attr.flavor == FL_PARAMETER)
3580 if (warn_unused_parameter
3581 && !sym->attr.referenced
3582 && !sym->attr.use_assoc)
3583 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3586 else if (sym->attr.flavor == FL_PROCEDURE)
3588 /* TODO: move to the appropriate place in resolve.c. */
3589 if (warn_return_type
3590 && sym->attr.function
3592 && sym != sym->result
3593 && !sym->result->attr.referenced
3594 && !sym->attr.use_assoc
3595 && sym->attr.if_source != IFSRC_IFBODY)
3597 gfc_warning ("Return value '%s' of function '%s' declared at "
3598 "%L not set", sym->result->name, sym->name,
3599 &sym->result->declared_at);
3601 /* Prevents "Unused variable" warning for RESULT variables. */
3602 sym->result->mark = 1;
3606 if (sym->attr.dummy == 1)
3608 /* Modify the tree type for scalar character dummy arguments of bind(c)
3609 procedures if they are passed by value. The tree type for them will
3610 be promoted to INTEGER_TYPE for the middle end, which appears to be
3611 what C would do with characters passed by-value. The value attribute
3612 implies the dummy is a scalar. */
3613 if (sym->attr.value == 1 && sym->backend_decl != NULL
3614 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3615 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3616 gfc_conv_scalar_char_value (sym, NULL, NULL);
3619 /* Make sure we convert the types of the derived types from iso_c_binding
3621 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3622 && sym->ts.type == BT_DERIVED)
3623 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3627 generate_local_vars (gfc_namespace * ns)
3629 gfc_traverse_ns (ns, generate_local_decl);
3633 /* Generate a switch statement to jump to the correct entry point. Also
3634 creates the label decls for the entry points. */
3637 gfc_trans_entry_master_switch (gfc_entry_list * el)
3644 gfc_init_block (&block);
3645 for (; el; el = el->next)
3647 /* Add the case label. */
3648 label = gfc_build_label_decl (NULL_TREE);
3649 val = build_int_cst (gfc_array_index_type, el->id);
3650 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3651 gfc_add_expr_to_block (&block, tmp);
3653 /* And jump to the actual entry point. */
3654 label = gfc_build_label_decl (NULL_TREE);
3655 tmp = build1_v (GOTO_EXPR, label);
3656 gfc_add_expr_to_block (&block, tmp);
3658 /* Save the label decl. */
3661 tmp = gfc_finish_block (&block);
3662 /* The first argument selects the entry point. */
3663 val = DECL_ARGUMENTS (current_function_decl);
3664 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3669 /* Generate code for a function. */
3672 gfc_generate_function_code (gfc_namespace * ns)
3685 sym = ns->proc_name;
3687 /* Check that the frontend isn't still using this. */
3688 gcc_assert (sym->tlink == NULL);
3691 /* Create the declaration for functions with global scope. */
3692 if (!sym->backend_decl)
3693 gfc_create_function_decl (ns);
3695 fndecl = sym->backend_decl;
3696 old_context = current_function_decl;
3700 push_function_context ();
3701 saved_parent_function_decls = saved_function_decls;
3702 saved_function_decls = NULL_TREE;
3705 trans_function_start (sym);
3707 gfc_init_block (&block);
3709 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3711 /* Copy length backend_decls to all entry point result
3716 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3717 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3718 for (el = ns->entries; el; el = el->next)
3719 el->sym->result->ts.cl->backend_decl = backend_decl;
3722 /* Translate COMMON blocks. */
3723 gfc_trans_common (ns);
3725 /* Null the parent fake result declaration if this namespace is
3726 a module function or an external procedures. */
3727 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3728 || ns->parent == NULL)
3729 parent_fake_result_decl = NULL_TREE;
3731 gfc_generate_contained_functions (ns);
3733 generate_local_vars (ns);
3735 /* Keep the parent fake result declaration in module functions
3736 or external procedures. */
3737 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3738 || ns->parent == NULL)
3739 current_fake_result_decl = parent_fake_result_decl;
3741 current_fake_result_decl = NULL_TREE;
3743 current_function_return_label = NULL;
3745 /* Now generate the code for the body of this function. */
3746 gfc_init_block (&body);
3748 /* If this is the main program, add a call to set_options to set up the
3749 runtime library Fortran language standard parameters. */
3750 if (sym->attr.is_main_program)
3752 tree array_type, array, var;
3754 /* Passing a new option to the library requires four modifications:
3755 + add it to the tree_cons list below
3756 + change the array size in the call to build_array_type
3757 + change the first argument to the library call
3758 gfor_fndecl_set_options
3759 + modify the library (runtime/compile_options.c)! */
3760 array = tree_cons (NULL_TREE,
3761 build_int_cst (integer_type_node,
3762 gfc_option.warn_std), NULL_TREE);
3763 array = tree_cons (NULL_TREE,
3764 build_int_cst (integer_type_node,
3765 gfc_option.allow_std), array);
3766 array = tree_cons (NULL_TREE,
3767 build_int_cst (integer_type_node, pedantic), array);
3768 array = tree_cons (NULL_TREE,
3769 build_int_cst (integer_type_node,
3770 gfc_option.flag_dump_core), array);
3771 array = tree_cons (NULL_TREE,
3772 build_int_cst (integer_type_node,
3773 gfc_option.flag_backtrace), array);
3774 array = tree_cons (NULL_TREE,
3775 build_int_cst (integer_type_node,
3776 gfc_option.flag_sign_zero), array);
3778 array = tree_cons (NULL_TREE,
3779 build_int_cst (integer_type_node,
3780 flag_bounds_check), array);
3782 array = tree_cons (NULL_TREE,
3783 build_int_cst (integer_type_node,
3784 gfc_option.flag_range_check), array);
3786 array_type = build_array_type (integer_type_node,
3787 build_index_type (build_int_cst (NULL_TREE,
3789 array = build_constructor_from_list (array_type, nreverse (array));
3790 TREE_CONSTANT (array) = 1;
3791 TREE_STATIC (array) = 1;
3793 /* Create a static variable to hold the jump table. */
3794 var = gfc_create_var (array_type, "options");
3795 TREE_CONSTANT (var) = 1;
3796 TREE_STATIC (var) = 1;
3797 TREE_READONLY (var) = 1;
3798 DECL_INITIAL (var) = array;
3799 var = gfc_build_addr_expr (pvoid_type_node, var);
3801 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3802 build_int_cst (integer_type_node, 8), var);
3803 gfc_add_expr_to_block (&body, tmp);
3806 /* If this is the main program and a -ffpe-trap option was provided,
3807 add a call to set_fpe so that the library will raise a FPE when
3809 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3811 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3812 build_int_cst (integer_type_node,
3814 gfc_add_expr_to_block (&body, tmp);
3817 /* If this is the main program and an -fconvert option was provided,
3818 add a call to set_convert. */
3820 if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3822 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3823 build_int_cst (integer_type_node,
3824 gfc_option.convert));
3825 gfc_add_expr_to_block (&body, tmp);
3828 /* If this is the main program and an -frecord-marker option was provided,
3829 add a call to set_record_marker. */
3831 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3833 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3834 build_int_cst (integer_type_node,
3835 gfc_option.record_marker));
3836 gfc_add_expr_to_block (&body, tmp);
3839 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3841 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3843 build_int_cst (integer_type_node,
3844 gfc_option.max_subrecord_length));
3845 gfc_add_expr_to_block (&body, tmp);
3848 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3849 && sym->attr.subroutine)
3851 tree alternate_return;
3852 alternate_return = gfc_get_fake_result_decl (sym, 0);
3853 gfc_add_modify (&body, alternate_return, integer_zero_node);
3858 /* Jump to the correct entry point. */
3859 tmp = gfc_trans_entry_master_switch (ns->entries);
3860 gfc_add_expr_to_block (&body, tmp);
3863 tmp = gfc_trans_code (ns->code);
3864 gfc_add_expr_to_block (&body, tmp);
3866 /* Add a return label if needed. */
3867 if (current_function_return_label)
3869 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3870 gfc_add_expr_to_block (&body, tmp);
3873 tmp = gfc_finish_block (&body);
3874 /* Add code to create and cleanup arrays. */
3875 tmp = gfc_trans_deferred_vars (sym, tmp);
3877 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3879 if (sym->attr.subroutine || sym == sym->result)
3881 if (current_fake_result_decl != NULL)
3882 result = TREE_VALUE (current_fake_result_decl);
3885 current_fake_result_decl = NULL_TREE;
3888 result = sym->result->backend_decl;
3890 if (result != NULL_TREE && sym->attr.function
3891 && sym->ts.type == BT_DERIVED
3892 && sym->ts.derived->attr.alloc_comp
3893 && !sym->attr.pointer)
3895 rank = sym->as ? sym->as->rank : 0;
3896 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3897 gfc_add_expr_to_block (&block, tmp2);
3900 gfc_add_expr_to_block (&block, tmp);
3902 if (result == NULL_TREE)
3904 /* TODO: move to the appropriate place in resolve.c. */
3905 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
3906 gfc_warning ("Return value of function '%s' at %L not set",
3907 sym->name, &sym->declared_at);
3909 TREE_NO_WARNING(sym->backend_decl) = 1;
3913 /* Set the return value to the dummy result variable. The
3914 types may be different for scalar default REAL functions
3915 with -ff2c, therefore we have to convert. */
3916 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3917 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3918 DECL_RESULT (fndecl), tmp);
3919 tmp = build1_v (RETURN_EXPR, tmp);
3920 gfc_add_expr_to_block (&block, tmp);
3924 gfc_add_expr_to_block (&block, tmp);
3927 /* Add all the decls we created during processing. */
3928 decl = saved_function_decls;
3933 next = TREE_CHAIN (decl);
3934 TREE_CHAIN (decl) = NULL_TREE;
3938 saved_function_decls = NULL_TREE;
3940 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3943 /* Finish off this function and send it for code generation. */
3945 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3947 DECL_SAVED_TREE (fndecl)
3948 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
3949 DECL_INITIAL (fndecl));
3951 /* Output the GENERIC tree. */
3952 dump_function (TDI_original, fndecl);
3954 /* Store the end of the function, so that we get good line number
3955 info for the epilogue. */
3956 cfun->function_end_locus = input_location;
3958 /* We're leaving the context of this function, so zap cfun.
3959 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3960 tree_rest_of_compilation. */
3965 pop_function_context ();
3966 saved_function_decls = saved_parent_function_decls;
3968 current_function_decl = old_context;
3970 if (decl_function_context (fndecl))
3971 /* Register this function with cgraph just far enough to get it
3972 added to our parent's nested function list. */
3973 (void) cgraph_node (fndecl);
3976 gfc_gimplify_function (fndecl);
3977 cgraph_finalize_function (fndecl, false);
3980 gfc_trans_use_stmts (ns);
3981 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3985 gfc_generate_constructors (void)
3987 gcc_assert (gfc_static_ctors == NULL_TREE);
3995 if (gfc_static_ctors == NULL_TREE)
3998 fnname = get_file_function_name ("I");
3999 type = build_function_type (void_type_node,
4000 gfc_chainon_list (NULL_TREE, void_type_node));
4002 fndecl = build_decl (FUNCTION_DECL, fnname, type);
4003 TREE_PUBLIC (fndecl) = 1;
4005 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
4006 DECL_ARTIFICIAL (decl) = 1;
4007 DECL_IGNORED_P (decl) = 1;
4008 DECL_CONTEXT (decl) = fndecl;
4009 DECL_RESULT (fndecl) = decl;
4013 current_function_decl = fndecl;
4015 rest_of_decl_compilation (fndecl, 1, 0);
4017 make_decl_rtl (fndecl);
4019 init_function_start (fndecl);
4023 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4025 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4026 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4032 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4033 DECL_SAVED_TREE (fndecl)
4034 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4035 DECL_INITIAL (fndecl));
4037 free_after_parsing (cfun);
4038 free_after_compilation (cfun);
4040 tree_rest_of_compilation (fndecl);
4042 current_function_decl = NULL_TREE;
4046 /* Translates a BLOCK DATA program unit. This means emitting the
4047 commons contained therein plus their initializations. We also emit
4048 a globally visible symbol to make sure that each BLOCK DATA program
4049 unit remains unique. */
4052 gfc_generate_block_data (gfc_namespace * ns)
4057 /* Tell the backend the source location of the block data. */
4059 gfc_set_backend_locus (&ns->proc_name->declared_at);
4061 gfc_set_backend_locus (&gfc_current_locus);
4063 /* Process the DATA statements. */
4064 gfc_trans_common (ns);
4066 /* Create a global symbol with the mane of the block data. This is to
4067 generate linker errors if the same name is used twice. It is never
4070 id = gfc_sym_mangled_function_id (ns->proc_name);
4072 id = get_identifier ("__BLOCK_DATA__");
4074 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4075 TREE_PUBLIC (decl) = 1;
4076 TREE_STATIC (decl) = 1;
4077 DECL_IGNORED_P (decl) = 1;
4080 rest_of_decl_compilation (decl, 1, 0);
4084 #include "gt-fortran-trans-decl.h"