1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* trans-decl.c -- Handling of backend function and variable decls, etc */
27 #include "coretypes.h"
29 #include "tree-dump.h"
30 #include "tree-gimple.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_internal_realloc;
78 tree gfor_fndecl_allocate;
79 tree gfor_fndecl_allocate_array;
80 tree gfor_fndecl_deallocate;
81 tree gfor_fndecl_pause_numeric;
82 tree gfor_fndecl_pause_string;
83 tree gfor_fndecl_stop_numeric;
84 tree gfor_fndecl_stop_string;
85 tree gfor_fndecl_select_string;
86 tree gfor_fndecl_runtime_error;
87 tree gfor_fndecl_runtime_error_at;
88 tree gfor_fndecl_os_error;
89 tree gfor_fndecl_generate_error;
90 tree gfor_fndecl_set_fpe;
91 tree gfor_fndecl_set_options;
92 tree gfor_fndecl_set_convert;
93 tree gfor_fndecl_set_record_marker;
94 tree gfor_fndecl_set_max_subrecord_length;
95 tree gfor_fndecl_ctime;
96 tree gfor_fndecl_fdate;
97 tree gfor_fndecl_ttynam;
98 tree gfor_fndecl_in_pack;
99 tree gfor_fndecl_in_unpack;
100 tree gfor_fndecl_associated;
103 /* Math functions. Many other math functions are handled in
104 trans-intrinsic.c. */
106 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
107 tree gfor_fndecl_math_cpowf;
108 tree gfor_fndecl_math_cpow;
109 tree gfor_fndecl_math_cpowl10;
110 tree gfor_fndecl_math_cpowl16;
111 tree gfor_fndecl_math_ishftc4;
112 tree gfor_fndecl_math_ishftc8;
113 tree gfor_fndecl_math_ishftc16;
114 tree gfor_fndecl_math_exponent4;
115 tree gfor_fndecl_math_exponent8;
116 tree gfor_fndecl_math_exponent10;
117 tree gfor_fndecl_math_exponent16;
120 /* String functions. */
122 tree gfor_fndecl_compare_string;
123 tree gfor_fndecl_concat_string;
124 tree gfor_fndecl_string_len_trim;
125 tree gfor_fndecl_string_index;
126 tree gfor_fndecl_string_scan;
127 tree gfor_fndecl_string_verify;
128 tree gfor_fndecl_string_trim;
129 tree gfor_fndecl_adjustl;
130 tree gfor_fndecl_adjustr;
133 /* Other misc. runtime library functions. */
135 tree gfor_fndecl_size0;
136 tree gfor_fndecl_size1;
137 tree gfor_fndecl_iargc;
139 /* Intrinsic functions implemented in FORTRAN. */
140 tree gfor_fndecl_si_kind;
141 tree gfor_fndecl_sr_kind;
143 /* BLAS gemm functions. */
144 tree gfor_fndecl_sgemm;
145 tree gfor_fndecl_dgemm;
146 tree gfor_fndecl_cgemm;
147 tree gfor_fndecl_zgemm;
151 gfc_add_decl_to_parent_function (tree decl)
154 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
155 DECL_NONLOCAL (decl) = 1;
156 TREE_CHAIN (decl) = saved_parent_function_decls;
157 saved_parent_function_decls = decl;
161 gfc_add_decl_to_function (tree decl)
164 TREE_USED (decl) = 1;
165 DECL_CONTEXT (decl) = current_function_decl;
166 TREE_CHAIN (decl) = saved_function_decls;
167 saved_function_decls = decl;
171 /* Build a backend label declaration. Set TREE_USED for named labels.
172 The context of the label is always the current_function_decl. All
173 labels are marked artificial. */
176 gfc_build_label_decl (tree label_id)
178 /* 2^32 temporaries should be enough. */
179 static unsigned int tmp_num = 1;
183 if (label_id == NULL_TREE)
185 /* Build an internal label name. */
186 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
187 label_id = get_identifier (label_name);
192 /* Build the LABEL_DECL node. Labels have no type. */
193 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
194 DECL_CONTEXT (label_decl) = current_function_decl;
195 DECL_MODE (label_decl) = VOIDmode;
197 /* We always define the label as used, even if the original source
198 file never references the label. We don't want all kinds of
199 spurious warnings for old-style Fortran code with too many
201 TREE_USED (label_decl) = 1;
203 DECL_ARTIFICIAL (label_decl) = 1;
208 /* Returns the return label for the current function. */
211 gfc_get_return_label (void)
213 char name[GFC_MAX_SYMBOL_LEN + 10];
215 if (current_function_return_label)
216 return current_function_return_label;
218 sprintf (name, "__return_%s",
219 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
221 current_function_return_label =
222 gfc_build_label_decl (get_identifier (name));
224 DECL_ARTIFICIAL (current_function_return_label) = 1;
226 return current_function_return_label;
230 /* Set the backend source location of a decl. */
233 gfc_set_decl_location (tree decl, locus * loc)
235 #ifdef USE_MAPPED_LOCATION
236 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
238 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
239 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
244 /* Return the backend label declaration for a given label structure,
245 or create it if it doesn't exist yet. */
248 gfc_get_label_decl (gfc_st_label * lp)
250 if (lp->backend_decl)
251 return lp->backend_decl;
254 char label_name[GFC_MAX_SYMBOL_LEN + 1];
257 /* Validate the label declaration from the front end. */
258 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
260 /* Build a mangled name for the label. */
261 sprintf (label_name, "__label_%.6d", lp->value);
263 /* Build the LABEL_DECL node. */
264 label_decl = gfc_build_label_decl (get_identifier (label_name));
266 /* Tell the debugger where the label came from. */
267 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
268 gfc_set_decl_location (label_decl, &lp->where);
270 DECL_ARTIFICIAL (label_decl) = 1;
272 /* Store the label in the label list and return the LABEL_DECL. */
273 lp->backend_decl = label_decl;
279 /* Convert a gfc_symbol to an identifier of the same name. */
282 gfc_sym_identifier (gfc_symbol * sym)
284 return (get_identifier (sym->name));
288 /* Construct mangled name from symbol name. */
291 gfc_sym_mangled_identifier (gfc_symbol * sym)
293 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
295 /* Prevent the mangling of identifiers that have an assigned
296 binding label (mainly those that are bind(c)). */
297 if (sym->attr.is_bind_c == 1
298 && sym->binding_label[0] != '\0')
299 return get_identifier(sym->binding_label);
301 if (sym->module == NULL)
302 return gfc_sym_identifier (sym);
305 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
306 return get_identifier (name);
311 /* Construct mangled function name from symbol name. */
314 gfc_sym_mangled_function_id (gfc_symbol * sym)
317 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
319 /* It may be possible to simply use the binding label if it's
320 provided, and remove the other checks. Then we could use it
321 for other things if we wished. */
322 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
323 sym->binding_label[0] != '\0')
324 /* use the binding label rather than the mangled name */
325 return get_identifier (sym->binding_label);
327 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
328 || (sym->module != NULL && (sym->attr.external
329 || sym->attr.if_source == IFSRC_IFBODY)))
331 if (strcmp (sym->name, "MAIN__") == 0
332 || sym->attr.proc == PROC_INTRINSIC)
333 return get_identifier (sym->name);
335 if (gfc_option.flag_underscoring)
337 has_underscore = strchr (sym->name, '_') != 0;
338 if (gfc_option.flag_second_underscore && has_underscore)
339 snprintf (name, sizeof name, "%s__", sym->name);
341 snprintf (name, sizeof name, "%s_", sym->name);
342 return get_identifier (name);
345 return get_identifier (sym->name);
349 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
350 return get_identifier (name);
355 /* Returns true if a variable of specified size should go on the stack. */
358 gfc_can_put_var_on_stack (tree size)
360 unsigned HOST_WIDE_INT low;
362 if (!INTEGER_CST_P (size))
365 if (gfc_option.flag_max_stack_var_size < 0)
368 if (TREE_INT_CST_HIGH (size) != 0)
371 low = TREE_INT_CST_LOW (size);
372 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
375 /* TODO: Set a per-function stack size limit. */
381 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
382 an expression involving its corresponding pointer. There are
383 2 cases; one for variable size arrays, and one for everything else,
384 because variable-sized arrays require one fewer level of
388 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
390 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
393 /* Parameters need to be dereferenced. */
394 if (sym->cp_pointer->attr.dummy)
395 ptr_decl = build_fold_indirect_ref (ptr_decl);
397 /* Check to see if we're dealing with a variable-sized array. */
398 if (sym->attr.dimension
399 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
401 /* These decls will be dereferenced later, so we don't dereference
403 value = convert (TREE_TYPE (decl), ptr_decl);
407 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
409 value = build_fold_indirect_ref (ptr_decl);
412 SET_DECL_VALUE_EXPR (decl, value);
413 DECL_HAS_VALUE_EXPR_P (decl) = 1;
414 GFC_DECL_CRAY_POINTEE (decl) = 1;
415 /* This is a fake variable just for debugging purposes. */
416 TREE_ASM_WRITTEN (decl) = 1;
420 /* Finish processing of a declaration without an initial value. */
423 gfc_finish_decl (tree decl)
425 gcc_assert (TREE_CODE (decl) == PARM_DECL
426 || DECL_INITIAL (decl) == NULL_TREE);
428 if (TREE_CODE (decl) != VAR_DECL)
431 if (DECL_SIZE (decl) == NULL_TREE
432 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
433 layout_decl (decl, 0);
435 /* A few consistency checks. */
436 /* A static variable with an incomplete type is an error if it is
437 initialized. Also if it is not file scope. Otherwise, let it
438 through, but if it is not `extern' then it may cause an error
440 /* An automatic variable with an incomplete type is an error. */
442 /* We should know the storage size. */
443 gcc_assert (DECL_SIZE (decl) != NULL_TREE
444 || (TREE_STATIC (decl)
445 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
446 : DECL_EXTERNAL (decl)));
448 /* The storage size should be constant. */
449 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
451 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
455 /* Apply symbol attributes to a variable, and add it to the function scope. */
458 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
461 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
462 This is the equivalent of the TARGET variables.
463 We also need to set this if the variable is passed by reference in a
466 /* Set DECL_VALUE_EXPR for Cray Pointees. */
467 if (sym->attr.cray_pointee)
468 gfc_finish_cray_pointee (decl, sym);
470 if (sym->attr.target)
471 TREE_ADDRESSABLE (decl) = 1;
472 /* If it wasn't used we wouldn't be getting it. */
473 TREE_USED (decl) = 1;
475 /* Chain this decl to the pending declarations. Don't do pushdecl()
476 because this would add them to the current scope rather than the
478 if (current_function_decl != NULL_TREE)
480 if (sym->ns->proc_name->backend_decl == current_function_decl
481 || sym->result == sym)
482 gfc_add_decl_to_function (decl);
484 gfc_add_decl_to_parent_function (decl);
487 if (sym->attr.cray_pointee)
490 if(sym->attr.is_bind_c == 1)
492 /* We need to put variables that are bind(c) into the common
493 segment of the object file, because this is what C would do.
494 gfortran would typically put them in either the BSS or
495 initialized data segments, and only mark them as common if
496 they were part of common blocks. However, if they are not put
497 into common space, then C cannot initialize global fortran
498 variables that it interoperates with and the draft says that
499 either Fortran or C should be able to initialize it (but not
500 both, of course.) (J3/04-007, section 15.3). */
501 TREE_PUBLIC(decl) = 1;
502 DECL_COMMON(decl) = 1;
505 /* If a variable is USE associated, it's always external. */
506 if (sym->attr.use_assoc)
508 DECL_EXTERNAL (decl) = 1;
509 TREE_PUBLIC (decl) = 1;
511 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
513 /* TODO: Don't set sym->module for result or dummy variables. */
514 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
515 /* This is the declaration of a module variable. */
516 TREE_PUBLIC (decl) = 1;
517 TREE_STATIC (decl) = 1;
520 if ((sym->attr.save || sym->attr.data || sym->value)
521 && !sym->attr.use_assoc)
522 TREE_STATIC (decl) = 1;
524 if (sym->attr.volatile_)
526 TREE_THIS_VOLATILE (decl) = 1;
527 new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
528 TREE_TYPE (decl) = new;
531 /* Keep variables larger than max-stack-var-size off stack. */
532 if (!sym->ns->proc_name->attr.recursive
533 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
534 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
535 /* Put variable length auto array pointers always into stack. */
536 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
537 || sym->attr.dimension == 0
538 || sym->as->type != AS_EXPLICIT
540 || sym->attr.allocatable)
541 && !DECL_ARTIFICIAL (decl))
542 TREE_STATIC (decl) = 1;
544 /* Handle threadprivate variables. */
545 if (sym->attr.threadprivate
546 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
547 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
551 /* Allocate the lang-specific part of a decl. */
554 gfc_allocate_lang_decl (tree decl)
556 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
557 ggc_alloc_cleared (sizeof (struct lang_decl));
560 /* Remember a symbol to generate initialization/cleanup code at function
564 gfc_defer_symbol_init (gfc_symbol * sym)
570 /* Don't add a symbol twice. */
574 last = head = sym->ns->proc_name;
577 /* Make sure that setup code for dummy variables which are used in the
578 setup of other variables is generated first. */
581 /* Find the first dummy arg seen after us, or the first non-dummy arg.
582 This is a circular list, so don't go past the head. */
584 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
590 /* Insert in between last and p. */
596 /* Create an array index type variable with function scope. */
599 create_index_var (const char * pfx, int nest)
603 decl = gfc_create_var_np (gfc_array_index_type, pfx);
605 gfc_add_decl_to_parent_function (decl);
607 gfc_add_decl_to_function (decl);
612 /* Create variables to hold all the non-constant bits of info for a
613 descriptorless array. Remember these in the lang-specific part of the
617 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
623 type = TREE_TYPE (decl);
625 /* We just use the descriptor, if there is one. */
626 if (GFC_DESCRIPTOR_TYPE_P (type))
629 gcc_assert (GFC_ARRAY_TYPE_P (type));
630 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
631 && !sym->attr.contained;
633 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
635 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
637 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
638 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
640 /* Don't try to use the unknown bound for assumed shape arrays. */
641 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
642 && (sym->as->type != AS_ASSUMED_SIZE
643 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
645 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
646 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
649 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
651 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
652 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
655 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
657 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
659 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
662 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
664 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
667 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
668 && sym->as->type != AS_ASSUMED_SIZE)
670 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
671 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
674 if (POINTER_TYPE_P (type))
676 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
677 gcc_assert (TYPE_LANG_SPECIFIC (type)
678 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
679 type = TREE_TYPE (type);
682 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
686 size = build2 (MINUS_EXPR, gfc_array_index_type,
687 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
688 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
690 TYPE_DOMAIN (type) = range;
696 /* For some dummy arguments we don't use the actual argument directly.
697 Instead we create a local decl and use that. This allows us to perform
698 initialization, and construct full type information. */
701 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
711 if (sym->attr.pointer || sym->attr.allocatable)
714 /* Add to list of variables if not a fake result variable. */
715 if (sym->attr.result || sym->attr.dummy)
716 gfc_defer_symbol_init (sym);
718 type = TREE_TYPE (dummy);
719 gcc_assert (TREE_CODE (dummy) == PARM_DECL
720 && POINTER_TYPE_P (type));
722 /* Do we know the element size? */
723 known_size = sym->ts.type != BT_CHARACTER
724 || INTEGER_CST_P (sym->ts.cl->backend_decl);
726 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
728 /* For descriptorless arrays with known element size the actual
729 argument is sufficient. */
730 gcc_assert (GFC_ARRAY_TYPE_P (type));
731 gfc_build_qualified_array (dummy, sym);
735 type = TREE_TYPE (type);
736 if (GFC_DESCRIPTOR_TYPE_P (type))
738 /* Create a descriptorless array pointer. */
741 if (!gfc_option.flag_repack_arrays)
743 if (as->type == AS_ASSUMED_SIZE)
744 packed = PACKED_FULL;
748 if (as->type == AS_EXPLICIT)
750 packed = PACKED_FULL;
751 for (n = 0; n < as->rank; n++)
755 && as->upper[n]->expr_type == EXPR_CONSTANT
756 && as->lower[n]->expr_type == EXPR_CONSTANT))
757 packed = PACKED_PARTIAL;
761 packed = PACKED_PARTIAL;
764 type = gfc_typenode_for_spec (&sym->ts);
765 type = gfc_get_nodesc_array_type (type, sym->as, packed);
769 /* We now have an expression for the element size, so create a fully
770 qualified type. Reset sym->backend decl or this will just return the
772 DECL_ARTIFICIAL (sym->backend_decl) = 1;
773 sym->backend_decl = NULL_TREE;
774 type = gfc_sym_type (sym);
775 packed = PACKED_FULL;
778 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
779 decl = build_decl (VAR_DECL, get_identifier (name), type);
781 DECL_ARTIFICIAL (decl) = 1;
782 TREE_PUBLIC (decl) = 0;
783 TREE_STATIC (decl) = 0;
784 DECL_EXTERNAL (decl) = 0;
786 /* We should never get deferred shape arrays here. We used to because of
788 gcc_assert (sym->as->type != AS_DEFERRED);
790 if (packed == PACKED_PARTIAL)
791 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
792 else if (packed == PACKED_FULL)
793 GFC_DECL_PACKED_ARRAY (decl) = 1;
795 gfc_build_qualified_array (decl, sym);
797 if (DECL_LANG_SPECIFIC (dummy))
798 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
800 gfc_allocate_lang_decl (decl);
802 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
804 if (sym->ns->proc_name->backend_decl == current_function_decl
805 || sym->attr.contained)
806 gfc_add_decl_to_function (decl);
808 gfc_add_decl_to_parent_function (decl);
814 /* Return a constant or a variable to use as a string length. Does not
815 add the decl to the current scope. */
818 gfc_create_string_length (gfc_symbol * sym)
822 gcc_assert (sym->ts.cl);
823 gfc_conv_const_charlen (sym->ts.cl);
825 if (sym->ts.cl->backend_decl == NULL_TREE)
827 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
829 /* Also prefix the mangled name. */
830 strcpy (&name[1], sym->name);
832 length = build_decl (VAR_DECL, get_identifier (name),
833 gfc_charlen_type_node);
834 DECL_ARTIFICIAL (length) = 1;
835 TREE_USED (length) = 1;
836 if (sym->ns->proc_name->tlink != NULL)
837 gfc_defer_symbol_init (sym);
838 sym->ts.cl->backend_decl = length;
841 return sym->ts.cl->backend_decl;
844 /* If a variable is assigned a label, we add another two auxiliary
848 gfc_add_assign_aux_vars (gfc_symbol * sym)
854 gcc_assert (sym->backend_decl);
856 decl = sym->backend_decl;
857 gfc_allocate_lang_decl (decl);
858 GFC_DECL_ASSIGN (decl) = 1;
859 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
860 gfc_charlen_type_node);
861 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
863 gfc_finish_var_decl (length, sym);
864 gfc_finish_var_decl (addr, sym);
865 /* STRING_LENGTH is also used as flag. Less than -1 means that
866 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
867 target label's address. Otherwise, value is the length of a format string
868 and ASSIGN_ADDR is its address. */
869 if (TREE_STATIC (length))
870 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
872 gfc_defer_symbol_init (sym);
874 GFC_DECL_STRING_LEN (decl) = length;
875 GFC_DECL_ASSIGN_ADDR (decl) = addr;
878 /* Return the decl for a gfc_symbol, create it if it doesn't already
882 gfc_get_symbol_decl (gfc_symbol * sym)
885 tree length = NULL_TREE;
888 gcc_assert (sym->attr.referenced
889 || sym->attr.use_assoc
890 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
892 if (sym->ns && sym->ns->proc_name->attr.function)
893 byref = gfc_return_by_reference (sym->ns->proc_name);
897 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
899 /* Return via extra parameter. */
900 if (sym->attr.result && byref
901 && !sym->backend_decl)
904 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
905 /* For entry master function skip over the __entry
907 if (sym->ns->proc_name->attr.entry_master)
908 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
911 /* Dummy variables should already have been created. */
912 gcc_assert (sym->backend_decl);
914 /* Create a character length variable. */
915 if (sym->ts.type == BT_CHARACTER)
917 if (sym->ts.cl->backend_decl == NULL_TREE)
918 length = gfc_create_string_length (sym);
920 length = sym->ts.cl->backend_decl;
921 if (TREE_CODE (length) == VAR_DECL
922 && DECL_CONTEXT (length) == NULL_TREE)
924 /* Add the string length to the same context as the symbol. */
925 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
926 gfc_add_decl_to_function (length);
928 gfc_add_decl_to_parent_function (length);
930 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
931 DECL_CONTEXT (length));
933 gfc_defer_symbol_init (sym);
937 /* Use a copy of the descriptor for dummy arrays. */
938 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
940 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
941 /* Prevent the dummy from being detected as unused if it is copied. */
942 if (sym->backend_decl != NULL && decl != sym->backend_decl)
943 DECL_ARTIFICIAL (sym->backend_decl) = 1;
944 sym->backend_decl = decl;
947 TREE_USED (sym->backend_decl) = 1;
948 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
950 gfc_add_assign_aux_vars (sym);
952 return sym->backend_decl;
955 if (sym->backend_decl)
956 return sym->backend_decl;
958 /* Catch function declarations. Only used for actual parameters. */
959 if (sym->attr.flavor == FL_PROCEDURE)
961 decl = gfc_get_extern_function_decl (sym);
965 if (sym->attr.intrinsic)
966 internal_error ("intrinsic variable which isn't a procedure");
968 /* Create string length decl first so that they can be used in the
970 if (sym->ts.type == BT_CHARACTER)
971 length = gfc_create_string_length (sym);
973 /* Create the decl for the variable. */
974 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
976 gfc_set_decl_location (decl, &sym->declared_at);
978 /* Symbols from modules should have their assembler names mangled.
979 This is done here rather than in gfc_finish_var_decl because it
980 is different for string length variables. */
982 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
984 if (sym->attr.dimension)
986 /* Create variables to hold the non-constant bits of array info. */
987 gfc_build_qualified_array (decl, sym);
989 /* Remember this variable for allocation/cleanup. */
990 gfc_defer_symbol_init (sym);
992 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
993 GFC_DECL_PACKED_ARRAY (decl) = 1;
996 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
997 gfc_defer_symbol_init (sym);
999 gfc_finish_var_decl (decl, sym);
1001 if (sym->ts.type == BT_CHARACTER)
1003 /* Character variables need special handling. */
1004 gfc_allocate_lang_decl (decl);
1006 if (TREE_CODE (length) != INTEGER_CST)
1008 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1012 /* Also prefix the mangled name for symbols from modules. */
1013 strcpy (&name[1], sym->name);
1016 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1017 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1019 gfc_finish_var_decl (length, sym);
1020 gcc_assert (!sym->value);
1023 sym->backend_decl = decl;
1025 if (sym->attr.assign)
1026 gfc_add_assign_aux_vars (sym);
1028 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1030 /* Add static initializer. */
1031 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1032 TREE_TYPE (decl), sym->attr.dimension,
1033 sym->attr.pointer || sym->attr.allocatable);
1040 /* Substitute a temporary variable in place of the real one. */
1043 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1045 save->attr = sym->attr;
1046 save->decl = sym->backend_decl;
1048 gfc_clear_attr (&sym->attr);
1049 sym->attr.referenced = 1;
1050 sym->attr.flavor = FL_VARIABLE;
1052 sym->backend_decl = decl;
1056 /* Restore the original variable. */
1059 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1061 sym->attr = save->attr;
1062 sym->backend_decl = save->decl;
1066 /* Get a basic decl for an external function. */
1069 gfc_get_extern_function_decl (gfc_symbol * sym)
1074 gfc_intrinsic_sym *isym;
1076 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1080 if (sym->backend_decl)
1081 return sym->backend_decl;
1083 /* We should never be creating external decls for alternate entry points.
1084 The procedure may be an alternate entry point, but we don't want/need
1086 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1088 if (sym->attr.intrinsic)
1090 /* Call the resolution function to get the actual name. This is
1091 a nasty hack which relies on the resolution functions only looking
1092 at the first argument. We pass NULL for the second argument
1093 otherwise things like AINT get confused. */
1094 isym = gfc_find_function (sym->name);
1095 gcc_assert (isym->resolve.f0 != NULL);
1097 memset (&e, 0, sizeof (e));
1098 e.expr_type = EXPR_FUNCTION;
1100 memset (&argexpr, 0, sizeof (argexpr));
1101 gcc_assert (isym->formal);
1102 argexpr.ts = isym->formal->ts;
1104 if (isym->formal->next == NULL)
1105 isym->resolve.f1 (&e, &argexpr);
1108 if (isym->formal->next->next == NULL)
1109 isym->resolve.f2 (&e, &argexpr, NULL);
1112 /* All specific intrinsics take less than 4 arguments. */
1113 gcc_assert (isym->formal->next->next->next == NULL);
1114 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1118 if (gfc_option.flag_f2c
1119 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1120 || e.ts.type == BT_COMPLEX))
1122 /* Specific which needs a different implementation if f2c
1123 calling conventions are used. */
1124 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1127 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1129 name = get_identifier (s);
1130 mangled_name = name;
1134 name = gfc_sym_identifier (sym);
1135 mangled_name = gfc_sym_mangled_function_id (sym);
1138 type = gfc_get_function_type (sym);
1139 fndecl = build_decl (FUNCTION_DECL, name, type);
1141 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1142 /* If the return type is a pointer, avoid alias issues by setting
1143 DECL_IS_MALLOC to nonzero. This means that the function should be
1144 treated as if it were a malloc, meaning it returns a pointer that
1146 if (POINTER_TYPE_P (type))
1147 DECL_IS_MALLOC (fndecl) = 1;
1149 /* Set the context of this decl. */
1150 if (0 && sym->ns && sym->ns->proc_name)
1152 /* TODO: Add external decls to the appropriate scope. */
1153 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1157 /* Global declaration, e.g. intrinsic subroutine. */
1158 DECL_CONTEXT (fndecl) = NULL_TREE;
1161 DECL_EXTERNAL (fndecl) = 1;
1163 /* This specifies if a function is globally addressable, i.e. it is
1164 the opposite of declaring static in C. */
1165 TREE_PUBLIC (fndecl) = 1;
1167 /* Set attributes for PURE functions. A call to PURE function in the
1168 Fortran 95 sense is both pure and without side effects in the C
1170 if (sym->attr.pure || sym->attr.elemental)
1172 if (sym->attr.function && !gfc_return_by_reference (sym))
1173 DECL_IS_PURE (fndecl) = 1;
1174 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1175 parameters and don't use alternate returns (is this
1176 allowed?). In that case, calls to them are meaningless, and
1177 can be optimized away. See also in build_function_decl(). */
1178 TREE_SIDE_EFFECTS (fndecl) = 0;
1181 /* Mark non-returning functions. */
1182 if (sym->attr.noreturn)
1183 TREE_THIS_VOLATILE(fndecl) = 1;
1185 sym->backend_decl = fndecl;
1187 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1188 pushdecl_top_level (fndecl);
1194 /* Create a declaration for a procedure. For external functions (in the C
1195 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1196 a master function with alternate entry points. */
1199 build_function_decl (gfc_symbol * sym)
1202 symbol_attribute attr;
1204 gfc_formal_arglist *f;
1206 gcc_assert (!sym->backend_decl);
1207 gcc_assert (!sym->attr.external);
1209 /* Set the line and filename. sym->declared_at seems to point to the
1210 last statement for subroutines, but it'll do for now. */
1211 gfc_set_backend_locus (&sym->declared_at);
1213 /* Allow only one nesting level. Allow public declarations. */
1214 gcc_assert (current_function_decl == NULL_TREE
1215 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1217 type = gfc_get_function_type (sym);
1218 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1220 /* Perform name mangling if this is a top level or module procedure. */
1221 if (current_function_decl == NULL_TREE)
1222 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1224 /* Figure out the return type of the declared function, and build a
1225 RESULT_DECL for it. If this is a subroutine with alternate
1226 returns, build a RESULT_DECL for it. */
1229 result_decl = NULL_TREE;
1230 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1233 if (gfc_return_by_reference (sym))
1234 type = void_type_node;
1237 if (sym->result != sym)
1238 result_decl = gfc_sym_identifier (sym->result);
1240 type = TREE_TYPE (TREE_TYPE (fndecl));
1245 /* Look for alternate return placeholders. */
1246 int has_alternate_returns = 0;
1247 for (f = sym->formal; f; f = f->next)
1251 has_alternate_returns = 1;
1256 if (has_alternate_returns)
1257 type = integer_type_node;
1259 type = void_type_node;
1262 result_decl = build_decl (RESULT_DECL, result_decl, type);
1263 DECL_ARTIFICIAL (result_decl) = 1;
1264 DECL_IGNORED_P (result_decl) = 1;
1265 DECL_CONTEXT (result_decl) = fndecl;
1266 DECL_RESULT (fndecl) = result_decl;
1268 /* Don't call layout_decl for a RESULT_DECL.
1269 layout_decl (result_decl, 0); */
1271 /* If the return type is a pointer, avoid alias issues by setting
1272 DECL_IS_MALLOC to nonzero. This means that the function should be
1273 treated as if it were a malloc, meaning it returns a pointer that
1275 if (POINTER_TYPE_P (type))
1276 DECL_IS_MALLOC (fndecl) = 1;
1278 /* Set up all attributes for the function. */
1279 DECL_CONTEXT (fndecl) = current_function_decl;
1280 DECL_EXTERNAL (fndecl) = 0;
1282 /* This specifies if a function is globally visible, i.e. it is
1283 the opposite of declaring static in C. */
1284 if (DECL_CONTEXT (fndecl) == NULL_TREE
1285 && !sym->attr.entry_master)
1286 TREE_PUBLIC (fndecl) = 1;
1288 /* TREE_STATIC means the function body is defined here. */
1289 TREE_STATIC (fndecl) = 1;
1291 /* Set attributes for PURE functions. A call to a PURE function in the
1292 Fortran 95 sense is both pure and without side effects in the C
1294 if (attr.pure || attr.elemental)
1296 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1297 including an alternate return. In that case it can also be
1298 marked as PURE. See also in gfc_get_extern_function_decl(). */
1299 if (attr.function && !gfc_return_by_reference (sym))
1300 DECL_IS_PURE (fndecl) = 1;
1301 TREE_SIDE_EFFECTS (fndecl) = 0;
1304 /* Layout the function declaration and put it in the binding level
1305 of the current function. */
1308 sym->backend_decl = fndecl;
1312 /* Create the DECL_ARGUMENTS for a procedure. */
1315 create_function_arglist (gfc_symbol * sym)
1318 gfc_formal_arglist *f;
1319 tree typelist, hidden_typelist;
1320 tree arglist, hidden_arglist;
1324 fndecl = sym->backend_decl;
1326 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1327 the new FUNCTION_DECL node. */
1328 arglist = NULL_TREE;
1329 hidden_arglist = NULL_TREE;
1330 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1332 if (sym->attr.entry_master)
1334 type = TREE_VALUE (typelist);
1335 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1337 DECL_CONTEXT (parm) = fndecl;
1338 DECL_ARG_TYPE (parm) = type;
1339 TREE_READONLY (parm) = 1;
1340 gfc_finish_decl (parm);
1341 DECL_ARTIFICIAL (parm) = 1;
1343 arglist = chainon (arglist, parm);
1344 typelist = TREE_CHAIN (typelist);
1347 if (gfc_return_by_reference (sym))
1349 tree type = TREE_VALUE (typelist), length = NULL;
1351 if (sym->ts.type == BT_CHARACTER)
1353 /* Length of character result. */
1354 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1355 gcc_assert (len_type == gfc_charlen_type_node);
1357 length = build_decl (PARM_DECL,
1358 get_identifier (".__result"),
1360 if (!sym->ts.cl->length)
1362 sym->ts.cl->backend_decl = length;
1363 TREE_USED (length) = 1;
1365 gcc_assert (TREE_CODE (length) == PARM_DECL);
1366 DECL_CONTEXT (length) = fndecl;
1367 DECL_ARG_TYPE (length) = len_type;
1368 TREE_READONLY (length) = 1;
1369 DECL_ARTIFICIAL (length) = 1;
1370 gfc_finish_decl (length);
1371 if (sym->ts.cl->backend_decl == NULL
1372 || sym->ts.cl->backend_decl == length)
1377 if (sym->ts.cl->backend_decl == NULL)
1379 tree len = build_decl (VAR_DECL,
1380 get_identifier ("..__result"),
1381 gfc_charlen_type_node);
1382 DECL_ARTIFICIAL (len) = 1;
1383 TREE_USED (len) = 1;
1384 sym->ts.cl->backend_decl = len;
1387 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1388 arg = sym->result ? sym->result : sym;
1389 backend_decl = arg->backend_decl;
1390 /* Temporary clear it, so that gfc_sym_type creates complete
1392 arg->backend_decl = NULL;
1393 type = gfc_sym_type (arg);
1394 arg->backend_decl = backend_decl;
1395 type = build_reference_type (type);
1399 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1401 DECL_CONTEXT (parm) = fndecl;
1402 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1403 TREE_READONLY (parm) = 1;
1404 DECL_ARTIFICIAL (parm) = 1;
1405 gfc_finish_decl (parm);
1407 arglist = chainon (arglist, parm);
1408 typelist = TREE_CHAIN (typelist);
1410 if (sym->ts.type == BT_CHARACTER)
1412 gfc_allocate_lang_decl (parm);
1413 arglist = chainon (arglist, length);
1414 typelist = TREE_CHAIN (typelist);
1418 hidden_typelist = typelist;
1419 for (f = sym->formal; f; f = f->next)
1420 if (f->sym != NULL) /* Ignore alternate returns. */
1421 hidden_typelist = TREE_CHAIN (hidden_typelist);
1423 for (f = sym->formal; f; f = f->next)
1425 char name[GFC_MAX_SYMBOL_LEN + 2];
1427 /* Ignore alternate returns. */
1431 type = TREE_VALUE (typelist);
1433 if (f->sym->ts.type == BT_CHARACTER)
1435 tree len_type = TREE_VALUE (hidden_typelist);
1436 tree length = NULL_TREE;
1437 gcc_assert (len_type == gfc_charlen_type_node);
1439 strcpy (&name[1], f->sym->name);
1441 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1443 hidden_arglist = chainon (hidden_arglist, length);
1444 DECL_CONTEXT (length) = fndecl;
1445 DECL_ARTIFICIAL (length) = 1;
1446 DECL_ARG_TYPE (length) = len_type;
1447 TREE_READONLY (length) = 1;
1448 gfc_finish_decl (length);
1450 /* TODO: Check string lengths when -fbounds-check. */
1452 /* Use the passed value for assumed length variables. */
1453 if (!f->sym->ts.cl->length)
1455 TREE_USED (length) = 1;
1456 if (!f->sym->ts.cl->backend_decl)
1457 f->sym->ts.cl->backend_decl = length;
1460 /* there is already another variable using this
1461 gfc_charlen node, build a new one for this variable
1462 and chain it into the list of gfc_charlens.
1463 This happens for e.g. in the case
1465 since CHARACTER declarations on the same line share
1466 the same gfc_charlen node. */
1469 cl = gfc_get_charlen ();
1470 cl->backend_decl = length;
1471 cl->next = f->sym->ts.cl->next;
1472 f->sym->ts.cl->next = cl;
1477 hidden_typelist = TREE_CHAIN (hidden_typelist);
1479 if (f->sym->ts.cl->backend_decl == NULL
1480 || f->sym->ts.cl->backend_decl == length)
1482 if (f->sym->ts.cl->backend_decl == NULL)
1483 gfc_create_string_length (f->sym);
1485 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1486 if (f->sym->attr.flavor == FL_PROCEDURE)
1487 type = build_pointer_type (gfc_get_function_type (f->sym));
1489 type = gfc_sym_type (f->sym);
1493 /* For non-constant length array arguments, make sure they use
1494 a different type node from TYPE_ARG_TYPES type. */
1495 if (f->sym->attr.dimension
1496 && type == TREE_VALUE (typelist)
1497 && TREE_CODE (type) == POINTER_TYPE
1498 && GFC_ARRAY_TYPE_P (type)
1499 && f->sym->as->type != AS_ASSUMED_SIZE
1500 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1502 if (f->sym->attr.flavor == FL_PROCEDURE)
1503 type = build_pointer_type (gfc_get_function_type (f->sym));
1505 type = gfc_sym_type (f->sym);
1508 /* Build a the argument declaration. */
1509 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1511 /* Fill in arg stuff. */
1512 DECL_CONTEXT (parm) = fndecl;
1513 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1514 /* All implementation args are read-only. */
1515 TREE_READONLY (parm) = 1;
1517 gfc_finish_decl (parm);
1519 f->sym->backend_decl = parm;
1521 arglist = chainon (arglist, parm);
1522 typelist = TREE_CHAIN (typelist);
1525 /* Add the hidden string length parameters. */
1526 arglist = chainon (arglist, hidden_arglist);
1528 gcc_assert (hidden_typelist == NULL_TREE
1529 || TREE_VALUE (hidden_typelist) == void_type_node);
1530 DECL_ARGUMENTS (fndecl) = arglist;
1533 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1536 gfc_gimplify_function (tree fndecl)
1538 struct cgraph_node *cgn;
1540 gimplify_function_tree (fndecl);
1541 dump_function (TDI_generic, fndecl);
1543 /* Generate errors for structured block violations. */
1544 /* ??? Could be done as part of resolve_labels. */
1546 diagnose_omp_structured_block_errors (fndecl);
1548 /* Convert all nested functions to GIMPLE now. We do things in this order
1549 so that items like VLA sizes are expanded properly in the context of the
1550 correct function. */
1551 cgn = cgraph_node (fndecl);
1552 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1553 gfc_gimplify_function (cgn->decl);
1557 /* Do the setup necessary before generating the body of a function. */
1560 trans_function_start (gfc_symbol * sym)
1564 fndecl = sym->backend_decl;
1566 /* Let GCC know the current scope is this function. */
1567 current_function_decl = fndecl;
1569 /* Let the world know what we're about to do. */
1570 announce_function (fndecl);
1572 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1574 /* Create RTL for function declaration. */
1575 rest_of_decl_compilation (fndecl, 1, 0);
1578 /* Create RTL for function definition. */
1579 make_decl_rtl (fndecl);
1581 init_function_start (fndecl);
1583 /* Even though we're inside a function body, we still don't want to
1584 call expand_expr to calculate the size of a variable-sized array.
1585 We haven't necessarily assigned RTL to all variables yet, so it's
1586 not safe to try to expand expressions involving them. */
1587 cfun->x_dont_save_pending_sizes_p = 1;
1589 /* function.c requires a push at the start of the function. */
1593 /* Create thunks for alternate entry points. */
1596 build_entry_thunks (gfc_namespace * ns)
1598 gfc_formal_arglist *formal;
1599 gfc_formal_arglist *thunk_formal;
1601 gfc_symbol *thunk_sym;
1609 /* This should always be a toplevel function. */
1610 gcc_assert (current_function_decl == NULL_TREE);
1612 gfc_get_backend_locus (&old_loc);
1613 for (el = ns->entries; el; el = el->next)
1615 thunk_sym = el->sym;
1617 build_function_decl (thunk_sym);
1618 create_function_arglist (thunk_sym);
1620 trans_function_start (thunk_sym);
1622 thunk_fndecl = thunk_sym->backend_decl;
1624 gfc_start_block (&body);
1626 /* Pass extra parameter identifying this entry point. */
1627 tmp = build_int_cst (gfc_array_index_type, el->id);
1628 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1629 string_args = NULL_TREE;
1631 if (thunk_sym->attr.function)
1633 if (gfc_return_by_reference (ns->proc_name))
1635 tree ref = DECL_ARGUMENTS (current_function_decl);
1636 args = tree_cons (NULL_TREE, ref, args);
1637 if (ns->proc_name->ts.type == BT_CHARACTER)
1638 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1643 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1645 /* Ignore alternate returns. */
1646 if (formal->sym == NULL)
1649 /* We don't have a clever way of identifying arguments, so resort to
1650 a brute-force search. */
1651 for (thunk_formal = thunk_sym->formal;
1653 thunk_formal = thunk_formal->next)
1655 if (thunk_formal->sym == formal->sym)
1661 /* Pass the argument. */
1662 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1663 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1665 if (formal->sym->ts.type == BT_CHARACTER)
1667 tmp = thunk_formal->sym->ts.cl->backend_decl;
1668 string_args = tree_cons (NULL_TREE, tmp, string_args);
1673 /* Pass NULL for a missing argument. */
1674 args = tree_cons (NULL_TREE, null_pointer_node, args);
1675 if (formal->sym->ts.type == BT_CHARACTER)
1677 tmp = build_int_cst (gfc_charlen_type_node, 0);
1678 string_args = tree_cons (NULL_TREE, tmp, string_args);
1683 /* Call the master function. */
1684 args = nreverse (args);
1685 args = chainon (args, nreverse (string_args));
1686 tmp = ns->proc_name->backend_decl;
1687 tmp = build_function_call_expr (tmp, args);
1688 if (ns->proc_name->attr.mixed_entry_master)
1690 tree union_decl, field;
1691 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1693 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1694 TREE_TYPE (master_type));
1695 DECL_ARTIFICIAL (union_decl) = 1;
1696 DECL_EXTERNAL (union_decl) = 0;
1697 TREE_PUBLIC (union_decl) = 0;
1698 TREE_USED (union_decl) = 1;
1699 layout_decl (union_decl, 0);
1700 pushdecl (union_decl);
1702 DECL_CONTEXT (union_decl) = current_function_decl;
1703 tmp = build2 (MODIFY_EXPR,
1704 TREE_TYPE (union_decl),
1706 gfc_add_expr_to_block (&body, tmp);
1708 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1709 field; field = TREE_CHAIN (field))
1710 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1711 thunk_sym->result->name) == 0)
1713 gcc_assert (field != NULL_TREE);
1714 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1716 tmp = build2 (MODIFY_EXPR,
1717 TREE_TYPE (DECL_RESULT (current_function_decl)),
1718 DECL_RESULT (current_function_decl), tmp);
1719 tmp = build1_v (RETURN_EXPR, tmp);
1721 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1724 tmp = build2 (MODIFY_EXPR,
1725 TREE_TYPE (DECL_RESULT (current_function_decl)),
1726 DECL_RESULT (current_function_decl), tmp);
1727 tmp = build1_v (RETURN_EXPR, tmp);
1729 gfc_add_expr_to_block (&body, tmp);
1731 /* Finish off this function and send it for code generation. */
1732 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1734 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1736 /* Output the GENERIC tree. */
1737 dump_function (TDI_original, thunk_fndecl);
1739 /* Store the end of the function, so that we get good line number
1740 info for the epilogue. */
1741 cfun->function_end_locus = input_location;
1743 /* We're leaving the context of this function, so zap cfun.
1744 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1745 tree_rest_of_compilation. */
1748 current_function_decl = NULL_TREE;
1750 gfc_gimplify_function (thunk_fndecl);
1751 cgraph_finalize_function (thunk_fndecl, false);
1753 /* We share the symbols in the formal argument list with other entry
1754 points and the master function. Clear them so that they are
1755 recreated for each function. */
1756 for (formal = thunk_sym->formal; formal; formal = formal->next)
1757 if (formal->sym != NULL) /* Ignore alternate returns. */
1759 formal->sym->backend_decl = NULL_TREE;
1760 if (formal->sym->ts.type == BT_CHARACTER)
1761 formal->sym->ts.cl->backend_decl = NULL_TREE;
1764 if (thunk_sym->attr.function)
1766 if (thunk_sym->ts.type == BT_CHARACTER)
1767 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1768 if (thunk_sym->result->ts.type == BT_CHARACTER)
1769 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1773 gfc_set_backend_locus (&old_loc);
1777 /* Create a decl for a function, and create any thunks for alternate entry
1781 gfc_create_function_decl (gfc_namespace * ns)
1783 /* Create a declaration for the master function. */
1784 build_function_decl (ns->proc_name);
1786 /* Compile the entry thunks. */
1788 build_entry_thunks (ns);
1790 /* Now create the read argument list. */
1791 create_function_arglist (ns->proc_name);
1794 /* Return the decl used to hold the function return value. If
1795 parent_flag is set, the context is the parent_scope. */
1798 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1802 tree this_fake_result_decl;
1803 tree this_function_decl;
1805 char name[GFC_MAX_SYMBOL_LEN + 10];
1809 this_fake_result_decl = parent_fake_result_decl;
1810 this_function_decl = DECL_CONTEXT (current_function_decl);
1814 this_fake_result_decl = current_fake_result_decl;
1815 this_function_decl = current_function_decl;
1819 && sym->ns->proc_name->backend_decl == this_function_decl
1820 && sym->ns->proc_name->attr.entry_master
1821 && sym != sym->ns->proc_name)
1824 if (this_fake_result_decl != NULL)
1825 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1826 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1829 return TREE_VALUE (t);
1830 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1833 this_fake_result_decl = parent_fake_result_decl;
1835 this_fake_result_decl = current_fake_result_decl;
1837 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1841 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1842 field; field = TREE_CHAIN (field))
1843 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1847 gcc_assert (field != NULL_TREE);
1848 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1852 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1854 gfc_add_decl_to_parent_function (var);
1856 gfc_add_decl_to_function (var);
1858 SET_DECL_VALUE_EXPR (var, decl);
1859 DECL_HAS_VALUE_EXPR_P (var) = 1;
1860 GFC_DECL_RESULT (var) = 1;
1862 TREE_CHAIN (this_fake_result_decl)
1863 = tree_cons (get_identifier (sym->name), var,
1864 TREE_CHAIN (this_fake_result_decl));
1868 if (this_fake_result_decl != NULL_TREE)
1869 return TREE_VALUE (this_fake_result_decl);
1871 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1876 if (sym->ts.type == BT_CHARACTER)
1878 if (sym->ts.cl->backend_decl == NULL_TREE)
1879 length = gfc_create_string_length (sym);
1881 length = sym->ts.cl->backend_decl;
1882 if (TREE_CODE (length) == VAR_DECL
1883 && DECL_CONTEXT (length) == NULL_TREE)
1884 gfc_add_decl_to_function (length);
1887 if (gfc_return_by_reference (sym))
1889 decl = DECL_ARGUMENTS (this_function_decl);
1891 if (sym->ns->proc_name->backend_decl == this_function_decl
1892 && sym->ns->proc_name->attr.entry_master)
1893 decl = TREE_CHAIN (decl);
1895 TREE_USED (decl) = 1;
1897 decl = gfc_build_dummy_array_decl (sym, decl);
1901 sprintf (name, "__result_%.20s",
1902 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1904 if (!sym->attr.mixed_entry_master && sym->attr.function)
1905 decl = build_decl (VAR_DECL, get_identifier (name),
1906 gfc_sym_type (sym));
1908 decl = build_decl (VAR_DECL, get_identifier (name),
1909 TREE_TYPE (TREE_TYPE (this_function_decl)));
1910 DECL_ARTIFICIAL (decl) = 1;
1911 DECL_EXTERNAL (decl) = 0;
1912 TREE_PUBLIC (decl) = 0;
1913 TREE_USED (decl) = 1;
1914 GFC_DECL_RESULT (decl) = 1;
1915 TREE_ADDRESSABLE (decl) = 1;
1917 layout_decl (decl, 0);
1920 gfc_add_decl_to_parent_function (decl);
1922 gfc_add_decl_to_function (decl);
1926 parent_fake_result_decl = build_tree_list (NULL, decl);
1928 current_fake_result_decl = build_tree_list (NULL, decl);
1934 /* Builds a function decl. The remaining parameters are the types of the
1935 function arguments. Negative nargs indicates a varargs function. */
1938 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1947 /* Library functions must be declared with global scope. */
1948 gcc_assert (current_function_decl == NULL_TREE);
1950 va_start (p, nargs);
1953 /* Create a list of the argument types. */
1954 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1956 argtype = va_arg (p, tree);
1957 arglist = gfc_chainon_list (arglist, argtype);
1962 /* Terminate the list. */
1963 arglist = gfc_chainon_list (arglist, void_type_node);
1966 /* Build the function type and decl. */
1967 fntype = build_function_type (rettype, arglist);
1968 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1970 /* Mark this decl as external. */
1971 DECL_EXTERNAL (fndecl) = 1;
1972 TREE_PUBLIC (fndecl) = 1;
1978 rest_of_decl_compilation (fndecl, 1, 0);
1984 gfc_build_intrinsic_function_decls (void)
1986 tree gfc_int4_type_node = gfc_get_int_type (4);
1987 tree gfc_int8_type_node = gfc_get_int_type (8);
1988 tree gfc_int16_type_node = gfc_get_int_type (16);
1989 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1990 tree gfc_real4_type_node = gfc_get_real_type (4);
1991 tree gfc_real8_type_node = gfc_get_real_type (8);
1992 tree gfc_real10_type_node = gfc_get_real_type (10);
1993 tree gfc_real16_type_node = gfc_get_real_type (16);
1994 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1995 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1996 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1997 tree gfc_complex16_type_node = gfc_get_complex_type (16);
1998 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2000 /* String functions. */
2001 gfor_fndecl_compare_string =
2002 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2005 gfc_charlen_type_node, pchar_type_node,
2006 gfc_charlen_type_node, pchar_type_node);
2008 gfor_fndecl_concat_string =
2009 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2012 gfc_charlen_type_node, pchar_type_node,
2013 gfc_charlen_type_node, pchar_type_node,
2014 gfc_charlen_type_node, pchar_type_node);
2016 gfor_fndecl_string_len_trim =
2017 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2019 2, gfc_charlen_type_node,
2022 gfor_fndecl_string_index =
2023 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2025 5, gfc_charlen_type_node, pchar_type_node,
2026 gfc_charlen_type_node, pchar_type_node,
2027 gfc_logical4_type_node);
2029 gfor_fndecl_string_scan =
2030 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2032 5, gfc_charlen_type_node, pchar_type_node,
2033 gfc_charlen_type_node, pchar_type_node,
2034 gfc_logical4_type_node);
2036 gfor_fndecl_string_verify =
2037 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2039 5, gfc_charlen_type_node, pchar_type_node,
2040 gfc_charlen_type_node, pchar_type_node,
2041 gfc_logical4_type_node);
2043 gfor_fndecl_string_trim =
2044 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2047 build_pointer_type (gfc_charlen_type_node),
2049 gfc_charlen_type_node,
2052 gfor_fndecl_ttynam =
2053 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2057 gfc_charlen_type_node,
2058 gfc_c_int_type_node);
2061 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2065 gfc_charlen_type_node);
2068 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2072 gfc_charlen_type_node,
2073 gfc_int8_type_node);
2075 gfor_fndecl_adjustl =
2076 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2080 gfc_charlen_type_node, pchar_type_node);
2082 gfor_fndecl_adjustr =
2083 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2087 gfc_charlen_type_node, pchar_type_node);
2089 gfor_fndecl_si_kind =
2090 gfc_build_library_function_decl (get_identifier
2091 (PREFIX("selected_int_kind")),
2096 gfor_fndecl_sr_kind =
2097 gfc_build_library_function_decl (get_identifier
2098 (PREFIX("selected_real_kind")),
2103 /* Power functions. */
2105 tree ctype, rtype, itype, jtype;
2106 int rkind, ikind, jkind;
2109 static int ikinds[NIKINDS] = {4, 8, 16};
2110 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2111 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2113 for (ikind=0; ikind < NIKINDS; ikind++)
2115 itype = gfc_get_int_type (ikinds[ikind]);
2117 for (jkind=0; jkind < NIKINDS; jkind++)
2119 jtype = gfc_get_int_type (ikinds[jkind]);
2122 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2124 gfor_fndecl_math_powi[jkind][ikind].integer =
2125 gfc_build_library_function_decl (get_identifier (name),
2126 jtype, 2, jtype, itype);
2127 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2131 for (rkind = 0; rkind < NRKINDS; rkind ++)
2133 rtype = gfc_get_real_type (rkinds[rkind]);
2136 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2138 gfor_fndecl_math_powi[rkind][ikind].real =
2139 gfc_build_library_function_decl (get_identifier (name),
2140 rtype, 2, rtype, itype);
2141 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2144 ctype = gfc_get_complex_type (rkinds[rkind]);
2147 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2149 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2150 gfc_build_library_function_decl (get_identifier (name),
2151 ctype, 2,ctype, itype);
2152 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2160 gfor_fndecl_math_cpowf =
2161 gfc_build_library_function_decl (get_identifier ("cpowf"),
2162 gfc_complex4_type_node,
2163 1, gfc_complex4_type_node);
2164 gfor_fndecl_math_cpow =
2165 gfc_build_library_function_decl (get_identifier ("cpow"),
2166 gfc_complex8_type_node,
2167 1, gfc_complex8_type_node);
2168 if (gfc_complex10_type_node)
2169 gfor_fndecl_math_cpowl10 =
2170 gfc_build_library_function_decl (get_identifier ("cpowl"),
2171 gfc_complex10_type_node, 1,
2172 gfc_complex10_type_node);
2173 if (gfc_complex16_type_node)
2174 gfor_fndecl_math_cpowl16 =
2175 gfc_build_library_function_decl (get_identifier ("cpowl"),
2176 gfc_complex16_type_node, 1,
2177 gfc_complex16_type_node);
2179 gfor_fndecl_math_ishftc4 =
2180 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2182 3, gfc_int4_type_node,
2183 gfc_int4_type_node, gfc_int4_type_node);
2184 gfor_fndecl_math_ishftc8 =
2185 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2187 3, gfc_int8_type_node,
2188 gfc_int4_type_node, gfc_int4_type_node);
2189 if (gfc_int16_type_node)
2190 gfor_fndecl_math_ishftc16 =
2191 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2192 gfc_int16_type_node, 3,
2193 gfc_int16_type_node,
2195 gfc_int4_type_node);
2197 gfor_fndecl_math_exponent4 =
2198 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2200 1, gfc_real4_type_node);
2201 gfor_fndecl_math_exponent8 =
2202 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2204 1, gfc_real8_type_node);
2205 if (gfc_real10_type_node)
2206 gfor_fndecl_math_exponent10 =
2207 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2208 gfc_int4_type_node, 1,
2209 gfc_real10_type_node);
2210 if (gfc_real16_type_node)
2211 gfor_fndecl_math_exponent16 =
2212 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2213 gfc_int4_type_node, 1,
2214 gfc_real16_type_node);
2216 /* BLAS functions. */
2218 tree pint = build_pointer_type (gfc_c_int_type_node);
2219 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2220 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2221 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2222 tree pz = build_pointer_type
2223 (gfc_get_complex_type (gfc_default_double_kind));
2225 gfor_fndecl_sgemm = gfc_build_library_function_decl
2227 (gfc_option.flag_underscoring ? "sgemm_"
2229 void_type_node, 15, pchar_type_node,
2230 pchar_type_node, pint, pint, pint, ps, ps, pint,
2231 ps, pint, ps, ps, pint, gfc_c_int_type_node,
2232 gfc_c_int_type_node);
2233 gfor_fndecl_dgemm = gfc_build_library_function_decl
2235 (gfc_option.flag_underscoring ? "dgemm_"
2237 void_type_node, 15, pchar_type_node,
2238 pchar_type_node, pint, pint, pint, pd, pd, pint,
2239 pd, pint, pd, pd, pint, gfc_c_int_type_node,
2240 gfc_c_int_type_node);
2241 gfor_fndecl_cgemm = gfc_build_library_function_decl
2243 (gfc_option.flag_underscoring ? "cgemm_"
2245 void_type_node, 15, pchar_type_node,
2246 pchar_type_node, pint, pint, pint, pc, pc, pint,
2247 pc, pint, pc, pc, pint, gfc_c_int_type_node,
2248 gfc_c_int_type_node);
2249 gfor_fndecl_zgemm = gfc_build_library_function_decl
2251 (gfc_option.flag_underscoring ? "zgemm_"
2253 void_type_node, 15, pchar_type_node,
2254 pchar_type_node, pint, pint, pint, pz, pz, pint,
2255 pz, pint, pz, pz, pint, gfc_c_int_type_node,
2256 gfc_c_int_type_node);
2259 /* Other functions. */
2261 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2262 gfc_array_index_type,
2263 1, pvoid_type_node);
2265 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2266 gfc_array_index_type,
2268 gfc_array_index_type);
2271 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2277 /* Make prototypes for runtime library functions. */
2280 gfc_build_builtin_function_decls (void)
2282 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2283 tree gfc_int4_type_node = gfc_get_int_type (4);
2284 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2285 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2287 gfor_fndecl_internal_realloc =
2288 gfc_build_library_function_decl (get_identifier
2289 (PREFIX("internal_realloc")),
2290 pvoid_type_node, 2, pvoid_type_node,
2291 gfc_array_index_type);
2293 gfor_fndecl_allocate =
2294 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2296 gfc_array_index_type, gfc_pint4_type_node);
2297 DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
2299 gfor_fndecl_allocate_array =
2300 gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2301 pvoid_type_node, 3, pvoid_type_node,
2302 gfc_array_index_type, gfc_pint4_type_node);
2303 DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
2305 gfor_fndecl_deallocate =
2306 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2307 void_type_node, 2, pvoid_type_node,
2308 gfc_pint4_type_node);
2310 gfor_fndecl_stop_numeric =
2311 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2312 void_type_node, 1, gfc_int4_type_node);
2314 /* Stop doesn't return. */
2315 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2317 gfor_fndecl_stop_string =
2318 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2319 void_type_node, 2, pchar_type_node,
2320 gfc_int4_type_node);
2321 /* Stop doesn't return. */
2322 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2324 gfor_fndecl_pause_numeric =
2325 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2326 void_type_node, 1, gfc_int4_type_node);
2328 gfor_fndecl_pause_string =
2329 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2330 void_type_node, 2, pchar_type_node,
2331 gfc_int4_type_node);
2333 gfor_fndecl_select_string =
2334 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2335 gfc_c_int_type_node, 0);
2337 gfor_fndecl_runtime_error =
2338 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2339 void_type_node, 1, pchar_type_node);
2340 /* The runtime_error function does not return. */
2341 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2343 gfor_fndecl_runtime_error_at =
2344 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2345 void_type_node, 2, pchar_type_node,
2347 /* The runtime_error_at function does not return. */
2348 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2350 gfor_fndecl_generate_error =
2351 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2352 void_type_node, 3, pvoid_type_node,
2353 gfc_c_int_type_node, pchar_type_node);
2355 gfor_fndecl_os_error =
2356 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2357 void_type_node, 1, pchar_type_node);
2358 /* The runtime_error function does not return. */
2359 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2361 gfor_fndecl_set_fpe =
2362 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2363 void_type_node, 1, gfc_c_int_type_node);
2365 /* Keep the array dimension in sync with the call, later in this file. */
2366 gfor_fndecl_set_options =
2367 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2368 void_type_node, 2, gfc_c_int_type_node,
2371 gfor_fndecl_set_convert =
2372 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2373 void_type_node, 1, gfc_c_int_type_node);
2375 gfor_fndecl_set_record_marker =
2376 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2377 void_type_node, 1, gfc_c_int_type_node);
2379 gfor_fndecl_set_max_subrecord_length =
2380 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2381 void_type_node, 1, gfc_c_int_type_node);
2383 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2384 get_identifier (PREFIX("internal_pack")),
2385 pvoid_type_node, 1, pvoid_type_node);
2387 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2388 get_identifier (PREFIX("internal_unpack")),
2389 pvoid_type_node, 1, pvoid_type_node);
2391 gfor_fndecl_associated =
2392 gfc_build_library_function_decl (
2393 get_identifier (PREFIX("associated")),
2394 gfc_logical4_type_node,
2399 gfc_build_intrinsic_function_decls ();
2400 gfc_build_intrinsic_lib_fndecls ();
2401 gfc_build_io_library_fndecls ();
2405 /* Evaluate the length of dummy character variables. */
2408 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2412 gfc_finish_decl (cl->backend_decl);
2414 gfc_start_block (&body);
2416 /* Evaluate the string length expression. */
2417 gfc_trans_init_string_length (cl, &body);
2419 gfc_trans_vla_type_sizes (sym, &body);
2421 gfc_add_expr_to_block (&body, fnbody);
2422 return gfc_finish_block (&body);
2426 /* Allocate and cleanup an automatic character variable. */
2429 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2435 gcc_assert (sym->backend_decl);
2436 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2438 gfc_start_block (&body);
2440 /* Evaluate the string length expression. */
2441 gfc_trans_init_string_length (sym->ts.cl, &body);
2443 gfc_trans_vla_type_sizes (sym, &body);
2445 decl = sym->backend_decl;
2447 /* Emit a DECL_EXPR for this variable, which will cause the
2448 gimplifier to allocate storage, and all that good stuff. */
2449 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2450 gfc_add_expr_to_block (&body, tmp);
2452 gfc_add_expr_to_block (&body, fnbody);
2453 return gfc_finish_block (&body);
2456 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2459 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2463 gcc_assert (sym->backend_decl);
2464 gfc_start_block (&body);
2466 /* Set the initial value to length. See the comments in
2467 function gfc_add_assign_aux_vars in this file. */
2468 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2469 build_int_cst (NULL_TREE, -2));
2471 gfc_add_expr_to_block (&body, fnbody);
2472 return gfc_finish_block (&body);
2476 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2478 tree t = *tp, var, val;
2480 if (t == NULL || t == error_mark_node)
2482 if (TREE_CONSTANT (t) || DECL_P (t))
2485 if (TREE_CODE (t) == SAVE_EXPR)
2487 if (SAVE_EXPR_RESOLVED_P (t))
2489 *tp = TREE_OPERAND (t, 0);
2492 val = TREE_OPERAND (t, 0);
2497 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2498 gfc_add_decl_to_function (var);
2499 gfc_add_modify_expr (body, var, val);
2500 if (TREE_CODE (t) == SAVE_EXPR)
2501 TREE_OPERAND (t, 0) = var;
2506 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2510 if (type == NULL || type == error_mark_node)
2513 type = TYPE_MAIN_VARIANT (type);
2515 if (TREE_CODE (type) == INTEGER_TYPE)
2517 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2518 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2520 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2522 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2523 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2526 else if (TREE_CODE (type) == ARRAY_TYPE)
2528 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2529 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2530 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2531 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2533 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2535 TYPE_SIZE (t) = TYPE_SIZE (type);
2536 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2541 /* Make sure all type sizes and array domains are either constant,
2542 or variable or parameter decls. This is a simplified variant
2543 of gimplify_type_sizes, but we can't use it here, as none of the
2544 variables in the expressions have been gimplified yet.
2545 As type sizes and domains for various variable length arrays
2546 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2547 time, without this routine gimplify_type_sizes in the middle-end
2548 could result in the type sizes being gimplified earlier than where
2549 those variables are initialized. */
2552 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2554 tree type = TREE_TYPE (sym->backend_decl);
2556 if (TREE_CODE (type) == FUNCTION_TYPE
2557 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2559 if (! current_fake_result_decl)
2562 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2565 while (POINTER_TYPE_P (type))
2566 type = TREE_TYPE (type);
2568 if (GFC_DESCRIPTOR_TYPE_P (type))
2570 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2572 while (POINTER_TYPE_P (etype))
2573 etype = TREE_TYPE (etype);
2575 gfc_trans_vla_type_sizes_1 (etype, body);
2578 gfc_trans_vla_type_sizes_1 (type, body);
2582 /* Generate function entry and exit code, and add it to the function body.
2584 Allocation and initialization of array variables.
2585 Allocation of character string variables.
2586 Initialization and possibly repacking of dummy arrays.
2587 Initialization of ASSIGN statement auxiliary variable. */
2590 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2594 gfc_formal_arglist *f;
2596 bool seen_trans_deferred_array = false;
2598 /* Deal with implicit return variables. Explicit return variables will
2599 already have been added. */
2600 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2602 if (!current_fake_result_decl)
2604 gfc_entry_list *el = NULL;
2605 if (proc_sym->attr.entry_master)
2607 for (el = proc_sym->ns->entries; el; el = el->next)
2608 if (el->sym != el->sym->result)
2612 warning (0, "Function does not return a value");
2614 else if (proc_sym->as)
2616 tree result = TREE_VALUE (current_fake_result_decl);
2617 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2619 /* An automatic character length, pointer array result. */
2620 if (proc_sym->ts.type == BT_CHARACTER
2621 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2622 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2625 else if (proc_sym->ts.type == BT_CHARACTER)
2627 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2628 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2632 gcc_assert (gfc_option.flag_f2c
2633 && proc_sym->ts.type == BT_COMPLEX);
2636 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2638 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2639 && sym->ts.derived->attr.alloc_comp;
2640 if (sym->attr.dimension)
2642 switch (sym->as->type)
2645 if (sym->attr.dummy || sym->attr.result)
2647 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2648 else if (sym->attr.pointer || sym->attr.allocatable)
2650 if (TREE_STATIC (sym->backend_decl))
2651 gfc_trans_static_array_pointer (sym);
2654 seen_trans_deferred_array = true;
2655 fnbody = gfc_trans_deferred_array (sym, fnbody);
2660 if (sym_has_alloc_comp)
2662 seen_trans_deferred_array = true;
2663 fnbody = gfc_trans_deferred_array (sym, fnbody);
2666 gfc_get_backend_locus (&loc);
2667 gfc_set_backend_locus (&sym->declared_at);
2668 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2670 gfc_set_backend_locus (&loc);
2674 case AS_ASSUMED_SIZE:
2675 /* Must be a dummy parameter. */
2676 gcc_assert (sym->attr.dummy);
2678 /* We should always pass assumed size arrays the g77 way. */
2679 fnbody = gfc_trans_g77_array (sym, fnbody);
2682 case AS_ASSUMED_SHAPE:
2683 /* Must be a dummy parameter. */
2684 gcc_assert (sym->attr.dummy);
2686 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2691 seen_trans_deferred_array = true;
2692 fnbody = gfc_trans_deferred_array (sym, fnbody);
2698 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2699 fnbody = gfc_trans_deferred_array (sym, fnbody);
2701 else if (sym_has_alloc_comp)
2702 fnbody = gfc_trans_deferred_array (sym, fnbody);
2703 else if (sym->ts.type == BT_CHARACTER)
2705 gfc_get_backend_locus (&loc);
2706 gfc_set_backend_locus (&sym->declared_at);
2707 if (sym->attr.dummy || sym->attr.result)
2708 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2710 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2711 gfc_set_backend_locus (&loc);
2713 else if (sym->attr.assign)
2715 gfc_get_backend_locus (&loc);
2716 gfc_set_backend_locus (&sym->declared_at);
2717 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2718 gfc_set_backend_locus (&loc);
2724 gfc_init_block (&body);
2726 for (f = proc_sym->formal; f; f = f->next)
2728 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2730 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2731 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2732 gfc_trans_vla_type_sizes (f->sym, &body);
2735 /* If an INTENT(OUT) dummy of derived type has a default
2736 initializer, it must be initialized here. */
2737 if (f->sym && f->sym->attr.intent == INTENT_OUT
2738 && f->sym->ts.type == BT_DERIVED
2739 && !f->sym->ts.derived->attr.alloc_comp
2744 gcc_assert (!f->sym->attr.allocatable);
2745 gfc_set_sym_referenced (f->sym);
2746 tmpe = gfc_lval_expr_from_sym (f->sym);
2747 tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
2749 present = gfc_conv_expr_present (f->sym);
2750 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2751 tmp, build_empty_stmt ());
2752 gfc_add_expr_to_block (&body, tmp);
2753 gfc_free_expr (tmpe);
2757 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2758 && current_fake_result_decl != NULL)
2760 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2761 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2762 gfc_trans_vla_type_sizes (proc_sym, &body);
2765 gfc_add_expr_to_block (&body, fnbody);
2766 return gfc_finish_block (&body);
2770 /* Output an initialized decl for a module variable. */
2773 gfc_create_module_variable (gfc_symbol * sym)
2777 /* Module functions with alternate entries are dealt with later and
2778 would get caught by the next condition. */
2779 if (sym->attr.entry)
2782 /* Make sure we convert the types of the derived types from iso_c_binding
2784 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2785 && sym->ts.type == BT_DERIVED)
2786 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2788 /* Only output variables and array valued parameters. */
2789 if (sym->attr.flavor != FL_VARIABLE
2790 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2793 /* Don't generate variables from other modules. Variables from
2794 COMMONs will already have been generated. */
2795 if (sym->attr.use_assoc || sym->attr.in_common)
2798 /* Equivalenced variables arrive here after creation. */
2799 if (sym->backend_decl
2800 && (sym->equiv_built || sym->attr.in_equivalence))
2803 if (sym->backend_decl)
2804 internal_error ("backend decl for module variable %s already exists",
2807 /* We always want module variables to be created. */
2808 sym->attr.referenced = 1;
2809 /* Create the decl. */
2810 decl = gfc_get_symbol_decl (sym);
2812 /* Create the variable. */
2814 rest_of_decl_compilation (decl, 1, 0);
2816 /* Also add length of strings. */
2817 if (sym->ts.type == BT_CHARACTER)
2821 length = sym->ts.cl->backend_decl;
2822 if (!INTEGER_CST_P (length))
2825 rest_of_decl_compilation (length, 1, 0);
2831 /* Generate all the required code for module variables. */
2834 gfc_generate_module_vars (gfc_namespace * ns)
2836 module_namespace = ns;
2838 /* Check if the frontend left the namespace in a reasonable state. */
2839 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2841 /* Generate COMMON blocks. */
2842 gfc_trans_common (ns);
2844 /* Create decls for all the module variables. */
2845 gfc_traverse_ns (ns, gfc_create_module_variable);
2849 gfc_generate_contained_functions (gfc_namespace * parent)
2853 /* We create all the prototypes before generating any code. */
2854 for (ns = parent->contained; ns; ns = ns->sibling)
2856 /* Skip namespaces from used modules. */
2857 if (ns->parent != parent)
2860 gfc_create_function_decl (ns);
2863 for (ns = parent->contained; ns; ns = ns->sibling)
2865 /* Skip namespaces from used modules. */
2866 if (ns->parent != parent)
2869 gfc_generate_function_code (ns);
2874 /* Drill down through expressions for the array specification bounds and
2875 character length calling generate_local_decl for all those variables
2876 that have not already been declared. */
2879 generate_local_decl (gfc_symbol *);
2882 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2884 gfc_actual_arglist *arg;
2891 switch (e->expr_type)
2894 for (arg = e->value.function.actual; arg; arg = arg->next)
2895 generate_expr_decls (sym, arg->expr);
2898 /* If the variable is not the same as the dependent, 'sym', and
2899 it is not marked as being declared and it is in the same
2900 namespace as 'sym', add it to the local declarations. */
2902 if (sym == e->symtree->n.sym
2903 || e->symtree->n.sym->mark
2904 || e->symtree->n.sym->ns != sym->ns)
2907 generate_local_decl (e->symtree->n.sym);
2911 generate_expr_decls (sym, e->value.op.op1);
2912 generate_expr_decls (sym, e->value.op.op2);
2921 for (ref = e->ref; ref; ref = ref->next)
2926 for (i = 0; i < ref->u.ar.dimen; i++)
2928 generate_expr_decls (sym, ref->u.ar.start[i]);
2929 generate_expr_decls (sym, ref->u.ar.end[i]);
2930 generate_expr_decls (sym, ref->u.ar.stride[i]);
2935 generate_expr_decls (sym, ref->u.ss.start);
2936 generate_expr_decls (sym, ref->u.ss.end);
2940 if (ref->u.c.component->ts.type == BT_CHARACTER
2941 && ref->u.c.component->ts.cl->length->expr_type
2943 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2945 if (ref->u.c.component->as)
2946 for (i = 0; i < ref->u.c.component->as->rank; i++)
2948 generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2949 generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2958 /* Check for dependencies in the character length and array spec. */
2961 generate_dependency_declarations (gfc_symbol *sym)
2965 if (sym->ts.type == BT_CHARACTER
2966 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2967 generate_expr_decls (sym, sym->ts.cl->length);
2969 if (sym->as && sym->as->rank)
2971 for (i = 0; i < sym->as->rank; i++)
2973 generate_expr_decls (sym, sym->as->lower[i]);
2974 generate_expr_decls (sym, sym->as->upper[i]);
2980 /* Generate decls for all local variables. We do this to ensure correct
2981 handling of expressions which only appear in the specification of
2985 generate_local_decl (gfc_symbol * sym)
2987 if (sym->attr.flavor == FL_VARIABLE)
2989 /* Check for dependencies in the array specification and string
2990 length, adding the necessary declarations to the function. We
2991 mark the symbol now, as well as in traverse_ns, to prevent
2992 getting stuck in a circular dependency. */
2994 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2995 generate_dependency_declarations (sym);
2997 if (sym->attr.referenced)
2998 gfc_get_symbol_decl (sym);
2999 /* INTENT(out) dummy arguments are likely meant to be set. */
3000 else if (warn_unused_variable
3002 && sym->attr.intent == INTENT_OUT)
3003 gfc_warning ("dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3004 sym->name, &sym->declared_at);
3005 /* Specific warning for unused dummy arguments. */
3006 else if (warn_unused_variable && sym->attr.dummy)
3007 gfc_warning ("unused dummy argument '%s' at %L", sym->name,
3009 /* Warn for unused variables, but not if they're inside a common
3010 block or are use-associated. */
3011 else if (warn_unused_variable
3012 && !(sym->attr.in_common || sym->attr.use_assoc))
3013 gfc_warning ("unused variable '%s' declared at %L", sym->name,
3015 /* For variable length CHARACTER parameters, the PARM_DECL already
3016 references the length variable, so force gfc_get_symbol_decl
3017 even when not referenced. If optimize > 0, it will be optimized
3018 away anyway. But do this only after emitting -Wunused-parameter
3019 warning if requested. */
3020 if (sym->attr.dummy && ! sym->attr.referenced
3021 && sym->ts.type == BT_CHARACTER
3022 && sym->ts.cl->backend_decl != NULL
3023 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3025 sym->attr.referenced = 1;
3026 gfc_get_symbol_decl (sym);
3029 /* We do not want the middle-end to warn about unused parameters
3030 as this was already done above. */
3031 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3032 TREE_NO_WARNING(sym->backend_decl) = 1;
3034 else if (sym->attr.flavor == FL_PARAMETER)
3036 if (warn_unused_variable
3037 && !sym->attr.referenced
3038 && !sym->attr.use_assoc)
3039 gfc_warning ("unused parameter '%s' declared at %L", sym->name,
3043 if (sym->attr.dummy == 1)
3045 /* Modify the tree type for scalar character dummy arguments of bind(c)
3046 procedures if they are passed by value. The tree type for them will
3047 be promoted to INTEGER_TYPE for the middle end, which appears to be
3048 what C would do with characters passed by-value. The value attribute
3049 implies the dummy is a scalar. */
3050 if (sym->attr.value == 1 && sym->backend_decl != NULL
3051 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3052 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3053 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3056 /* Make sure we convert the types of the derived types from iso_c_binding
3058 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3059 && sym->ts.type == BT_DERIVED)
3060 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3064 generate_local_vars (gfc_namespace * ns)
3066 gfc_traverse_ns (ns, generate_local_decl);
3070 /* Generate a switch statement to jump to the correct entry point. Also
3071 creates the label decls for the entry points. */
3074 gfc_trans_entry_master_switch (gfc_entry_list * el)
3081 gfc_init_block (&block);
3082 for (; el; el = el->next)
3084 /* Add the case label. */
3085 label = gfc_build_label_decl (NULL_TREE);
3086 val = build_int_cst (gfc_array_index_type, el->id);
3087 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3088 gfc_add_expr_to_block (&block, tmp);
3090 /* And jump to the actual entry point. */
3091 label = gfc_build_label_decl (NULL_TREE);
3092 tmp = build1_v (GOTO_EXPR, label);
3093 gfc_add_expr_to_block (&block, tmp);
3095 /* Save the label decl. */
3098 tmp = gfc_finish_block (&block);
3099 /* The first argument selects the entry point. */
3100 val = DECL_ARGUMENTS (current_function_decl);
3101 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3106 /* Generate code for a function. */
3109 gfc_generate_function_code (gfc_namespace * ns)
3122 sym = ns->proc_name;
3124 /* Check that the frontend isn't still using this. */
3125 gcc_assert (sym->tlink == NULL);
3128 /* Create the declaration for functions with global scope. */
3129 if (!sym->backend_decl)
3130 gfc_create_function_decl (ns);
3132 fndecl = sym->backend_decl;
3133 old_context = current_function_decl;
3137 push_function_context ();
3138 saved_parent_function_decls = saved_function_decls;
3139 saved_function_decls = NULL_TREE;
3142 trans_function_start (sym);
3144 gfc_start_block (&block);
3146 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3148 /* Copy length backend_decls to all entry point result
3153 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3154 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3155 for (el = ns->entries; el; el = el->next)
3156 el->sym->result->ts.cl->backend_decl = backend_decl;
3159 /* Translate COMMON blocks. */
3160 gfc_trans_common (ns);
3162 /* Null the parent fake result declaration if this namespace is
3163 a module function or an external procedures. */
3164 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3165 || ns->parent == NULL)
3166 parent_fake_result_decl = NULL_TREE;
3168 gfc_generate_contained_functions (ns);
3170 generate_local_vars (ns);
3172 /* Keep the parent fake result declaration in module functions
3173 or external procedures. */
3174 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3175 || ns->parent == NULL)
3176 current_fake_result_decl = parent_fake_result_decl;
3178 current_fake_result_decl = NULL_TREE;
3180 current_function_return_label = NULL;
3182 /* Now generate the code for the body of this function. */
3183 gfc_init_block (&body);
3185 /* If this is the main program, add a call to set_options to set up the
3186 runtime library Fortran language standard parameters. */
3187 if (sym->attr.is_main_program)
3189 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3190 tree array_type, array, var;
3192 /* Passing a new option to the library requires four modifications:
3193 + add it to the tree_cons list below
3194 + change the array size in the call to build_array_type
3195 + change the first argument to the library call
3196 gfor_fndecl_set_options
3197 + modify the library (runtime/compile_options.c)! */
3198 array = tree_cons (NULL_TREE,
3199 build_int_cst (gfc_c_int_type_node,
3200 gfc_option.warn_std), NULL_TREE);
3201 array = tree_cons (NULL_TREE,
3202 build_int_cst (gfc_c_int_type_node,
3203 gfc_option.allow_std), array);
3204 array = tree_cons (NULL_TREE,
3205 build_int_cst (gfc_c_int_type_node, pedantic), array);
3206 array = tree_cons (NULL_TREE,
3207 build_int_cst (gfc_c_int_type_node,
3208 gfc_option.flag_dump_core), array);
3209 array = tree_cons (NULL_TREE,
3210 build_int_cst (gfc_c_int_type_node,
3211 gfc_option.flag_backtrace), array);
3212 array = tree_cons (NULL_TREE,
3213 build_int_cst (gfc_c_int_type_node,
3214 gfc_option.flag_sign_zero), array);
3216 array = tree_cons (NULL_TREE,
3217 build_int_cst (gfc_c_int_type_node,
3218 flag_bounds_check), array);
3220 array_type = build_array_type (gfc_c_int_type_node,
3221 build_index_type (build_int_cst (NULL_TREE,
3223 array = build_constructor_from_list (array_type, nreverse (array));
3224 TREE_CONSTANT (array) = 1;
3225 TREE_INVARIANT (array) = 1;
3226 TREE_STATIC (array) = 1;
3228 /* Create a static variable to hold the jump table. */
3229 var = gfc_create_var (array_type, "options");
3230 TREE_CONSTANT (var) = 1;
3231 TREE_INVARIANT (var) = 1;
3232 TREE_STATIC (var) = 1;
3233 TREE_READONLY (var) = 1;
3234 DECL_INITIAL (var) = array;
3235 var = gfc_build_addr_expr (pvoid_type_node, var);
3237 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3238 build_int_cst (gfc_c_int_type_node, 7), var);
3239 gfc_add_expr_to_block (&body, tmp);
3242 /* If this is the main program and a -ffpe-trap option was provided,
3243 add a call to set_fpe so that the library will raise a FPE when
3245 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3247 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3248 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3249 build_int_cst (gfc_c_int_type_node,
3251 gfc_add_expr_to_block (&body, tmp);
3254 /* If this is the main program and an -fconvert option was provided,
3255 add a call to set_convert. */
3257 if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
3259 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3260 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3261 build_int_cst (gfc_c_int_type_node,
3262 gfc_option.convert));
3263 gfc_add_expr_to_block (&body, tmp);
3266 /* If this is the main program and an -frecord-marker option was provided,
3267 add a call to set_record_marker. */
3269 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3271 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3272 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3273 build_int_cst (gfc_c_int_type_node,
3274 gfc_option.record_marker));
3275 gfc_add_expr_to_block (&body, tmp);
3278 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3280 tree gfc_c_int_type_node;
3282 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3283 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3285 build_int_cst (gfc_c_int_type_node,
3286 gfc_option.max_subrecord_length));
3287 gfc_add_expr_to_block (&body, tmp);
3290 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3291 && sym->attr.subroutine)
3293 tree alternate_return;
3294 alternate_return = gfc_get_fake_result_decl (sym, 0);
3295 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3300 /* Jump to the correct entry point. */
3301 tmp = gfc_trans_entry_master_switch (ns->entries);
3302 gfc_add_expr_to_block (&body, tmp);
3305 tmp = gfc_trans_code (ns->code);
3306 gfc_add_expr_to_block (&body, tmp);
3308 /* Add a return label if needed. */
3309 if (current_function_return_label)
3311 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3312 gfc_add_expr_to_block (&body, tmp);
3315 tmp = gfc_finish_block (&body);
3316 /* Add code to create and cleanup arrays. */
3317 tmp = gfc_trans_deferred_vars (sym, tmp);
3319 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3321 if (sym->attr.subroutine || sym == sym->result)
3323 if (current_fake_result_decl != NULL)
3324 result = TREE_VALUE (current_fake_result_decl);
3327 current_fake_result_decl = NULL_TREE;
3330 result = sym->result->backend_decl;
3332 if (result != NULL_TREE && sym->attr.function
3333 && sym->ts.type == BT_DERIVED
3334 && sym->ts.derived->attr.alloc_comp
3335 && !sym->attr.pointer)
3337 rank = sym->as ? sym->as->rank : 0;
3338 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3339 gfc_add_expr_to_block (&block, tmp2);
3342 gfc_add_expr_to_block (&block, tmp);
3344 if (result == NULL_TREE)
3345 warning (0, "Function return value not set");
3348 /* Set the return value to the dummy result variable. The
3349 types may be different for scalar default REAL functions
3350 with -ff2c, therefore we have to convert. */
3351 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3352 tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3353 DECL_RESULT (fndecl), tmp);
3354 tmp = build1_v (RETURN_EXPR, tmp);
3355 gfc_add_expr_to_block (&block, tmp);
3359 gfc_add_expr_to_block (&block, tmp);
3362 /* Add all the decls we created during processing. */
3363 decl = saved_function_decls;
3368 next = TREE_CHAIN (decl);
3369 TREE_CHAIN (decl) = NULL_TREE;
3373 saved_function_decls = NULL_TREE;
3375 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3377 /* Finish off this function and send it for code generation. */
3379 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3381 /* Output the GENERIC tree. */
3382 dump_function (TDI_original, fndecl);
3384 /* Store the end of the function, so that we get good line number
3385 info for the epilogue. */
3386 cfun->function_end_locus = input_location;
3388 /* We're leaving the context of this function, so zap cfun.
3389 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3390 tree_rest_of_compilation. */
3395 pop_function_context ();
3396 saved_function_decls = saved_parent_function_decls;
3398 current_function_decl = old_context;
3400 if (decl_function_context (fndecl))
3401 /* Register this function with cgraph just far enough to get it
3402 added to our parent's nested function list. */
3403 (void) cgraph_node (fndecl);
3406 gfc_gimplify_function (fndecl);
3407 cgraph_finalize_function (fndecl, false);
3412 gfc_generate_constructors (void)
3414 gcc_assert (gfc_static_ctors == NULL_TREE);
3422 if (gfc_static_ctors == NULL_TREE)
3425 fnname = get_file_function_name ("I");
3426 type = build_function_type (void_type_node,
3427 gfc_chainon_list (NULL_TREE, void_type_node));
3429 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3430 TREE_PUBLIC (fndecl) = 1;
3432 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3433 DECL_ARTIFICIAL (decl) = 1;
3434 DECL_IGNORED_P (decl) = 1;
3435 DECL_CONTEXT (decl) = fndecl;
3436 DECL_RESULT (fndecl) = decl;
3440 current_function_decl = fndecl;
3442 rest_of_decl_compilation (fndecl, 1, 0);
3444 make_decl_rtl (fndecl);
3446 init_function_start (fndecl);
3450 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3452 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3453 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3458 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3460 free_after_parsing (cfun);
3461 free_after_compilation (cfun);
3463 tree_rest_of_compilation (fndecl);
3465 current_function_decl = NULL_TREE;
3469 /* Translates a BLOCK DATA program unit. This means emitting the
3470 commons contained therein plus their initializations. We also emit
3471 a globally visible symbol to make sure that each BLOCK DATA program
3472 unit remains unique. */
3475 gfc_generate_block_data (gfc_namespace * ns)
3480 /* Tell the backend the source location of the block data. */
3482 gfc_set_backend_locus (&ns->proc_name->declared_at);
3484 gfc_set_backend_locus (&gfc_current_locus);
3486 /* Process the DATA statements. */
3487 gfc_trans_common (ns);
3489 /* Create a global symbol with the mane of the block data. This is to
3490 generate linker errors if the same name is used twice. It is never
3493 id = gfc_sym_mangled_function_id (ns->proc_name);
3495 id = get_identifier ("__BLOCK_DATA__");
3497 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3498 TREE_PUBLIC (decl) = 1;
3499 TREE_STATIC (decl) = 1;
3502 rest_of_decl_compilation (decl, 1, 0);
3506 #include "gt-fortran-trans-decl.h"