1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
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_ctime;
98 tree gfor_fndecl_fdate;
99 tree gfor_fndecl_ttynam;
100 tree gfor_fndecl_in_pack;
101 tree gfor_fndecl_in_unpack;
102 tree gfor_fndecl_associated;
105 /* Math functions. Many other math functions are handled in
106 trans-intrinsic.c. */
108 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
109 tree gfor_fndecl_math_cpowf;
110 tree gfor_fndecl_math_cpow;
111 tree gfor_fndecl_math_cpowl10;
112 tree gfor_fndecl_math_cpowl16;
113 tree gfor_fndecl_math_ishftc4;
114 tree gfor_fndecl_math_ishftc8;
115 tree gfor_fndecl_math_ishftc16;
116 tree gfor_fndecl_math_exponent4;
117 tree gfor_fndecl_math_exponent8;
118 tree gfor_fndecl_math_exponent10;
119 tree gfor_fndecl_math_exponent16;
122 /* String functions. */
124 tree gfor_fndecl_compare_string;
125 tree gfor_fndecl_concat_string;
126 tree gfor_fndecl_string_len_trim;
127 tree gfor_fndecl_string_index;
128 tree gfor_fndecl_string_scan;
129 tree gfor_fndecl_string_verify;
130 tree gfor_fndecl_string_trim;
131 tree gfor_fndecl_string_repeat;
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__%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.if_source == IFSRC_IFBODY))
319 if (strcmp (sym->name, "MAIN__") == 0
320 || sym->attr.proc == PROC_INTRINSIC)
321 return get_identifier (sym->name);
323 if (gfc_option.flag_underscoring)
325 has_underscore = strchr (sym->name, '_') != 0;
326 if (gfc_option.flag_second_underscore && has_underscore)
327 snprintf (name, sizeof name, "%s__", sym->name);
329 snprintf (name, sizeof name, "%s_", sym->name);
330 return get_identifier (name);
333 return get_identifier (sym->name);
337 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
338 return get_identifier (name);
343 /* Returns true if a variable of specified size should go on the stack. */
346 gfc_can_put_var_on_stack (tree size)
348 unsigned HOST_WIDE_INT low;
350 if (!INTEGER_CST_P (size))
353 if (gfc_option.flag_max_stack_var_size < 0)
356 if (TREE_INT_CST_HIGH (size) != 0)
359 low = TREE_INT_CST_LOW (size);
360 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
363 /* TODO: Set a per-function stack size limit. */
369 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
370 an expression involving its corresponding pointer. There are
371 2 cases; one for variable size arrays, and one for everything else,
372 because variable-sized arrays require one fewer level of
376 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
378 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
381 /* Parameters need to be dereferenced. */
382 if (sym->cp_pointer->attr.dummy)
383 ptr_decl = build_fold_indirect_ref (ptr_decl);
385 /* Check to see if we're dealing with a variable-sized array. */
386 if (sym->attr.dimension
387 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
389 /* These decls will be dereferenced later, so we don't dereference
391 value = convert (TREE_TYPE (decl), ptr_decl);
395 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
397 value = build_fold_indirect_ref (ptr_decl);
400 SET_DECL_VALUE_EXPR (decl, value);
401 DECL_HAS_VALUE_EXPR_P (decl) = 1;
402 GFC_DECL_CRAY_POINTEE (decl) = 1;
403 /* This is a fake variable just for debugging purposes. */
404 TREE_ASM_WRITTEN (decl) = 1;
408 /* Finish processing of a declaration and install its initial value. */
411 gfc_finish_decl (tree decl, tree init)
413 if (TREE_CODE (decl) == PARM_DECL)
414 gcc_assert (init == NULL_TREE);
415 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
416 -- it overlaps DECL_ARG_TYPE. */
417 else if (init == NULL_TREE)
418 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
420 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
422 if (init != NULL_TREE)
424 if (TREE_CODE (decl) != TYPE_DECL)
425 DECL_INITIAL (decl) = init;
428 /* typedef foo = bar; store the type of bar as the type of foo. */
429 TREE_TYPE (decl) = TREE_TYPE (init);
430 DECL_INITIAL (decl) = init = 0;
434 if (TREE_CODE (decl) == VAR_DECL)
436 if (DECL_SIZE (decl) == NULL_TREE
437 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
438 layout_decl (decl, 0);
440 /* A static variable with an incomplete type is an error if it is
441 initialized. Also if it is not file scope. Otherwise, let it
442 through, but if it is not `extern' then it may cause an error
444 /* An automatic variable with an incomplete type is an error. */
445 if (DECL_SIZE (decl) == NULL_TREE
446 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
447 || DECL_CONTEXT (decl) != 0)
448 : !DECL_EXTERNAL (decl)))
450 gfc_fatal_error ("storage size not known");
453 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
454 && (DECL_SIZE (decl) != 0)
455 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
457 gfc_fatal_error ("storage size not constant");
464 /* Apply symbol attributes to a variable, and add it to the function scope. */
467 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
469 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
470 This is the equivalent of the TARGET variables.
471 We also need to set this if the variable is passed by reference in a
474 /* Set DECL_VALUE_EXPR for Cray Pointees. */
475 if (sym->attr.cray_pointee)
476 gfc_finish_cray_pointee (decl, sym);
478 if (sym->attr.target)
479 TREE_ADDRESSABLE (decl) = 1;
480 /* If it wasn't used we wouldn't be getting it. */
481 TREE_USED (decl) = 1;
483 /* Chain this decl to the pending declarations. Don't do pushdecl()
484 because this would add them to the current scope rather than the
486 if (current_function_decl != NULL_TREE)
488 if (sym->ns->proc_name->backend_decl == current_function_decl
489 || sym->result == sym)
490 gfc_add_decl_to_function (decl);
492 gfc_add_decl_to_parent_function (decl);
495 if (sym->attr.cray_pointee)
498 /* If a variable is USE associated, it's always external. */
499 if (sym->attr.use_assoc)
501 DECL_EXTERNAL (decl) = 1;
502 TREE_PUBLIC (decl) = 1;
504 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
506 /* TODO: Don't set sym->module for result or dummy variables. */
507 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
508 /* This is the declaration of a module variable. */
509 TREE_PUBLIC (decl) = 1;
510 TREE_STATIC (decl) = 1;
513 if ((sym->attr.save || sym->attr.data || sym->value)
514 && !sym->attr.use_assoc)
515 TREE_STATIC (decl) = 1;
517 if (sym->attr.volatile_)
520 TREE_THIS_VOLATILE (decl) = 1;
521 new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
522 TREE_TYPE (decl) = new;
525 /* Keep variables larger than max-stack-var-size off stack. */
526 if (!sym->ns->proc_name->attr.recursive
527 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
528 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
529 /* Put variable length auto array pointers always into stack. */
530 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
531 || sym->attr.dimension == 0
532 || sym->as->type != AS_EXPLICIT
534 || sym->attr.allocatable)
535 && !DECL_ARTIFICIAL (decl))
536 TREE_STATIC (decl) = 1;
538 /* Handle threadprivate variables. */
539 if (sym->attr.threadprivate && targetm.have_tls
540 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
541 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
545 /* Allocate the lang-specific part of a decl. */
548 gfc_allocate_lang_decl (tree decl)
550 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
551 ggc_alloc_cleared (sizeof (struct lang_decl));
554 /* Remember a symbol to generate initialization/cleanup code at function
558 gfc_defer_symbol_init (gfc_symbol * sym)
564 /* Don't add a symbol twice. */
568 last = head = sym->ns->proc_name;
571 /* Make sure that setup code for dummy variables which are used in the
572 setup of other variables is generated first. */
575 /* Find the first dummy arg seen after us, or the first non-dummy arg.
576 This is a circular list, so don't go past the head. */
578 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
584 /* Insert in between last and p. */
590 /* Create an array index type variable with function scope. */
593 create_index_var (const char * pfx, int nest)
597 decl = gfc_create_var_np (gfc_array_index_type, pfx);
599 gfc_add_decl_to_parent_function (decl);
601 gfc_add_decl_to_function (decl);
606 /* Create variables to hold all the non-constant bits of info for a
607 descriptorless array. Remember these in the lang-specific part of the
611 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
617 type = TREE_TYPE (decl);
619 /* We just use the descriptor, if there is one. */
620 if (GFC_DESCRIPTOR_TYPE_P (type))
623 gcc_assert (GFC_ARRAY_TYPE_P (type));
624 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
625 && !sym->attr.contained;
627 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
629 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
630 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
631 /* Don't try to use the unknown bound for assumed shape arrays. */
632 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
633 && (sym->as->type != AS_ASSUMED_SIZE
634 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
635 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
637 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
638 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
640 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
642 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
645 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
647 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
650 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
651 && sym->as->type != AS_ASSUMED_SIZE)
652 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
654 if (POINTER_TYPE_P (type))
656 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
657 gcc_assert (TYPE_LANG_SPECIFIC (type)
658 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
659 type = TREE_TYPE (type);
662 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
666 size = build2 (MINUS_EXPR, gfc_array_index_type,
667 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
668 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
670 TYPE_DOMAIN (type) = range;
676 /* For some dummy arguments we don't use the actual argument directly.
677 Instead we create a local decl and use that. This allows us to perform
678 initialization, and construct full type information. */
681 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
691 if (sym->attr.pointer || sym->attr.allocatable)
694 /* Add to list of variables if not a fake result variable. */
695 if (sym->attr.result || sym->attr.dummy)
696 gfc_defer_symbol_init (sym);
698 type = TREE_TYPE (dummy);
699 gcc_assert (TREE_CODE (dummy) == PARM_DECL
700 && POINTER_TYPE_P (type));
702 /* Do we know the element size? */
703 known_size = sym->ts.type != BT_CHARACTER
704 || INTEGER_CST_P (sym->ts.cl->backend_decl);
706 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
708 /* For descriptorless arrays with known element size the actual
709 argument is sufficient. */
710 gcc_assert (GFC_ARRAY_TYPE_P (type));
711 gfc_build_qualified_array (dummy, sym);
715 type = TREE_TYPE (type);
716 if (GFC_DESCRIPTOR_TYPE_P (type))
718 /* Create a descriptorless array pointer. */
721 if (!gfc_option.flag_repack_arrays)
723 if (as->type == AS_ASSUMED_SIZE)
728 if (as->type == AS_EXPLICIT)
731 for (n = 0; n < as->rank; n++)
735 && as->upper[n]->expr_type == EXPR_CONSTANT
736 && as->lower[n]->expr_type == EXPR_CONSTANT))
744 type = gfc_typenode_for_spec (&sym->ts);
745 type = gfc_get_nodesc_array_type (type, sym->as, packed);
749 /* We now have an expression for the element size, so create a fully
750 qualified type. Reset sym->backend decl or this will just return the
752 DECL_ARTIFICIAL (sym->backend_decl) = 1;
753 sym->backend_decl = NULL_TREE;
754 type = gfc_sym_type (sym);
758 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
759 decl = build_decl (VAR_DECL, get_identifier (name), type);
761 DECL_ARTIFICIAL (decl) = 1;
762 TREE_PUBLIC (decl) = 0;
763 TREE_STATIC (decl) = 0;
764 DECL_EXTERNAL (decl) = 0;
766 /* We should never get deferred shape arrays here. We used to because of
768 gcc_assert (sym->as->type != AS_DEFERRED);
773 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
777 GFC_DECL_PACKED_ARRAY (decl) = 1;
781 gfc_build_qualified_array (decl, sym);
783 if (DECL_LANG_SPECIFIC (dummy))
784 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
786 gfc_allocate_lang_decl (decl);
788 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
790 if (sym->ns->proc_name->backend_decl == current_function_decl
791 || sym->attr.contained)
792 gfc_add_decl_to_function (decl);
794 gfc_add_decl_to_parent_function (decl);
800 /* Return a constant or a variable to use as a string length. Does not
801 add the decl to the current scope. */
804 gfc_create_string_length (gfc_symbol * sym)
808 gcc_assert (sym->ts.cl);
809 gfc_conv_const_charlen (sym->ts.cl);
811 if (sym->ts.cl->backend_decl == NULL_TREE)
813 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
815 /* Also prefix the mangled name. */
816 strcpy (&name[1], sym->name);
818 length = build_decl (VAR_DECL, get_identifier (name),
819 gfc_charlen_type_node);
820 DECL_ARTIFICIAL (length) = 1;
821 TREE_USED (length) = 1;
822 if (sym->ns->proc_name->tlink != NULL)
823 gfc_defer_symbol_init (sym);
824 sym->ts.cl->backend_decl = length;
827 return sym->ts.cl->backend_decl;
830 /* If a variable is assigned a label, we add another two auxiliary
834 gfc_add_assign_aux_vars (gfc_symbol * sym)
840 gcc_assert (sym->backend_decl);
842 decl = sym->backend_decl;
843 gfc_allocate_lang_decl (decl);
844 GFC_DECL_ASSIGN (decl) = 1;
845 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
846 gfc_charlen_type_node);
847 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
849 gfc_finish_var_decl (length, sym);
850 gfc_finish_var_decl (addr, sym);
851 /* STRING_LENGTH is also used as flag. Less than -1 means that
852 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
853 target label's address. Otherwise, value is the length of a format string
854 and ASSIGN_ADDR is its address. */
855 if (TREE_STATIC (length))
856 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
858 gfc_defer_symbol_init (sym);
860 GFC_DECL_STRING_LEN (decl) = length;
861 GFC_DECL_ASSIGN_ADDR (decl) = addr;
864 /* Return the decl for a gfc_symbol, create it if it doesn't already
868 gfc_get_symbol_decl (gfc_symbol * sym)
871 tree length = NULL_TREE;
874 gcc_assert (sym->attr.referenced
875 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
877 if (sym->ns && sym->ns->proc_name->attr.function)
878 byref = gfc_return_by_reference (sym->ns->proc_name);
882 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
884 /* Return via extra parameter. */
885 if (sym->attr.result && byref
886 && !sym->backend_decl)
889 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
890 /* For entry master function skip over the __entry
892 if (sym->ns->proc_name->attr.entry_master)
893 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
896 /* Dummy variables should already have been created. */
897 gcc_assert (sym->backend_decl);
899 /* Create a character length variable. */
900 if (sym->ts.type == BT_CHARACTER)
902 if (sym->ts.cl->backend_decl == NULL_TREE)
903 length = gfc_create_string_length (sym);
905 length = sym->ts.cl->backend_decl;
906 if (TREE_CODE (length) == VAR_DECL
907 && DECL_CONTEXT (length) == NULL_TREE)
909 /* Add the string length to the same context as the symbol. */
910 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
911 gfc_add_decl_to_function (length);
913 gfc_add_decl_to_parent_function (length);
915 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
916 DECL_CONTEXT (length));
918 gfc_defer_symbol_init (sym);
922 /* Use a copy of the descriptor for dummy arrays. */
923 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
925 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
926 /* Prevent the dummy from being detected as unused if it is copied. */
927 if (sym->backend_decl != NULL && decl != sym->backend_decl)
928 DECL_ARTIFICIAL (sym->backend_decl) = 1;
929 sym->backend_decl = decl;
932 TREE_USED (sym->backend_decl) = 1;
933 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
935 gfc_add_assign_aux_vars (sym);
937 return sym->backend_decl;
940 if (sym->backend_decl)
941 return sym->backend_decl;
943 /* Catch function declarations. Only used for actual parameters. */
944 if (sym->attr.flavor == FL_PROCEDURE)
946 decl = gfc_get_extern_function_decl (sym);
950 if (sym->attr.intrinsic)
951 internal_error ("intrinsic variable which isn't a procedure");
953 /* Create string length decl first so that they can be used in the
955 if (sym->ts.type == BT_CHARACTER)
956 length = gfc_create_string_length (sym);
958 /* Create the decl for the variable. */
959 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
961 gfc_set_decl_location (decl, &sym->declared_at);
963 /* Symbols from modules should have their assembler names mangled.
964 This is done here rather than in gfc_finish_var_decl because it
965 is different for string length variables. */
967 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
969 if (sym->attr.dimension)
971 /* Create variables to hold the non-constant bits of array info. */
972 gfc_build_qualified_array (decl, sym);
974 /* Remember this variable for allocation/cleanup. */
975 gfc_defer_symbol_init (sym);
977 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
978 GFC_DECL_PACKED_ARRAY (decl) = 1;
981 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
982 gfc_defer_symbol_init (sym);
984 gfc_finish_var_decl (decl, sym);
986 if (sym->ts.type == BT_CHARACTER)
988 /* Character variables need special handling. */
989 gfc_allocate_lang_decl (decl);
991 if (TREE_CODE (length) != INTEGER_CST)
993 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
997 /* Also prefix the mangled name for symbols from modules. */
998 strcpy (&name[1], sym->name);
1001 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1002 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1004 gfc_finish_var_decl (length, sym);
1005 gcc_assert (!sym->value);
1008 sym->backend_decl = decl;
1010 if (sym->attr.assign)
1011 gfc_add_assign_aux_vars (sym);
1013 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1015 /* Add static initializer. */
1016 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1017 TREE_TYPE (decl), sym->attr.dimension,
1018 sym->attr.pointer || sym->attr.allocatable);
1025 /* Substitute a temporary variable in place of the real one. */
1028 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1030 save->attr = sym->attr;
1031 save->decl = sym->backend_decl;
1033 gfc_clear_attr (&sym->attr);
1034 sym->attr.referenced = 1;
1035 sym->attr.flavor = FL_VARIABLE;
1037 sym->backend_decl = decl;
1041 /* Restore the original variable. */
1044 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1046 sym->attr = save->attr;
1047 sym->backend_decl = save->decl;
1051 /* Get a basic decl for an external function. */
1054 gfc_get_extern_function_decl (gfc_symbol * sym)
1059 gfc_intrinsic_sym *isym;
1061 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
1065 if (sym->backend_decl)
1066 return sym->backend_decl;
1068 /* We should never be creating external decls for alternate entry points.
1069 The procedure may be an alternate entry point, but we don't want/need
1071 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1073 if (sym->attr.intrinsic)
1075 /* Call the resolution function to get the actual name. This is
1076 a nasty hack which relies on the resolution functions only looking
1077 at the first argument. We pass NULL for the second argument
1078 otherwise things like AINT get confused. */
1079 isym = gfc_find_function (sym->name);
1080 gcc_assert (isym->resolve.f0 != NULL);
1082 memset (&e, 0, sizeof (e));
1083 e.expr_type = EXPR_FUNCTION;
1085 memset (&argexpr, 0, sizeof (argexpr));
1086 gcc_assert (isym->formal);
1087 argexpr.ts = isym->formal->ts;
1089 if (isym->formal->next == NULL)
1090 isym->resolve.f1 (&e, &argexpr);
1093 if (isym->formal->next->next == NULL)
1094 isym->resolve.f2 (&e, &argexpr, NULL);
1097 /* All specific intrinsics take less than 4 arguments. */
1098 gcc_assert (isym->formal->next->next->next == NULL);
1099 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1103 if (gfc_option.flag_f2c
1104 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1105 || e.ts.type == BT_COMPLEX))
1107 /* Specific which needs a different implementation if f2c
1108 calling conventions are used. */
1109 sprintf (s, "f2c_specific%s", e.value.function.name);
1112 sprintf (s, "specific%s", e.value.function.name);
1114 name = get_identifier (s);
1115 mangled_name = name;
1119 name = gfc_sym_identifier (sym);
1120 mangled_name = gfc_sym_mangled_function_id (sym);
1123 type = gfc_get_function_type (sym);
1124 fndecl = build_decl (FUNCTION_DECL, name, type);
1126 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1127 /* If the return type is a pointer, avoid alias issues by setting
1128 DECL_IS_MALLOC to nonzero. This means that the function should be
1129 treated as if it were a malloc, meaning it returns a pointer that
1131 if (POINTER_TYPE_P (type))
1132 DECL_IS_MALLOC (fndecl) = 1;
1134 /* Set the context of this decl. */
1135 if (0 && sym->ns && sym->ns->proc_name)
1137 /* TODO: Add external decls to the appropriate scope. */
1138 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1142 /* Global declaration, e.g. intrinsic subroutine. */
1143 DECL_CONTEXT (fndecl) = NULL_TREE;
1146 DECL_EXTERNAL (fndecl) = 1;
1148 /* This specifies if a function is globally addressable, i.e. it is
1149 the opposite of declaring static in C. */
1150 TREE_PUBLIC (fndecl) = 1;
1152 /* Set attributes for PURE functions. A call to PURE function in the
1153 Fortran 95 sense is both pure and without side effects in the C
1155 if (sym->attr.pure || sym->attr.elemental)
1157 if (sym->attr.function && !gfc_return_by_reference (sym))
1158 DECL_IS_PURE (fndecl) = 1;
1159 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1160 parameters and don't use alternate returns (is this
1161 allowed?). In that case, calls to them are meaningless, and
1162 can be optimized away. See also in build_function_decl(). */
1163 TREE_SIDE_EFFECTS (fndecl) = 0;
1166 /* Mark non-returning functions. */
1167 if (sym->attr.noreturn)
1168 TREE_THIS_VOLATILE(fndecl) = 1;
1170 sym->backend_decl = fndecl;
1172 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1173 pushdecl_top_level (fndecl);
1179 /* Create a declaration for a procedure. For external functions (in the C
1180 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1181 a master function with alternate entry points. */
1184 build_function_decl (gfc_symbol * sym)
1187 symbol_attribute attr;
1189 gfc_formal_arglist *f;
1191 gcc_assert (!sym->backend_decl);
1192 gcc_assert (!sym->attr.external);
1194 /* Set the line and filename. sym->declared_at seems to point to the
1195 last statement for subroutines, but it'll do for now. */
1196 gfc_set_backend_locus (&sym->declared_at);
1198 /* Allow only one nesting level. Allow public declarations. */
1199 gcc_assert (current_function_decl == NULL_TREE
1200 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1202 type = gfc_get_function_type (sym);
1203 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1205 /* Perform name mangling if this is a top level or module procedure. */
1206 if (current_function_decl == NULL_TREE)
1207 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1209 /* Figure out the return type of the declared function, and build a
1210 RESULT_DECL for it. If this is a subroutine with alternate
1211 returns, build a RESULT_DECL for it. */
1214 result_decl = NULL_TREE;
1215 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1218 if (gfc_return_by_reference (sym))
1219 type = void_type_node;
1222 if (sym->result != sym)
1223 result_decl = gfc_sym_identifier (sym->result);
1225 type = TREE_TYPE (TREE_TYPE (fndecl));
1230 /* Look for alternate return placeholders. */
1231 int has_alternate_returns = 0;
1232 for (f = sym->formal; f; f = f->next)
1236 has_alternate_returns = 1;
1241 if (has_alternate_returns)
1242 type = integer_type_node;
1244 type = void_type_node;
1247 result_decl = build_decl (RESULT_DECL, result_decl, type);
1248 DECL_ARTIFICIAL (result_decl) = 1;
1249 DECL_IGNORED_P (result_decl) = 1;
1250 DECL_CONTEXT (result_decl) = fndecl;
1251 DECL_RESULT (fndecl) = result_decl;
1253 /* Don't call layout_decl for a RESULT_DECL.
1254 layout_decl (result_decl, 0); */
1256 /* If the return type is a pointer, avoid alias issues by setting
1257 DECL_IS_MALLOC to nonzero. This means that the function should be
1258 treated as if it were a malloc, meaning it returns a pointer that
1260 if (POINTER_TYPE_P (type))
1261 DECL_IS_MALLOC (fndecl) = 1;
1263 /* Set up all attributes for the function. */
1264 DECL_CONTEXT (fndecl) = current_function_decl;
1265 DECL_EXTERNAL (fndecl) = 0;
1267 /* This specifies if a function is globally visible, i.e. it is
1268 the opposite of declaring static in C. */
1269 if (DECL_CONTEXT (fndecl) == NULL_TREE
1270 && !sym->attr.entry_master)
1271 TREE_PUBLIC (fndecl) = 1;
1273 /* TREE_STATIC means the function body is defined here. */
1274 TREE_STATIC (fndecl) = 1;
1276 /* Set attributes for PURE functions. A call to a PURE function in the
1277 Fortran 95 sense is both pure and without side effects in the C
1279 if (attr.pure || attr.elemental)
1281 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1282 including a alternate return. In that case it can also be
1283 marked as PURE. See also in gfc_get_extern_function_decl(). */
1284 if (attr.function && !gfc_return_by_reference (sym))
1285 DECL_IS_PURE (fndecl) = 1;
1286 TREE_SIDE_EFFECTS (fndecl) = 0;
1289 /* Layout the function declaration and put it in the binding level
1290 of the current function. */
1293 sym->backend_decl = fndecl;
1297 /* Create the DECL_ARGUMENTS for a procedure. */
1300 create_function_arglist (gfc_symbol * sym)
1303 gfc_formal_arglist *f;
1304 tree typelist, hidden_typelist;
1305 tree arglist, hidden_arglist;
1309 fndecl = sym->backend_decl;
1311 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1312 the new FUNCTION_DECL node. */
1313 arglist = NULL_TREE;
1314 hidden_arglist = NULL_TREE;
1315 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1317 if (sym->attr.entry_master)
1319 type = TREE_VALUE (typelist);
1320 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1322 DECL_CONTEXT (parm) = fndecl;
1323 DECL_ARG_TYPE (parm) = type;
1324 TREE_READONLY (parm) = 1;
1325 gfc_finish_decl (parm, NULL_TREE);
1326 DECL_ARTIFICIAL (parm) = 1;
1328 arglist = chainon (arglist, parm);
1329 typelist = TREE_CHAIN (typelist);
1332 if (gfc_return_by_reference (sym))
1334 tree type = TREE_VALUE (typelist), length = NULL;
1336 if (sym->ts.type == BT_CHARACTER)
1338 /* Length of character result. */
1339 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1340 gcc_assert (len_type == gfc_charlen_type_node);
1342 length = build_decl (PARM_DECL,
1343 get_identifier (".__result"),
1345 if (!sym->ts.cl->length)
1347 sym->ts.cl->backend_decl = length;
1348 TREE_USED (length) = 1;
1350 gcc_assert (TREE_CODE (length) == PARM_DECL);
1351 DECL_CONTEXT (length) = fndecl;
1352 DECL_ARG_TYPE (length) = len_type;
1353 TREE_READONLY (length) = 1;
1354 DECL_ARTIFICIAL (length) = 1;
1355 gfc_finish_decl (length, NULL_TREE);
1356 if (sym->ts.cl->backend_decl == NULL
1357 || sym->ts.cl->backend_decl == length)
1362 if (sym->ts.cl->backend_decl == NULL)
1364 tree len = build_decl (VAR_DECL,
1365 get_identifier ("..__result"),
1366 gfc_charlen_type_node);
1367 DECL_ARTIFICIAL (len) = 1;
1368 TREE_USED (len) = 1;
1369 sym->ts.cl->backend_decl = len;
1372 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1373 arg = sym->result ? sym->result : sym;
1374 backend_decl = arg->backend_decl;
1375 /* Temporary clear it, so that gfc_sym_type creates complete
1377 arg->backend_decl = NULL;
1378 type = gfc_sym_type (arg);
1379 arg->backend_decl = backend_decl;
1380 type = build_reference_type (type);
1384 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1386 DECL_CONTEXT (parm) = fndecl;
1387 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1388 TREE_READONLY (parm) = 1;
1389 DECL_ARTIFICIAL (parm) = 1;
1390 gfc_finish_decl (parm, NULL_TREE);
1392 arglist = chainon (arglist, parm);
1393 typelist = TREE_CHAIN (typelist);
1395 if (sym->ts.type == BT_CHARACTER)
1397 gfc_allocate_lang_decl (parm);
1398 arglist = chainon (arglist, length);
1399 typelist = TREE_CHAIN (typelist);
1403 hidden_typelist = typelist;
1404 for (f = sym->formal; f; f = f->next)
1405 if (f->sym != NULL) /* Ignore alternate returns. */
1406 hidden_typelist = TREE_CHAIN (hidden_typelist);
1408 for (f = sym->formal; f; f = f->next)
1410 char name[GFC_MAX_SYMBOL_LEN + 2];
1412 /* Ignore alternate returns. */
1416 type = TREE_VALUE (typelist);
1418 if (f->sym->ts.type == BT_CHARACTER)
1420 tree len_type = TREE_VALUE (hidden_typelist);
1421 tree length = NULL_TREE;
1422 gcc_assert (len_type == gfc_charlen_type_node);
1424 strcpy (&name[1], f->sym->name);
1426 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1428 hidden_arglist = chainon (hidden_arglist, length);
1429 DECL_CONTEXT (length) = fndecl;
1430 DECL_ARTIFICIAL (length) = 1;
1431 DECL_ARG_TYPE (length) = len_type;
1432 TREE_READONLY (length) = 1;
1433 gfc_finish_decl (length, NULL_TREE);
1435 /* TODO: Check string lengths when -fbounds-check. */
1437 /* Use the passed value for assumed length variables. */
1438 if (!f->sym->ts.cl->length)
1440 TREE_USED (length) = 1;
1441 if (!f->sym->ts.cl->backend_decl)
1442 f->sym->ts.cl->backend_decl = length;
1445 /* there is already another variable using this
1446 gfc_charlen node, build a new one for this variable
1447 and chain it into the list of gfc_charlens.
1448 This happens for e.g. in the case
1450 since CHARACTER declarations on the same line share
1451 the same gfc_charlen node. */
1454 cl = gfc_get_charlen ();
1455 cl->backend_decl = length;
1456 cl->next = f->sym->ts.cl->next;
1457 f->sym->ts.cl->next = cl;
1462 hidden_typelist = TREE_CHAIN (hidden_typelist);
1464 if (f->sym->ts.cl->backend_decl == NULL
1465 || f->sym->ts.cl->backend_decl == length)
1467 if (f->sym->ts.cl->backend_decl == NULL)
1468 gfc_create_string_length (f->sym);
1470 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1471 if (f->sym->attr.flavor == FL_PROCEDURE)
1472 type = build_pointer_type (gfc_get_function_type (f->sym));
1474 type = gfc_sym_type (f->sym);
1478 /* For non-constant length array arguments, make sure they use
1479 a different type node from TYPE_ARG_TYPES type. */
1480 if (f->sym->attr.dimension
1481 && type == TREE_VALUE (typelist)
1482 && TREE_CODE (type) == POINTER_TYPE
1483 && GFC_ARRAY_TYPE_P (type)
1484 && f->sym->as->type != AS_ASSUMED_SIZE
1485 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1487 if (f->sym->attr.flavor == FL_PROCEDURE)
1488 type = build_pointer_type (gfc_get_function_type (f->sym));
1490 type = gfc_sym_type (f->sym);
1493 /* Build a the argument declaration. */
1494 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1496 /* Fill in arg stuff. */
1497 DECL_CONTEXT (parm) = fndecl;
1498 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1499 /* All implementation args are read-only. */
1500 TREE_READONLY (parm) = 1;
1502 gfc_finish_decl (parm, NULL_TREE);
1504 f->sym->backend_decl = parm;
1506 arglist = chainon (arglist, parm);
1507 typelist = TREE_CHAIN (typelist);
1510 /* Add the hidden string length parameters. */
1511 arglist = chainon (arglist, hidden_arglist);
1513 gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
1514 DECL_ARGUMENTS (fndecl) = arglist;
1517 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1520 gfc_gimplify_function (tree fndecl)
1522 struct cgraph_node *cgn;
1524 gimplify_function_tree (fndecl);
1525 dump_function (TDI_generic, fndecl);
1527 /* Generate errors for structured block violations. */
1528 /* ??? Could be done as part of resolve_labels. */
1530 diagnose_omp_structured_block_errors (fndecl);
1532 /* Convert all nested functions to GIMPLE now. We do things in this order
1533 so that items like VLA sizes are expanded properly in the context of the
1534 correct function. */
1535 cgn = cgraph_node (fndecl);
1536 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1537 gfc_gimplify_function (cgn->decl);
1541 /* Do the setup necessary before generating the body of a function. */
1544 trans_function_start (gfc_symbol * sym)
1548 fndecl = sym->backend_decl;
1550 /* Let GCC know the current scope is this function. */
1551 current_function_decl = fndecl;
1553 /* Let the world know what we're about to do. */
1554 announce_function (fndecl);
1556 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1558 /* Create RTL for function declaration. */
1559 rest_of_decl_compilation (fndecl, 1, 0);
1562 /* Create RTL for function definition. */
1563 make_decl_rtl (fndecl);
1565 init_function_start (fndecl);
1567 /* Even though we're inside a function body, we still don't want to
1568 call expand_expr to calculate the size of a variable-sized array.
1569 We haven't necessarily assigned RTL to all variables yet, so it's
1570 not safe to try to expand expressions involving them. */
1571 cfun->x_dont_save_pending_sizes_p = 1;
1573 /* function.c requires a push at the start of the function. */
1577 /* Create thunks for alternate entry points. */
1580 build_entry_thunks (gfc_namespace * ns)
1582 gfc_formal_arglist *formal;
1583 gfc_formal_arglist *thunk_formal;
1585 gfc_symbol *thunk_sym;
1593 /* This should always be a toplevel function. */
1594 gcc_assert (current_function_decl == NULL_TREE);
1596 gfc_get_backend_locus (&old_loc);
1597 for (el = ns->entries; el; el = el->next)
1599 thunk_sym = el->sym;
1601 build_function_decl (thunk_sym);
1602 create_function_arglist (thunk_sym);
1604 trans_function_start (thunk_sym);
1606 thunk_fndecl = thunk_sym->backend_decl;
1608 gfc_start_block (&body);
1610 /* Pass extra parameter identifying this entry point. */
1611 tmp = build_int_cst (gfc_array_index_type, el->id);
1612 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1613 string_args = NULL_TREE;
1615 if (thunk_sym->attr.function)
1617 if (gfc_return_by_reference (ns->proc_name))
1619 tree ref = DECL_ARGUMENTS (current_function_decl);
1620 args = tree_cons (NULL_TREE, ref, args);
1621 if (ns->proc_name->ts.type == BT_CHARACTER)
1622 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1627 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1629 /* Ignore alternate returns. */
1630 if (formal->sym == NULL)
1633 /* We don't have a clever way of identifying arguments, so resort to
1634 a brute-force search. */
1635 for (thunk_formal = thunk_sym->formal;
1637 thunk_formal = thunk_formal->next)
1639 if (thunk_formal->sym == formal->sym)
1645 /* Pass the argument. */
1646 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1647 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1649 if (formal->sym->ts.type == BT_CHARACTER)
1651 tmp = thunk_formal->sym->ts.cl->backend_decl;
1652 string_args = tree_cons (NULL_TREE, tmp, string_args);
1657 /* Pass NULL for a missing argument. */
1658 args = tree_cons (NULL_TREE, null_pointer_node, args);
1659 if (formal->sym->ts.type == BT_CHARACTER)
1661 tmp = build_int_cst (gfc_charlen_type_node, 0);
1662 string_args = tree_cons (NULL_TREE, tmp, string_args);
1667 /* Call the master function. */
1668 args = nreverse (args);
1669 args = chainon (args, nreverse (string_args));
1670 tmp = ns->proc_name->backend_decl;
1671 tmp = build_function_call_expr (tmp, args);
1672 if (ns->proc_name->attr.mixed_entry_master)
1674 tree union_decl, field;
1675 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1677 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1678 TREE_TYPE (master_type));
1679 DECL_ARTIFICIAL (union_decl) = 1;
1680 DECL_EXTERNAL (union_decl) = 0;
1681 TREE_PUBLIC (union_decl) = 0;
1682 TREE_USED (union_decl) = 1;
1683 layout_decl (union_decl, 0);
1684 pushdecl (union_decl);
1686 DECL_CONTEXT (union_decl) = current_function_decl;
1687 tmp = build2 (MODIFY_EXPR,
1688 TREE_TYPE (union_decl),
1690 gfc_add_expr_to_block (&body, tmp);
1692 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1693 field; field = TREE_CHAIN (field))
1694 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1695 thunk_sym->result->name) == 0)
1697 gcc_assert (field != NULL_TREE);
1698 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1700 tmp = build2 (MODIFY_EXPR,
1701 TREE_TYPE (DECL_RESULT (current_function_decl)),
1702 DECL_RESULT (current_function_decl), tmp);
1703 tmp = build1_v (RETURN_EXPR, tmp);
1705 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1708 tmp = build2 (MODIFY_EXPR,
1709 TREE_TYPE (DECL_RESULT (current_function_decl)),
1710 DECL_RESULT (current_function_decl), tmp);
1711 tmp = build1_v (RETURN_EXPR, tmp);
1713 gfc_add_expr_to_block (&body, tmp);
1715 /* Finish off this function and send it for code generation. */
1716 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1718 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1720 /* Output the GENERIC tree. */
1721 dump_function (TDI_original, thunk_fndecl);
1723 /* Store the end of the function, so that we get good line number
1724 info for the epilogue. */
1725 cfun->function_end_locus = input_location;
1727 /* We're leaving the context of this function, so zap cfun.
1728 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1729 tree_rest_of_compilation. */
1732 current_function_decl = NULL_TREE;
1734 gfc_gimplify_function (thunk_fndecl);
1735 cgraph_finalize_function (thunk_fndecl, false);
1737 /* We share the symbols in the formal argument list with other entry
1738 points and the master function. Clear them so that they are
1739 recreated for each function. */
1740 for (formal = thunk_sym->formal; formal; formal = formal->next)
1741 if (formal->sym != NULL) /* Ignore alternate returns. */
1743 formal->sym->backend_decl = NULL_TREE;
1744 if (formal->sym->ts.type == BT_CHARACTER)
1745 formal->sym->ts.cl->backend_decl = NULL_TREE;
1748 if (thunk_sym->attr.function)
1750 if (thunk_sym->ts.type == BT_CHARACTER)
1751 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1752 if (thunk_sym->result->ts.type == BT_CHARACTER)
1753 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1757 gfc_set_backend_locus (&old_loc);
1761 /* Create a decl for a function, and create any thunks for alternate entry
1765 gfc_create_function_decl (gfc_namespace * ns)
1767 /* Create a declaration for the master function. */
1768 build_function_decl (ns->proc_name);
1770 /* Compile the entry thunks. */
1772 build_entry_thunks (ns);
1774 /* Now create the read argument list. */
1775 create_function_arglist (ns->proc_name);
1778 /* Return the decl used to hold the function return value. If
1779 parent_flag is set, the context is the parent_scope*/
1782 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1786 tree this_fake_result_decl;
1787 tree this_function_decl;
1789 char name[GFC_MAX_SYMBOL_LEN + 10];
1793 this_fake_result_decl = parent_fake_result_decl;
1794 this_function_decl = DECL_CONTEXT (current_function_decl);
1798 this_fake_result_decl = current_fake_result_decl;
1799 this_function_decl = current_function_decl;
1803 && sym->ns->proc_name->backend_decl == this_function_decl
1804 && sym->ns->proc_name->attr.entry_master
1805 && sym != sym->ns->proc_name)
1808 if (this_fake_result_decl != NULL)
1809 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1810 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1813 return TREE_VALUE (t);
1814 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1817 this_fake_result_decl = parent_fake_result_decl;
1819 this_fake_result_decl = current_fake_result_decl;
1821 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1825 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1826 field; field = TREE_CHAIN (field))
1827 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1831 gcc_assert (field != NULL_TREE);
1832 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1836 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1838 gfc_add_decl_to_parent_function (var);
1840 gfc_add_decl_to_function (var);
1842 SET_DECL_VALUE_EXPR (var, decl);
1843 DECL_HAS_VALUE_EXPR_P (var) = 1;
1844 GFC_DECL_RESULT (var) = 1;
1846 TREE_CHAIN (this_fake_result_decl)
1847 = tree_cons (get_identifier (sym->name), var,
1848 TREE_CHAIN (this_fake_result_decl));
1852 if (this_fake_result_decl != NULL_TREE)
1853 return TREE_VALUE (this_fake_result_decl);
1855 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1860 if (sym->ts.type == BT_CHARACTER)
1862 if (sym->ts.cl->backend_decl == NULL_TREE)
1863 length = gfc_create_string_length (sym);
1865 length = sym->ts.cl->backend_decl;
1866 if (TREE_CODE (length) == VAR_DECL
1867 && DECL_CONTEXT (length) == NULL_TREE)
1868 gfc_add_decl_to_function (length);
1871 if (gfc_return_by_reference (sym))
1873 decl = DECL_ARGUMENTS (this_function_decl);
1875 if (sym->ns->proc_name->backend_decl == this_function_decl
1876 && sym->ns->proc_name->attr.entry_master)
1877 decl = TREE_CHAIN (decl);
1879 TREE_USED (decl) = 1;
1881 decl = gfc_build_dummy_array_decl (sym, decl);
1885 sprintf (name, "__result_%.20s",
1886 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1888 decl = build_decl (VAR_DECL, get_identifier (name),
1889 TREE_TYPE (TREE_TYPE (this_function_decl)));
1891 DECL_ARTIFICIAL (decl) = 1;
1892 DECL_EXTERNAL (decl) = 0;
1893 TREE_PUBLIC (decl) = 0;
1894 TREE_USED (decl) = 1;
1895 GFC_DECL_RESULT (decl) = 1;
1896 TREE_ADDRESSABLE (decl) = 1;
1898 layout_decl (decl, 0);
1901 gfc_add_decl_to_parent_function (decl);
1903 gfc_add_decl_to_function (decl);
1907 parent_fake_result_decl = build_tree_list (NULL, decl);
1909 current_fake_result_decl = build_tree_list (NULL, decl);
1915 /* Builds a function decl. The remaining parameters are the types of the
1916 function arguments. Negative nargs indicates a varargs function. */
1919 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1928 /* Library functions must be declared with global scope. */
1929 gcc_assert (current_function_decl == NULL_TREE);
1931 va_start (p, nargs);
1934 /* Create a list of the argument types. */
1935 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1937 argtype = va_arg (p, tree);
1938 arglist = gfc_chainon_list (arglist, argtype);
1943 /* Terminate the list. */
1944 arglist = gfc_chainon_list (arglist, void_type_node);
1947 /* Build the function type and decl. */
1948 fntype = build_function_type (rettype, arglist);
1949 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1951 /* Mark this decl as external. */
1952 DECL_EXTERNAL (fndecl) = 1;
1953 TREE_PUBLIC (fndecl) = 1;
1959 rest_of_decl_compilation (fndecl, 1, 0);
1965 gfc_build_intrinsic_function_decls (void)
1967 tree gfc_int4_type_node = gfc_get_int_type (4);
1968 tree gfc_int8_type_node = gfc_get_int_type (8);
1969 tree gfc_int16_type_node = gfc_get_int_type (16);
1970 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1971 tree gfc_real4_type_node = gfc_get_real_type (4);
1972 tree gfc_real8_type_node = gfc_get_real_type (8);
1973 tree gfc_real10_type_node = gfc_get_real_type (10);
1974 tree gfc_real16_type_node = gfc_get_real_type (16);
1975 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1976 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1977 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1978 tree gfc_complex16_type_node = gfc_get_complex_type (16);
1979 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1981 /* String functions. */
1982 gfor_fndecl_compare_string =
1983 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1986 gfc_charlen_type_node, pchar_type_node,
1987 gfc_charlen_type_node, pchar_type_node);
1989 gfor_fndecl_concat_string =
1990 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1993 gfc_charlen_type_node, pchar_type_node,
1994 gfc_charlen_type_node, pchar_type_node,
1995 gfc_charlen_type_node, pchar_type_node);
1997 gfor_fndecl_string_len_trim =
1998 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2000 2, gfc_charlen_type_node,
2003 gfor_fndecl_string_index =
2004 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2006 5, gfc_charlen_type_node, pchar_type_node,
2007 gfc_charlen_type_node, pchar_type_node,
2008 gfc_logical4_type_node);
2010 gfor_fndecl_string_scan =
2011 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2013 5, gfc_charlen_type_node, pchar_type_node,
2014 gfc_charlen_type_node, pchar_type_node,
2015 gfc_logical4_type_node);
2017 gfor_fndecl_string_verify =
2018 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2020 5, gfc_charlen_type_node, pchar_type_node,
2021 gfc_charlen_type_node, pchar_type_node,
2022 gfc_logical4_type_node);
2024 gfor_fndecl_string_trim =
2025 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2028 build_pointer_type (gfc_charlen_type_node),
2030 gfc_charlen_type_node,
2033 gfor_fndecl_string_repeat =
2034 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
2038 gfc_charlen_type_node,
2040 gfc_int4_type_node);
2042 gfor_fndecl_ttynam =
2043 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2047 gfc_charlen_type_node,
2048 gfc_c_int_type_node);
2051 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2055 gfc_charlen_type_node);
2058 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2062 gfc_charlen_type_node,
2063 gfc_int8_type_node);
2065 gfor_fndecl_adjustl =
2066 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2070 gfc_charlen_type_node, pchar_type_node);
2072 gfor_fndecl_adjustr =
2073 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2077 gfc_charlen_type_node, pchar_type_node);
2079 gfor_fndecl_si_kind =
2080 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2085 gfor_fndecl_sr_kind =
2086 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
2091 /* Power functions. */
2093 tree ctype, rtype, itype, jtype;
2094 int rkind, ikind, jkind;
2097 static int ikinds[NIKINDS] = {4, 8, 16};
2098 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2099 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2101 for (ikind=0; ikind < NIKINDS; ikind++)
2103 itype = gfc_get_int_type (ikinds[ikind]);
2105 for (jkind=0; jkind < NIKINDS; jkind++)
2107 jtype = gfc_get_int_type (ikinds[jkind]);
2110 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2112 gfor_fndecl_math_powi[jkind][ikind].integer =
2113 gfc_build_library_function_decl (get_identifier (name),
2114 jtype, 2, jtype, itype);
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);
2130 ctype = gfc_get_complex_type (rkinds[rkind]);
2133 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2135 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2136 gfc_build_library_function_decl (get_identifier (name),
2137 ctype, 2,ctype, itype);
2145 gfor_fndecl_math_cpowf =
2146 gfc_build_library_function_decl (get_identifier ("cpowf"),
2147 gfc_complex4_type_node,
2148 1, gfc_complex4_type_node);
2149 gfor_fndecl_math_cpow =
2150 gfc_build_library_function_decl (get_identifier ("cpow"),
2151 gfc_complex8_type_node,
2152 1, gfc_complex8_type_node);
2153 if (gfc_complex10_type_node)
2154 gfor_fndecl_math_cpowl10 =
2155 gfc_build_library_function_decl (get_identifier ("cpowl"),
2156 gfc_complex10_type_node, 1,
2157 gfc_complex10_type_node);
2158 if (gfc_complex16_type_node)
2159 gfor_fndecl_math_cpowl16 =
2160 gfc_build_library_function_decl (get_identifier ("cpowl"),
2161 gfc_complex16_type_node, 1,
2162 gfc_complex16_type_node);
2164 gfor_fndecl_math_ishftc4 =
2165 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2167 3, gfc_int4_type_node,
2168 gfc_int4_type_node, gfc_int4_type_node);
2169 gfor_fndecl_math_ishftc8 =
2170 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2172 3, gfc_int8_type_node,
2173 gfc_int4_type_node, gfc_int4_type_node);
2174 if (gfc_int16_type_node)
2175 gfor_fndecl_math_ishftc16 =
2176 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2177 gfc_int16_type_node, 3,
2178 gfc_int16_type_node,
2180 gfc_int4_type_node);
2182 gfor_fndecl_math_exponent4 =
2183 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2185 1, gfc_real4_type_node);
2186 gfor_fndecl_math_exponent8 =
2187 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2189 1, gfc_real8_type_node);
2190 if (gfc_real10_type_node)
2191 gfor_fndecl_math_exponent10 =
2192 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2193 gfc_int4_type_node, 1,
2194 gfc_real10_type_node);
2195 if (gfc_real16_type_node)
2196 gfor_fndecl_math_exponent16 =
2197 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2198 gfc_int4_type_node, 1,
2199 gfc_real16_type_node);
2201 /* BLAS functions. */
2203 tree pint = build_pointer_type (gfc_c_int_type_node);
2204 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2205 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2206 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2207 tree pz = build_pointer_type
2208 (gfc_get_complex_type (gfc_default_double_kind));
2210 gfor_fndecl_sgemm = gfc_build_library_function_decl
2212 (gfc_option.flag_underscoring ? "sgemm_"
2214 void_type_node, 15, pchar_type_node,
2215 pchar_type_node, pint, pint, pint, ps, ps, pint,
2216 ps, pint, ps, ps, pint, gfc_c_int_type_node,
2217 gfc_c_int_type_node);
2218 gfor_fndecl_dgemm = gfc_build_library_function_decl
2220 (gfc_option.flag_underscoring ? "dgemm_"
2222 void_type_node, 15, pchar_type_node,
2223 pchar_type_node, pint, pint, pint, pd, pd, pint,
2224 pd, pint, pd, pd, pint, gfc_c_int_type_node,
2225 gfc_c_int_type_node);
2226 gfor_fndecl_cgemm = gfc_build_library_function_decl
2228 (gfc_option.flag_underscoring ? "cgemm_"
2230 void_type_node, 15, pchar_type_node,
2231 pchar_type_node, pint, pint, pint, pc, pc, pint,
2232 pc, pint, pc, pc, pint, gfc_c_int_type_node,
2233 gfc_c_int_type_node);
2234 gfor_fndecl_zgemm = gfc_build_library_function_decl
2236 (gfc_option.flag_underscoring ? "zgemm_"
2238 void_type_node, 15, pchar_type_node,
2239 pchar_type_node, pint, pint, pint, pz, pz, pint,
2240 pz, pint, pz, pz, pint, gfc_c_int_type_node,
2241 gfc_c_int_type_node);
2244 /* Other functions. */
2246 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2247 gfc_array_index_type,
2248 1, pvoid_type_node);
2250 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2251 gfc_array_index_type,
2253 gfc_array_index_type);
2256 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2262 /* Make prototypes for runtime library functions. */
2265 gfc_build_builtin_function_decls (void)
2267 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2268 tree gfc_int4_type_node = gfc_get_int_type (4);
2269 tree gfc_int8_type_node = gfc_get_int_type (8);
2270 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2271 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2273 /* Treat these two internal malloc wrappers as malloc. */
2274 gfor_fndecl_internal_malloc =
2275 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2276 pvoid_type_node, 1, gfc_int4_type_node);
2277 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
2279 gfor_fndecl_internal_malloc64 =
2280 gfc_build_library_function_decl (get_identifier
2281 (PREFIX("internal_malloc64")),
2282 pvoid_type_node, 1, gfc_int8_type_node);
2283 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
2285 gfor_fndecl_internal_realloc =
2286 gfc_build_library_function_decl (get_identifier
2287 (PREFIX("internal_realloc")),
2288 pvoid_type_node, 2, pvoid_type_node,
2289 gfc_int4_type_node);
2291 gfor_fndecl_internal_realloc64 =
2292 gfc_build_library_function_decl (get_identifier
2293 (PREFIX("internal_realloc64")),
2294 pvoid_type_node, 2, pvoid_type_node,
2295 gfc_int8_type_node);
2297 gfor_fndecl_internal_free =
2298 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2299 void_type_node, 1, pvoid_type_node);
2301 gfor_fndecl_allocate =
2302 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2303 void_type_node, 2, ppvoid_type_node,
2304 gfc_int4_type_node);
2306 gfor_fndecl_allocate64 =
2307 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2308 void_type_node, 2, ppvoid_type_node,
2309 gfc_int8_type_node);
2311 gfor_fndecl_allocate_array =
2312 gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2313 void_type_node, 2, ppvoid_type_node,
2314 gfc_int4_type_node);
2316 gfor_fndecl_allocate64_array =
2317 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
2318 void_type_node, 2, ppvoid_type_node,
2319 gfc_int8_type_node);
2321 gfor_fndecl_deallocate =
2322 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2323 void_type_node, 2, ppvoid_type_node,
2324 gfc_pint4_type_node);
2326 gfor_fndecl_stop_numeric =
2327 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2328 void_type_node, 1, gfc_int4_type_node);
2330 /* Stop doesn't return. */
2331 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2333 gfor_fndecl_stop_string =
2334 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2335 void_type_node, 2, pchar_type_node,
2336 gfc_int4_type_node);
2337 /* Stop doesn't return. */
2338 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2340 gfor_fndecl_pause_numeric =
2341 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2342 void_type_node, 1, gfc_int4_type_node);
2344 gfor_fndecl_pause_string =
2345 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2346 void_type_node, 2, pchar_type_node,
2347 gfc_int4_type_node);
2349 gfor_fndecl_select_string =
2350 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2351 pvoid_type_node, 0);
2353 gfor_fndecl_runtime_error =
2354 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2355 void_type_node, 1, pchar_type_node);
2356 /* The runtime_error function does not return. */
2357 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2359 gfor_fndecl_set_fpe =
2360 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2361 void_type_node, 1, gfc_c_int_type_node);
2363 gfor_fndecl_set_std =
2364 gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2369 gfc_int4_type_node);
2371 gfor_fndecl_set_convert =
2372 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2373 void_type_node, 1, gfc_c_int_type_node);
2375 gfor_fndecl_set_record_marker =
2376 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2377 void_type_node, 1, gfc_c_int_type_node);
2379 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2380 get_identifier (PREFIX("internal_pack")),
2381 pvoid_type_node, 1, pvoid_type_node);
2383 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2384 get_identifier (PREFIX("internal_unpack")),
2385 pvoid_type_node, 1, pvoid_type_node);
2387 gfor_fndecl_associated =
2388 gfc_build_library_function_decl (
2389 get_identifier (PREFIX("associated")),
2390 gfc_logical4_type_node,
2395 gfc_build_intrinsic_function_decls ();
2396 gfc_build_intrinsic_lib_fndecls ();
2397 gfc_build_io_library_fndecls ();
2401 /* Evaluate the length of dummy character variables. */
2404 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2408 gfc_finish_decl (cl->backend_decl, NULL_TREE);
2410 gfc_start_block (&body);
2412 /* Evaluate the string length expression. */
2413 gfc_trans_init_string_length (cl, &body);
2415 gfc_trans_vla_type_sizes (sym, &body);
2417 gfc_add_expr_to_block (&body, fnbody);
2418 return gfc_finish_block (&body);
2422 /* Allocate and cleanup an automatic character variable. */
2425 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2431 gcc_assert (sym->backend_decl);
2432 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2434 gfc_start_block (&body);
2436 /* Evaluate the string length expression. */
2437 gfc_trans_init_string_length (sym->ts.cl, &body);
2439 gfc_trans_vla_type_sizes (sym, &body);
2441 decl = sym->backend_decl;
2443 /* Emit a DECL_EXPR for this variable, which will cause the
2444 gimplifier to allocate storage, and all that good stuff. */
2445 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2446 gfc_add_expr_to_block (&body, tmp);
2448 gfc_add_expr_to_block (&body, fnbody);
2449 return gfc_finish_block (&body);
2452 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2455 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2459 gcc_assert (sym->backend_decl);
2460 gfc_start_block (&body);
2462 /* Set the initial value to length. See the comments in
2463 function gfc_add_assign_aux_vars in this file. */
2464 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2465 build_int_cst (NULL_TREE, -2));
2467 gfc_add_expr_to_block (&body, fnbody);
2468 return gfc_finish_block (&body);
2472 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2474 tree t = *tp, var, val;
2476 if (t == NULL || t == error_mark_node)
2478 if (TREE_CONSTANT (t) || DECL_P (t))
2481 if (TREE_CODE (t) == SAVE_EXPR)
2483 if (SAVE_EXPR_RESOLVED_P (t))
2485 *tp = TREE_OPERAND (t, 0);
2488 val = TREE_OPERAND (t, 0);
2493 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2494 gfc_add_decl_to_function (var);
2495 gfc_add_modify_expr (body, var, val);
2496 if (TREE_CODE (t) == SAVE_EXPR)
2497 TREE_OPERAND (t, 0) = var;
2502 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2506 if (type == NULL || type == error_mark_node)
2509 type = TYPE_MAIN_VARIANT (type);
2511 if (TREE_CODE (type) == INTEGER_TYPE)
2513 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2514 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2516 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2518 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2519 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2522 else if (TREE_CODE (type) == ARRAY_TYPE)
2524 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2525 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2526 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2527 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2529 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2531 TYPE_SIZE (t) = TYPE_SIZE (type);
2532 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2537 /* Make sure all type sizes and array domains are either constant,
2538 or variable or parameter decls. This is a simplified variant
2539 of gimplify_type_sizes, but we can't use it here, as none of the
2540 variables in the expressions have been gimplified yet.
2541 As type sizes and domains for various variable length arrays
2542 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2543 time, without this routine gimplify_type_sizes in the middle-end
2544 could result in the type sizes being gimplified earlier than where
2545 those variables are initialized. */
2548 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2550 tree type = TREE_TYPE (sym->backend_decl);
2552 if (TREE_CODE (type) == FUNCTION_TYPE
2553 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2555 if (! current_fake_result_decl)
2558 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2561 while (POINTER_TYPE_P (type))
2562 type = TREE_TYPE (type);
2564 if (GFC_DESCRIPTOR_TYPE_P (type))
2566 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2568 while (POINTER_TYPE_P (etype))
2569 etype = TREE_TYPE (etype);
2571 gfc_trans_vla_type_sizes_1 (etype, body);
2574 gfc_trans_vla_type_sizes_1 (type, body);
2578 /* Generate function entry and exit code, and add it to the function body.
2580 Allocation and initialization of array variables.
2581 Allocation of character string variables.
2582 Initialization and possibly repacking of dummy arrays.
2583 Initialization of ASSIGN statement auxiliary variable. */
2586 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2590 gfc_formal_arglist *f;
2592 bool seen_trans_deferred_array = false;
2594 /* Deal with implicit return variables. Explicit return variables will
2595 already have been added. */
2596 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2598 if (!current_fake_result_decl)
2600 gfc_entry_list *el = NULL;
2601 if (proc_sym->attr.entry_master)
2603 for (el = proc_sym->ns->entries; el; el = el->next)
2604 if (el->sym != el->sym->result)
2608 warning (0, "Function does not return a value");
2610 else if (proc_sym->as)
2612 tree result = TREE_VALUE (current_fake_result_decl);
2613 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2615 /* An automatic character length, pointer array result. */
2616 if (proc_sym->ts.type == BT_CHARACTER
2617 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2618 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2621 else if (proc_sym->ts.type == BT_CHARACTER)
2623 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2624 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2628 gcc_assert (gfc_option.flag_f2c
2629 && proc_sym->ts.type == BT_COMPLEX);
2632 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2634 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2635 && sym->ts.derived->attr.alloc_comp;
2636 if (sym->attr.dimension)
2638 switch (sym->as->type)
2641 if (sym->attr.dummy || sym->attr.result)
2643 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2644 else if (sym->attr.pointer || sym->attr.allocatable)
2646 if (TREE_STATIC (sym->backend_decl))
2647 gfc_trans_static_array_pointer (sym);
2650 seen_trans_deferred_array = true;
2651 fnbody = gfc_trans_deferred_array (sym, fnbody);
2656 if (sym_has_alloc_comp)
2658 seen_trans_deferred_array = true;
2659 fnbody = gfc_trans_deferred_array (sym, fnbody);
2662 gfc_get_backend_locus (&loc);
2663 gfc_set_backend_locus (&sym->declared_at);
2664 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2666 gfc_set_backend_locus (&loc);
2670 case AS_ASSUMED_SIZE:
2671 /* Must be a dummy parameter. */
2672 gcc_assert (sym->attr.dummy);
2674 /* We should always pass assumed size arrays the g77 way. */
2675 fnbody = gfc_trans_g77_array (sym, fnbody);
2678 case AS_ASSUMED_SHAPE:
2679 /* Must be a dummy parameter. */
2680 gcc_assert (sym->attr.dummy);
2682 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2687 seen_trans_deferred_array = true;
2688 fnbody = gfc_trans_deferred_array (sym, fnbody);
2694 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2695 fnbody = gfc_trans_deferred_array (sym, fnbody);
2697 else if (sym_has_alloc_comp)
2698 fnbody = gfc_trans_deferred_array (sym, fnbody);
2699 else if (sym->ts.type == BT_CHARACTER)
2701 gfc_get_backend_locus (&loc);
2702 gfc_set_backend_locus (&sym->declared_at);
2703 if (sym->attr.dummy || sym->attr.result)
2704 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2706 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2707 gfc_set_backend_locus (&loc);
2709 else if (sym->attr.assign)
2711 gfc_get_backend_locus (&loc);
2712 gfc_set_backend_locus (&sym->declared_at);
2713 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2714 gfc_set_backend_locus (&loc);
2720 gfc_init_block (&body);
2722 for (f = proc_sym->formal; f; f = f->next)
2723 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2725 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2726 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2727 gfc_trans_vla_type_sizes (f->sym, &body);
2730 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2731 && current_fake_result_decl != NULL)
2733 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2734 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2735 gfc_trans_vla_type_sizes (proc_sym, &body);
2738 gfc_add_expr_to_block (&body, fnbody);
2739 return gfc_finish_block (&body);
2743 /* Output an initialized decl for a module variable. */
2746 gfc_create_module_variable (gfc_symbol * sym)
2750 /* Module functions with alternate entries are dealt with later and
2751 would get caught by the next condition. */
2752 if (sym->attr.entry)
2755 /* Only output symbols from this module. */
2756 if (sym->ns != module_namespace)
2758 /* I don't think this should ever happen. */
2759 internal_error ("module symbol %s in wrong namespace", sym->name);
2762 /* Only output variables and array valued parameters. */
2763 if (sym->attr.flavor != FL_VARIABLE
2764 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2767 /* Don't generate variables from other modules. Variables from
2768 COMMONs will already have been generated. */
2769 if (sym->attr.use_assoc || sym->attr.in_common)
2772 /* Equivalenced variables arrive here after creation. */
2773 if (sym->backend_decl
2774 && (sym->equiv_built || sym->attr.in_equivalence))
2777 if (sym->backend_decl)
2778 internal_error ("backend decl for module variable %s already exists",
2781 /* We always want module variables to be created. */
2782 sym->attr.referenced = 1;
2783 /* Create the decl. */
2784 decl = gfc_get_symbol_decl (sym);
2786 /* Create the variable. */
2788 rest_of_decl_compilation (decl, 1, 0);
2790 /* Also add length of strings. */
2791 if (sym->ts.type == BT_CHARACTER)
2795 length = sym->ts.cl->backend_decl;
2796 if (!INTEGER_CST_P (length))
2799 rest_of_decl_compilation (length, 1, 0);
2805 /* Generate all the required code for module variables. */
2808 gfc_generate_module_vars (gfc_namespace * ns)
2810 module_namespace = ns;
2812 /* Check if the frontend left the namespace in a reasonable state. */
2813 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2815 /* Generate COMMON blocks. */
2816 gfc_trans_common (ns);
2818 /* Create decls for all the module variables. */
2819 gfc_traverse_ns (ns, gfc_create_module_variable);
2823 gfc_generate_contained_functions (gfc_namespace * parent)
2827 /* We create all the prototypes before generating any code. */
2828 for (ns = parent->contained; ns; ns = ns->sibling)
2830 /* Skip namespaces from used modules. */
2831 if (ns->parent != parent)
2834 gfc_create_function_decl (ns);
2837 for (ns = parent->contained; ns; ns = ns->sibling)
2839 /* Skip namespaces from used modules. */
2840 if (ns->parent != parent)
2843 gfc_generate_function_code (ns);
2848 /* Drill down through expressions for the array specification bounds and
2849 character length calling generate_local_decl for all those variables
2850 that have not already been declared. */
2853 generate_local_decl (gfc_symbol *);
2856 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2858 gfc_actual_arglist *arg;
2865 switch (e->expr_type)
2868 for (arg = e->value.function.actual; arg; arg = arg->next)
2869 generate_expr_decls (sym, arg->expr);
2872 /* If the variable is not the same as the dependent, 'sym', and
2873 it is not marked as being declared and it is in the same
2874 namespace as 'sym', add it to the local declarations. */
2876 if (sym == e->symtree->n.sym
2877 || e->symtree->n.sym->mark
2878 || e->symtree->n.sym->ns != sym->ns)
2881 generate_local_decl (e->symtree->n.sym);
2885 generate_expr_decls (sym, e->value.op.op1);
2886 generate_expr_decls (sym, e->value.op.op2);
2895 for (ref = e->ref; ref; ref = ref->next)
2900 for (i = 0; i < ref->u.ar.dimen; i++)
2902 generate_expr_decls (sym, ref->u.ar.start[i]);
2903 generate_expr_decls (sym, ref->u.ar.end[i]);
2904 generate_expr_decls (sym, ref->u.ar.stride[i]);
2909 generate_expr_decls (sym, ref->u.ss.start);
2910 generate_expr_decls (sym, ref->u.ss.end);
2914 if (ref->u.c.component->ts.type == BT_CHARACTER
2915 && ref->u.c.component->ts.cl->length->expr_type
2917 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2919 if (ref->u.c.component->as)
2920 for (i = 0; i < ref->u.c.component->as->rank; i++)
2922 generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2923 generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2932 /* Check for dependencies in the character length and array spec. */
2935 generate_dependency_declarations (gfc_symbol *sym)
2939 if (sym->ts.type == BT_CHARACTER
2940 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2941 generate_expr_decls (sym, sym->ts.cl->length);
2943 if (sym->as && sym->as->rank)
2945 for (i = 0; i < sym->as->rank; i++)
2947 generate_expr_decls (sym, sym->as->lower[i]);
2948 generate_expr_decls (sym, sym->as->upper[i]);
2954 /* Generate decls for all local variables. We do this to ensure correct
2955 handling of expressions which only appear in the specification of
2959 generate_local_decl (gfc_symbol * sym)
2961 if (sym->attr.flavor == FL_VARIABLE)
2963 /* Check for dependencies in the array specification and string
2964 length, adding the necessary declarations to the function. We
2965 mark the symbol now, as well as in traverse_ns, to prevent
2966 getting stuck in a circular dependency. */
2968 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2969 generate_dependency_declarations (sym);
2971 if (sym->attr.referenced)
2972 gfc_get_symbol_decl (sym);
2973 else if (sym->attr.dummy && warn_unused_parameter)
2974 gfc_warning ("Unused parameter %s declared at %L", sym->name,
2976 /* Warn for unused variables, but not if they're inside a common
2977 block or are use-associated. */
2978 else if (warn_unused_variable
2979 && !(sym->attr.in_common || sym->attr.use_assoc))
2980 gfc_warning ("Unused variable %s declared at %L", sym->name,
2982 /* For variable length CHARACTER parameters, the PARM_DECL already
2983 references the length variable, so force gfc_get_symbol_decl
2984 even when not referenced. If optimize > 0, it will be optimized
2985 away anyway. But do this only after emitting -Wunused-parameter
2986 warning if requested. */
2987 if (sym->attr.dummy && ! sym->attr.referenced
2988 && sym->ts.type == BT_CHARACTER
2989 && sym->ts.cl->backend_decl != NULL
2990 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2992 sym->attr.referenced = 1;
2993 gfc_get_symbol_decl (sym);
2999 generate_local_vars (gfc_namespace * ns)
3001 gfc_traverse_ns (ns, generate_local_decl);
3005 /* Generate a switch statement to jump to the correct entry point. Also
3006 creates the label decls for the entry points. */
3009 gfc_trans_entry_master_switch (gfc_entry_list * el)
3016 gfc_init_block (&block);
3017 for (; el; el = el->next)
3019 /* Add the case label. */
3020 label = gfc_build_label_decl (NULL_TREE);
3021 val = build_int_cst (gfc_array_index_type, el->id);
3022 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3023 gfc_add_expr_to_block (&block, tmp);
3025 /* And jump to the actual entry point. */
3026 label = gfc_build_label_decl (NULL_TREE);
3027 tmp = build1_v (GOTO_EXPR, label);
3028 gfc_add_expr_to_block (&block, tmp);
3030 /* Save the label decl. */
3033 tmp = gfc_finish_block (&block);
3034 /* The first argument selects the entry point. */
3035 val = DECL_ARGUMENTS (current_function_decl);
3036 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3041 /* Generate code for a function. */
3044 gfc_generate_function_code (gfc_namespace * ns)
3057 sym = ns->proc_name;
3059 /* Check that the frontend isn't still using this. */
3060 gcc_assert (sym->tlink == NULL);
3063 /* Create the declaration for functions with global scope. */
3064 if (!sym->backend_decl)
3065 gfc_create_function_decl (ns);
3067 fndecl = sym->backend_decl;
3068 old_context = current_function_decl;
3072 push_function_context ();
3073 saved_parent_function_decls = saved_function_decls;
3074 saved_function_decls = NULL_TREE;
3077 trans_function_start (sym);
3079 gfc_start_block (&block);
3081 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3083 /* Copy length backend_decls to all entry point result
3088 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3089 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3090 for (el = ns->entries; el; el = el->next)
3091 el->sym->result->ts.cl->backend_decl = backend_decl;
3094 /* Translate COMMON blocks. */
3095 gfc_trans_common (ns);
3097 /* Null the parent fake result declaration if this namespace is
3098 a module function or an external procedures. */
3099 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3100 || ns->parent == NULL)
3101 parent_fake_result_decl = NULL_TREE;
3103 gfc_generate_contained_functions (ns);
3105 generate_local_vars (ns);
3107 /* Keep the parent fake result declaration in module functions
3108 or external procedures. */
3109 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3110 || ns->parent == NULL)
3111 current_fake_result_decl = parent_fake_result_decl;
3113 current_fake_result_decl = NULL_TREE;
3115 current_function_return_label = NULL;
3117 /* Now generate the code for the body of this function. */
3118 gfc_init_block (&body);
3120 /* If this is the main program, add a call to set_std to set up the
3121 runtime library Fortran language standard parameters. */
3123 if (sym->attr.is_main_program)
3125 tree arglist, gfc_int4_type_node;
3127 gfc_int4_type_node = gfc_get_int_type (4);
3128 arglist = gfc_chainon_list (NULL_TREE,
3129 build_int_cst (gfc_int4_type_node,
3130 gfc_option.warn_std));
3131 arglist = gfc_chainon_list (arglist,
3132 build_int_cst (gfc_int4_type_node,
3133 gfc_option.allow_std));
3134 arglist = gfc_chainon_list (arglist,
3135 build_int_cst (gfc_int4_type_node,
3137 tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
3138 gfc_add_expr_to_block (&body, tmp);
3141 /* If this is the main program and a -ffpe-trap option was provided,
3142 add a call to set_fpe so that the library will raise a FPE when
3144 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3146 tree arglist, gfc_c_int_type_node;
3148 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3149 arglist = gfc_chainon_list (NULL_TREE,
3150 build_int_cst (gfc_c_int_type_node,
3152 tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
3153 gfc_add_expr_to_block (&body, tmp);
3156 /* If this is the main program and an -fconvert option was provided,
3157 add a call to set_convert. */
3159 if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
3161 tree arglist, gfc_c_int_type_node;
3163 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3164 arglist = gfc_chainon_list (NULL_TREE,
3165 build_int_cst (gfc_c_int_type_node,
3166 gfc_option.convert));
3167 tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
3168 gfc_add_expr_to_block (&body, tmp);
3171 /* If this is the main program and an -frecord-marker option was provided,
3172 add a call to set_record_marker. */
3174 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3176 tree arglist, gfc_c_int_type_node;
3178 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3179 arglist = gfc_chainon_list (NULL_TREE,
3180 build_int_cst (gfc_c_int_type_node,
3181 gfc_option.record_marker));
3182 tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
3183 gfc_add_expr_to_block (&body, tmp);
3187 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3188 && sym->attr.subroutine)
3190 tree alternate_return;
3191 alternate_return = gfc_get_fake_result_decl (sym, 0);
3192 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3197 /* Jump to the correct entry point. */
3198 tmp = gfc_trans_entry_master_switch (ns->entries);
3199 gfc_add_expr_to_block (&body, tmp);
3202 tmp = gfc_trans_code (ns->code);
3203 gfc_add_expr_to_block (&body, tmp);
3205 /* Add a return label if needed. */
3206 if (current_function_return_label)
3208 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3209 gfc_add_expr_to_block (&body, tmp);
3212 tmp = gfc_finish_block (&body);
3213 /* Add code to create and cleanup arrays. */
3214 tmp = gfc_trans_deferred_vars (sym, tmp);
3216 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3218 if (sym->attr.subroutine || sym == sym->result)
3220 if (current_fake_result_decl != NULL)
3221 result = TREE_VALUE (current_fake_result_decl);
3224 current_fake_result_decl = NULL_TREE;
3227 result = sym->result->backend_decl;
3229 if (result != NULL_TREE && sym->attr.function
3230 && sym->ts.type == BT_DERIVED
3231 && sym->ts.derived->attr.alloc_comp)
3233 rank = sym->as ? sym->as->rank : 0;
3234 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3235 gfc_add_expr_to_block (&block, tmp2);
3238 gfc_add_expr_to_block (&block, tmp);
3240 if (result == NULL_TREE)
3241 warning (0, "Function return value not set");
3244 /* Set the return value to the dummy result variable. */
3245 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
3246 DECL_RESULT (fndecl), result);
3247 tmp = build1_v (RETURN_EXPR, tmp);
3248 gfc_add_expr_to_block (&block, tmp);
3252 gfc_add_expr_to_block (&block, tmp);
3255 /* Add all the decls we created during processing. */
3256 decl = saved_function_decls;
3261 next = TREE_CHAIN (decl);
3262 TREE_CHAIN (decl) = NULL_TREE;
3266 saved_function_decls = NULL_TREE;
3268 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3270 /* Finish off this function and send it for code generation. */
3272 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3274 /* Output the GENERIC tree. */
3275 dump_function (TDI_original, fndecl);
3277 /* Store the end of the function, so that we get good line number
3278 info for the epilogue. */
3279 cfun->function_end_locus = input_location;
3281 /* We're leaving the context of this function, so zap cfun.
3282 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3283 tree_rest_of_compilation. */
3288 pop_function_context ();
3289 saved_function_decls = saved_parent_function_decls;
3291 current_function_decl = old_context;
3293 if (decl_function_context (fndecl))
3294 /* Register this function with cgraph just far enough to get it
3295 added to our parent's nested function list. */
3296 (void) cgraph_node (fndecl);
3299 gfc_gimplify_function (fndecl);
3300 cgraph_finalize_function (fndecl, false);
3305 gfc_generate_constructors (void)
3307 gcc_assert (gfc_static_ctors == NULL_TREE);
3315 if (gfc_static_ctors == NULL_TREE)
3318 fnname = get_file_function_name ("I");
3319 type = build_function_type (void_type_node,
3320 gfc_chainon_list (NULL_TREE, void_type_node));
3322 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3323 TREE_PUBLIC (fndecl) = 1;
3325 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3326 DECL_ARTIFICIAL (decl) = 1;
3327 DECL_IGNORED_P (decl) = 1;
3328 DECL_CONTEXT (decl) = fndecl;
3329 DECL_RESULT (fndecl) = decl;
3333 current_function_decl = fndecl;
3335 rest_of_decl_compilation (fndecl, 1, 0);
3337 make_decl_rtl (fndecl);
3339 init_function_start (fndecl);
3343 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3346 build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
3347 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3352 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3354 free_after_parsing (cfun);
3355 free_after_compilation (cfun);
3357 tree_rest_of_compilation (fndecl);
3359 current_function_decl = NULL_TREE;
3363 /* Translates a BLOCK DATA program unit. This means emitting the
3364 commons contained therein plus their initializations. We also emit
3365 a globally visible symbol to make sure that each BLOCK DATA program
3366 unit remains unique. */
3369 gfc_generate_block_data (gfc_namespace * ns)
3374 /* Tell the backend the source location of the block data. */
3376 gfc_set_backend_locus (&ns->proc_name->declared_at);
3378 gfc_set_backend_locus (&gfc_current_locus);
3380 /* Process the DATA statements. */
3381 gfc_trans_common (ns);
3383 /* Create a global symbol with the mane of the block data. This is to
3384 generate linker errors if the same name is used twice. It is never
3387 id = gfc_sym_mangled_function_id (ns->proc_name);
3389 id = get_identifier ("__BLOCK_DATA__");
3391 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3392 TREE_PUBLIC (decl) = 1;
3393 TREE_STATIC (decl) = 1;
3396 rest_of_decl_compilation (decl, 1, 0);
3400 #include "gt-fortran-trans-decl.h"