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_malloc;
78 tree gfor_fndecl_internal_malloc64;
79 tree gfor_fndecl_internal_realloc;
80 tree gfor_fndecl_internal_realloc64;
81 tree gfor_fndecl_internal_free;
82 tree gfor_fndecl_allocate;
83 tree gfor_fndecl_allocate64;
84 tree gfor_fndecl_allocate_array;
85 tree gfor_fndecl_allocate64_array;
86 tree gfor_fndecl_deallocate;
87 tree gfor_fndecl_pause_numeric;
88 tree gfor_fndecl_pause_string;
89 tree gfor_fndecl_stop_numeric;
90 tree gfor_fndecl_stop_string;
91 tree gfor_fndecl_select_string;
92 tree gfor_fndecl_runtime_error;
93 tree gfor_fndecl_set_fpe;
94 tree gfor_fndecl_set_std;
95 tree gfor_fndecl_set_convert;
96 tree gfor_fndecl_set_record_marker;
97 tree gfor_fndecl_set_max_subrecord_length;
98 tree gfor_fndecl_ctime;
99 tree gfor_fndecl_fdate;
100 tree gfor_fndecl_ttynam;
101 tree gfor_fndecl_in_pack;
102 tree gfor_fndecl_in_unpack;
103 tree gfor_fndecl_associated;
106 /* Math functions. Many other math functions are handled in
107 trans-intrinsic.c. */
109 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
110 tree gfor_fndecl_math_cpowf;
111 tree gfor_fndecl_math_cpow;
112 tree gfor_fndecl_math_cpowl10;
113 tree gfor_fndecl_math_cpowl16;
114 tree gfor_fndecl_math_ishftc4;
115 tree gfor_fndecl_math_ishftc8;
116 tree gfor_fndecl_math_ishftc16;
117 tree gfor_fndecl_math_exponent4;
118 tree gfor_fndecl_math_exponent8;
119 tree gfor_fndecl_math_exponent10;
120 tree gfor_fndecl_math_exponent16;
123 /* String functions. */
125 tree gfor_fndecl_compare_string;
126 tree gfor_fndecl_concat_string;
127 tree gfor_fndecl_string_len_trim;
128 tree gfor_fndecl_string_index;
129 tree gfor_fndecl_string_scan;
130 tree gfor_fndecl_string_verify;
131 tree gfor_fndecl_string_trim;
132 tree gfor_fndecl_adjustl;
133 tree gfor_fndecl_adjustr;
136 /* Other misc. runtime library functions. */
138 tree gfor_fndecl_size0;
139 tree gfor_fndecl_size1;
140 tree gfor_fndecl_iargc;
142 /* Intrinsic functions implemented in FORTRAN. */
143 tree gfor_fndecl_si_kind;
144 tree gfor_fndecl_sr_kind;
146 /* BLAS gemm functions. */
147 tree gfor_fndecl_sgemm;
148 tree gfor_fndecl_dgemm;
149 tree gfor_fndecl_cgemm;
150 tree gfor_fndecl_zgemm;
154 gfc_add_decl_to_parent_function (tree decl)
157 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
158 DECL_NONLOCAL (decl) = 1;
159 TREE_CHAIN (decl) = saved_parent_function_decls;
160 saved_parent_function_decls = decl;
164 gfc_add_decl_to_function (tree decl)
167 TREE_USED (decl) = 1;
168 DECL_CONTEXT (decl) = current_function_decl;
169 TREE_CHAIN (decl) = saved_function_decls;
170 saved_function_decls = decl;
174 /* Build a backend label declaration. Set TREE_USED for named labels.
175 The context of the label is always the current_function_decl. All
176 labels are marked artificial. */
179 gfc_build_label_decl (tree label_id)
181 /* 2^32 temporaries should be enough. */
182 static unsigned int tmp_num = 1;
186 if (label_id == NULL_TREE)
188 /* Build an internal label name. */
189 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
190 label_id = get_identifier (label_name);
195 /* Build the LABEL_DECL node. Labels have no type. */
196 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
197 DECL_CONTEXT (label_decl) = current_function_decl;
198 DECL_MODE (label_decl) = VOIDmode;
200 /* We always define the label as used, even if the original source
201 file never references the label. We don't want all kinds of
202 spurious warnings for old-style Fortran code with too many
204 TREE_USED (label_decl) = 1;
206 DECL_ARTIFICIAL (label_decl) = 1;
211 /* Returns the return label for the current function. */
214 gfc_get_return_label (void)
216 char name[GFC_MAX_SYMBOL_LEN + 10];
218 if (current_function_return_label)
219 return current_function_return_label;
221 sprintf (name, "__return_%s",
222 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
224 current_function_return_label =
225 gfc_build_label_decl (get_identifier (name));
227 DECL_ARTIFICIAL (current_function_return_label) = 1;
229 return current_function_return_label;
233 /* Set the backend source location of a decl. */
236 gfc_set_decl_location (tree decl, locus * loc)
238 #ifdef USE_MAPPED_LOCATION
239 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
241 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
242 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
247 /* Return the backend label declaration for a given label structure,
248 or create it if it doesn't exist yet. */
251 gfc_get_label_decl (gfc_st_label * lp)
253 if (lp->backend_decl)
254 return lp->backend_decl;
257 char label_name[GFC_MAX_SYMBOL_LEN + 1];
260 /* Validate the label declaration from the front end. */
261 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
263 /* Build a mangled name for the label. */
264 sprintf (label_name, "__label_%.6d", lp->value);
266 /* Build the LABEL_DECL node. */
267 label_decl = gfc_build_label_decl (get_identifier (label_name));
269 /* Tell the debugger where the label came from. */
270 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
271 gfc_set_decl_location (label_decl, &lp->where);
273 DECL_ARTIFICIAL (label_decl) = 1;
275 /* Store the label in the label list and return the LABEL_DECL. */
276 lp->backend_decl = label_decl;
282 /* Convert a gfc_symbol to an identifier of the same name. */
285 gfc_sym_identifier (gfc_symbol * sym)
287 return (get_identifier (sym->name));
291 /* Construct mangled name from symbol name. */
294 gfc_sym_mangled_identifier (gfc_symbol * sym)
296 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
298 if (sym->module == NULL)
299 return gfc_sym_identifier (sym);
302 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
303 return get_identifier (name);
308 /* Construct mangled function name from symbol name. */
311 gfc_sym_mangled_function_id (gfc_symbol * sym)
314 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
316 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
317 || (sym->module != NULL && (sym->attr.external
318 || sym->attr.if_source == IFSRC_IFBODY)))
320 if (strcmp (sym->name, "MAIN__") == 0
321 || sym->attr.proc == PROC_INTRINSIC)
322 return get_identifier (sym->name);
324 if (gfc_option.flag_underscoring)
326 has_underscore = strchr (sym->name, '_') != 0;
327 if (gfc_option.flag_second_underscore && has_underscore)
328 snprintf (name, sizeof name, "%s__", sym->name);
330 snprintf (name, sizeof name, "%s_", sym->name);
331 return get_identifier (name);
334 return get_identifier (sym->name);
338 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
339 return get_identifier (name);
344 /* Returns true if a variable of specified size should go on the stack. */
347 gfc_can_put_var_on_stack (tree size)
349 unsigned HOST_WIDE_INT low;
351 if (!INTEGER_CST_P (size))
354 if (gfc_option.flag_max_stack_var_size < 0)
357 if (TREE_INT_CST_HIGH (size) != 0)
360 low = TREE_INT_CST_LOW (size);
361 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
364 /* TODO: Set a per-function stack size limit. */
370 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
371 an expression involving its corresponding pointer. There are
372 2 cases; one for variable size arrays, and one for everything else,
373 because variable-sized arrays require one fewer level of
377 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
379 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
382 /* Parameters need to be dereferenced. */
383 if (sym->cp_pointer->attr.dummy)
384 ptr_decl = build_fold_indirect_ref (ptr_decl);
386 /* Check to see if we're dealing with a variable-sized array. */
387 if (sym->attr.dimension
388 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
390 /* These decls will be dereferenced later, so we don't dereference
392 value = convert (TREE_TYPE (decl), ptr_decl);
396 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
398 value = build_fold_indirect_ref (ptr_decl);
401 SET_DECL_VALUE_EXPR (decl, value);
402 DECL_HAS_VALUE_EXPR_P (decl) = 1;
403 GFC_DECL_CRAY_POINTEE (decl) = 1;
404 /* This is a fake variable just for debugging purposes. */
405 TREE_ASM_WRITTEN (decl) = 1;
409 /* Finish processing of a declaration and install its initial value. */
412 gfc_finish_decl (tree decl, tree init)
414 if (TREE_CODE (decl) == PARM_DECL)
415 gcc_assert (init == NULL_TREE);
416 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
417 -- it overlaps DECL_ARG_TYPE. */
418 else if (init == NULL_TREE)
419 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
421 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
423 if (init != NULL_TREE)
425 if (TREE_CODE (decl) != TYPE_DECL)
426 DECL_INITIAL (decl) = init;
429 /* typedef foo = bar; store the type of bar as the type of foo. */
430 TREE_TYPE (decl) = TREE_TYPE (init);
431 DECL_INITIAL (decl) = init = 0;
435 if (TREE_CODE (decl) == VAR_DECL)
437 if (DECL_SIZE (decl) == NULL_TREE
438 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
439 layout_decl (decl, 0);
441 /* A static variable with an incomplete type is an error if it is
442 initialized. Also if it is not file scope. Otherwise, let it
443 through, but if it is not `extern' then it may cause an error
445 /* An automatic variable with an incomplete type is an error. */
446 if (DECL_SIZE (decl) == NULL_TREE
447 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
448 || DECL_CONTEXT (decl) != 0)
449 : !DECL_EXTERNAL (decl)))
451 gfc_fatal_error ("storage size not known");
454 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
455 && (DECL_SIZE (decl) != 0)
456 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
458 gfc_fatal_error ("storage size not constant");
465 /* Apply symbol attributes to a variable, and add it to the function scope. */
468 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
471 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
472 This is the equivalent of the TARGET variables.
473 We also need to set this if the variable is passed by reference in a
476 /* Set DECL_VALUE_EXPR for Cray Pointees. */
477 if (sym->attr.cray_pointee)
478 gfc_finish_cray_pointee (decl, sym);
480 if (sym->attr.target)
481 TREE_ADDRESSABLE (decl) = 1;
482 /* If it wasn't used we wouldn't be getting it. */
483 TREE_USED (decl) = 1;
485 /* Chain this decl to the pending declarations. Don't do pushdecl()
486 because this would add them to the current scope rather than the
488 if (current_function_decl != NULL_TREE)
490 if (sym->ns->proc_name->backend_decl == current_function_decl
491 || sym->result == sym)
492 gfc_add_decl_to_function (decl);
494 gfc_add_decl_to_parent_function (decl);
497 if (sym->attr.cray_pointee)
500 /* If a variable is USE associated, it's always external. */
501 if (sym->attr.use_assoc)
503 DECL_EXTERNAL (decl) = 1;
504 TREE_PUBLIC (decl) = 1;
506 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
508 /* TODO: Don't set sym->module for result or dummy variables. */
509 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
510 /* This is the declaration of a module variable. */
511 TREE_PUBLIC (decl) = 1;
512 TREE_STATIC (decl) = 1;
515 if ((sym->attr.save || sym->attr.data || sym->value)
516 && !sym->attr.use_assoc)
517 TREE_STATIC (decl) = 1;
519 if (sym->attr.volatile_)
521 TREE_THIS_VOLATILE (decl) = 1;
522 new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
523 TREE_TYPE (decl) = new;
526 /* Keep variables larger than max-stack-var-size off stack. */
527 if (!sym->ns->proc_name->attr.recursive
528 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
529 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
530 /* Put variable length auto array pointers always into stack. */
531 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
532 || sym->attr.dimension == 0
533 || sym->as->type != AS_EXPLICIT
535 || sym->attr.allocatable)
536 && !DECL_ARTIFICIAL (decl))
537 TREE_STATIC (decl) = 1;
539 /* Handle threadprivate variables. */
540 if (sym->attr.threadprivate
541 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
542 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
546 /* Allocate the lang-specific part of a decl. */
549 gfc_allocate_lang_decl (tree decl)
551 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
552 ggc_alloc_cleared (sizeof (struct lang_decl));
555 /* Remember a symbol to generate initialization/cleanup code at function
559 gfc_defer_symbol_init (gfc_symbol * sym)
565 /* Don't add a symbol twice. */
569 last = head = sym->ns->proc_name;
572 /* Make sure that setup code for dummy variables which are used in the
573 setup of other variables is generated first. */
576 /* Find the first dummy arg seen after us, or the first non-dummy arg.
577 This is a circular list, so don't go past the head. */
579 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
585 /* Insert in between last and p. */
591 /* Create an array index type variable with function scope. */
594 create_index_var (const char * pfx, int nest)
598 decl = gfc_create_var_np (gfc_array_index_type, pfx);
600 gfc_add_decl_to_parent_function (decl);
602 gfc_add_decl_to_function (decl);
607 /* Create variables to hold all the non-constant bits of info for a
608 descriptorless array. Remember these in the lang-specific part of the
612 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
618 type = TREE_TYPE (decl);
620 /* We just use the descriptor, if there is one. */
621 if (GFC_DESCRIPTOR_TYPE_P (type))
624 gcc_assert (GFC_ARRAY_TYPE_P (type));
625 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
626 && !sym->attr.contained;
628 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
630 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
631 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
632 /* Don't try to use the unknown bound for assumed shape arrays. */
633 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
634 && (sym->as->type != AS_ASSUMED_SIZE
635 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
636 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
638 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
639 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
641 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
643 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
646 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
648 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
651 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
652 && sym->as->type != AS_ASSUMED_SIZE)
653 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
655 if (POINTER_TYPE_P (type))
657 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
658 gcc_assert (TYPE_LANG_SPECIFIC (type)
659 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
660 type = TREE_TYPE (type);
663 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
667 size = build2 (MINUS_EXPR, gfc_array_index_type,
668 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
669 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
671 TYPE_DOMAIN (type) = range;
677 /* For some dummy arguments we don't use the actual argument directly.
678 Instead we create a local decl and use that. This allows us to perform
679 initialization, and construct full type information. */
682 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
692 if (sym->attr.pointer || sym->attr.allocatable)
695 /* Add to list of variables if not a fake result variable. */
696 if (sym->attr.result || sym->attr.dummy)
697 gfc_defer_symbol_init (sym);
699 type = TREE_TYPE (dummy);
700 gcc_assert (TREE_CODE (dummy) == PARM_DECL
701 && POINTER_TYPE_P (type));
703 /* Do we know the element size? */
704 known_size = sym->ts.type != BT_CHARACTER
705 || INTEGER_CST_P (sym->ts.cl->backend_decl);
707 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
709 /* For descriptorless arrays with known element size the actual
710 argument is sufficient. */
711 gcc_assert (GFC_ARRAY_TYPE_P (type));
712 gfc_build_qualified_array (dummy, sym);
716 type = TREE_TYPE (type);
717 if (GFC_DESCRIPTOR_TYPE_P (type))
719 /* Create a descriptorless array pointer. */
722 if (!gfc_option.flag_repack_arrays)
724 if (as->type == AS_ASSUMED_SIZE)
729 if (as->type == AS_EXPLICIT)
732 for (n = 0; n < as->rank; n++)
736 && as->upper[n]->expr_type == EXPR_CONSTANT
737 && as->lower[n]->expr_type == EXPR_CONSTANT))
745 type = gfc_typenode_for_spec (&sym->ts);
746 type = gfc_get_nodesc_array_type (type, sym->as, packed);
750 /* We now have an expression for the element size, so create a fully
751 qualified type. Reset sym->backend decl or this will just return the
753 DECL_ARTIFICIAL (sym->backend_decl) = 1;
754 sym->backend_decl = NULL_TREE;
755 type = gfc_sym_type (sym);
759 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
760 decl = build_decl (VAR_DECL, get_identifier (name), type);
762 DECL_ARTIFICIAL (decl) = 1;
763 TREE_PUBLIC (decl) = 0;
764 TREE_STATIC (decl) = 0;
765 DECL_EXTERNAL (decl) = 0;
767 /* We should never get deferred shape arrays here. We used to because of
769 gcc_assert (sym->as->type != AS_DEFERRED);
774 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
778 GFC_DECL_PACKED_ARRAY (decl) = 1;
782 gfc_build_qualified_array (decl, sym);
784 if (DECL_LANG_SPECIFIC (dummy))
785 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
787 gfc_allocate_lang_decl (decl);
789 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
791 if (sym->ns->proc_name->backend_decl == current_function_decl
792 || sym->attr.contained)
793 gfc_add_decl_to_function (decl);
795 gfc_add_decl_to_parent_function (decl);
801 /* Return a constant or a variable to use as a string length. Does not
802 add the decl to the current scope. */
805 gfc_create_string_length (gfc_symbol * sym)
809 gcc_assert (sym->ts.cl);
810 gfc_conv_const_charlen (sym->ts.cl);
812 if (sym->ts.cl->backend_decl == NULL_TREE)
814 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
816 /* Also prefix the mangled name. */
817 strcpy (&name[1], sym->name);
819 length = build_decl (VAR_DECL, get_identifier (name),
820 gfc_charlen_type_node);
821 DECL_ARTIFICIAL (length) = 1;
822 TREE_USED (length) = 1;
823 if (sym->ns->proc_name->tlink != NULL)
824 gfc_defer_symbol_init (sym);
825 sym->ts.cl->backend_decl = length;
828 return sym->ts.cl->backend_decl;
831 /* If a variable is assigned a label, we add another two auxiliary
835 gfc_add_assign_aux_vars (gfc_symbol * sym)
841 gcc_assert (sym->backend_decl);
843 decl = sym->backend_decl;
844 gfc_allocate_lang_decl (decl);
845 GFC_DECL_ASSIGN (decl) = 1;
846 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
847 gfc_charlen_type_node);
848 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
850 gfc_finish_var_decl (length, sym);
851 gfc_finish_var_decl (addr, sym);
852 /* STRING_LENGTH is also used as flag. Less than -1 means that
853 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
854 target label's address. Otherwise, value is the length of a format string
855 and ASSIGN_ADDR is its address. */
856 if (TREE_STATIC (length))
857 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
859 gfc_defer_symbol_init (sym);
861 GFC_DECL_STRING_LEN (decl) = length;
862 GFC_DECL_ASSIGN_ADDR (decl) = addr;
865 /* Return the decl for a gfc_symbol, create it if it doesn't already
869 gfc_get_symbol_decl (gfc_symbol * sym)
872 tree length = NULL_TREE;
875 gcc_assert (sym->attr.referenced
876 || sym->attr.use_assoc
877 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
879 if (sym->ns && sym->ns->proc_name->attr.function)
880 byref = gfc_return_by_reference (sym->ns->proc_name);
884 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
886 /* Return via extra parameter. */
887 if (sym->attr.result && byref
888 && !sym->backend_decl)
891 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
892 /* For entry master function skip over the __entry
894 if (sym->ns->proc_name->attr.entry_master)
895 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
898 /* Dummy variables should already have been created. */
899 gcc_assert (sym->backend_decl);
901 /* Create a character length variable. */
902 if (sym->ts.type == BT_CHARACTER)
904 if (sym->ts.cl->backend_decl == NULL_TREE)
905 length = gfc_create_string_length (sym);
907 length = sym->ts.cl->backend_decl;
908 if (TREE_CODE (length) == VAR_DECL
909 && DECL_CONTEXT (length) == NULL_TREE)
911 /* Add the string length to the same context as the symbol. */
912 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
913 gfc_add_decl_to_function (length);
915 gfc_add_decl_to_parent_function (length);
917 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
918 DECL_CONTEXT (length));
920 gfc_defer_symbol_init (sym);
924 /* Use a copy of the descriptor for dummy arrays. */
925 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
927 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
928 /* Prevent the dummy from being detected as unused if it is copied. */
929 if (sym->backend_decl != NULL && decl != sym->backend_decl)
930 DECL_ARTIFICIAL (sym->backend_decl) = 1;
931 sym->backend_decl = decl;
934 TREE_USED (sym->backend_decl) = 1;
935 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
937 gfc_add_assign_aux_vars (sym);
939 return sym->backend_decl;
942 if (sym->backend_decl)
943 return sym->backend_decl;
945 /* Catch function declarations. Only used for actual parameters. */
946 if (sym->attr.flavor == FL_PROCEDURE)
948 decl = gfc_get_extern_function_decl (sym);
952 if (sym->attr.intrinsic)
953 internal_error ("intrinsic variable which isn't a procedure");
955 /* Create string length decl first so that they can be used in the
957 if (sym->ts.type == BT_CHARACTER)
958 length = gfc_create_string_length (sym);
960 /* Create the decl for the variable. */
961 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
963 gfc_set_decl_location (decl, &sym->declared_at);
965 /* Symbols from modules should have their assembler names mangled.
966 This is done here rather than in gfc_finish_var_decl because it
967 is different for string length variables. */
969 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
971 if (sym->attr.dimension)
973 /* Create variables to hold the non-constant bits of array info. */
974 gfc_build_qualified_array (decl, sym);
976 /* Remember this variable for allocation/cleanup. */
977 gfc_defer_symbol_init (sym);
979 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
980 GFC_DECL_PACKED_ARRAY (decl) = 1;
983 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
984 gfc_defer_symbol_init (sym);
986 gfc_finish_var_decl (decl, sym);
988 if (sym->ts.type == BT_CHARACTER)
990 /* Character variables need special handling. */
991 gfc_allocate_lang_decl (decl);
993 if (TREE_CODE (length) != INTEGER_CST)
995 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
999 /* Also prefix the mangled name for symbols from modules. */
1000 strcpy (&name[1], sym->name);
1003 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1004 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1006 gfc_finish_var_decl (length, sym);
1007 gcc_assert (!sym->value);
1010 sym->backend_decl = decl;
1012 if (sym->attr.assign)
1013 gfc_add_assign_aux_vars (sym);
1015 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1017 /* Add static initializer. */
1018 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1019 TREE_TYPE (decl), sym->attr.dimension,
1020 sym->attr.pointer || sym->attr.allocatable);
1027 /* Substitute a temporary variable in place of the real one. */
1030 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1032 save->attr = sym->attr;
1033 save->decl = sym->backend_decl;
1035 gfc_clear_attr (&sym->attr);
1036 sym->attr.referenced = 1;
1037 sym->attr.flavor = FL_VARIABLE;
1039 sym->backend_decl = decl;
1043 /* Restore the original variable. */
1046 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1048 sym->attr = save->attr;
1049 sym->backend_decl = save->decl;
1053 /* Get a basic decl for an external function. */
1056 gfc_get_extern_function_decl (gfc_symbol * sym)
1061 gfc_intrinsic_sym *isym;
1063 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1067 if (sym->backend_decl)
1068 return sym->backend_decl;
1070 /* We should never be creating external decls for alternate entry points.
1071 The procedure may be an alternate entry point, but we don't want/need
1073 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1075 if (sym->attr.intrinsic)
1077 /* Call the resolution function to get the actual name. This is
1078 a nasty hack which relies on the resolution functions only looking
1079 at the first argument. We pass NULL for the second argument
1080 otherwise things like AINT get confused. */
1081 isym = gfc_find_function (sym->name);
1082 gcc_assert (isym->resolve.f0 != NULL);
1084 memset (&e, 0, sizeof (e));
1085 e.expr_type = EXPR_FUNCTION;
1087 memset (&argexpr, 0, sizeof (argexpr));
1088 gcc_assert (isym->formal);
1089 argexpr.ts = isym->formal->ts;
1091 if (isym->formal->next == NULL)
1092 isym->resolve.f1 (&e, &argexpr);
1095 if (isym->formal->next->next == NULL)
1096 isym->resolve.f2 (&e, &argexpr, NULL);
1099 /* All specific intrinsics take less than 4 arguments. */
1100 gcc_assert (isym->formal->next->next->next == NULL);
1101 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1105 if (gfc_option.flag_f2c
1106 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1107 || e.ts.type == BT_COMPLEX))
1109 /* Specific which needs a different implementation if f2c
1110 calling conventions are used. */
1111 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1114 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1116 name = get_identifier (s);
1117 mangled_name = name;
1121 name = gfc_sym_identifier (sym);
1122 mangled_name = gfc_sym_mangled_function_id (sym);
1125 type = gfc_get_function_type (sym);
1126 fndecl = build_decl (FUNCTION_DECL, name, type);
1128 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1129 /* If the return type is a pointer, avoid alias issues by setting
1130 DECL_IS_MALLOC to nonzero. This means that the function should be
1131 treated as if it were a malloc, meaning it returns a pointer that
1133 if (POINTER_TYPE_P (type))
1134 DECL_IS_MALLOC (fndecl) = 1;
1136 /* Set the context of this decl. */
1137 if (0 && sym->ns && sym->ns->proc_name)
1139 /* TODO: Add external decls to the appropriate scope. */
1140 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1144 /* Global declaration, e.g. intrinsic subroutine. */
1145 DECL_CONTEXT (fndecl) = NULL_TREE;
1148 DECL_EXTERNAL (fndecl) = 1;
1150 /* This specifies if a function is globally addressable, i.e. it is
1151 the opposite of declaring static in C. */
1152 TREE_PUBLIC (fndecl) = 1;
1154 /* Set attributes for PURE functions. A call to PURE function in the
1155 Fortran 95 sense is both pure and without side effects in the C
1157 if (sym->attr.pure || sym->attr.elemental)
1159 if (sym->attr.function && !gfc_return_by_reference (sym))
1160 DECL_IS_PURE (fndecl) = 1;
1161 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1162 parameters and don't use alternate returns (is this
1163 allowed?). In that case, calls to them are meaningless, and
1164 can be optimized away. See also in build_function_decl(). */
1165 TREE_SIDE_EFFECTS (fndecl) = 0;
1168 /* Mark non-returning functions. */
1169 if (sym->attr.noreturn)
1170 TREE_THIS_VOLATILE(fndecl) = 1;
1172 sym->backend_decl = fndecl;
1174 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1175 pushdecl_top_level (fndecl);
1181 /* Create a declaration for a procedure. For external functions (in the C
1182 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1183 a master function with alternate entry points. */
1186 build_function_decl (gfc_symbol * sym)
1189 symbol_attribute attr;
1191 gfc_formal_arglist *f;
1193 gcc_assert (!sym->backend_decl);
1194 gcc_assert (!sym->attr.external);
1196 /* Set the line and filename. sym->declared_at seems to point to the
1197 last statement for subroutines, but it'll do for now. */
1198 gfc_set_backend_locus (&sym->declared_at);
1200 /* Allow only one nesting level. Allow public declarations. */
1201 gcc_assert (current_function_decl == NULL_TREE
1202 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1204 type = gfc_get_function_type (sym);
1205 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1207 /* Perform name mangling if this is a top level or module procedure. */
1208 if (current_function_decl == NULL_TREE)
1209 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1211 /* Figure out the return type of the declared function, and build a
1212 RESULT_DECL for it. If this is a subroutine with alternate
1213 returns, build a RESULT_DECL for it. */
1216 result_decl = NULL_TREE;
1217 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1220 if (gfc_return_by_reference (sym))
1221 type = void_type_node;
1224 if (sym->result != sym)
1225 result_decl = gfc_sym_identifier (sym->result);
1227 type = TREE_TYPE (TREE_TYPE (fndecl));
1232 /* Look for alternate return placeholders. */
1233 int has_alternate_returns = 0;
1234 for (f = sym->formal; f; f = f->next)
1238 has_alternate_returns = 1;
1243 if (has_alternate_returns)
1244 type = integer_type_node;
1246 type = void_type_node;
1249 result_decl = build_decl (RESULT_DECL, result_decl, type);
1250 DECL_ARTIFICIAL (result_decl) = 1;
1251 DECL_IGNORED_P (result_decl) = 1;
1252 DECL_CONTEXT (result_decl) = fndecl;
1253 DECL_RESULT (fndecl) = result_decl;
1255 /* Don't call layout_decl for a RESULT_DECL.
1256 layout_decl (result_decl, 0); */
1258 /* If the return type is a pointer, avoid alias issues by setting
1259 DECL_IS_MALLOC to nonzero. This means that the function should be
1260 treated as if it were a malloc, meaning it returns a pointer that
1262 if (POINTER_TYPE_P (type))
1263 DECL_IS_MALLOC (fndecl) = 1;
1265 /* Set up all attributes for the function. */
1266 DECL_CONTEXT (fndecl) = current_function_decl;
1267 DECL_EXTERNAL (fndecl) = 0;
1269 /* This specifies if a function is globally visible, i.e. it is
1270 the opposite of declaring static in C. */
1271 if (DECL_CONTEXT (fndecl) == NULL_TREE
1272 && !sym->attr.entry_master)
1273 TREE_PUBLIC (fndecl) = 1;
1275 /* TREE_STATIC means the function body is defined here. */
1276 TREE_STATIC (fndecl) = 1;
1278 /* Set attributes for PURE functions. A call to a PURE function in the
1279 Fortran 95 sense is both pure and without side effects in the C
1281 if (attr.pure || attr.elemental)
1283 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1284 including a alternate return. In that case it can also be
1285 marked as PURE. See also in gfc_get_extern_function_decl(). */
1286 if (attr.function && !gfc_return_by_reference (sym))
1287 DECL_IS_PURE (fndecl) = 1;
1288 TREE_SIDE_EFFECTS (fndecl) = 0;
1291 /* Layout the function declaration and put it in the binding level
1292 of the current function. */
1295 sym->backend_decl = fndecl;
1299 /* Create the DECL_ARGUMENTS for a procedure. */
1302 create_function_arglist (gfc_symbol * sym)
1305 gfc_formal_arglist *f;
1306 tree typelist, hidden_typelist;
1307 tree arglist, hidden_arglist;
1311 fndecl = sym->backend_decl;
1313 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1314 the new FUNCTION_DECL node. */
1315 arglist = NULL_TREE;
1316 hidden_arglist = NULL_TREE;
1317 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1319 if (sym->attr.entry_master)
1321 type = TREE_VALUE (typelist);
1322 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1324 DECL_CONTEXT (parm) = fndecl;
1325 DECL_ARG_TYPE (parm) = type;
1326 TREE_READONLY (parm) = 1;
1327 gfc_finish_decl (parm, NULL_TREE);
1328 DECL_ARTIFICIAL (parm) = 1;
1330 arglist = chainon (arglist, parm);
1331 typelist = TREE_CHAIN (typelist);
1334 if (gfc_return_by_reference (sym))
1336 tree type = TREE_VALUE (typelist), length = NULL;
1338 if (sym->ts.type == BT_CHARACTER)
1340 /* Length of character result. */
1341 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1342 gcc_assert (len_type == gfc_charlen_type_node);
1344 length = build_decl (PARM_DECL,
1345 get_identifier (".__result"),
1347 if (!sym->ts.cl->length)
1349 sym->ts.cl->backend_decl = length;
1350 TREE_USED (length) = 1;
1352 gcc_assert (TREE_CODE (length) == PARM_DECL);
1353 DECL_CONTEXT (length) = fndecl;
1354 DECL_ARG_TYPE (length) = len_type;
1355 TREE_READONLY (length) = 1;
1356 DECL_ARTIFICIAL (length) = 1;
1357 gfc_finish_decl (length, NULL_TREE);
1358 if (sym->ts.cl->backend_decl == NULL
1359 || sym->ts.cl->backend_decl == length)
1364 if (sym->ts.cl->backend_decl == NULL)
1366 tree len = build_decl (VAR_DECL,
1367 get_identifier ("..__result"),
1368 gfc_charlen_type_node);
1369 DECL_ARTIFICIAL (len) = 1;
1370 TREE_USED (len) = 1;
1371 sym->ts.cl->backend_decl = len;
1374 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1375 arg = sym->result ? sym->result : sym;
1376 backend_decl = arg->backend_decl;
1377 /* Temporary clear it, so that gfc_sym_type creates complete
1379 arg->backend_decl = NULL;
1380 type = gfc_sym_type (arg);
1381 arg->backend_decl = backend_decl;
1382 type = build_reference_type (type);
1386 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1388 DECL_CONTEXT (parm) = fndecl;
1389 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1390 TREE_READONLY (parm) = 1;
1391 DECL_ARTIFICIAL (parm) = 1;
1392 gfc_finish_decl (parm, NULL_TREE);
1394 arglist = chainon (arglist, parm);
1395 typelist = TREE_CHAIN (typelist);
1397 if (sym->ts.type == BT_CHARACTER)
1399 gfc_allocate_lang_decl (parm);
1400 arglist = chainon (arglist, length);
1401 typelist = TREE_CHAIN (typelist);
1405 hidden_typelist = typelist;
1406 for (f = sym->formal; f; f = f->next)
1407 if (f->sym != NULL) /* Ignore alternate returns. */
1408 hidden_typelist = TREE_CHAIN (hidden_typelist);
1410 for (f = sym->formal; f; f = f->next)
1412 char name[GFC_MAX_SYMBOL_LEN + 2];
1414 /* Ignore alternate returns. */
1418 type = TREE_VALUE (typelist);
1420 if (f->sym->ts.type == BT_CHARACTER)
1422 tree len_type = TREE_VALUE (hidden_typelist);
1423 tree length = NULL_TREE;
1424 gcc_assert (len_type == gfc_charlen_type_node);
1426 strcpy (&name[1], f->sym->name);
1428 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1430 hidden_arglist = chainon (hidden_arglist, length);
1431 DECL_CONTEXT (length) = fndecl;
1432 DECL_ARTIFICIAL (length) = 1;
1433 DECL_ARG_TYPE (length) = len_type;
1434 TREE_READONLY (length) = 1;
1435 gfc_finish_decl (length, NULL_TREE);
1437 /* TODO: Check string lengths when -fbounds-check. */
1439 /* Use the passed value for assumed length variables. */
1440 if (!f->sym->ts.cl->length)
1442 TREE_USED (length) = 1;
1443 if (!f->sym->ts.cl->backend_decl)
1444 f->sym->ts.cl->backend_decl = length;
1447 /* there is already another variable using this
1448 gfc_charlen node, build a new one for this variable
1449 and chain it into the list of gfc_charlens.
1450 This happens for e.g. in the case
1452 since CHARACTER declarations on the same line share
1453 the same gfc_charlen node. */
1456 cl = gfc_get_charlen ();
1457 cl->backend_decl = length;
1458 cl->next = f->sym->ts.cl->next;
1459 f->sym->ts.cl->next = cl;
1464 hidden_typelist = TREE_CHAIN (hidden_typelist);
1466 if (f->sym->ts.cl->backend_decl == NULL
1467 || f->sym->ts.cl->backend_decl == length)
1469 if (f->sym->ts.cl->backend_decl == NULL)
1470 gfc_create_string_length (f->sym);
1472 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1473 if (f->sym->attr.flavor == FL_PROCEDURE)
1474 type = build_pointer_type (gfc_get_function_type (f->sym));
1476 type = gfc_sym_type (f->sym);
1480 /* For non-constant length array arguments, make sure they use
1481 a different type node from TYPE_ARG_TYPES type. */
1482 if (f->sym->attr.dimension
1483 && type == TREE_VALUE (typelist)
1484 && TREE_CODE (type) == POINTER_TYPE
1485 && GFC_ARRAY_TYPE_P (type)
1486 && f->sym->as->type != AS_ASSUMED_SIZE
1487 && ! COMPLETE_TYPE_P (TREE_TYPE (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);
1495 /* Build a the argument declaration. */
1496 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1498 /* Fill in arg stuff. */
1499 DECL_CONTEXT (parm) = fndecl;
1500 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1501 /* All implementation args are read-only. */
1502 TREE_READONLY (parm) = 1;
1504 gfc_finish_decl (parm, NULL_TREE);
1506 f->sym->backend_decl = parm;
1508 arglist = chainon (arglist, parm);
1509 typelist = TREE_CHAIN (typelist);
1512 /* Add the hidden string length parameters. */
1513 arglist = chainon (arglist, hidden_arglist);
1515 gcc_assert (hidden_typelist == NULL_TREE
1516 || TREE_VALUE (hidden_typelist) == void_type_node);
1517 DECL_ARGUMENTS (fndecl) = arglist;
1520 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1523 gfc_gimplify_function (tree fndecl)
1525 struct cgraph_node *cgn;
1527 gimplify_function_tree (fndecl);
1528 dump_function (TDI_generic, fndecl);
1530 /* Generate errors for structured block violations. */
1531 /* ??? Could be done as part of resolve_labels. */
1533 diagnose_omp_structured_block_errors (fndecl);
1535 /* Convert all nested functions to GIMPLE now. We do things in this order
1536 so that items like VLA sizes are expanded properly in the context of the
1537 correct function. */
1538 cgn = cgraph_node (fndecl);
1539 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1540 gfc_gimplify_function (cgn->decl);
1544 /* Do the setup necessary before generating the body of a function. */
1547 trans_function_start (gfc_symbol * sym)
1551 fndecl = sym->backend_decl;
1553 /* Let GCC know the current scope is this function. */
1554 current_function_decl = fndecl;
1556 /* Let the world know what we're about to do. */
1557 announce_function (fndecl);
1559 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1561 /* Create RTL for function declaration. */
1562 rest_of_decl_compilation (fndecl, 1, 0);
1565 /* Create RTL for function definition. */
1566 make_decl_rtl (fndecl);
1568 init_function_start (fndecl);
1570 /* Even though we're inside a function body, we still don't want to
1571 call expand_expr to calculate the size of a variable-sized array.
1572 We haven't necessarily assigned RTL to all variables yet, so it's
1573 not safe to try to expand expressions involving them. */
1574 cfun->x_dont_save_pending_sizes_p = 1;
1576 /* function.c requires a push at the start of the function. */
1580 /* Create thunks for alternate entry points. */
1583 build_entry_thunks (gfc_namespace * ns)
1585 gfc_formal_arglist *formal;
1586 gfc_formal_arglist *thunk_formal;
1588 gfc_symbol *thunk_sym;
1596 /* This should always be a toplevel function. */
1597 gcc_assert (current_function_decl == NULL_TREE);
1599 gfc_get_backend_locus (&old_loc);
1600 for (el = ns->entries; el; el = el->next)
1602 thunk_sym = el->sym;
1604 build_function_decl (thunk_sym);
1605 create_function_arglist (thunk_sym);
1607 trans_function_start (thunk_sym);
1609 thunk_fndecl = thunk_sym->backend_decl;
1611 gfc_start_block (&body);
1613 /* Pass extra parameter identifying this entry point. */
1614 tmp = build_int_cst (gfc_array_index_type, el->id);
1615 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1616 string_args = NULL_TREE;
1618 if (thunk_sym->attr.function)
1620 if (gfc_return_by_reference (ns->proc_name))
1622 tree ref = DECL_ARGUMENTS (current_function_decl);
1623 args = tree_cons (NULL_TREE, ref, args);
1624 if (ns->proc_name->ts.type == BT_CHARACTER)
1625 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1630 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1632 /* Ignore alternate returns. */
1633 if (formal->sym == NULL)
1636 /* We don't have a clever way of identifying arguments, so resort to
1637 a brute-force search. */
1638 for (thunk_formal = thunk_sym->formal;
1640 thunk_formal = thunk_formal->next)
1642 if (thunk_formal->sym == formal->sym)
1648 /* Pass the argument. */
1649 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1650 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1652 if (formal->sym->ts.type == BT_CHARACTER)
1654 tmp = thunk_formal->sym->ts.cl->backend_decl;
1655 string_args = tree_cons (NULL_TREE, tmp, string_args);
1660 /* Pass NULL for a missing argument. */
1661 args = tree_cons (NULL_TREE, null_pointer_node, args);
1662 if (formal->sym->ts.type == BT_CHARACTER)
1664 tmp = build_int_cst (gfc_charlen_type_node, 0);
1665 string_args = tree_cons (NULL_TREE, tmp, string_args);
1670 /* Call the master function. */
1671 args = nreverse (args);
1672 args = chainon (args, nreverse (string_args));
1673 tmp = ns->proc_name->backend_decl;
1674 tmp = build_function_call_expr (tmp, args);
1675 if (ns->proc_name->attr.mixed_entry_master)
1677 tree union_decl, field;
1678 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1680 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1681 TREE_TYPE (master_type));
1682 DECL_ARTIFICIAL (union_decl) = 1;
1683 DECL_EXTERNAL (union_decl) = 0;
1684 TREE_PUBLIC (union_decl) = 0;
1685 TREE_USED (union_decl) = 1;
1686 layout_decl (union_decl, 0);
1687 pushdecl (union_decl);
1689 DECL_CONTEXT (union_decl) = current_function_decl;
1690 tmp = build2 (MODIFY_EXPR,
1691 TREE_TYPE (union_decl),
1693 gfc_add_expr_to_block (&body, tmp);
1695 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1696 field; field = TREE_CHAIN (field))
1697 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1698 thunk_sym->result->name) == 0)
1700 gcc_assert (field != NULL_TREE);
1701 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1703 tmp = build2 (MODIFY_EXPR,
1704 TREE_TYPE (DECL_RESULT (current_function_decl)),
1705 DECL_RESULT (current_function_decl), tmp);
1706 tmp = build1_v (RETURN_EXPR, tmp);
1708 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1711 tmp = build2 (MODIFY_EXPR,
1712 TREE_TYPE (DECL_RESULT (current_function_decl)),
1713 DECL_RESULT (current_function_decl), tmp);
1714 tmp = build1_v (RETURN_EXPR, tmp);
1716 gfc_add_expr_to_block (&body, tmp);
1718 /* Finish off this function and send it for code generation. */
1719 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1721 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1723 /* Output the GENERIC tree. */
1724 dump_function (TDI_original, thunk_fndecl);
1726 /* Store the end of the function, so that we get good line number
1727 info for the epilogue. */
1728 cfun->function_end_locus = input_location;
1730 /* We're leaving the context of this function, so zap cfun.
1731 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1732 tree_rest_of_compilation. */
1735 current_function_decl = NULL_TREE;
1737 gfc_gimplify_function (thunk_fndecl);
1738 cgraph_finalize_function (thunk_fndecl, false);
1740 /* We share the symbols in the formal argument list with other entry
1741 points and the master function. Clear them so that they are
1742 recreated for each function. */
1743 for (formal = thunk_sym->formal; formal; formal = formal->next)
1744 if (formal->sym != NULL) /* Ignore alternate returns. */
1746 formal->sym->backend_decl = NULL_TREE;
1747 if (formal->sym->ts.type == BT_CHARACTER)
1748 formal->sym->ts.cl->backend_decl = NULL_TREE;
1751 if (thunk_sym->attr.function)
1753 if (thunk_sym->ts.type == BT_CHARACTER)
1754 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1755 if (thunk_sym->result->ts.type == BT_CHARACTER)
1756 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1760 gfc_set_backend_locus (&old_loc);
1764 /* Create a decl for a function, and create any thunks for alternate entry
1768 gfc_create_function_decl (gfc_namespace * ns)
1770 /* Create a declaration for the master function. */
1771 build_function_decl (ns->proc_name);
1773 /* Compile the entry thunks. */
1775 build_entry_thunks (ns);
1777 /* Now create the read argument list. */
1778 create_function_arglist (ns->proc_name);
1781 /* Return the decl used to hold the function return value. If
1782 parent_flag is set, the context is the parent_scope. */
1785 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1789 tree this_fake_result_decl;
1790 tree this_function_decl;
1792 char name[GFC_MAX_SYMBOL_LEN + 10];
1796 this_fake_result_decl = parent_fake_result_decl;
1797 this_function_decl = DECL_CONTEXT (current_function_decl);
1801 this_fake_result_decl = current_fake_result_decl;
1802 this_function_decl = current_function_decl;
1806 && sym->ns->proc_name->backend_decl == this_function_decl
1807 && sym->ns->proc_name->attr.entry_master
1808 && sym != sym->ns->proc_name)
1811 if (this_fake_result_decl != NULL)
1812 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1813 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1816 return TREE_VALUE (t);
1817 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1820 this_fake_result_decl = parent_fake_result_decl;
1822 this_fake_result_decl = current_fake_result_decl;
1824 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1828 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1829 field; field = TREE_CHAIN (field))
1830 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1834 gcc_assert (field != NULL_TREE);
1835 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1839 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1841 gfc_add_decl_to_parent_function (var);
1843 gfc_add_decl_to_function (var);
1845 SET_DECL_VALUE_EXPR (var, decl);
1846 DECL_HAS_VALUE_EXPR_P (var) = 1;
1847 GFC_DECL_RESULT (var) = 1;
1849 TREE_CHAIN (this_fake_result_decl)
1850 = tree_cons (get_identifier (sym->name), var,
1851 TREE_CHAIN (this_fake_result_decl));
1855 if (this_fake_result_decl != NULL_TREE)
1856 return TREE_VALUE (this_fake_result_decl);
1858 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1863 if (sym->ts.type == BT_CHARACTER)
1865 if (sym->ts.cl->backend_decl == NULL_TREE)
1866 length = gfc_create_string_length (sym);
1868 length = sym->ts.cl->backend_decl;
1869 if (TREE_CODE (length) == VAR_DECL
1870 && DECL_CONTEXT (length) == NULL_TREE)
1871 gfc_add_decl_to_function (length);
1874 if (gfc_return_by_reference (sym))
1876 decl = DECL_ARGUMENTS (this_function_decl);
1878 if (sym->ns->proc_name->backend_decl == this_function_decl
1879 && sym->ns->proc_name->attr.entry_master)
1880 decl = TREE_CHAIN (decl);
1882 TREE_USED (decl) = 1;
1884 decl = gfc_build_dummy_array_decl (sym, decl);
1888 sprintf (name, "__result_%.20s",
1889 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1891 if (!sym->attr.mixed_entry_master && sym->attr.function)
1892 decl = build_decl (VAR_DECL, get_identifier (name),
1893 gfc_sym_type (sym));
1895 decl = build_decl (VAR_DECL, get_identifier (name),
1896 TREE_TYPE (TREE_TYPE (this_function_decl)));
1897 DECL_ARTIFICIAL (decl) = 1;
1898 DECL_EXTERNAL (decl) = 0;
1899 TREE_PUBLIC (decl) = 0;
1900 TREE_USED (decl) = 1;
1901 GFC_DECL_RESULT (decl) = 1;
1902 TREE_ADDRESSABLE (decl) = 1;
1904 layout_decl (decl, 0);
1907 gfc_add_decl_to_parent_function (decl);
1909 gfc_add_decl_to_function (decl);
1913 parent_fake_result_decl = build_tree_list (NULL, decl);
1915 current_fake_result_decl = build_tree_list (NULL, decl);
1921 /* Builds a function decl. The remaining parameters are the types of the
1922 function arguments. Negative nargs indicates a varargs function. */
1925 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1934 /* Library functions must be declared with global scope. */
1935 gcc_assert (current_function_decl == NULL_TREE);
1937 va_start (p, nargs);
1940 /* Create a list of the argument types. */
1941 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1943 argtype = va_arg (p, tree);
1944 arglist = gfc_chainon_list (arglist, argtype);
1949 /* Terminate the list. */
1950 arglist = gfc_chainon_list (arglist, void_type_node);
1953 /* Build the function type and decl. */
1954 fntype = build_function_type (rettype, arglist);
1955 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1957 /* Mark this decl as external. */
1958 DECL_EXTERNAL (fndecl) = 1;
1959 TREE_PUBLIC (fndecl) = 1;
1965 rest_of_decl_compilation (fndecl, 1, 0);
1971 gfc_build_intrinsic_function_decls (void)
1973 tree gfc_int4_type_node = gfc_get_int_type (4);
1974 tree gfc_int8_type_node = gfc_get_int_type (8);
1975 tree gfc_int16_type_node = gfc_get_int_type (16);
1976 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1977 tree gfc_real4_type_node = gfc_get_real_type (4);
1978 tree gfc_real8_type_node = gfc_get_real_type (8);
1979 tree gfc_real10_type_node = gfc_get_real_type (10);
1980 tree gfc_real16_type_node = gfc_get_real_type (16);
1981 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1982 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1983 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1984 tree gfc_complex16_type_node = gfc_get_complex_type (16);
1985 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1987 /* String functions. */
1988 gfor_fndecl_compare_string =
1989 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1992 gfc_charlen_type_node, pchar_type_node,
1993 gfc_charlen_type_node, pchar_type_node);
1995 gfor_fndecl_concat_string =
1996 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1999 gfc_charlen_type_node, pchar_type_node,
2000 gfc_charlen_type_node, pchar_type_node,
2001 gfc_charlen_type_node, pchar_type_node);
2003 gfor_fndecl_string_len_trim =
2004 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2006 2, gfc_charlen_type_node,
2009 gfor_fndecl_string_index =
2010 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2012 5, gfc_charlen_type_node, pchar_type_node,
2013 gfc_charlen_type_node, pchar_type_node,
2014 gfc_logical4_type_node);
2016 gfor_fndecl_string_scan =
2017 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2019 5, gfc_charlen_type_node, pchar_type_node,
2020 gfc_charlen_type_node, pchar_type_node,
2021 gfc_logical4_type_node);
2023 gfor_fndecl_string_verify =
2024 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
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_trim =
2031 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2034 build_pointer_type (gfc_charlen_type_node),
2036 gfc_charlen_type_node,
2039 gfor_fndecl_ttynam =
2040 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2044 gfc_charlen_type_node,
2045 gfc_c_int_type_node);
2048 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2052 gfc_charlen_type_node);
2055 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2059 gfc_charlen_type_node,
2060 gfc_int8_type_node);
2062 gfor_fndecl_adjustl =
2063 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2067 gfc_charlen_type_node, pchar_type_node);
2069 gfor_fndecl_adjustr =
2070 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2074 gfc_charlen_type_node, pchar_type_node);
2076 gfor_fndecl_si_kind =
2077 gfc_build_library_function_decl (get_identifier
2078 (PREFIX("selected_int_kind")),
2083 gfor_fndecl_sr_kind =
2084 gfc_build_library_function_decl (get_identifier
2085 (PREFIX("selected_real_kind")),
2090 /* Power functions. */
2092 tree ctype, rtype, itype, jtype;
2093 int rkind, ikind, jkind;
2096 static int ikinds[NIKINDS] = {4, 8, 16};
2097 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2098 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2100 for (ikind=0; ikind < NIKINDS; ikind++)
2102 itype = gfc_get_int_type (ikinds[ikind]);
2104 for (jkind=0; jkind < NIKINDS; jkind++)
2106 jtype = gfc_get_int_type (ikinds[jkind]);
2109 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2111 gfor_fndecl_math_powi[jkind][ikind].integer =
2112 gfc_build_library_function_decl (get_identifier (name),
2113 jtype, 2, jtype, itype);
2114 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2118 for (rkind = 0; rkind < NRKINDS; rkind ++)
2120 rtype = gfc_get_real_type (rkinds[rkind]);
2123 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2125 gfor_fndecl_math_powi[rkind][ikind].real =
2126 gfc_build_library_function_decl (get_identifier (name),
2127 rtype, 2, rtype, itype);
2128 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2131 ctype = gfc_get_complex_type (rkinds[rkind]);
2134 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2136 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2137 gfc_build_library_function_decl (get_identifier (name),
2138 ctype, 2,ctype, itype);
2139 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2147 gfor_fndecl_math_cpowf =
2148 gfc_build_library_function_decl (get_identifier ("cpowf"),
2149 gfc_complex4_type_node,
2150 1, gfc_complex4_type_node);
2151 gfor_fndecl_math_cpow =
2152 gfc_build_library_function_decl (get_identifier ("cpow"),
2153 gfc_complex8_type_node,
2154 1, gfc_complex8_type_node);
2155 if (gfc_complex10_type_node)
2156 gfor_fndecl_math_cpowl10 =
2157 gfc_build_library_function_decl (get_identifier ("cpowl"),
2158 gfc_complex10_type_node, 1,
2159 gfc_complex10_type_node);
2160 if (gfc_complex16_type_node)
2161 gfor_fndecl_math_cpowl16 =
2162 gfc_build_library_function_decl (get_identifier ("cpowl"),
2163 gfc_complex16_type_node, 1,
2164 gfc_complex16_type_node);
2166 gfor_fndecl_math_ishftc4 =
2167 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2169 3, gfc_int4_type_node,
2170 gfc_int4_type_node, gfc_int4_type_node);
2171 gfor_fndecl_math_ishftc8 =
2172 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2174 3, gfc_int8_type_node,
2175 gfc_int4_type_node, gfc_int4_type_node);
2176 if (gfc_int16_type_node)
2177 gfor_fndecl_math_ishftc16 =
2178 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2179 gfc_int16_type_node, 3,
2180 gfc_int16_type_node,
2182 gfc_int4_type_node);
2184 gfor_fndecl_math_exponent4 =
2185 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2187 1, gfc_real4_type_node);
2188 gfor_fndecl_math_exponent8 =
2189 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2191 1, gfc_real8_type_node);
2192 if (gfc_real10_type_node)
2193 gfor_fndecl_math_exponent10 =
2194 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2195 gfc_int4_type_node, 1,
2196 gfc_real10_type_node);
2197 if (gfc_real16_type_node)
2198 gfor_fndecl_math_exponent16 =
2199 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2200 gfc_int4_type_node, 1,
2201 gfc_real16_type_node);
2203 /* BLAS functions. */
2205 tree pint = build_pointer_type (gfc_c_int_type_node);
2206 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2207 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2208 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2209 tree pz = build_pointer_type
2210 (gfc_get_complex_type (gfc_default_double_kind));
2212 gfor_fndecl_sgemm = gfc_build_library_function_decl
2214 (gfc_option.flag_underscoring ? "sgemm_"
2216 void_type_node, 15, pchar_type_node,
2217 pchar_type_node, pint, pint, pint, ps, ps, pint,
2218 ps, pint, ps, ps, pint, gfc_c_int_type_node,
2219 gfc_c_int_type_node);
2220 gfor_fndecl_dgemm = gfc_build_library_function_decl
2222 (gfc_option.flag_underscoring ? "dgemm_"
2224 void_type_node, 15, pchar_type_node,
2225 pchar_type_node, pint, pint, pint, pd, pd, pint,
2226 pd, pint, pd, pd, pint, gfc_c_int_type_node,
2227 gfc_c_int_type_node);
2228 gfor_fndecl_cgemm = gfc_build_library_function_decl
2230 (gfc_option.flag_underscoring ? "cgemm_"
2232 void_type_node, 15, pchar_type_node,
2233 pchar_type_node, pint, pint, pint, pc, pc, pint,
2234 pc, pint, pc, pc, pint, gfc_c_int_type_node,
2235 gfc_c_int_type_node);
2236 gfor_fndecl_zgemm = gfc_build_library_function_decl
2238 (gfc_option.flag_underscoring ? "zgemm_"
2240 void_type_node, 15, pchar_type_node,
2241 pchar_type_node, pint, pint, pint, pz, pz, pint,
2242 pz, pint, pz, pz, pint, gfc_c_int_type_node,
2243 gfc_c_int_type_node);
2246 /* Other functions. */
2248 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2249 gfc_array_index_type,
2250 1, pvoid_type_node);
2252 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2253 gfc_array_index_type,
2255 gfc_array_index_type);
2258 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2264 /* Make prototypes for runtime library functions. */
2267 gfc_build_builtin_function_decls (void)
2269 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2270 tree gfc_int4_type_node = gfc_get_int_type (4);
2271 tree gfc_int8_type_node = gfc_get_int_type (8);
2272 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2273 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2275 /* Treat these two internal malloc wrappers as malloc. */
2276 gfor_fndecl_internal_malloc =
2277 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2278 pvoid_type_node, 1, gfc_int4_type_node);
2279 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
2281 gfor_fndecl_internal_malloc64 =
2282 gfc_build_library_function_decl (get_identifier
2283 (PREFIX("internal_malloc64")),
2284 pvoid_type_node, 1, gfc_int8_type_node);
2285 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
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_int4_type_node);
2293 gfor_fndecl_internal_realloc64 =
2294 gfc_build_library_function_decl (get_identifier
2295 (PREFIX("internal_realloc64")),
2296 pvoid_type_node, 2, pvoid_type_node,
2297 gfc_int8_type_node);
2299 gfor_fndecl_internal_free =
2300 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2301 void_type_node, 1, pvoid_type_node);
2303 gfor_fndecl_allocate =
2304 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2306 gfc_int4_type_node, gfc_pint4_type_node);
2307 DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
2309 gfor_fndecl_allocate64 =
2310 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2312 gfc_int8_type_node, gfc_pint4_type_node);
2313 DECL_IS_MALLOC (gfor_fndecl_allocate64) = 1;
2315 gfor_fndecl_allocate_array =
2316 gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2317 pvoid_type_node, 3, pvoid_type_node,
2318 gfc_int4_type_node, gfc_pint4_type_node);
2319 DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
2321 gfor_fndecl_allocate64_array =
2322 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
2323 pvoid_type_node, 3, pvoid_type_node,
2324 gfc_int8_type_node, gfc_pint4_type_node);
2325 DECL_IS_MALLOC (gfor_fndecl_allocate64_array) = 1;
2327 gfor_fndecl_deallocate =
2328 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2329 void_type_node, 2, pvoid_type_node,
2330 gfc_pint4_type_node);
2332 gfor_fndecl_stop_numeric =
2333 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2334 void_type_node, 1, gfc_int4_type_node);
2336 /* Stop doesn't return. */
2337 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2339 gfor_fndecl_stop_string =
2340 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2341 void_type_node, 2, pchar_type_node,
2342 gfc_int4_type_node);
2343 /* Stop doesn't return. */
2344 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2346 gfor_fndecl_pause_numeric =
2347 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2348 void_type_node, 1, gfc_int4_type_node);
2350 gfor_fndecl_pause_string =
2351 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2352 void_type_node, 2, pchar_type_node,
2353 gfc_int4_type_node);
2355 gfor_fndecl_select_string =
2356 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2357 pvoid_type_node, 0);
2359 gfor_fndecl_runtime_error =
2360 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2361 void_type_node, 1, pchar_type_node);
2362 /* The runtime_error function does not return. */
2363 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2365 gfor_fndecl_set_fpe =
2366 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2367 void_type_node, 1, gfc_c_int_type_node);
2369 gfor_fndecl_set_std =
2370 gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2377 gfc_int4_type_node);
2379 gfor_fndecl_set_convert =
2380 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2381 void_type_node, 1, gfc_c_int_type_node);
2383 gfor_fndecl_set_record_marker =
2384 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2385 void_type_node, 1, gfc_c_int_type_node);
2387 gfor_fndecl_set_max_subrecord_length =
2388 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2389 void_type_node, 1, gfc_c_int_type_node);
2391 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2392 get_identifier (PREFIX("internal_pack")),
2393 pvoid_type_node, 1, pvoid_type_node);
2395 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2396 get_identifier (PREFIX("internal_unpack")),
2397 pvoid_type_node, 1, pvoid_type_node);
2399 gfor_fndecl_associated =
2400 gfc_build_library_function_decl (
2401 get_identifier (PREFIX("associated")),
2402 gfc_logical4_type_node,
2407 gfc_build_intrinsic_function_decls ();
2408 gfc_build_intrinsic_lib_fndecls ();
2409 gfc_build_io_library_fndecls ();
2413 /* Evaluate the length of dummy character variables. */
2416 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2420 gfc_finish_decl (cl->backend_decl, NULL_TREE);
2422 gfc_start_block (&body);
2424 /* Evaluate the string length expression. */
2425 gfc_trans_init_string_length (cl, &body);
2427 gfc_trans_vla_type_sizes (sym, &body);
2429 gfc_add_expr_to_block (&body, fnbody);
2430 return gfc_finish_block (&body);
2434 /* Allocate and cleanup an automatic character variable. */
2437 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2443 gcc_assert (sym->backend_decl);
2444 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2446 gfc_start_block (&body);
2448 /* Evaluate the string length expression. */
2449 gfc_trans_init_string_length (sym->ts.cl, &body);
2451 gfc_trans_vla_type_sizes (sym, &body);
2453 decl = sym->backend_decl;
2455 /* Emit a DECL_EXPR for this variable, which will cause the
2456 gimplifier to allocate storage, and all that good stuff. */
2457 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2458 gfc_add_expr_to_block (&body, tmp);
2460 gfc_add_expr_to_block (&body, fnbody);
2461 return gfc_finish_block (&body);
2464 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2467 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2471 gcc_assert (sym->backend_decl);
2472 gfc_start_block (&body);
2474 /* Set the initial value to length. See the comments in
2475 function gfc_add_assign_aux_vars in this file. */
2476 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2477 build_int_cst (NULL_TREE, -2));
2479 gfc_add_expr_to_block (&body, fnbody);
2480 return gfc_finish_block (&body);
2484 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2486 tree t = *tp, var, val;
2488 if (t == NULL || t == error_mark_node)
2490 if (TREE_CONSTANT (t) || DECL_P (t))
2493 if (TREE_CODE (t) == SAVE_EXPR)
2495 if (SAVE_EXPR_RESOLVED_P (t))
2497 *tp = TREE_OPERAND (t, 0);
2500 val = TREE_OPERAND (t, 0);
2505 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2506 gfc_add_decl_to_function (var);
2507 gfc_add_modify_expr (body, var, val);
2508 if (TREE_CODE (t) == SAVE_EXPR)
2509 TREE_OPERAND (t, 0) = var;
2514 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2518 if (type == NULL || type == error_mark_node)
2521 type = TYPE_MAIN_VARIANT (type);
2523 if (TREE_CODE (type) == INTEGER_TYPE)
2525 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2526 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2528 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2530 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2531 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2534 else if (TREE_CODE (type) == ARRAY_TYPE)
2536 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2537 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2538 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2539 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2541 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2543 TYPE_SIZE (t) = TYPE_SIZE (type);
2544 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2549 /* Make sure all type sizes and array domains are either constant,
2550 or variable or parameter decls. This is a simplified variant
2551 of gimplify_type_sizes, but we can't use it here, as none of the
2552 variables in the expressions have been gimplified yet.
2553 As type sizes and domains for various variable length arrays
2554 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2555 time, without this routine gimplify_type_sizes in the middle-end
2556 could result in the type sizes being gimplified earlier than where
2557 those variables are initialized. */
2560 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2562 tree type = TREE_TYPE (sym->backend_decl);
2564 if (TREE_CODE (type) == FUNCTION_TYPE
2565 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2567 if (! current_fake_result_decl)
2570 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2573 while (POINTER_TYPE_P (type))
2574 type = TREE_TYPE (type);
2576 if (GFC_DESCRIPTOR_TYPE_P (type))
2578 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2580 while (POINTER_TYPE_P (etype))
2581 etype = TREE_TYPE (etype);
2583 gfc_trans_vla_type_sizes_1 (etype, body);
2586 gfc_trans_vla_type_sizes_1 (type, body);
2590 /* Generate function entry and exit code, and add it to the function body.
2592 Allocation and initialization of array variables.
2593 Allocation of character string variables.
2594 Initialization and possibly repacking of dummy arrays.
2595 Initialization of ASSIGN statement auxiliary variable. */
2598 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2602 gfc_formal_arglist *f;
2604 bool seen_trans_deferred_array = false;
2606 /* Deal with implicit return variables. Explicit return variables will
2607 already have been added. */
2608 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2610 if (!current_fake_result_decl)
2612 gfc_entry_list *el = NULL;
2613 if (proc_sym->attr.entry_master)
2615 for (el = proc_sym->ns->entries; el; el = el->next)
2616 if (el->sym != el->sym->result)
2620 warning (0, "Function does not return a value");
2622 else if (proc_sym->as)
2624 tree result = TREE_VALUE (current_fake_result_decl);
2625 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2627 /* An automatic character length, pointer array result. */
2628 if (proc_sym->ts.type == BT_CHARACTER
2629 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2630 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2633 else if (proc_sym->ts.type == BT_CHARACTER)
2635 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2636 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2640 gcc_assert (gfc_option.flag_f2c
2641 && proc_sym->ts.type == BT_COMPLEX);
2644 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2646 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2647 && sym->ts.derived->attr.alloc_comp;
2648 if (sym->attr.dimension)
2650 switch (sym->as->type)
2653 if (sym->attr.dummy || sym->attr.result)
2655 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2656 else if (sym->attr.pointer || sym->attr.allocatable)
2658 if (TREE_STATIC (sym->backend_decl))
2659 gfc_trans_static_array_pointer (sym);
2662 seen_trans_deferred_array = true;
2663 fnbody = gfc_trans_deferred_array (sym, fnbody);
2668 if (sym_has_alloc_comp)
2670 seen_trans_deferred_array = true;
2671 fnbody = gfc_trans_deferred_array (sym, fnbody);
2674 gfc_get_backend_locus (&loc);
2675 gfc_set_backend_locus (&sym->declared_at);
2676 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2678 gfc_set_backend_locus (&loc);
2682 case AS_ASSUMED_SIZE:
2683 /* Must be a dummy parameter. */
2684 gcc_assert (sym->attr.dummy);
2686 /* We should always pass assumed size arrays the g77 way. */
2687 fnbody = gfc_trans_g77_array (sym, fnbody);
2690 case AS_ASSUMED_SHAPE:
2691 /* Must be a dummy parameter. */
2692 gcc_assert (sym->attr.dummy);
2694 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2699 seen_trans_deferred_array = true;
2700 fnbody = gfc_trans_deferred_array (sym, fnbody);
2706 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2707 fnbody = gfc_trans_deferred_array (sym, fnbody);
2709 else if (sym_has_alloc_comp)
2710 fnbody = gfc_trans_deferred_array (sym, fnbody);
2711 else if (sym->ts.type == BT_CHARACTER)
2713 gfc_get_backend_locus (&loc);
2714 gfc_set_backend_locus (&sym->declared_at);
2715 if (sym->attr.dummy || sym->attr.result)
2716 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2718 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2719 gfc_set_backend_locus (&loc);
2721 else if (sym->attr.assign)
2723 gfc_get_backend_locus (&loc);
2724 gfc_set_backend_locus (&sym->declared_at);
2725 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2726 gfc_set_backend_locus (&loc);
2732 gfc_init_block (&body);
2734 for (f = proc_sym->formal; f; f = f->next)
2735 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2737 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2738 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2739 gfc_trans_vla_type_sizes (f->sym, &body);
2742 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2743 && current_fake_result_decl != NULL)
2745 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2746 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2747 gfc_trans_vla_type_sizes (proc_sym, &body);
2750 gfc_add_expr_to_block (&body, fnbody);
2751 return gfc_finish_block (&body);
2755 /* Output an initialized decl for a module variable. */
2758 gfc_create_module_variable (gfc_symbol * sym)
2762 /* Module functions with alternate entries are dealt with later and
2763 would get caught by the next condition. */
2764 if (sym->attr.entry)
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 else if (sym->attr.dummy && warn_unused_parameter)
2979 gfc_warning ("Unused parameter %s declared at %L", sym->name,
2981 /* Warn for unused variables, but not if they're inside a common
2982 block or are use-associated. */
2983 else if (warn_unused_variable
2984 && !(sym->attr.in_common || sym->attr.use_assoc))
2985 gfc_warning ("Unused variable %s declared at %L", sym->name,
2987 /* For variable length CHARACTER parameters, the PARM_DECL already
2988 references the length variable, so force gfc_get_symbol_decl
2989 even when not referenced. If optimize > 0, it will be optimized
2990 away anyway. But do this only after emitting -Wunused-parameter
2991 warning if requested. */
2992 if (sym->attr.dummy && ! sym->attr.referenced
2993 && sym->ts.type == BT_CHARACTER
2994 && sym->ts.cl->backend_decl != NULL
2995 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2997 sym->attr.referenced = 1;
2998 gfc_get_symbol_decl (sym);
3004 generate_local_vars (gfc_namespace * ns)
3006 gfc_traverse_ns (ns, generate_local_decl);
3010 /* Generate a switch statement to jump to the correct entry point. Also
3011 creates the label decls for the entry points. */
3014 gfc_trans_entry_master_switch (gfc_entry_list * el)
3021 gfc_init_block (&block);
3022 for (; el; el = el->next)
3024 /* Add the case label. */
3025 label = gfc_build_label_decl (NULL_TREE);
3026 val = build_int_cst (gfc_array_index_type, el->id);
3027 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3028 gfc_add_expr_to_block (&block, tmp);
3030 /* And jump to the actual entry point. */
3031 label = gfc_build_label_decl (NULL_TREE);
3032 tmp = build1_v (GOTO_EXPR, label);
3033 gfc_add_expr_to_block (&block, tmp);
3035 /* Save the label decl. */
3038 tmp = gfc_finish_block (&block);
3039 /* The first argument selects the entry point. */
3040 val = DECL_ARGUMENTS (current_function_decl);
3041 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3046 /* Generate code for a function. */
3049 gfc_generate_function_code (gfc_namespace * ns)
3062 sym = ns->proc_name;
3064 /* Check that the frontend isn't still using this. */
3065 gcc_assert (sym->tlink == NULL);
3068 /* Create the declaration for functions with global scope. */
3069 if (!sym->backend_decl)
3070 gfc_create_function_decl (ns);
3072 fndecl = sym->backend_decl;
3073 old_context = current_function_decl;
3077 push_function_context ();
3078 saved_parent_function_decls = saved_function_decls;
3079 saved_function_decls = NULL_TREE;
3082 trans_function_start (sym);
3084 gfc_start_block (&block);
3086 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3088 /* Copy length backend_decls to all entry point result
3093 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3094 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3095 for (el = ns->entries; el; el = el->next)
3096 el->sym->result->ts.cl->backend_decl = backend_decl;
3099 /* Translate COMMON blocks. */
3100 gfc_trans_common (ns);
3102 /* Null the parent fake result declaration if this namespace is
3103 a module function or an external procedures. */
3104 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3105 || ns->parent == NULL)
3106 parent_fake_result_decl = NULL_TREE;
3108 gfc_generate_contained_functions (ns);
3110 generate_local_vars (ns);
3112 /* Keep the parent fake result declaration in module functions
3113 or external procedures. */
3114 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3115 || ns->parent == NULL)
3116 current_fake_result_decl = parent_fake_result_decl;
3118 current_fake_result_decl = NULL_TREE;
3120 current_function_return_label = NULL;
3122 /* Now generate the code for the body of this function. */
3123 gfc_init_block (&body);
3125 /* If this is the main program, add a call to set_std to set up the
3126 runtime library Fortran language standard parameters. */
3128 if (sym->attr.is_main_program)
3130 tree gfc_int4_type_node = gfc_get_int_type (4);
3131 tmp = build_call_expr (gfor_fndecl_set_std, 5,
3132 build_int_cst (gfc_int4_type_node,
3133 gfc_option.warn_std),
3134 build_int_cst (gfc_int4_type_node,
3135 gfc_option.allow_std),
3136 build_int_cst (gfc_int4_type_node,
3138 build_int_cst (gfc_int4_type_node,
3139 gfc_option.flag_dump_core),
3140 build_int_cst (gfc_int4_type_node,
3141 gfc_option.flag_backtrace));
3142 gfc_add_expr_to_block (&body, tmp);
3145 /* If this is the main program and a -ffpe-trap option was provided,
3146 add a call to set_fpe so that the library will raise a FPE when
3148 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3150 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3151 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3152 build_int_cst (gfc_c_int_type_node,
3154 gfc_add_expr_to_block (&body, tmp);
3157 /* If this is the main program and an -fconvert option was provided,
3158 add a call to set_convert. */
3160 if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
3162 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3163 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3164 build_int_cst (gfc_c_int_type_node,
3165 gfc_option.convert));
3166 gfc_add_expr_to_block (&body, tmp);
3169 /* If this is the main program and an -frecord-marker option was provided,
3170 add a call to set_record_marker. */
3172 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3174 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3175 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3176 build_int_cst (gfc_c_int_type_node,
3177 gfc_option.record_marker));
3178 gfc_add_expr_to_block (&body, tmp);
3181 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3183 tree gfc_c_int_type_node;
3185 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3186 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3188 build_int_cst (gfc_c_int_type_node,
3189 gfc_option.max_subrecord_length));
3190 gfc_add_expr_to_block (&body, tmp);
3193 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3194 && sym->attr.subroutine)
3196 tree alternate_return;
3197 alternate_return = gfc_get_fake_result_decl (sym, 0);
3198 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3203 /* Jump to the correct entry point. */
3204 tmp = gfc_trans_entry_master_switch (ns->entries);
3205 gfc_add_expr_to_block (&body, tmp);
3208 tmp = gfc_trans_code (ns->code);
3209 gfc_add_expr_to_block (&body, tmp);
3211 /* Add a return label if needed. */
3212 if (current_function_return_label)
3214 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3215 gfc_add_expr_to_block (&body, tmp);
3218 tmp = gfc_finish_block (&body);
3219 /* Add code to create and cleanup arrays. */
3220 tmp = gfc_trans_deferred_vars (sym, tmp);
3222 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3224 if (sym->attr.subroutine || sym == sym->result)
3226 if (current_fake_result_decl != NULL)
3227 result = TREE_VALUE (current_fake_result_decl);
3230 current_fake_result_decl = NULL_TREE;
3233 result = sym->result->backend_decl;
3235 if (result != NULL_TREE && sym->attr.function
3236 && sym->ts.type == BT_DERIVED
3237 && sym->ts.derived->attr.alloc_comp
3238 && !sym->attr.pointer)
3240 rank = sym->as ? sym->as->rank : 0;
3241 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3242 gfc_add_expr_to_block (&block, tmp2);
3245 gfc_add_expr_to_block (&block, tmp);
3247 if (result == NULL_TREE)
3248 warning (0, "Function return value not set");
3251 /* Set the return value to the dummy result variable. The
3252 types may be different for scalar default REAL functions
3253 with -ff2c, therefore we have to convert. */
3254 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3255 tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3256 DECL_RESULT (fndecl), tmp);
3257 tmp = build1_v (RETURN_EXPR, tmp);
3258 gfc_add_expr_to_block (&block, tmp);
3262 gfc_add_expr_to_block (&block, tmp);
3265 /* Add all the decls we created during processing. */
3266 decl = saved_function_decls;
3271 next = TREE_CHAIN (decl);
3272 TREE_CHAIN (decl) = NULL_TREE;
3276 saved_function_decls = NULL_TREE;
3278 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3280 /* Finish off this function and send it for code generation. */
3282 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3284 /* Output the GENERIC tree. */
3285 dump_function (TDI_original, fndecl);
3287 /* Store the end of the function, so that we get good line number
3288 info for the epilogue. */
3289 cfun->function_end_locus = input_location;
3291 /* We're leaving the context of this function, so zap cfun.
3292 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3293 tree_rest_of_compilation. */
3298 pop_function_context ();
3299 saved_function_decls = saved_parent_function_decls;
3301 current_function_decl = old_context;
3303 if (decl_function_context (fndecl))
3304 /* Register this function with cgraph just far enough to get it
3305 added to our parent's nested function list. */
3306 (void) cgraph_node (fndecl);
3309 gfc_gimplify_function (fndecl);
3310 cgraph_finalize_function (fndecl, false);
3315 gfc_generate_constructors (void)
3317 gcc_assert (gfc_static_ctors == NULL_TREE);
3325 if (gfc_static_ctors == NULL_TREE)
3328 fnname = get_file_function_name ("I");
3329 type = build_function_type (void_type_node,
3330 gfc_chainon_list (NULL_TREE, void_type_node));
3332 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3333 TREE_PUBLIC (fndecl) = 1;
3335 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3336 DECL_ARTIFICIAL (decl) = 1;
3337 DECL_IGNORED_P (decl) = 1;
3338 DECL_CONTEXT (decl) = fndecl;
3339 DECL_RESULT (fndecl) = decl;
3343 current_function_decl = fndecl;
3345 rest_of_decl_compilation (fndecl, 1, 0);
3347 make_decl_rtl (fndecl);
3349 init_function_start (fndecl);
3353 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3355 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3356 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3361 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3363 free_after_parsing (cfun);
3364 free_after_compilation (cfun);
3366 tree_rest_of_compilation (fndecl);
3368 current_function_decl = NULL_TREE;
3372 /* Translates a BLOCK DATA program unit. This means emitting the
3373 commons contained therein plus their initializations. We also emit
3374 a globally visible symbol to make sure that each BLOCK DATA program
3375 unit remains unique. */
3378 gfc_generate_block_data (gfc_namespace * ns)
3383 /* Tell the backend the source location of the block data. */
3385 gfc_set_backend_locus (&ns->proc_name->declared_at);
3387 gfc_set_backend_locus (&gfc_current_locus);
3389 /* Process the DATA statements. */
3390 gfc_trans_common (ns);
3392 /* Create a global symbol with the mane of the block data. This is to
3393 generate linker errors if the same name is used twice. It is never
3396 id = gfc_sym_mangled_function_id (ns->proc_name);
3398 id = get_identifier ("__BLOCK_DATA__");
3400 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3401 TREE_PUBLIC (decl) = 1;
3402 TREE_STATIC (decl) = 1;
3405 rest_of_decl_compilation (decl, 1, 0);
3409 #include "gt-fortran-trans-decl.h"