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 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "trans-const.h"
43 /* Only for gfc_trans_code. Shouldn't need to include this. */
44 #include "trans-stmt.h"
46 #define MAX_LABEL_VALUE 99999
49 /* Holds the result of the function if no result variable specified. */
51 static GTY(()) tree current_fake_result_decl;
52 static GTY(()) tree parent_fake_result_decl;
54 static GTY(()) tree current_function_return_label;
57 /* Holds the variable DECLs for the current function. */
59 static GTY(()) tree saved_function_decls;
60 static GTY(()) tree saved_parent_function_decls;
63 /* The namespace of the module we're currently generating. Only used while
64 outputting decls for module variables. Do not rely on this being set. */
66 static gfc_namespace *module_namespace;
69 /* List of static constructor functions. */
71 tree gfc_static_ctors;
74 /* Function declarations for builtin library functions. */
76 tree gfor_fndecl_pause_numeric;
77 tree gfor_fndecl_pause_string;
78 tree gfor_fndecl_stop_numeric;
79 tree gfor_fndecl_stop_string;
80 tree gfor_fndecl_select_string;
81 tree gfor_fndecl_runtime_error;
82 tree gfor_fndecl_runtime_error_at;
83 tree gfor_fndecl_os_error;
84 tree gfor_fndecl_generate_error;
85 tree gfor_fndecl_set_fpe;
86 tree gfor_fndecl_set_options;
87 tree gfor_fndecl_set_convert;
88 tree gfor_fndecl_set_record_marker;
89 tree gfor_fndecl_set_max_subrecord_length;
90 tree gfor_fndecl_ctime;
91 tree gfor_fndecl_fdate;
92 tree gfor_fndecl_ttynam;
93 tree gfor_fndecl_in_pack;
94 tree gfor_fndecl_in_unpack;
95 tree gfor_fndecl_associated;
98 /* Math functions. Many other math functions are handled in
101 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
102 tree gfor_fndecl_math_cpowf;
103 tree gfor_fndecl_math_cpow;
104 tree gfor_fndecl_math_cpowl10;
105 tree gfor_fndecl_math_cpowl16;
106 tree gfor_fndecl_math_ishftc4;
107 tree gfor_fndecl_math_ishftc8;
108 tree gfor_fndecl_math_ishftc16;
109 tree gfor_fndecl_math_exponent4;
110 tree gfor_fndecl_math_exponent8;
111 tree gfor_fndecl_math_exponent10;
112 tree gfor_fndecl_math_exponent16;
115 /* String functions. */
117 tree gfor_fndecl_compare_string;
118 tree gfor_fndecl_concat_string;
119 tree gfor_fndecl_string_len_trim;
120 tree gfor_fndecl_string_index;
121 tree gfor_fndecl_string_scan;
122 tree gfor_fndecl_string_verify;
123 tree gfor_fndecl_string_trim;
124 tree gfor_fndecl_string_minmax;
125 tree gfor_fndecl_adjustl;
126 tree gfor_fndecl_adjustr;
129 /* Other misc. runtime library functions. */
131 tree gfor_fndecl_size0;
132 tree gfor_fndecl_size1;
133 tree gfor_fndecl_iargc;
135 /* Intrinsic functions implemented in FORTRAN. */
136 tree gfor_fndecl_si_kind;
137 tree gfor_fndecl_sr_kind;
139 /* BLAS gemm functions. */
140 tree gfor_fndecl_sgemm;
141 tree gfor_fndecl_dgemm;
142 tree gfor_fndecl_cgemm;
143 tree gfor_fndecl_zgemm;
147 gfc_add_decl_to_parent_function (tree decl)
150 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
151 DECL_NONLOCAL (decl) = 1;
152 TREE_CHAIN (decl) = saved_parent_function_decls;
153 saved_parent_function_decls = decl;
157 gfc_add_decl_to_function (tree decl)
160 TREE_USED (decl) = 1;
161 DECL_CONTEXT (decl) = current_function_decl;
162 TREE_CHAIN (decl) = saved_function_decls;
163 saved_function_decls = decl;
167 /* Build a backend label declaration. Set TREE_USED for named labels.
168 The context of the label is always the current_function_decl. All
169 labels are marked artificial. */
172 gfc_build_label_decl (tree label_id)
174 /* 2^32 temporaries should be enough. */
175 static unsigned int tmp_num = 1;
179 if (label_id == NULL_TREE)
181 /* Build an internal label name. */
182 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
183 label_id = get_identifier (label_name);
188 /* Build the LABEL_DECL node. Labels have no type. */
189 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
190 DECL_CONTEXT (label_decl) = current_function_decl;
191 DECL_MODE (label_decl) = VOIDmode;
193 /* We always define the label as used, even if the original source
194 file never references the label. We don't want all kinds of
195 spurious warnings for old-style Fortran code with too many
197 TREE_USED (label_decl) = 1;
199 DECL_ARTIFICIAL (label_decl) = 1;
204 /* Returns the return label for the current function. */
207 gfc_get_return_label (void)
209 char name[GFC_MAX_SYMBOL_LEN + 10];
211 if (current_function_return_label)
212 return current_function_return_label;
214 sprintf (name, "__return_%s",
215 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
217 current_function_return_label =
218 gfc_build_label_decl (get_identifier (name));
220 DECL_ARTIFICIAL (current_function_return_label) = 1;
222 return current_function_return_label;
226 /* Set the backend source location of a decl. */
229 gfc_set_decl_location (tree decl, locus * loc)
231 #ifdef USE_MAPPED_LOCATION
232 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
234 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
235 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
240 /* Return the backend label declaration for a given label structure,
241 or create it if it doesn't exist yet. */
244 gfc_get_label_decl (gfc_st_label * lp)
246 if (lp->backend_decl)
247 return lp->backend_decl;
250 char label_name[GFC_MAX_SYMBOL_LEN + 1];
253 /* Validate the label declaration from the front end. */
254 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
256 /* Build a mangled name for the label. */
257 sprintf (label_name, "__label_%.6d", lp->value);
259 /* Build the LABEL_DECL node. */
260 label_decl = gfc_build_label_decl (get_identifier (label_name));
262 /* Tell the debugger where the label came from. */
263 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
264 gfc_set_decl_location (label_decl, &lp->where);
266 DECL_ARTIFICIAL (label_decl) = 1;
268 /* Store the label in the label list and return the LABEL_DECL. */
269 lp->backend_decl = label_decl;
275 /* Convert a gfc_symbol to an identifier of the same name. */
278 gfc_sym_identifier (gfc_symbol * sym)
280 return (get_identifier (sym->name));
284 /* Construct mangled name from symbol name. */
287 gfc_sym_mangled_identifier (gfc_symbol * sym)
289 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
291 /* Prevent the mangling of identifiers that have an assigned
292 binding label (mainly those that are bind(c)). */
293 if (sym->attr.is_bind_c == 1
294 && sym->binding_label[0] != '\0')
295 return get_identifier(sym->binding_label);
297 if (sym->module == NULL)
298 return gfc_sym_identifier (sym);
301 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
302 return get_identifier (name);
307 /* Construct mangled function name from symbol name. */
310 gfc_sym_mangled_function_id (gfc_symbol * sym)
313 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
315 /* It may be possible to simply use the binding label if it's
316 provided, and remove the other checks. Then we could use it
317 for other things if we wished. */
318 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
319 sym->binding_label[0] != '\0')
320 /* use the binding label rather than the mangled name */
321 return get_identifier (sym->binding_label);
323 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
324 || (sym->module != NULL && (sym->attr.external
325 || sym->attr.if_source == IFSRC_IFBODY)))
327 if (strcmp (sym->name, "MAIN__") == 0
328 || sym->attr.proc == PROC_INTRINSIC)
329 return get_identifier (sym->name);
331 if (gfc_option.flag_underscoring)
333 has_underscore = strchr (sym->name, '_') != 0;
334 if (gfc_option.flag_second_underscore && has_underscore)
335 snprintf (name, sizeof name, "%s__", sym->name);
337 snprintf (name, sizeof name, "%s_", sym->name);
338 return get_identifier (name);
341 return get_identifier (sym->name);
345 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
346 return get_identifier (name);
351 /* Returns true if a variable of specified size should go on the stack. */
354 gfc_can_put_var_on_stack (tree size)
356 unsigned HOST_WIDE_INT low;
358 if (!INTEGER_CST_P (size))
361 if (gfc_option.flag_max_stack_var_size < 0)
364 if (TREE_INT_CST_HIGH (size) != 0)
367 low = TREE_INT_CST_LOW (size);
368 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
371 /* TODO: Set a per-function stack size limit. */
377 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
378 an expression involving its corresponding pointer. There are
379 2 cases; one for variable size arrays, and one for everything else,
380 because variable-sized arrays require one fewer level of
384 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
386 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
389 /* Parameters need to be dereferenced. */
390 if (sym->cp_pointer->attr.dummy)
391 ptr_decl = build_fold_indirect_ref (ptr_decl);
393 /* Check to see if we're dealing with a variable-sized array. */
394 if (sym->attr.dimension
395 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
397 /* These decls will be dereferenced later, so we don't dereference
399 value = convert (TREE_TYPE (decl), ptr_decl);
403 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
405 value = build_fold_indirect_ref (ptr_decl);
408 SET_DECL_VALUE_EXPR (decl, value);
409 DECL_HAS_VALUE_EXPR_P (decl) = 1;
410 GFC_DECL_CRAY_POINTEE (decl) = 1;
411 /* This is a fake variable just for debugging purposes. */
412 TREE_ASM_WRITTEN (decl) = 1;
416 /* Finish processing of a declaration without an initial value. */
419 gfc_finish_decl (tree decl)
421 gcc_assert (TREE_CODE (decl) == PARM_DECL
422 || DECL_INITIAL (decl) == NULL_TREE);
424 if (TREE_CODE (decl) != VAR_DECL)
427 if (DECL_SIZE (decl) == NULL_TREE
428 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
429 layout_decl (decl, 0);
431 /* A few consistency checks. */
432 /* A static variable with an incomplete type is an error if it is
433 initialized. Also if it is not file scope. Otherwise, let it
434 through, but if it is not `extern' then it may cause an error
436 /* An automatic variable with an incomplete type is an error. */
438 /* We should know the storage size. */
439 gcc_assert (DECL_SIZE (decl) != NULL_TREE
440 || (TREE_STATIC (decl)
441 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
442 : DECL_EXTERNAL (decl)));
444 /* The storage size should be constant. */
445 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
447 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
451 /* Apply symbol attributes to a variable, and add it to the function scope. */
454 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
457 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
458 This is the equivalent of the TARGET variables.
459 We also need to set this if the variable is passed by reference in a
462 /* Set DECL_VALUE_EXPR for Cray Pointees. */
463 if (sym->attr.cray_pointee)
464 gfc_finish_cray_pointee (decl, sym);
466 if (sym->attr.target)
467 TREE_ADDRESSABLE (decl) = 1;
468 /* If it wasn't used we wouldn't be getting it. */
469 TREE_USED (decl) = 1;
471 /* Chain this decl to the pending declarations. Don't do pushdecl()
472 because this would add them to the current scope rather than the
474 if (current_function_decl != NULL_TREE)
476 if (sym->ns->proc_name->backend_decl == current_function_decl
477 || sym->result == sym)
478 gfc_add_decl_to_function (decl);
480 gfc_add_decl_to_parent_function (decl);
483 if (sym->attr.cray_pointee)
486 if(sym->attr.is_bind_c == 1)
488 /* We need to put variables that are bind(c) into the common
489 segment of the object file, because this is what C would do.
490 gfortran would typically put them in either the BSS or
491 initialized data segments, and only mark them as common if
492 they were part of common blocks. However, if they are not put
493 into common space, then C cannot initialize global fortran
494 variables that it interoperates with and the draft says that
495 either Fortran or C should be able to initialize it (but not
496 both, of course.) (J3/04-007, section 15.3). */
497 TREE_PUBLIC(decl) = 1;
498 DECL_COMMON(decl) = 1;
501 /* If a variable is USE associated, it's always external. */
502 if (sym->attr.use_assoc)
504 DECL_EXTERNAL (decl) = 1;
505 TREE_PUBLIC (decl) = 1;
507 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
509 /* TODO: Don't set sym->module for result or dummy variables. */
510 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
511 /* This is the declaration of a module variable. */
512 TREE_PUBLIC (decl) = 1;
513 TREE_STATIC (decl) = 1;
516 if ((sym->attr.save || sym->attr.data || sym->value)
517 && !sym->attr.use_assoc)
518 TREE_STATIC (decl) = 1;
520 if (sym->attr.volatile_)
522 TREE_THIS_VOLATILE (decl) = 1;
523 new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
524 TREE_TYPE (decl) = new;
527 /* Keep variables larger than max-stack-var-size off stack. */
528 if (!sym->ns->proc_name->attr.recursive
529 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
530 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
531 /* Put variable length auto array pointers always into stack. */
532 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
533 || sym->attr.dimension == 0
534 || sym->as->type != AS_EXPLICIT
536 || sym->attr.allocatable)
537 && !DECL_ARTIFICIAL (decl))
538 TREE_STATIC (decl) = 1;
540 /* Handle threadprivate variables. */
541 if (sym->attr.threadprivate
542 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
543 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
547 /* Allocate the lang-specific part of a decl. */
550 gfc_allocate_lang_decl (tree decl)
552 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
553 ggc_alloc_cleared (sizeof (struct lang_decl));
556 /* Remember a symbol to generate initialization/cleanup code at function
560 gfc_defer_symbol_init (gfc_symbol * sym)
566 /* Don't add a symbol twice. */
570 last = head = sym->ns->proc_name;
573 /* Make sure that setup code for dummy variables which are used in the
574 setup of other variables is generated first. */
577 /* Find the first dummy arg seen after us, or the first non-dummy arg.
578 This is a circular list, so don't go past the head. */
580 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
586 /* Insert in between last and p. */
592 /* Create an array index type variable with function scope. */
595 create_index_var (const char * pfx, int nest)
599 decl = gfc_create_var_np (gfc_array_index_type, pfx);
601 gfc_add_decl_to_parent_function (decl);
603 gfc_add_decl_to_function (decl);
608 /* Create variables to hold all the non-constant bits of info for a
609 descriptorless array. Remember these in the lang-specific part of the
613 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
619 type = TREE_TYPE (decl);
621 /* We just use the descriptor, if there is one. */
622 if (GFC_DESCRIPTOR_TYPE_P (type))
625 gcc_assert (GFC_ARRAY_TYPE_P (type));
626 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
627 && !sym->attr.contained;
629 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
631 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
633 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
634 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
636 /* Don't try to use the unknown bound for assumed shape arrays. */
637 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
638 && (sym->as->type != AS_ASSUMED_SIZE
639 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
641 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
642 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
645 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
647 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
648 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
651 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
653 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
655 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
658 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
660 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
663 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
664 && sym->as->type != AS_ASSUMED_SIZE)
666 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
667 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
670 if (POINTER_TYPE_P (type))
672 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
673 gcc_assert (TYPE_LANG_SPECIFIC (type)
674 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
675 type = TREE_TYPE (type);
678 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
682 size = build2 (MINUS_EXPR, gfc_array_index_type,
683 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
684 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
686 TYPE_DOMAIN (type) = range;
692 /* For some dummy arguments we don't use the actual argument directly.
693 Instead we create a local decl and use that. This allows us to perform
694 initialization, and construct full type information. */
697 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
707 if (sym->attr.pointer || sym->attr.allocatable)
710 /* Add to list of variables if not a fake result variable. */
711 if (sym->attr.result || sym->attr.dummy)
712 gfc_defer_symbol_init (sym);
714 type = TREE_TYPE (dummy);
715 gcc_assert (TREE_CODE (dummy) == PARM_DECL
716 && POINTER_TYPE_P (type));
718 /* Do we know the element size? */
719 known_size = sym->ts.type != BT_CHARACTER
720 || INTEGER_CST_P (sym->ts.cl->backend_decl);
722 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
724 /* For descriptorless arrays with known element size the actual
725 argument is sufficient. */
726 gcc_assert (GFC_ARRAY_TYPE_P (type));
727 gfc_build_qualified_array (dummy, sym);
731 type = TREE_TYPE (type);
732 if (GFC_DESCRIPTOR_TYPE_P (type))
734 /* Create a descriptorless array pointer. */
737 if (!gfc_option.flag_repack_arrays)
739 if (as->type == AS_ASSUMED_SIZE)
740 packed = PACKED_FULL;
744 if (as->type == AS_EXPLICIT)
746 packed = PACKED_FULL;
747 for (n = 0; n < as->rank; n++)
751 && as->upper[n]->expr_type == EXPR_CONSTANT
752 && as->lower[n]->expr_type == EXPR_CONSTANT))
753 packed = PACKED_PARTIAL;
757 packed = PACKED_PARTIAL;
760 type = gfc_typenode_for_spec (&sym->ts);
761 type = gfc_get_nodesc_array_type (type, sym->as, packed);
765 /* We now have an expression for the element size, so create a fully
766 qualified type. Reset sym->backend decl or this will just return the
768 DECL_ARTIFICIAL (sym->backend_decl) = 1;
769 sym->backend_decl = NULL_TREE;
770 type = gfc_sym_type (sym);
771 packed = PACKED_FULL;
774 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
775 decl = build_decl (VAR_DECL, get_identifier (name), type);
777 DECL_ARTIFICIAL (decl) = 1;
778 TREE_PUBLIC (decl) = 0;
779 TREE_STATIC (decl) = 0;
780 DECL_EXTERNAL (decl) = 0;
782 /* We should never get deferred shape arrays here. We used to because of
784 gcc_assert (sym->as->type != AS_DEFERRED);
786 if (packed == PACKED_PARTIAL)
787 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
788 else if (packed == PACKED_FULL)
789 GFC_DECL_PACKED_ARRAY (decl) = 1;
791 gfc_build_qualified_array (decl, sym);
793 if (DECL_LANG_SPECIFIC (dummy))
794 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
796 gfc_allocate_lang_decl (decl);
798 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
800 if (sym->ns->proc_name->backend_decl == current_function_decl
801 || sym->attr.contained)
802 gfc_add_decl_to_function (decl);
804 gfc_add_decl_to_parent_function (decl);
810 /* Return a constant or a variable to use as a string length. Does not
811 add the decl to the current scope. */
814 gfc_create_string_length (gfc_symbol * sym)
818 gcc_assert (sym->ts.cl);
819 gfc_conv_const_charlen (sym->ts.cl);
821 if (sym->ts.cl->backend_decl == NULL_TREE)
823 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
825 /* Also prefix the mangled name. */
826 strcpy (&name[1], sym->name);
828 length = build_decl (VAR_DECL, get_identifier (name),
829 gfc_charlen_type_node);
830 DECL_ARTIFICIAL (length) = 1;
831 TREE_USED (length) = 1;
832 if (sym->ns->proc_name->tlink != NULL)
833 gfc_defer_symbol_init (sym);
834 sym->ts.cl->backend_decl = length;
837 return sym->ts.cl->backend_decl;
840 /* If a variable is assigned a label, we add another two auxiliary
844 gfc_add_assign_aux_vars (gfc_symbol * sym)
850 gcc_assert (sym->backend_decl);
852 decl = sym->backend_decl;
853 gfc_allocate_lang_decl (decl);
854 GFC_DECL_ASSIGN (decl) = 1;
855 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
856 gfc_charlen_type_node);
857 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
859 gfc_finish_var_decl (length, sym);
860 gfc_finish_var_decl (addr, sym);
861 /* STRING_LENGTH is also used as flag. Less than -1 means that
862 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
863 target label's address. Otherwise, value is the length of a format string
864 and ASSIGN_ADDR is its address. */
865 if (TREE_STATIC (length))
866 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
868 gfc_defer_symbol_init (sym);
870 GFC_DECL_STRING_LEN (decl) = length;
871 GFC_DECL_ASSIGN_ADDR (decl) = addr;
874 /* Return the decl for a gfc_symbol, create it if it doesn't already
878 gfc_get_symbol_decl (gfc_symbol * sym)
881 tree length = NULL_TREE;
884 gcc_assert (sym->attr.referenced
885 || sym->attr.use_assoc
886 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
888 if (sym->ns && sym->ns->proc_name->attr.function)
889 byref = gfc_return_by_reference (sym->ns->proc_name);
893 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
895 /* Return via extra parameter. */
896 if (sym->attr.result && byref
897 && !sym->backend_decl)
900 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
901 /* For entry master function skip over the __entry
903 if (sym->ns->proc_name->attr.entry_master)
904 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
907 /* Dummy variables should already have been created. */
908 gcc_assert (sym->backend_decl);
910 /* Create a character length variable. */
911 if (sym->ts.type == BT_CHARACTER)
913 if (sym->ts.cl->backend_decl == NULL_TREE)
914 length = gfc_create_string_length (sym);
916 length = sym->ts.cl->backend_decl;
917 if (TREE_CODE (length) == VAR_DECL
918 && DECL_CONTEXT (length) == NULL_TREE)
920 /* Add the string length to the same context as the symbol. */
921 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
922 gfc_add_decl_to_function (length);
924 gfc_add_decl_to_parent_function (length);
926 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
927 DECL_CONTEXT (length));
929 gfc_defer_symbol_init (sym);
933 /* Use a copy of the descriptor for dummy arrays. */
934 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
936 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
937 /* Prevent the dummy from being detected as unused if it is copied. */
938 if (sym->backend_decl != NULL && decl != sym->backend_decl)
939 DECL_ARTIFICIAL (sym->backend_decl) = 1;
940 sym->backend_decl = decl;
943 TREE_USED (sym->backend_decl) = 1;
944 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
946 gfc_add_assign_aux_vars (sym);
948 return sym->backend_decl;
951 if (sym->backend_decl)
952 return sym->backend_decl;
954 /* Catch function declarations. Only used for actual parameters. */
955 if (sym->attr.flavor == FL_PROCEDURE)
957 decl = gfc_get_extern_function_decl (sym);
961 if (sym->attr.intrinsic)
962 internal_error ("intrinsic variable which isn't a procedure");
964 /* Create string length decl first so that they can be used in the
966 if (sym->ts.type == BT_CHARACTER)
967 length = gfc_create_string_length (sym);
969 /* Create the decl for the variable. */
970 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
972 gfc_set_decl_location (decl, &sym->declared_at);
974 /* Symbols from modules should have their assembler names mangled.
975 This is done here rather than in gfc_finish_var_decl because it
976 is different for string length variables. */
978 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
980 if (sym->attr.dimension)
982 /* Create variables to hold the non-constant bits of array info. */
983 gfc_build_qualified_array (decl, sym);
985 /* Remember this variable for allocation/cleanup. */
986 gfc_defer_symbol_init (sym);
988 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
989 GFC_DECL_PACKED_ARRAY (decl) = 1;
992 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
993 gfc_defer_symbol_init (sym);
995 gfc_finish_var_decl (decl, sym);
997 if (sym->ts.type == BT_CHARACTER)
999 /* Character variables need special handling. */
1000 gfc_allocate_lang_decl (decl);
1002 if (TREE_CODE (length) != INTEGER_CST)
1004 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1008 /* Also prefix the mangled name for symbols from modules. */
1009 strcpy (&name[1], sym->name);
1012 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1013 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1015 gfc_finish_var_decl (length, sym);
1016 gcc_assert (!sym->value);
1019 else if (sym->attr.subref_array_pointer)
1021 /* We need the span for these beasts. */
1022 gfc_allocate_lang_decl (decl);
1025 if (sym->attr.subref_array_pointer)
1028 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1029 span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1030 gfc_array_index_type);
1031 gfc_finish_var_decl (span, sym);
1032 TREE_STATIC (span) = 1;
1033 DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
1035 GFC_DECL_SPAN (decl) = span;
1038 sym->backend_decl = decl;
1040 if (sym->attr.assign)
1041 gfc_add_assign_aux_vars (sym);
1043 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1045 /* Add static initializer. */
1046 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1047 TREE_TYPE (decl), sym->attr.dimension,
1048 sym->attr.pointer || sym->attr.allocatable);
1055 /* Substitute a temporary variable in place of the real one. */
1058 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1060 save->attr = sym->attr;
1061 save->decl = sym->backend_decl;
1063 gfc_clear_attr (&sym->attr);
1064 sym->attr.referenced = 1;
1065 sym->attr.flavor = FL_VARIABLE;
1067 sym->backend_decl = decl;
1071 /* Restore the original variable. */
1074 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1076 sym->attr = save->attr;
1077 sym->backend_decl = save->decl;
1081 /* Get a basic decl for an external function. */
1084 gfc_get_extern_function_decl (gfc_symbol * sym)
1089 gfc_intrinsic_sym *isym;
1091 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1095 if (sym->backend_decl)
1096 return sym->backend_decl;
1098 /* We should never be creating external decls for alternate entry points.
1099 The procedure may be an alternate entry point, but we don't want/need
1101 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1103 if (sym->attr.intrinsic)
1105 /* Call the resolution function to get the actual name. This is
1106 a nasty hack which relies on the resolution functions only looking
1107 at the first argument. We pass NULL for the second argument
1108 otherwise things like AINT get confused. */
1109 isym = gfc_find_function (sym->name);
1110 gcc_assert (isym->resolve.f0 != NULL);
1112 memset (&e, 0, sizeof (e));
1113 e.expr_type = EXPR_FUNCTION;
1115 memset (&argexpr, 0, sizeof (argexpr));
1116 gcc_assert (isym->formal);
1117 argexpr.ts = isym->formal->ts;
1119 if (isym->formal->next == NULL)
1120 isym->resolve.f1 (&e, &argexpr);
1123 if (isym->formal->next->next == NULL)
1124 isym->resolve.f2 (&e, &argexpr, NULL);
1127 if (isym->formal->next->next->next == NULL)
1128 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1131 /* All specific intrinsics take less than 5 arguments. */
1132 gcc_assert (isym->formal->next->next->next->next == NULL);
1133 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1138 if (gfc_option.flag_f2c
1139 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1140 || e.ts.type == BT_COMPLEX))
1142 /* Specific which needs a different implementation if f2c
1143 calling conventions are used. */
1144 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1147 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1149 name = get_identifier (s);
1150 mangled_name = name;
1154 name = gfc_sym_identifier (sym);
1155 mangled_name = gfc_sym_mangled_function_id (sym);
1158 type = gfc_get_function_type (sym);
1159 fndecl = build_decl (FUNCTION_DECL, name, type);
1161 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1162 /* If the return type is a pointer, avoid alias issues by setting
1163 DECL_IS_MALLOC to nonzero. This means that the function should be
1164 treated as if it were a malloc, meaning it returns a pointer that
1166 if (POINTER_TYPE_P (type))
1167 DECL_IS_MALLOC (fndecl) = 1;
1169 /* Set the context of this decl. */
1170 if (0 && sym->ns && sym->ns->proc_name)
1172 /* TODO: Add external decls to the appropriate scope. */
1173 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1177 /* Global declaration, e.g. intrinsic subroutine. */
1178 DECL_CONTEXT (fndecl) = NULL_TREE;
1181 DECL_EXTERNAL (fndecl) = 1;
1183 /* This specifies if a function is globally addressable, i.e. it is
1184 the opposite of declaring static in C. */
1185 TREE_PUBLIC (fndecl) = 1;
1187 /* Set attributes for PURE functions. A call to PURE function in the
1188 Fortran 95 sense is both pure and without side effects in the C
1190 if (sym->attr.pure || sym->attr.elemental)
1192 if (sym->attr.function && !gfc_return_by_reference (sym))
1193 DECL_IS_PURE (fndecl) = 1;
1194 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1195 parameters and don't use alternate returns (is this
1196 allowed?). In that case, calls to them are meaningless, and
1197 can be optimized away. See also in build_function_decl(). */
1198 TREE_SIDE_EFFECTS (fndecl) = 0;
1201 /* Mark non-returning functions. */
1202 if (sym->attr.noreturn)
1203 TREE_THIS_VOLATILE(fndecl) = 1;
1205 sym->backend_decl = fndecl;
1207 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1208 pushdecl_top_level (fndecl);
1214 /* Create a declaration for a procedure. For external functions (in the C
1215 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1216 a master function with alternate entry points. */
1219 build_function_decl (gfc_symbol * sym)
1222 symbol_attribute attr;
1224 gfc_formal_arglist *f;
1226 gcc_assert (!sym->backend_decl);
1227 gcc_assert (!sym->attr.external);
1229 /* Set the line and filename. sym->declared_at seems to point to the
1230 last statement for subroutines, but it'll do for now. */
1231 gfc_set_backend_locus (&sym->declared_at);
1233 /* Allow only one nesting level. Allow public declarations. */
1234 gcc_assert (current_function_decl == NULL_TREE
1235 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1237 type = gfc_get_function_type (sym);
1238 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1240 /* Perform name mangling if this is a top level or module procedure. */
1241 if (current_function_decl == NULL_TREE)
1242 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1244 /* Figure out the return type of the declared function, and build a
1245 RESULT_DECL for it. If this is a subroutine with alternate
1246 returns, build a RESULT_DECL for it. */
1249 result_decl = NULL_TREE;
1250 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1253 if (gfc_return_by_reference (sym))
1254 type = void_type_node;
1257 if (sym->result != sym)
1258 result_decl = gfc_sym_identifier (sym->result);
1260 type = TREE_TYPE (TREE_TYPE (fndecl));
1265 /* Look for alternate return placeholders. */
1266 int has_alternate_returns = 0;
1267 for (f = sym->formal; f; f = f->next)
1271 has_alternate_returns = 1;
1276 if (has_alternate_returns)
1277 type = integer_type_node;
1279 type = void_type_node;
1282 result_decl = build_decl (RESULT_DECL, result_decl, type);
1283 DECL_ARTIFICIAL (result_decl) = 1;
1284 DECL_IGNORED_P (result_decl) = 1;
1285 DECL_CONTEXT (result_decl) = fndecl;
1286 DECL_RESULT (fndecl) = result_decl;
1288 /* Don't call layout_decl for a RESULT_DECL.
1289 layout_decl (result_decl, 0); */
1291 /* If the return type is a pointer, avoid alias issues by setting
1292 DECL_IS_MALLOC to nonzero. This means that the function should be
1293 treated as if it were a malloc, meaning it returns a pointer that
1295 if (POINTER_TYPE_P (type))
1296 DECL_IS_MALLOC (fndecl) = 1;
1298 /* Set up all attributes for the function. */
1299 DECL_CONTEXT (fndecl) = current_function_decl;
1300 DECL_EXTERNAL (fndecl) = 0;
1302 /* This specifies if a function is globally visible, i.e. it is
1303 the opposite of declaring static in C. */
1304 if (DECL_CONTEXT (fndecl) == NULL_TREE
1305 && !sym->attr.entry_master)
1306 TREE_PUBLIC (fndecl) = 1;
1308 /* TREE_STATIC means the function body is defined here. */
1309 TREE_STATIC (fndecl) = 1;
1311 /* Set attributes for PURE functions. A call to a PURE function in the
1312 Fortran 95 sense is both pure and without side effects in the C
1314 if (attr.pure || attr.elemental)
1316 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1317 including an alternate return. In that case it can also be
1318 marked as PURE. See also in gfc_get_extern_function_decl(). */
1319 if (attr.function && !gfc_return_by_reference (sym))
1320 DECL_IS_PURE (fndecl) = 1;
1321 TREE_SIDE_EFFECTS (fndecl) = 0;
1324 /* Layout the function declaration and put it in the binding level
1325 of the current function. */
1328 sym->backend_decl = fndecl;
1332 /* Create the DECL_ARGUMENTS for a procedure. */
1335 create_function_arglist (gfc_symbol * sym)
1338 gfc_formal_arglist *f;
1339 tree typelist, hidden_typelist;
1340 tree arglist, hidden_arglist;
1344 fndecl = sym->backend_decl;
1346 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1347 the new FUNCTION_DECL node. */
1348 arglist = NULL_TREE;
1349 hidden_arglist = NULL_TREE;
1350 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1352 if (sym->attr.entry_master)
1354 type = TREE_VALUE (typelist);
1355 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1357 DECL_CONTEXT (parm) = fndecl;
1358 DECL_ARG_TYPE (parm) = type;
1359 TREE_READONLY (parm) = 1;
1360 gfc_finish_decl (parm);
1361 DECL_ARTIFICIAL (parm) = 1;
1363 arglist = chainon (arglist, parm);
1364 typelist = TREE_CHAIN (typelist);
1367 if (gfc_return_by_reference (sym))
1369 tree type = TREE_VALUE (typelist), length = NULL;
1371 if (sym->ts.type == BT_CHARACTER)
1373 /* Length of character result. */
1374 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1375 gcc_assert (len_type == gfc_charlen_type_node);
1377 length = build_decl (PARM_DECL,
1378 get_identifier (".__result"),
1380 if (!sym->ts.cl->length)
1382 sym->ts.cl->backend_decl = length;
1383 TREE_USED (length) = 1;
1385 gcc_assert (TREE_CODE (length) == PARM_DECL);
1386 DECL_CONTEXT (length) = fndecl;
1387 DECL_ARG_TYPE (length) = len_type;
1388 TREE_READONLY (length) = 1;
1389 DECL_ARTIFICIAL (length) = 1;
1390 gfc_finish_decl (length);
1391 if (sym->ts.cl->backend_decl == NULL
1392 || sym->ts.cl->backend_decl == length)
1397 if (sym->ts.cl->backend_decl == NULL)
1399 tree len = build_decl (VAR_DECL,
1400 get_identifier ("..__result"),
1401 gfc_charlen_type_node);
1402 DECL_ARTIFICIAL (len) = 1;
1403 TREE_USED (len) = 1;
1404 sym->ts.cl->backend_decl = len;
1407 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1408 arg = sym->result ? sym->result : sym;
1409 backend_decl = arg->backend_decl;
1410 /* Temporary clear it, so that gfc_sym_type creates complete
1412 arg->backend_decl = NULL;
1413 type = gfc_sym_type (arg);
1414 arg->backend_decl = backend_decl;
1415 type = build_reference_type (type);
1419 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1421 DECL_CONTEXT (parm) = fndecl;
1422 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1423 TREE_READONLY (parm) = 1;
1424 DECL_ARTIFICIAL (parm) = 1;
1425 gfc_finish_decl (parm);
1427 arglist = chainon (arglist, parm);
1428 typelist = TREE_CHAIN (typelist);
1430 if (sym->ts.type == BT_CHARACTER)
1432 gfc_allocate_lang_decl (parm);
1433 arglist = chainon (arglist, length);
1434 typelist = TREE_CHAIN (typelist);
1438 hidden_typelist = typelist;
1439 for (f = sym->formal; f; f = f->next)
1440 if (f->sym != NULL) /* Ignore alternate returns. */
1441 hidden_typelist = TREE_CHAIN (hidden_typelist);
1443 for (f = sym->formal; f; f = f->next)
1445 char name[GFC_MAX_SYMBOL_LEN + 2];
1447 /* Ignore alternate returns. */
1451 type = TREE_VALUE (typelist);
1453 if (f->sym->ts.type == BT_CHARACTER)
1455 tree len_type = TREE_VALUE (hidden_typelist);
1456 tree length = NULL_TREE;
1457 gcc_assert (len_type == gfc_charlen_type_node);
1459 strcpy (&name[1], f->sym->name);
1461 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1463 hidden_arglist = chainon (hidden_arglist, length);
1464 DECL_CONTEXT (length) = fndecl;
1465 DECL_ARTIFICIAL (length) = 1;
1466 DECL_ARG_TYPE (length) = len_type;
1467 TREE_READONLY (length) = 1;
1468 gfc_finish_decl (length);
1470 /* TODO: Check string lengths when -fbounds-check. */
1472 /* Use the passed value for assumed length variables. */
1473 if (!f->sym->ts.cl->length)
1475 TREE_USED (length) = 1;
1476 gcc_assert (!f->sym->ts.cl->backend_decl);
1477 f->sym->ts.cl->backend_decl = length;
1480 hidden_typelist = TREE_CHAIN (hidden_typelist);
1482 if (f->sym->ts.cl->backend_decl == NULL
1483 || f->sym->ts.cl->backend_decl == length)
1485 if (f->sym->ts.cl->backend_decl == NULL)
1486 gfc_create_string_length (f->sym);
1488 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1489 if (f->sym->attr.flavor == FL_PROCEDURE)
1490 type = build_pointer_type (gfc_get_function_type (f->sym));
1492 type = gfc_sym_type (f->sym);
1496 /* For non-constant length array arguments, make sure they use
1497 a different type node from TYPE_ARG_TYPES type. */
1498 if (f->sym->attr.dimension
1499 && type == TREE_VALUE (typelist)
1500 && TREE_CODE (type) == POINTER_TYPE
1501 && GFC_ARRAY_TYPE_P (type)
1502 && f->sym->as->type != AS_ASSUMED_SIZE
1503 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1505 if (f->sym->attr.flavor == FL_PROCEDURE)
1506 type = build_pointer_type (gfc_get_function_type (f->sym));
1508 type = gfc_sym_type (f->sym);
1511 /* Build a the argument declaration. */
1512 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1514 /* Fill in arg stuff. */
1515 DECL_CONTEXT (parm) = fndecl;
1516 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1517 /* All implementation args are read-only. */
1518 TREE_READONLY (parm) = 1;
1520 gfc_finish_decl (parm);
1522 f->sym->backend_decl = parm;
1524 arglist = chainon (arglist, parm);
1525 typelist = TREE_CHAIN (typelist);
1528 /* Add the hidden string length parameters. */
1529 arglist = chainon (arglist, hidden_arglist);
1531 gcc_assert (hidden_typelist == NULL_TREE
1532 || TREE_VALUE (hidden_typelist) == void_type_node);
1533 DECL_ARGUMENTS (fndecl) = arglist;
1536 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1539 gfc_gimplify_function (tree fndecl)
1541 struct cgraph_node *cgn;
1543 gimplify_function_tree (fndecl);
1544 dump_function (TDI_generic, fndecl);
1546 /* Generate errors for structured block violations. */
1547 /* ??? Could be done as part of resolve_labels. */
1549 diagnose_omp_structured_block_errors (fndecl);
1551 /* Convert all nested functions to GIMPLE now. We do things in this order
1552 so that items like VLA sizes are expanded properly in the context of the
1553 correct function. */
1554 cgn = cgraph_node (fndecl);
1555 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1556 gfc_gimplify_function (cgn->decl);
1560 /* Do the setup necessary before generating the body of a function. */
1563 trans_function_start (gfc_symbol * sym)
1567 fndecl = sym->backend_decl;
1569 /* Let GCC know the current scope is this function. */
1570 current_function_decl = fndecl;
1572 /* Let the world know what we're about to do. */
1573 announce_function (fndecl);
1575 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1577 /* Create RTL for function declaration. */
1578 rest_of_decl_compilation (fndecl, 1, 0);
1581 /* Create RTL for function definition. */
1582 make_decl_rtl (fndecl);
1584 init_function_start (fndecl);
1586 /* Even though we're inside a function body, we still don't want to
1587 call expand_expr to calculate the size of a variable-sized array.
1588 We haven't necessarily assigned RTL to all variables yet, so it's
1589 not safe to try to expand expressions involving them. */
1590 cfun->x_dont_save_pending_sizes_p = 1;
1592 /* function.c requires a push at the start of the function. */
1596 /* Create thunks for alternate entry points. */
1599 build_entry_thunks (gfc_namespace * ns)
1601 gfc_formal_arglist *formal;
1602 gfc_formal_arglist *thunk_formal;
1604 gfc_symbol *thunk_sym;
1612 /* This should always be a toplevel function. */
1613 gcc_assert (current_function_decl == NULL_TREE);
1615 gfc_get_backend_locus (&old_loc);
1616 for (el = ns->entries; el; el = el->next)
1618 thunk_sym = el->sym;
1620 build_function_decl (thunk_sym);
1621 create_function_arglist (thunk_sym);
1623 trans_function_start (thunk_sym);
1625 thunk_fndecl = thunk_sym->backend_decl;
1627 gfc_start_block (&body);
1629 /* Pass extra parameter identifying this entry point. */
1630 tmp = build_int_cst (gfc_array_index_type, el->id);
1631 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1632 string_args = NULL_TREE;
1634 if (thunk_sym->attr.function)
1636 if (gfc_return_by_reference (ns->proc_name))
1638 tree ref = DECL_ARGUMENTS (current_function_decl);
1639 args = tree_cons (NULL_TREE, ref, args);
1640 if (ns->proc_name->ts.type == BT_CHARACTER)
1641 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1646 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1648 /* Ignore alternate returns. */
1649 if (formal->sym == NULL)
1652 /* We don't have a clever way of identifying arguments, so resort to
1653 a brute-force search. */
1654 for (thunk_formal = thunk_sym->formal;
1656 thunk_formal = thunk_formal->next)
1658 if (thunk_formal->sym == formal->sym)
1664 /* Pass the argument. */
1665 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1666 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1668 if (formal->sym->ts.type == BT_CHARACTER)
1670 tmp = thunk_formal->sym->ts.cl->backend_decl;
1671 string_args = tree_cons (NULL_TREE, tmp, string_args);
1676 /* Pass NULL for a missing argument. */
1677 args = tree_cons (NULL_TREE, null_pointer_node, args);
1678 if (formal->sym->ts.type == BT_CHARACTER)
1680 tmp = build_int_cst (gfc_charlen_type_node, 0);
1681 string_args = tree_cons (NULL_TREE, tmp, string_args);
1686 /* Call the master function. */
1687 args = nreverse (args);
1688 args = chainon (args, nreverse (string_args));
1689 tmp = ns->proc_name->backend_decl;
1690 tmp = build_function_call_expr (tmp, args);
1691 if (ns->proc_name->attr.mixed_entry_master)
1693 tree union_decl, field;
1694 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1696 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1697 TREE_TYPE (master_type));
1698 DECL_ARTIFICIAL (union_decl) = 1;
1699 DECL_EXTERNAL (union_decl) = 0;
1700 TREE_PUBLIC (union_decl) = 0;
1701 TREE_USED (union_decl) = 1;
1702 layout_decl (union_decl, 0);
1703 pushdecl (union_decl);
1705 DECL_CONTEXT (union_decl) = current_function_decl;
1706 tmp = build2 (MODIFY_EXPR,
1707 TREE_TYPE (union_decl),
1709 gfc_add_expr_to_block (&body, tmp);
1711 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1712 field; field = TREE_CHAIN (field))
1713 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1714 thunk_sym->result->name) == 0)
1716 gcc_assert (field != NULL_TREE);
1717 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1719 tmp = build2 (MODIFY_EXPR,
1720 TREE_TYPE (DECL_RESULT (current_function_decl)),
1721 DECL_RESULT (current_function_decl), tmp);
1722 tmp = build1_v (RETURN_EXPR, tmp);
1724 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1727 tmp = build2 (MODIFY_EXPR,
1728 TREE_TYPE (DECL_RESULT (current_function_decl)),
1729 DECL_RESULT (current_function_decl), tmp);
1730 tmp = build1_v (RETURN_EXPR, tmp);
1732 gfc_add_expr_to_block (&body, tmp);
1734 /* Finish off this function and send it for code generation. */
1735 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1737 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1739 /* Output the GENERIC tree. */
1740 dump_function (TDI_original, thunk_fndecl);
1742 /* Store the end of the function, so that we get good line number
1743 info for the epilogue. */
1744 cfun->function_end_locus = input_location;
1746 /* We're leaving the context of this function, so zap cfun.
1747 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1748 tree_rest_of_compilation. */
1751 current_function_decl = NULL_TREE;
1753 gfc_gimplify_function (thunk_fndecl);
1754 cgraph_finalize_function (thunk_fndecl, false);
1756 /* We share the symbols in the formal argument list with other entry
1757 points and the master function. Clear them so that they are
1758 recreated for each function. */
1759 for (formal = thunk_sym->formal; formal; formal = formal->next)
1760 if (formal->sym != NULL) /* Ignore alternate returns. */
1762 formal->sym->backend_decl = NULL_TREE;
1763 if (formal->sym->ts.type == BT_CHARACTER)
1764 formal->sym->ts.cl->backend_decl = NULL_TREE;
1767 if (thunk_sym->attr.function)
1769 if (thunk_sym->ts.type == BT_CHARACTER)
1770 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1771 if (thunk_sym->result->ts.type == BT_CHARACTER)
1772 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1776 gfc_set_backend_locus (&old_loc);
1780 /* Create a decl for a function, and create any thunks for alternate entry
1784 gfc_create_function_decl (gfc_namespace * ns)
1786 /* Create a declaration for the master function. */
1787 build_function_decl (ns->proc_name);
1789 /* Compile the entry thunks. */
1791 build_entry_thunks (ns);
1793 /* Now create the read argument list. */
1794 create_function_arglist (ns->proc_name);
1797 /* Return the decl used to hold the function return value. If
1798 parent_flag is set, the context is the parent_scope. */
1801 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1805 tree this_fake_result_decl;
1806 tree this_function_decl;
1808 char name[GFC_MAX_SYMBOL_LEN + 10];
1812 this_fake_result_decl = parent_fake_result_decl;
1813 this_function_decl = DECL_CONTEXT (current_function_decl);
1817 this_fake_result_decl = current_fake_result_decl;
1818 this_function_decl = current_function_decl;
1822 && sym->ns->proc_name->backend_decl == this_function_decl
1823 && sym->ns->proc_name->attr.entry_master
1824 && sym != sym->ns->proc_name)
1827 if (this_fake_result_decl != NULL)
1828 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1829 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1832 return TREE_VALUE (t);
1833 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1836 this_fake_result_decl = parent_fake_result_decl;
1838 this_fake_result_decl = current_fake_result_decl;
1840 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1844 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1845 field; field = TREE_CHAIN (field))
1846 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1850 gcc_assert (field != NULL_TREE);
1851 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1855 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1857 gfc_add_decl_to_parent_function (var);
1859 gfc_add_decl_to_function (var);
1861 SET_DECL_VALUE_EXPR (var, decl);
1862 DECL_HAS_VALUE_EXPR_P (var) = 1;
1863 GFC_DECL_RESULT (var) = 1;
1865 TREE_CHAIN (this_fake_result_decl)
1866 = tree_cons (get_identifier (sym->name), var,
1867 TREE_CHAIN (this_fake_result_decl));
1871 if (this_fake_result_decl != NULL_TREE)
1872 return TREE_VALUE (this_fake_result_decl);
1874 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1879 if (sym->ts.type == BT_CHARACTER)
1881 if (sym->ts.cl->backend_decl == NULL_TREE)
1882 length = gfc_create_string_length (sym);
1884 length = sym->ts.cl->backend_decl;
1885 if (TREE_CODE (length) == VAR_DECL
1886 && DECL_CONTEXT (length) == NULL_TREE)
1887 gfc_add_decl_to_function (length);
1890 if (gfc_return_by_reference (sym))
1892 decl = DECL_ARGUMENTS (this_function_decl);
1894 if (sym->ns->proc_name->backend_decl == this_function_decl
1895 && sym->ns->proc_name->attr.entry_master)
1896 decl = TREE_CHAIN (decl);
1898 TREE_USED (decl) = 1;
1900 decl = gfc_build_dummy_array_decl (sym, decl);
1904 sprintf (name, "__result_%.20s",
1905 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1907 if (!sym->attr.mixed_entry_master && sym->attr.function)
1908 decl = build_decl (VAR_DECL, get_identifier (name),
1909 gfc_sym_type (sym));
1911 decl = build_decl (VAR_DECL, get_identifier (name),
1912 TREE_TYPE (TREE_TYPE (this_function_decl)));
1913 DECL_ARTIFICIAL (decl) = 1;
1914 DECL_EXTERNAL (decl) = 0;
1915 TREE_PUBLIC (decl) = 0;
1916 TREE_USED (decl) = 1;
1917 GFC_DECL_RESULT (decl) = 1;
1918 TREE_ADDRESSABLE (decl) = 1;
1920 layout_decl (decl, 0);
1923 gfc_add_decl_to_parent_function (decl);
1925 gfc_add_decl_to_function (decl);
1929 parent_fake_result_decl = build_tree_list (NULL, decl);
1931 current_fake_result_decl = build_tree_list (NULL, decl);
1937 /* Builds a function decl. The remaining parameters are the types of the
1938 function arguments. Negative nargs indicates a varargs function. */
1941 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1950 /* Library functions must be declared with global scope. */
1951 gcc_assert (current_function_decl == NULL_TREE);
1953 va_start (p, nargs);
1956 /* Create a list of the argument types. */
1957 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1959 argtype = va_arg (p, tree);
1960 arglist = gfc_chainon_list (arglist, argtype);
1965 /* Terminate the list. */
1966 arglist = gfc_chainon_list (arglist, void_type_node);
1969 /* Build the function type and decl. */
1970 fntype = build_function_type (rettype, arglist);
1971 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1973 /* Mark this decl as external. */
1974 DECL_EXTERNAL (fndecl) = 1;
1975 TREE_PUBLIC (fndecl) = 1;
1981 rest_of_decl_compilation (fndecl, 1, 0);
1987 gfc_build_intrinsic_function_decls (void)
1989 tree gfc_int4_type_node = gfc_get_int_type (4);
1990 tree gfc_int8_type_node = gfc_get_int_type (8);
1991 tree gfc_int16_type_node = gfc_get_int_type (16);
1992 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1993 tree gfc_real4_type_node = gfc_get_real_type (4);
1994 tree gfc_real8_type_node = gfc_get_real_type (8);
1995 tree gfc_real10_type_node = gfc_get_real_type (10);
1996 tree gfc_real16_type_node = gfc_get_real_type (16);
1997 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1998 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1999 tree gfc_complex10_type_node = gfc_get_complex_type (10);
2000 tree gfc_complex16_type_node = gfc_get_complex_type (16);
2002 /* String functions. */
2003 gfor_fndecl_compare_string =
2004 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2005 integer_type_node, 4,
2006 gfc_charlen_type_node, pchar_type_node,
2007 gfc_charlen_type_node, pchar_type_node);
2009 gfor_fndecl_concat_string =
2010 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2013 gfc_charlen_type_node, pchar_type_node,
2014 gfc_charlen_type_node, pchar_type_node,
2015 gfc_charlen_type_node, pchar_type_node);
2017 gfor_fndecl_string_len_trim =
2018 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2020 2, gfc_charlen_type_node,
2023 gfor_fndecl_string_index =
2024 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2026 5, gfc_charlen_type_node, pchar_type_node,
2027 gfc_charlen_type_node, pchar_type_node,
2028 gfc_logical4_type_node);
2030 gfor_fndecl_string_scan =
2031 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2033 5, gfc_charlen_type_node, pchar_type_node,
2034 gfc_charlen_type_node, pchar_type_node,
2035 gfc_logical4_type_node);
2037 gfor_fndecl_string_verify =
2038 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2040 5, gfc_charlen_type_node, pchar_type_node,
2041 gfc_charlen_type_node, pchar_type_node,
2042 gfc_logical4_type_node);
2044 gfor_fndecl_string_trim =
2045 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2048 build_pointer_type (gfc_charlen_type_node),
2050 gfc_charlen_type_node,
2053 gfor_fndecl_string_minmax =
2054 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2056 build_pointer_type (gfc_charlen_type_node),
2057 ppvoid_type_node, integer_type_node,
2060 gfor_fndecl_ttynam =
2061 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2065 gfc_charlen_type_node,
2069 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2073 gfc_charlen_type_node);
2076 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2080 gfc_charlen_type_node,
2081 gfc_int8_type_node);
2083 gfor_fndecl_adjustl =
2084 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2088 gfc_charlen_type_node, pchar_type_node);
2090 gfor_fndecl_adjustr =
2091 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2095 gfc_charlen_type_node, pchar_type_node);
2097 gfor_fndecl_si_kind =
2098 gfc_build_library_function_decl (get_identifier
2099 (PREFIX("selected_int_kind")),
2104 gfor_fndecl_sr_kind =
2105 gfc_build_library_function_decl (get_identifier
2106 (PREFIX("selected_real_kind")),
2111 /* Power functions. */
2113 tree ctype, rtype, itype, jtype;
2114 int rkind, ikind, jkind;
2117 static int ikinds[NIKINDS] = {4, 8, 16};
2118 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2119 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2121 for (ikind=0; ikind < NIKINDS; ikind++)
2123 itype = gfc_get_int_type (ikinds[ikind]);
2125 for (jkind=0; jkind < NIKINDS; jkind++)
2127 jtype = gfc_get_int_type (ikinds[jkind]);
2130 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2132 gfor_fndecl_math_powi[jkind][ikind].integer =
2133 gfc_build_library_function_decl (get_identifier (name),
2134 jtype, 2, jtype, itype);
2135 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2139 for (rkind = 0; rkind < NRKINDS; rkind ++)
2141 rtype = gfc_get_real_type (rkinds[rkind]);
2144 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2146 gfor_fndecl_math_powi[rkind][ikind].real =
2147 gfc_build_library_function_decl (get_identifier (name),
2148 rtype, 2, rtype, itype);
2149 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2152 ctype = gfc_get_complex_type (rkinds[rkind]);
2155 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2157 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2158 gfc_build_library_function_decl (get_identifier (name),
2159 ctype, 2,ctype, itype);
2160 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2168 gfor_fndecl_math_cpowf =
2169 gfc_build_library_function_decl (get_identifier ("cpowf"),
2170 gfc_complex4_type_node,
2171 1, gfc_complex4_type_node);
2172 gfor_fndecl_math_cpow =
2173 gfc_build_library_function_decl (get_identifier ("cpow"),
2174 gfc_complex8_type_node,
2175 1, gfc_complex8_type_node);
2176 if (gfc_complex10_type_node)
2177 gfor_fndecl_math_cpowl10 =
2178 gfc_build_library_function_decl (get_identifier ("cpowl"),
2179 gfc_complex10_type_node, 1,
2180 gfc_complex10_type_node);
2181 if (gfc_complex16_type_node)
2182 gfor_fndecl_math_cpowl16 =
2183 gfc_build_library_function_decl (get_identifier ("cpowl"),
2184 gfc_complex16_type_node, 1,
2185 gfc_complex16_type_node);
2187 gfor_fndecl_math_ishftc4 =
2188 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2190 3, gfc_int4_type_node,
2191 gfc_int4_type_node, gfc_int4_type_node);
2192 gfor_fndecl_math_ishftc8 =
2193 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2195 3, gfc_int8_type_node,
2196 gfc_int4_type_node, gfc_int4_type_node);
2197 if (gfc_int16_type_node)
2198 gfor_fndecl_math_ishftc16 =
2199 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2200 gfc_int16_type_node, 3,
2201 gfc_int16_type_node,
2203 gfc_int4_type_node);
2205 gfor_fndecl_math_exponent4 =
2206 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2208 1, gfc_real4_type_node);
2209 gfor_fndecl_math_exponent8 =
2210 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2212 1, gfc_real8_type_node);
2213 if (gfc_real10_type_node)
2214 gfor_fndecl_math_exponent10 =
2215 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2216 gfc_int4_type_node, 1,
2217 gfc_real10_type_node);
2218 if (gfc_real16_type_node)
2219 gfor_fndecl_math_exponent16 =
2220 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2221 gfc_int4_type_node, 1,
2222 gfc_real16_type_node);
2224 /* BLAS functions. */
2226 tree pint = build_pointer_type (integer_type_node);
2227 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2228 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2229 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2230 tree pz = build_pointer_type
2231 (gfc_get_complex_type (gfc_default_double_kind));
2233 gfor_fndecl_sgemm = gfc_build_library_function_decl
2235 (gfc_option.flag_underscoring ? "sgemm_"
2237 void_type_node, 15, pchar_type_node,
2238 pchar_type_node, pint, pint, pint, ps, ps, pint,
2239 ps, pint, ps, ps, pint, integer_type_node,
2241 gfor_fndecl_dgemm = gfc_build_library_function_decl
2243 (gfc_option.flag_underscoring ? "dgemm_"
2245 void_type_node, 15, pchar_type_node,
2246 pchar_type_node, pint, pint, pint, pd, pd, pint,
2247 pd, pint, pd, pd, pint, integer_type_node,
2249 gfor_fndecl_cgemm = gfc_build_library_function_decl
2251 (gfc_option.flag_underscoring ? "cgemm_"
2253 void_type_node, 15, pchar_type_node,
2254 pchar_type_node, pint, pint, pint, pc, pc, pint,
2255 pc, pint, pc, pc, pint, integer_type_node,
2257 gfor_fndecl_zgemm = gfc_build_library_function_decl
2259 (gfc_option.flag_underscoring ? "zgemm_"
2261 void_type_node, 15, pchar_type_node,
2262 pchar_type_node, pint, pint, pint, pz, pz, pint,
2263 pz, pint, pz, pz, pint, integer_type_node,
2267 /* Other functions. */
2269 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2270 gfc_array_index_type,
2271 1, pvoid_type_node);
2273 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2274 gfc_array_index_type,
2276 gfc_array_index_type);
2279 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2285 /* Make prototypes for runtime library functions. */
2288 gfc_build_builtin_function_decls (void)
2290 tree gfc_int4_type_node = gfc_get_int_type (4);
2292 gfor_fndecl_stop_numeric =
2293 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2294 void_type_node, 1, gfc_int4_type_node);
2295 /* Stop doesn't return. */
2296 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2298 gfor_fndecl_stop_string =
2299 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2300 void_type_node, 2, pchar_type_node,
2301 gfc_int4_type_node);
2302 /* Stop doesn't return. */
2303 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2305 gfor_fndecl_pause_numeric =
2306 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2307 void_type_node, 1, gfc_int4_type_node);
2309 gfor_fndecl_pause_string =
2310 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2311 void_type_node, 2, pchar_type_node,
2312 gfc_int4_type_node);
2314 gfor_fndecl_select_string =
2315 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2316 integer_type_node, 0);
2318 gfor_fndecl_runtime_error =
2319 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2320 void_type_node, -1, pchar_type_node);
2321 /* The runtime_error function does not return. */
2322 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2324 gfor_fndecl_runtime_error_at =
2325 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2326 void_type_node, -2, pchar_type_node,
2328 /* The runtime_error_at function does not return. */
2329 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2331 gfor_fndecl_generate_error =
2332 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2333 void_type_node, 3, pvoid_type_node,
2334 integer_type_node, pchar_type_node);
2336 gfor_fndecl_os_error =
2337 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2338 void_type_node, 1, pchar_type_node);
2339 /* The runtime_error function does not return. */
2340 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2342 gfor_fndecl_set_fpe =
2343 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2344 void_type_node, 1, integer_type_node);
2346 /* Keep the array dimension in sync with the call, later in this file. */
2347 gfor_fndecl_set_options =
2348 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2349 void_type_node, 2, integer_type_node,
2352 gfor_fndecl_set_convert =
2353 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2354 void_type_node, 1, integer_type_node);
2356 gfor_fndecl_set_record_marker =
2357 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2358 void_type_node, 1, integer_type_node);
2360 gfor_fndecl_set_max_subrecord_length =
2361 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2362 void_type_node, 1, integer_type_node);
2364 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2365 get_identifier (PREFIX("internal_pack")),
2366 pvoid_type_node, 1, pvoid_type_node);
2368 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2369 get_identifier (PREFIX("internal_unpack")),
2370 pvoid_type_node, 1, pvoid_type_node);
2372 gfor_fndecl_associated =
2373 gfc_build_library_function_decl (
2374 get_identifier (PREFIX("associated")),
2375 integer_type_node, 2, ppvoid_type_node,
2378 gfc_build_intrinsic_function_decls ();
2379 gfc_build_intrinsic_lib_fndecls ();
2380 gfc_build_io_library_fndecls ();
2384 /* Evaluate the length of dummy character variables. */
2387 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2391 gfc_finish_decl (cl->backend_decl);
2393 gfc_start_block (&body);
2395 /* Evaluate the string length expression. */
2396 gfc_conv_string_length (cl, &body);
2398 gfc_trans_vla_type_sizes (sym, &body);
2400 gfc_add_expr_to_block (&body, fnbody);
2401 return gfc_finish_block (&body);
2405 /* Allocate and cleanup an automatic character variable. */
2408 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2414 gcc_assert (sym->backend_decl);
2415 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2417 gfc_start_block (&body);
2419 /* Evaluate the string length expression. */
2420 gfc_conv_string_length (sym->ts.cl, &body);
2422 gfc_trans_vla_type_sizes (sym, &body);
2424 decl = sym->backend_decl;
2426 /* Emit a DECL_EXPR for this variable, which will cause the
2427 gimplifier to allocate storage, and all that good stuff. */
2428 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2429 gfc_add_expr_to_block (&body, tmp);
2431 gfc_add_expr_to_block (&body, fnbody);
2432 return gfc_finish_block (&body);
2435 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2438 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2442 gcc_assert (sym->backend_decl);
2443 gfc_start_block (&body);
2445 /* Set the initial value to length. See the comments in
2446 function gfc_add_assign_aux_vars in this file. */
2447 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2448 build_int_cst (NULL_TREE, -2));
2450 gfc_add_expr_to_block (&body, fnbody);
2451 return gfc_finish_block (&body);
2455 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2457 tree t = *tp, var, val;
2459 if (t == NULL || t == error_mark_node)
2461 if (TREE_CONSTANT (t) || DECL_P (t))
2464 if (TREE_CODE (t) == SAVE_EXPR)
2466 if (SAVE_EXPR_RESOLVED_P (t))
2468 *tp = TREE_OPERAND (t, 0);
2471 val = TREE_OPERAND (t, 0);
2476 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2477 gfc_add_decl_to_function (var);
2478 gfc_add_modify_expr (body, var, val);
2479 if (TREE_CODE (t) == SAVE_EXPR)
2480 TREE_OPERAND (t, 0) = var;
2485 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2489 if (type == NULL || type == error_mark_node)
2492 type = TYPE_MAIN_VARIANT (type);
2494 if (TREE_CODE (type) == INTEGER_TYPE)
2496 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2497 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2499 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2501 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2502 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2505 else if (TREE_CODE (type) == ARRAY_TYPE)
2507 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2508 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2509 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2510 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2512 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2514 TYPE_SIZE (t) = TYPE_SIZE (type);
2515 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2520 /* Make sure all type sizes and array domains are either constant,
2521 or variable or parameter decls. This is a simplified variant
2522 of gimplify_type_sizes, but we can't use it here, as none of the
2523 variables in the expressions have been gimplified yet.
2524 As type sizes and domains for various variable length arrays
2525 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2526 time, without this routine gimplify_type_sizes in the middle-end
2527 could result in the type sizes being gimplified earlier than where
2528 those variables are initialized. */
2531 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2533 tree type = TREE_TYPE (sym->backend_decl);
2535 if (TREE_CODE (type) == FUNCTION_TYPE
2536 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2538 if (! current_fake_result_decl)
2541 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2544 while (POINTER_TYPE_P (type))
2545 type = TREE_TYPE (type);
2547 if (GFC_DESCRIPTOR_TYPE_P (type))
2549 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2551 while (POINTER_TYPE_P (etype))
2552 etype = TREE_TYPE (etype);
2554 gfc_trans_vla_type_sizes_1 (etype, body);
2557 gfc_trans_vla_type_sizes_1 (type, body);
2561 /* Generate function entry and exit code, and add it to the function body.
2563 Allocation and initialization of array variables.
2564 Allocation of character string variables.
2565 Initialization and possibly repacking of dummy arrays.
2566 Initialization of ASSIGN statement auxiliary variable. */
2569 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2573 gfc_formal_arglist *f;
2575 bool seen_trans_deferred_array = false;
2577 /* Deal with implicit return variables. Explicit return variables will
2578 already have been added. */
2579 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2581 if (!current_fake_result_decl)
2583 gfc_entry_list *el = NULL;
2584 if (proc_sym->attr.entry_master)
2586 for (el = proc_sym->ns->entries; el; el = el->next)
2587 if (el->sym != el->sym->result)
2591 warning (0, "Function does not return a value");
2593 else if (proc_sym->as)
2595 tree result = TREE_VALUE (current_fake_result_decl);
2596 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2598 /* An automatic character length, pointer array result. */
2599 if (proc_sym->ts.type == BT_CHARACTER
2600 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2601 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2604 else if (proc_sym->ts.type == BT_CHARACTER)
2606 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2607 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2611 gcc_assert (gfc_option.flag_f2c
2612 && proc_sym->ts.type == BT_COMPLEX);
2615 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2617 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2618 && sym->ts.derived->attr.alloc_comp;
2619 if (sym->attr.dimension)
2621 switch (sym->as->type)
2624 if (sym->attr.dummy || sym->attr.result)
2626 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2627 else if (sym->attr.pointer || sym->attr.allocatable)
2629 if (TREE_STATIC (sym->backend_decl))
2630 gfc_trans_static_array_pointer (sym);
2633 seen_trans_deferred_array = true;
2634 fnbody = gfc_trans_deferred_array (sym, fnbody);
2639 if (sym_has_alloc_comp)
2641 seen_trans_deferred_array = true;
2642 fnbody = gfc_trans_deferred_array (sym, fnbody);
2645 gfc_get_backend_locus (&loc);
2646 gfc_set_backend_locus (&sym->declared_at);
2647 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2649 gfc_set_backend_locus (&loc);
2653 case AS_ASSUMED_SIZE:
2654 /* Must be a dummy parameter. */
2655 gcc_assert (sym->attr.dummy);
2657 /* We should always pass assumed size arrays the g77 way. */
2658 fnbody = gfc_trans_g77_array (sym, fnbody);
2661 case AS_ASSUMED_SHAPE:
2662 /* Must be a dummy parameter. */
2663 gcc_assert (sym->attr.dummy);
2665 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2670 seen_trans_deferred_array = true;
2671 fnbody = gfc_trans_deferred_array (sym, fnbody);
2677 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2678 fnbody = gfc_trans_deferred_array (sym, fnbody);
2680 else if (sym_has_alloc_comp)
2681 fnbody = gfc_trans_deferred_array (sym, fnbody);
2682 else if (sym->ts.type == BT_CHARACTER)
2684 gfc_get_backend_locus (&loc);
2685 gfc_set_backend_locus (&sym->declared_at);
2686 if (sym->attr.dummy || sym->attr.result)
2687 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2689 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2690 gfc_set_backend_locus (&loc);
2692 else if (sym->attr.assign)
2694 gfc_get_backend_locus (&loc);
2695 gfc_set_backend_locus (&sym->declared_at);
2696 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2697 gfc_set_backend_locus (&loc);
2703 gfc_init_block (&body);
2705 for (f = proc_sym->formal; f; f = f->next)
2707 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2709 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2710 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2711 gfc_trans_vla_type_sizes (f->sym, &body);
2714 /* If an INTENT(OUT) dummy of derived type has a default
2715 initializer, it must be initialized here. */
2716 if (f->sym && f->sym->attr.intent == INTENT_OUT
2717 && f->sym->ts.type == BT_DERIVED
2718 && !f->sym->ts.derived->attr.alloc_comp
2723 gcc_assert (!f->sym->attr.allocatable);
2724 gfc_set_sym_referenced (f->sym);
2725 tmpe = gfc_lval_expr_from_sym (f->sym);
2726 tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
2728 present = gfc_conv_expr_present (f->sym);
2729 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2730 tmp, build_empty_stmt ());
2731 gfc_add_expr_to_block (&body, tmp);
2732 gfc_free_expr (tmpe);
2736 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2737 && current_fake_result_decl != NULL)
2739 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2740 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2741 gfc_trans_vla_type_sizes (proc_sym, &body);
2744 gfc_add_expr_to_block (&body, fnbody);
2745 return gfc_finish_block (&body);
2749 /* Output an initialized decl for a module variable. */
2752 gfc_create_module_variable (gfc_symbol * sym)
2756 /* Module functions with alternate entries are dealt with later and
2757 would get caught by the next condition. */
2758 if (sym->attr.entry)
2761 /* Make sure we convert the types of the derived types from iso_c_binding
2763 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2764 && sym->ts.type == BT_DERIVED)
2765 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2767 /* Only output variables and array valued parameters. */
2768 if (sym->attr.flavor != FL_VARIABLE
2769 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2772 /* Don't generate variables from other modules. Variables from
2773 COMMONs will already have been generated. */
2774 if (sym->attr.use_assoc || sym->attr.in_common)
2777 /* Equivalenced variables arrive here after creation. */
2778 if (sym->backend_decl
2779 && (sym->equiv_built || sym->attr.in_equivalence))
2782 if (sym->backend_decl)
2783 internal_error ("backend decl for module variable %s already exists",
2786 /* We always want module variables to be created. */
2787 sym->attr.referenced = 1;
2788 /* Create the decl. */
2789 decl = gfc_get_symbol_decl (sym);
2791 /* Create the variable. */
2793 rest_of_decl_compilation (decl, 1, 0);
2795 /* Also add length of strings. */
2796 if (sym->ts.type == BT_CHARACTER)
2800 length = sym->ts.cl->backend_decl;
2801 if (!INTEGER_CST_P (length))
2804 rest_of_decl_compilation (length, 1, 0);
2810 /* Generate all the required code for module variables. */
2813 gfc_generate_module_vars (gfc_namespace * ns)
2815 module_namespace = ns;
2817 /* Check if the frontend left the namespace in a reasonable state. */
2818 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2820 /* Generate COMMON blocks. */
2821 gfc_trans_common (ns);
2823 /* Create decls for all the module variables. */
2824 gfc_traverse_ns (ns, gfc_create_module_variable);
2828 gfc_generate_contained_functions (gfc_namespace * parent)
2832 /* We create all the prototypes before generating any code. */
2833 for (ns = parent->contained; ns; ns = ns->sibling)
2835 /* Skip namespaces from used modules. */
2836 if (ns->parent != parent)
2839 gfc_create_function_decl (ns);
2842 for (ns = parent->contained; ns; ns = ns->sibling)
2844 /* Skip namespaces from used modules. */
2845 if (ns->parent != parent)
2848 gfc_generate_function_code (ns);
2853 /* Drill down through expressions for the array specification bounds and
2854 character length calling generate_local_decl for all those variables
2855 that have not already been declared. */
2858 generate_local_decl (gfc_symbol *);
2861 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2863 gfc_actual_arglist *arg;
2870 switch (e->expr_type)
2873 for (arg = e->value.function.actual; arg; arg = arg->next)
2874 generate_expr_decls (sym, arg->expr);
2877 /* If the variable is not the same as the dependent, 'sym', and
2878 it is not marked as being declared and it is in the same
2879 namespace as 'sym', add it to the local declarations. */
2881 if (sym == e->symtree->n.sym
2882 || e->symtree->n.sym->mark
2883 || e->symtree->n.sym->ns != sym->ns)
2886 generate_local_decl (e->symtree->n.sym);
2890 generate_expr_decls (sym, e->value.op.op1);
2891 generate_expr_decls (sym, e->value.op.op2);
2900 for (ref = e->ref; ref; ref = ref->next)
2905 for (i = 0; i < ref->u.ar.dimen; i++)
2907 generate_expr_decls (sym, ref->u.ar.start[i]);
2908 generate_expr_decls (sym, ref->u.ar.end[i]);
2909 generate_expr_decls (sym, ref->u.ar.stride[i]);
2914 generate_expr_decls (sym, ref->u.ss.start);
2915 generate_expr_decls (sym, ref->u.ss.end);
2919 if (ref->u.c.component->ts.type == BT_CHARACTER
2920 && ref->u.c.component->ts.cl->length->expr_type
2922 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2924 if (ref->u.c.component->as)
2925 for (i = 0; i < ref->u.c.component->as->rank; i++)
2927 generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2928 generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2937 /* Check for dependencies in the character length and array spec. */
2940 generate_dependency_declarations (gfc_symbol *sym)
2944 if (sym->ts.type == BT_CHARACTER
2945 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2946 generate_expr_decls (sym, sym->ts.cl->length);
2948 if (sym->as && sym->as->rank)
2950 for (i = 0; i < sym->as->rank; i++)
2952 generate_expr_decls (sym, sym->as->lower[i]);
2953 generate_expr_decls (sym, sym->as->upper[i]);
2959 /* Generate decls for all local variables. We do this to ensure correct
2960 handling of expressions which only appear in the specification of
2964 generate_local_decl (gfc_symbol * sym)
2966 if (sym->attr.flavor == FL_VARIABLE)
2968 /* Check for dependencies in the array specification and string
2969 length, adding the necessary declarations to the function. We
2970 mark the symbol now, as well as in traverse_ns, to prevent
2971 getting stuck in a circular dependency. */
2973 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2974 generate_dependency_declarations (sym);
2976 if (sym->attr.referenced)
2977 gfc_get_symbol_decl (sym);
2978 /* INTENT(out) dummy arguments are likely meant to be set. */
2979 else if (warn_unused_variable
2981 && sym->attr.intent == INTENT_OUT)
2982 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
2983 sym->name, &sym->declared_at);
2984 /* Specific warning for unused dummy arguments. */
2985 else if (warn_unused_variable && sym->attr.dummy)
2986 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
2988 /* Warn for unused variables, but not if they're inside a common
2989 block or are use-associated. */
2990 else if (warn_unused_variable
2991 && !(sym->attr.in_common || sym->attr.use_assoc))
2992 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
2994 /* For variable length CHARACTER parameters, the PARM_DECL already
2995 references the length variable, so force gfc_get_symbol_decl
2996 even when not referenced. If optimize > 0, it will be optimized
2997 away anyway. But do this only after emitting -Wunused-parameter
2998 warning if requested. */
2999 if (sym->attr.dummy && ! sym->attr.referenced
3000 && sym->ts.type == BT_CHARACTER
3001 && sym->ts.cl->backend_decl != NULL
3002 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3004 sym->attr.referenced = 1;
3005 gfc_get_symbol_decl (sym);
3008 /* We do not want the middle-end to warn about unused parameters
3009 as this was already done above. */
3010 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3011 TREE_NO_WARNING(sym->backend_decl) = 1;
3013 else if (sym->attr.flavor == FL_PARAMETER)
3015 if (warn_unused_parameter
3016 && !sym->attr.referenced
3017 && !sym->attr.use_assoc)
3018 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3022 if (sym->attr.dummy == 1)
3024 /* Modify the tree type for scalar character dummy arguments of bind(c)
3025 procedures if they are passed by value. The tree type for them will
3026 be promoted to INTEGER_TYPE for the middle end, which appears to be
3027 what C would do with characters passed by-value. The value attribute
3028 implies the dummy is a scalar. */
3029 if (sym->attr.value == 1 && sym->backend_decl != NULL
3030 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3031 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3032 gfc_conv_scalar_char_value (sym, NULL, NULL);
3035 /* Make sure we convert the types of the derived types from iso_c_binding
3037 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3038 && sym->ts.type == BT_DERIVED)
3039 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3043 generate_local_vars (gfc_namespace * ns)
3045 gfc_traverse_ns (ns, generate_local_decl);
3049 /* Generate a switch statement to jump to the correct entry point. Also
3050 creates the label decls for the entry points. */
3053 gfc_trans_entry_master_switch (gfc_entry_list * el)
3060 gfc_init_block (&block);
3061 for (; el; el = el->next)
3063 /* Add the case label. */
3064 label = gfc_build_label_decl (NULL_TREE);
3065 val = build_int_cst (gfc_array_index_type, el->id);
3066 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3067 gfc_add_expr_to_block (&block, tmp);
3069 /* And jump to the actual entry point. */
3070 label = gfc_build_label_decl (NULL_TREE);
3071 tmp = build1_v (GOTO_EXPR, label);
3072 gfc_add_expr_to_block (&block, tmp);
3074 /* Save the label decl. */
3077 tmp = gfc_finish_block (&block);
3078 /* The first argument selects the entry point. */
3079 val = DECL_ARGUMENTS (current_function_decl);
3080 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3085 /* Generate code for a function. */
3088 gfc_generate_function_code (gfc_namespace * ns)
3101 sym = ns->proc_name;
3103 /* Check that the frontend isn't still using this. */
3104 gcc_assert (sym->tlink == NULL);
3107 /* Create the declaration for functions with global scope. */
3108 if (!sym->backend_decl)
3109 gfc_create_function_decl (ns);
3111 fndecl = sym->backend_decl;
3112 old_context = current_function_decl;
3116 push_function_context ();
3117 saved_parent_function_decls = saved_function_decls;
3118 saved_function_decls = NULL_TREE;
3121 trans_function_start (sym);
3123 gfc_start_block (&block);
3125 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3127 /* Copy length backend_decls to all entry point result
3132 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3133 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3134 for (el = ns->entries; el; el = el->next)
3135 el->sym->result->ts.cl->backend_decl = backend_decl;
3138 /* Translate COMMON blocks. */
3139 gfc_trans_common (ns);
3141 /* Null the parent fake result declaration if this namespace is
3142 a module function or an external procedures. */
3143 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3144 || ns->parent == NULL)
3145 parent_fake_result_decl = NULL_TREE;
3147 gfc_generate_contained_functions (ns);
3149 generate_local_vars (ns);
3151 /* Keep the parent fake result declaration in module functions
3152 or external procedures. */
3153 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3154 || ns->parent == NULL)
3155 current_fake_result_decl = parent_fake_result_decl;
3157 current_fake_result_decl = NULL_TREE;
3159 current_function_return_label = NULL;
3161 /* Now generate the code for the body of this function. */
3162 gfc_init_block (&body);
3164 /* If this is the main program, add a call to set_options to set up the
3165 runtime library Fortran language standard parameters. */
3166 if (sym->attr.is_main_program)
3168 tree array_type, array, var;
3170 /* Passing a new option to the library requires four modifications:
3171 + add it to the tree_cons list below
3172 + change the array size in the call to build_array_type
3173 + change the first argument to the library call
3174 gfor_fndecl_set_options
3175 + modify the library (runtime/compile_options.c)! */
3176 array = tree_cons (NULL_TREE,
3177 build_int_cst (integer_type_node,
3178 gfc_option.warn_std), NULL_TREE);
3179 array = tree_cons (NULL_TREE,
3180 build_int_cst (integer_type_node,
3181 gfc_option.allow_std), array);
3182 array = tree_cons (NULL_TREE,
3183 build_int_cst (integer_type_node, pedantic), array);
3184 array = tree_cons (NULL_TREE,
3185 build_int_cst (integer_type_node,
3186 gfc_option.flag_dump_core), array);
3187 array = tree_cons (NULL_TREE,
3188 build_int_cst (integer_type_node,
3189 gfc_option.flag_backtrace), array);
3190 array = tree_cons (NULL_TREE,
3191 build_int_cst (integer_type_node,
3192 gfc_option.flag_sign_zero), array);
3194 array = tree_cons (NULL_TREE,
3195 build_int_cst (integer_type_node,
3196 flag_bounds_check), array);
3198 array_type = build_array_type (integer_type_node,
3199 build_index_type (build_int_cst (NULL_TREE,
3201 array = build_constructor_from_list (array_type, nreverse (array));
3202 TREE_CONSTANT (array) = 1;
3203 TREE_INVARIANT (array) = 1;
3204 TREE_STATIC (array) = 1;
3206 /* Create a static variable to hold the jump table. */
3207 var = gfc_create_var (array_type, "options");
3208 TREE_CONSTANT (var) = 1;
3209 TREE_INVARIANT (var) = 1;
3210 TREE_STATIC (var) = 1;
3211 TREE_READONLY (var) = 1;
3212 DECL_INITIAL (var) = array;
3213 var = gfc_build_addr_expr (pvoid_type_node, var);
3215 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3216 build_int_cst (integer_type_node, 7), var);
3217 gfc_add_expr_to_block (&body, tmp);
3220 /* If this is the main program and a -ffpe-trap option was provided,
3221 add a call to set_fpe so that the library will raise a FPE when
3223 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3225 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3226 build_int_cst (integer_type_node,
3228 gfc_add_expr_to_block (&body, tmp);
3231 /* If this is the main program and an -fconvert option was provided,
3232 add a call to set_convert. */
3234 if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3236 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3237 build_int_cst (integer_type_node,
3238 gfc_option.convert));
3239 gfc_add_expr_to_block (&body, tmp);
3242 /* If this is the main program and an -frecord-marker option was provided,
3243 add a call to set_record_marker. */
3245 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3247 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3248 build_int_cst (integer_type_node,
3249 gfc_option.record_marker));
3250 gfc_add_expr_to_block (&body, tmp);
3253 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3255 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3257 build_int_cst (integer_type_node,
3258 gfc_option.max_subrecord_length));
3259 gfc_add_expr_to_block (&body, tmp);
3262 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3263 && sym->attr.subroutine)
3265 tree alternate_return;
3266 alternate_return = gfc_get_fake_result_decl (sym, 0);
3267 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3272 /* Jump to the correct entry point. */
3273 tmp = gfc_trans_entry_master_switch (ns->entries);
3274 gfc_add_expr_to_block (&body, tmp);
3277 tmp = gfc_trans_code (ns->code);
3278 gfc_add_expr_to_block (&body, tmp);
3280 /* Add a return label if needed. */
3281 if (current_function_return_label)
3283 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3284 gfc_add_expr_to_block (&body, tmp);
3287 tmp = gfc_finish_block (&body);
3288 /* Add code to create and cleanup arrays. */
3289 tmp = gfc_trans_deferred_vars (sym, tmp);
3291 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3293 if (sym->attr.subroutine || sym == sym->result)
3295 if (current_fake_result_decl != NULL)
3296 result = TREE_VALUE (current_fake_result_decl);
3299 current_fake_result_decl = NULL_TREE;
3302 result = sym->result->backend_decl;
3304 if (result != NULL_TREE && sym->attr.function
3305 && sym->ts.type == BT_DERIVED
3306 && sym->ts.derived->attr.alloc_comp
3307 && !sym->attr.pointer)
3309 rank = sym->as ? sym->as->rank : 0;
3310 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3311 gfc_add_expr_to_block (&block, tmp2);
3314 gfc_add_expr_to_block (&block, tmp);
3316 if (result == NULL_TREE)
3317 warning (0, "Function return value not set");
3320 /* Set the return value to the dummy result variable. The
3321 types may be different for scalar default REAL functions
3322 with -ff2c, therefore we have to convert. */
3323 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3324 tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3325 DECL_RESULT (fndecl), tmp);
3326 tmp = build1_v (RETURN_EXPR, tmp);
3327 gfc_add_expr_to_block (&block, tmp);
3331 gfc_add_expr_to_block (&block, tmp);
3334 /* Add all the decls we created during processing. */
3335 decl = saved_function_decls;
3340 next = TREE_CHAIN (decl);
3341 TREE_CHAIN (decl) = NULL_TREE;
3345 saved_function_decls = NULL_TREE;
3347 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3349 /* Finish off this function and send it for code generation. */
3351 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3353 /* Output the GENERIC tree. */
3354 dump_function (TDI_original, fndecl);
3356 /* Store the end of the function, so that we get good line number
3357 info for the epilogue. */
3358 cfun->function_end_locus = input_location;
3360 /* We're leaving the context of this function, so zap cfun.
3361 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3362 tree_rest_of_compilation. */
3367 pop_function_context ();
3368 saved_function_decls = saved_parent_function_decls;
3370 current_function_decl = old_context;
3372 if (decl_function_context (fndecl))
3373 /* Register this function with cgraph just far enough to get it
3374 added to our parent's nested function list. */
3375 (void) cgraph_node (fndecl);
3378 gfc_gimplify_function (fndecl);
3379 cgraph_finalize_function (fndecl, false);
3384 gfc_generate_constructors (void)
3386 gcc_assert (gfc_static_ctors == NULL_TREE);
3394 if (gfc_static_ctors == NULL_TREE)
3397 fnname = get_file_function_name ("I");
3398 type = build_function_type (void_type_node,
3399 gfc_chainon_list (NULL_TREE, void_type_node));
3401 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3402 TREE_PUBLIC (fndecl) = 1;
3404 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3405 DECL_ARTIFICIAL (decl) = 1;
3406 DECL_IGNORED_P (decl) = 1;
3407 DECL_CONTEXT (decl) = fndecl;
3408 DECL_RESULT (fndecl) = decl;
3412 current_function_decl = fndecl;
3414 rest_of_decl_compilation (fndecl, 1, 0);
3416 make_decl_rtl (fndecl);
3418 init_function_start (fndecl);
3422 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3424 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3425 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3430 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3432 free_after_parsing (cfun);
3433 free_after_compilation (cfun);
3435 tree_rest_of_compilation (fndecl);
3437 current_function_decl = NULL_TREE;
3441 /* Translates a BLOCK DATA program unit. This means emitting the
3442 commons contained therein plus their initializations. We also emit
3443 a globally visible symbol to make sure that each BLOCK DATA program
3444 unit remains unique. */
3447 gfc_generate_block_data (gfc_namespace * ns)
3452 /* Tell the backend the source location of the block data. */
3454 gfc_set_backend_locus (&ns->proc_name->declared_at);
3456 gfc_set_backend_locus (&gfc_current_locus);
3458 /* Process the DATA statements. */
3459 gfc_trans_common (ns);
3461 /* Create a global symbol with the mane of the block data. This is to
3462 generate linker errors if the same name is used twice. It is never
3465 id = gfc_sym_mangled_function_id (ns->proc_name);
3467 id = get_identifier ("__BLOCK_DATA__");
3469 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3470 TREE_PUBLIC (decl) = 1;
3471 TREE_STATIC (decl) = 1;
3474 rest_of_decl_compilation (decl, 1, 0);
3478 #include "gt-fortran-trans-decl.h"