Fix ChangeLog
[official-gcc.git] / gcc / fortran / trans-decl.c
blob57914ae7a427e6e651379871ae045d314efce380
1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
3 Foundation, Inc.
4 Contributed by Paul Brook
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
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
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "tree.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
30 #include "ggc.h"
31 #include "toplev.h"
32 #include "tm.h"
33 #include "rtl.h"
34 #include "target.h"
35 #include "function.h"
36 #include "flags.h"
37 #include "cgraph.h"
38 #include "gfortran.h"
39 #include "trans.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 #include "trans-const.h"
43 /* Only for gfc_trans_code. Shouldn't need to include this. */
44 #include "trans-stmt.h"
46 #define MAX_LABEL_VALUE 99999
49 /* Holds the result of the function if no result variable specified. */
51 static GTY(()) tree current_fake_result_decl;
52 static GTY(()) tree parent_fake_result_decl;
54 static GTY(()) tree current_function_return_label;
57 /* Holds the variable DECLs for the current function. */
59 static GTY(()) tree saved_function_decls;
60 static GTY(()) tree saved_parent_function_decls;
63 /* The namespace of the module we're currently generating. Only used while
64 outputting decls for module variables. Do not rely on this being set. */
66 static gfc_namespace *module_namespace;
69 /* List of static constructor functions. */
71 tree gfc_static_ctors;
74 /* Function declarations for builtin library functions. */
76 tree gfor_fndecl_pause_numeric;
77 tree gfor_fndecl_pause_string;
78 tree gfor_fndecl_stop_numeric;
79 tree gfor_fndecl_stop_string;
80 tree gfor_fndecl_runtime_error;
81 tree gfor_fndecl_runtime_error_at;
82 tree gfor_fndecl_os_error;
83 tree gfor_fndecl_generate_error;
84 tree gfor_fndecl_set_fpe;
85 tree gfor_fndecl_set_options;
86 tree gfor_fndecl_set_convert;
87 tree gfor_fndecl_set_record_marker;
88 tree gfor_fndecl_set_max_subrecord_length;
89 tree gfor_fndecl_ctime;
90 tree gfor_fndecl_fdate;
91 tree gfor_fndecl_ttynam;
92 tree gfor_fndecl_in_pack;
93 tree gfor_fndecl_in_unpack;
94 tree gfor_fndecl_associated;
97 /* Math functions. Many other math functions are handled in
98 trans-intrinsic.c. */
100 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
101 tree gfor_fndecl_math_ishftc4;
102 tree gfor_fndecl_math_ishftc8;
103 tree gfor_fndecl_math_ishftc16;
106 /* String functions. */
108 tree gfor_fndecl_compare_string;
109 tree gfor_fndecl_concat_string;
110 tree gfor_fndecl_string_len_trim;
111 tree gfor_fndecl_string_index;
112 tree gfor_fndecl_string_scan;
113 tree gfor_fndecl_string_verify;
114 tree gfor_fndecl_string_trim;
115 tree gfor_fndecl_string_minmax;
116 tree gfor_fndecl_adjustl;
117 tree gfor_fndecl_adjustr;
118 tree gfor_fndecl_select_string;
119 tree gfor_fndecl_compare_string_char4;
120 tree gfor_fndecl_concat_string_char4;
121 tree gfor_fndecl_string_len_trim_char4;
122 tree gfor_fndecl_string_index_char4;
123 tree gfor_fndecl_string_scan_char4;
124 tree gfor_fndecl_string_verify_char4;
125 tree gfor_fndecl_string_trim_char4;
126 tree gfor_fndecl_string_minmax_char4;
127 tree gfor_fndecl_adjustl_char4;
128 tree gfor_fndecl_adjustr_char4;
129 tree gfor_fndecl_select_string_char4;
132 /* Conversion between character kinds. */
133 tree gfor_fndecl_convert_char1_to_char4;
134 tree gfor_fndecl_convert_char4_to_char1;
137 /* Other misc. runtime library functions. */
139 tree gfor_fndecl_size0;
140 tree gfor_fndecl_size1;
141 tree gfor_fndecl_iargc;
143 /* Intrinsic functions implemented in Fortran. */
144 tree gfor_fndecl_sc_kind;
145 tree gfor_fndecl_si_kind;
146 tree gfor_fndecl_sr_kind;
148 /* BLAS gemm functions. */
149 tree gfor_fndecl_sgemm;
150 tree gfor_fndecl_dgemm;
151 tree gfor_fndecl_cgemm;
152 tree gfor_fndecl_zgemm;
155 static void
156 gfc_add_decl_to_parent_function (tree decl)
158 gcc_assert (decl);
159 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
160 DECL_NONLOCAL (decl) = 1;
161 TREE_CHAIN (decl) = saved_parent_function_decls;
162 saved_parent_function_decls = decl;
165 void
166 gfc_add_decl_to_function (tree decl)
168 gcc_assert (decl);
169 TREE_USED (decl) = 1;
170 DECL_CONTEXT (decl) = current_function_decl;
171 TREE_CHAIN (decl) = saved_function_decls;
172 saved_function_decls = decl;
176 /* Build a backend label declaration. Set TREE_USED for named labels.
177 The context of the label is always the current_function_decl. All
178 labels are marked artificial. */
180 tree
181 gfc_build_label_decl (tree label_id)
183 /* 2^32 temporaries should be enough. */
184 static unsigned int tmp_num = 1;
185 tree label_decl;
186 char *label_name;
188 if (label_id == NULL_TREE)
190 /* Build an internal label name. */
191 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
192 label_id = get_identifier (label_name);
194 else
195 label_name = NULL;
197 /* Build the LABEL_DECL node. Labels have no type. */
198 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
199 DECL_CONTEXT (label_decl) = current_function_decl;
200 DECL_MODE (label_decl) = VOIDmode;
202 /* We always define the label as used, even if the original source
203 file never references the label. We don't want all kinds of
204 spurious warnings for old-style Fortran code with too many
205 labels. */
206 TREE_USED (label_decl) = 1;
208 DECL_ARTIFICIAL (label_decl) = 1;
209 return label_decl;
213 /* Returns the return label for the current function. */
215 tree
216 gfc_get_return_label (void)
218 char name[GFC_MAX_SYMBOL_LEN + 10];
220 if (current_function_return_label)
221 return current_function_return_label;
223 sprintf (name, "__return_%s",
224 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
226 current_function_return_label =
227 gfc_build_label_decl (get_identifier (name));
229 DECL_ARTIFICIAL (current_function_return_label) = 1;
231 return current_function_return_label;
235 /* Set the backend source location of a decl. */
237 void
238 gfc_set_decl_location (tree decl, locus * loc)
240 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
244 /* Return the backend label declaration for a given label structure,
245 or create it if it doesn't exist yet. */
247 tree
248 gfc_get_label_decl (gfc_st_label * lp)
250 if (lp->backend_decl)
251 return lp->backend_decl;
252 else
254 char label_name[GFC_MAX_SYMBOL_LEN + 1];
255 tree label_decl;
257 /* Validate the label declaration from the front end. */
258 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
260 /* Build a mangled name for the label. */
261 sprintf (label_name, "__label_%.6d", lp->value);
263 /* Build the LABEL_DECL node. */
264 label_decl = gfc_build_label_decl (get_identifier (label_name));
266 /* Tell the debugger where the label came from. */
267 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
268 gfc_set_decl_location (label_decl, &lp->where);
269 else
270 DECL_ARTIFICIAL (label_decl) = 1;
272 /* Store the label in the label list and return the LABEL_DECL. */
273 lp->backend_decl = label_decl;
274 return label_decl;
279 /* Convert a gfc_symbol to an identifier of the same name. */
281 static tree
282 gfc_sym_identifier (gfc_symbol * sym)
284 return (get_identifier (sym->name));
288 /* Construct mangled name from symbol name. */
290 static tree
291 gfc_sym_mangled_identifier (gfc_symbol * sym)
293 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
295 /* Prevent the mangling of identifiers that have an assigned
296 binding label (mainly those that are bind(c)). */
297 if (sym->attr.is_bind_c == 1
298 && sym->binding_label[0] != '\0')
299 return get_identifier(sym->binding_label);
301 if (sym->module == NULL)
302 return gfc_sym_identifier (sym);
303 else
305 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
306 return get_identifier (name);
311 /* Construct mangled function name from symbol name. */
313 static tree
314 gfc_sym_mangled_function_id (gfc_symbol * sym)
316 int has_underscore;
317 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
319 /* It may be possible to simply use the binding label if it's
320 provided, and remove the other checks. Then we could use it
321 for other things if we wished. */
322 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
323 sym->binding_label[0] != '\0')
324 /* use the binding label rather than the mangled name */
325 return get_identifier (sym->binding_label);
327 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
328 || (sym->module != NULL && (sym->attr.external
329 || sym->attr.if_source == IFSRC_IFBODY)))
331 /* Main program is mangled into MAIN__. */
332 if (sym->attr.is_main_program)
333 return get_identifier ("MAIN__");
335 /* Intrinsic procedures are never mangled. */
336 if (sym->attr.proc == PROC_INTRINSIC)
337 return get_identifier (sym->name);
339 if (gfc_option.flag_underscoring)
341 has_underscore = strchr (sym->name, '_') != 0;
342 if (gfc_option.flag_second_underscore && has_underscore)
343 snprintf (name, sizeof name, "%s__", sym->name);
344 else
345 snprintf (name, sizeof name, "%s_", sym->name);
346 return get_identifier (name);
348 else
349 return get_identifier (sym->name);
351 else
353 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
354 return get_identifier (name);
359 /* Returns true if a variable of specified size should go on the stack. */
362 gfc_can_put_var_on_stack (tree size)
364 unsigned HOST_WIDE_INT low;
366 if (!INTEGER_CST_P (size))
367 return 0;
369 if (gfc_option.flag_max_stack_var_size < 0)
370 return 1;
372 if (TREE_INT_CST_HIGH (size) != 0)
373 return 0;
375 low = TREE_INT_CST_LOW (size);
376 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
377 return 0;
379 /* TODO: Set a per-function stack size limit. */
381 return 1;
385 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
386 an expression involving its corresponding pointer. There are
387 2 cases; one for variable size arrays, and one for everything else,
388 because variable-sized arrays require one fewer level of
389 indirection. */
391 static void
392 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
394 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
395 tree value;
397 /* Parameters need to be dereferenced. */
398 if (sym->cp_pointer->attr.dummy)
399 ptr_decl = build_fold_indirect_ref (ptr_decl);
401 /* Check to see if we're dealing with a variable-sized array. */
402 if (sym->attr.dimension
403 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
405 /* These decls will be dereferenced later, so we don't dereference
406 them here. */
407 value = convert (TREE_TYPE (decl), ptr_decl);
409 else
411 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
412 ptr_decl);
413 value = build_fold_indirect_ref (ptr_decl);
416 SET_DECL_VALUE_EXPR (decl, value);
417 DECL_HAS_VALUE_EXPR_P (decl) = 1;
418 GFC_DECL_CRAY_POINTEE (decl) = 1;
419 /* This is a fake variable just for debugging purposes. */
420 TREE_ASM_WRITTEN (decl) = 1;
424 /* Finish processing of a declaration without an initial value. */
426 static void
427 gfc_finish_decl (tree decl)
429 gcc_assert (TREE_CODE (decl) == PARM_DECL
430 || DECL_INITIAL (decl) == NULL_TREE);
432 if (TREE_CODE (decl) != VAR_DECL)
433 return;
435 if (DECL_SIZE (decl) == NULL_TREE
436 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
437 layout_decl (decl, 0);
439 /* A few consistency checks. */
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
443 message later. */
444 /* An automatic variable with an incomplete type is an error. */
446 /* We should know the storage size. */
447 gcc_assert (DECL_SIZE (decl) != NULL_TREE
448 || (TREE_STATIC (decl)
449 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
450 : DECL_EXTERNAL (decl)));
452 /* The storage size should be constant. */
453 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
454 || !DECL_SIZE (decl)
455 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
459 /* Apply symbol attributes to a variable, and add it to the function scope. */
461 static void
462 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
464 tree new;
465 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
466 This is the equivalent of the TARGET variables.
467 We also need to set this if the variable is passed by reference in a
468 CALL statement. */
470 /* Set DECL_VALUE_EXPR for Cray Pointees. */
471 if (sym->attr.cray_pointee)
472 gfc_finish_cray_pointee (decl, sym);
474 if (sym->attr.target)
475 TREE_ADDRESSABLE (decl) = 1;
476 /* If it wasn't used we wouldn't be getting it. */
477 TREE_USED (decl) = 1;
479 /* Chain this decl to the pending declarations. Don't do pushdecl()
480 because this would add them to the current scope rather than the
481 function scope. */
482 if (current_function_decl != NULL_TREE)
484 if (sym->ns->proc_name->backend_decl == current_function_decl
485 || sym->result == sym)
486 gfc_add_decl_to_function (decl);
487 else
488 gfc_add_decl_to_parent_function (decl);
491 if (sym->attr.cray_pointee)
492 return;
494 if(sym->attr.is_bind_c == 1)
496 /* We need to put variables that are bind(c) into the common
497 segment of the object file, because this is what C would do.
498 gfortran would typically put them in either the BSS or
499 initialized data segments, and only mark them as common if
500 they were part of common blocks. However, if they are not put
501 into common space, then C cannot initialize global fortran
502 variables that it interoperates with and the draft says that
503 either Fortran or C should be able to initialize it (but not
504 both, of course.) (J3/04-007, section 15.3). */
505 TREE_PUBLIC(decl) = 1;
506 DECL_COMMON(decl) = 1;
509 /* If a variable is USE associated, it's always external. */
510 if (sym->attr.use_assoc)
512 DECL_EXTERNAL (decl) = 1;
513 TREE_PUBLIC (decl) = 1;
515 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
517 /* TODO: Don't set sym->module for result or dummy variables. */
518 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
519 /* This is the declaration of a module variable. */
520 TREE_PUBLIC (decl) = 1;
521 TREE_STATIC (decl) = 1;
524 /* Derived types are a bit peculiar because of the possibility of
525 a default initializer; this must be applied each time the variable
526 comes into scope it therefore need not be static. These variables
527 are SAVE_NONE but have an initializer. Otherwise explicitly
528 intitialized variables are SAVE_IMPLICIT and explicitly saved are
529 SAVE_EXPLICIT. */
530 if (!sym->attr.use_assoc
531 && (sym->attr.save != SAVE_NONE || sym->attr.data
532 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
533 TREE_STATIC (decl) = 1;
535 if (sym->attr.volatile_)
537 TREE_THIS_VOLATILE (decl) = 1;
538 new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
539 TREE_TYPE (decl) = new;
542 /* Keep variables larger than max-stack-var-size off stack. */
543 if (!sym->ns->proc_name->attr.recursive
544 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
545 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
546 /* Put variable length auto array pointers always into stack. */
547 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
548 || sym->attr.dimension == 0
549 || sym->as->type != AS_EXPLICIT
550 || sym->attr.pointer
551 || sym->attr.allocatable)
552 && !DECL_ARTIFICIAL (decl))
553 TREE_STATIC (decl) = 1;
555 /* Handle threadprivate variables. */
556 if (sym->attr.threadprivate
557 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
558 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
562 /* Allocate the lang-specific part of a decl. */
564 void
565 gfc_allocate_lang_decl (tree decl)
567 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
568 ggc_alloc_cleared (sizeof (struct lang_decl));
571 /* Remember a symbol to generate initialization/cleanup code at function
572 entry/exit. */
574 static void
575 gfc_defer_symbol_init (gfc_symbol * sym)
577 gfc_symbol *p;
578 gfc_symbol *last;
579 gfc_symbol *head;
581 /* Don't add a symbol twice. */
582 if (sym->tlink)
583 return;
585 last = head = sym->ns->proc_name;
586 p = last->tlink;
588 /* Make sure that setup code for dummy variables which are used in the
589 setup of other variables is generated first. */
590 if (sym->attr.dummy)
592 /* Find the first dummy arg seen after us, or the first non-dummy arg.
593 This is a circular list, so don't go past the head. */
594 while (p != head
595 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
597 last = p;
598 p = p->tlink;
601 /* Insert in between last and p. */
602 last->tlink = sym;
603 sym->tlink = p;
607 /* Create an array index type variable with function scope. */
609 static tree
610 create_index_var (const char * pfx, int nest)
612 tree decl;
614 decl = gfc_create_var_np (gfc_array_index_type, pfx);
615 if (nest)
616 gfc_add_decl_to_parent_function (decl);
617 else
618 gfc_add_decl_to_function (decl);
619 return decl;
623 /* Create variables to hold all the non-constant bits of info for a
624 descriptorless array. Remember these in the lang-specific part of the
625 type. */
627 static void
628 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
630 tree type;
631 int dim;
632 int nest;
634 type = TREE_TYPE (decl);
636 /* We just use the descriptor, if there is one. */
637 if (GFC_DESCRIPTOR_TYPE_P (type))
638 return;
640 gcc_assert (GFC_ARRAY_TYPE_P (type));
641 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
642 && !sym->attr.contained;
644 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
646 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
648 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
649 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
651 /* Don't try to use the unknown bound for assumed shape arrays. */
652 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
653 && (sym->as->type != AS_ASSUMED_SIZE
654 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
656 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
657 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
660 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
662 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
663 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
666 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
668 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
669 "offset");
670 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
672 if (nest)
673 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
674 else
675 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
678 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
679 && sym->as->type != AS_ASSUMED_SIZE)
681 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
682 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
685 if (POINTER_TYPE_P (type))
687 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
688 gcc_assert (TYPE_LANG_SPECIFIC (type)
689 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
690 type = TREE_TYPE (type);
693 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
695 tree size, range;
697 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
698 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
699 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
700 size);
701 TYPE_DOMAIN (type) = range;
702 layout_type (type);
707 /* For some dummy arguments we don't use the actual argument directly.
708 Instead we create a local decl and use that. This allows us to perform
709 initialization, and construct full type information. */
711 static tree
712 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
714 tree decl;
715 tree type;
716 gfc_array_spec *as;
717 char *name;
718 gfc_packed packed;
719 int n;
720 bool known_size;
722 if (sym->attr.pointer || sym->attr.allocatable)
723 return dummy;
725 /* Add to list of variables if not a fake result variable. */
726 if (sym->attr.result || sym->attr.dummy)
727 gfc_defer_symbol_init (sym);
729 type = TREE_TYPE (dummy);
730 gcc_assert (TREE_CODE (dummy) == PARM_DECL
731 && POINTER_TYPE_P (type));
733 /* Do we know the element size? */
734 known_size = sym->ts.type != BT_CHARACTER
735 || INTEGER_CST_P (sym->ts.cl->backend_decl);
737 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
739 /* For descriptorless arrays with known element size the actual
740 argument is sufficient. */
741 gcc_assert (GFC_ARRAY_TYPE_P (type));
742 gfc_build_qualified_array (dummy, sym);
743 return dummy;
746 type = TREE_TYPE (type);
747 if (GFC_DESCRIPTOR_TYPE_P (type))
749 /* Create a descriptorless array pointer. */
750 as = sym->as;
751 packed = PACKED_NO;
753 /* Even when -frepack-arrays is used, symbols with TARGET attribute
754 are not repacked. */
755 if (!gfc_option.flag_repack_arrays || sym->attr.target)
757 if (as->type == AS_ASSUMED_SIZE)
758 packed = PACKED_FULL;
760 else
762 if (as->type == AS_EXPLICIT)
764 packed = PACKED_FULL;
765 for (n = 0; n < as->rank; n++)
767 if (!(as->upper[n]
768 && as->lower[n]
769 && as->upper[n]->expr_type == EXPR_CONSTANT
770 && as->lower[n]->expr_type == EXPR_CONSTANT))
771 packed = PACKED_PARTIAL;
774 else
775 packed = PACKED_PARTIAL;
778 type = gfc_typenode_for_spec (&sym->ts);
779 type = gfc_get_nodesc_array_type (type, sym->as, packed);
781 else
783 /* We now have an expression for the element size, so create a fully
784 qualified type. Reset sym->backend decl or this will just return the
785 old type. */
786 DECL_ARTIFICIAL (sym->backend_decl) = 1;
787 sym->backend_decl = NULL_TREE;
788 type = gfc_sym_type (sym);
789 packed = PACKED_FULL;
792 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
793 decl = build_decl (VAR_DECL, get_identifier (name), type);
795 DECL_ARTIFICIAL (decl) = 1;
796 TREE_PUBLIC (decl) = 0;
797 TREE_STATIC (decl) = 0;
798 DECL_EXTERNAL (decl) = 0;
800 /* We should never get deferred shape arrays here. We used to because of
801 frontend bugs. */
802 gcc_assert (sym->as->type != AS_DEFERRED);
804 if (packed == PACKED_PARTIAL)
805 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
806 else if (packed == PACKED_FULL)
807 GFC_DECL_PACKED_ARRAY (decl) = 1;
809 gfc_build_qualified_array (decl, sym);
811 if (DECL_LANG_SPECIFIC (dummy))
812 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
813 else
814 gfc_allocate_lang_decl (decl);
816 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
818 if (sym->ns->proc_name->backend_decl == current_function_decl
819 || sym->attr.contained)
820 gfc_add_decl_to_function (decl);
821 else
822 gfc_add_decl_to_parent_function (decl);
824 return decl;
828 /* Return a constant or a variable to use as a string length. Does not
829 add the decl to the current scope. */
831 static tree
832 gfc_create_string_length (gfc_symbol * sym)
834 tree length;
836 gcc_assert (sym->ts.cl);
837 gfc_conv_const_charlen (sym->ts.cl);
839 if (sym->ts.cl->backend_decl == NULL_TREE)
841 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
843 /* Also prefix the mangled name. */
844 strcpy (&name[1], sym->name);
845 name[0] = '.';
846 length = build_decl (VAR_DECL, get_identifier (name),
847 gfc_charlen_type_node);
848 DECL_ARTIFICIAL (length) = 1;
849 TREE_USED (length) = 1;
850 if (sym->ns->proc_name->tlink != NULL)
851 gfc_defer_symbol_init (sym);
852 sym->ts.cl->backend_decl = length;
855 return sym->ts.cl->backend_decl;
858 /* If a variable is assigned a label, we add another two auxiliary
859 variables. */
861 static void
862 gfc_add_assign_aux_vars (gfc_symbol * sym)
864 tree addr;
865 tree length;
866 tree decl;
868 gcc_assert (sym->backend_decl);
870 decl = sym->backend_decl;
871 gfc_allocate_lang_decl (decl);
872 GFC_DECL_ASSIGN (decl) = 1;
873 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
874 gfc_charlen_type_node);
875 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
876 pvoid_type_node);
877 gfc_finish_var_decl (length, sym);
878 gfc_finish_var_decl (addr, sym);
879 /* STRING_LENGTH is also used as flag. Less than -1 means that
880 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
881 target label's address. Otherwise, value is the length of a format string
882 and ASSIGN_ADDR is its address. */
883 if (TREE_STATIC (length))
884 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
885 else
886 gfc_defer_symbol_init (sym);
888 GFC_DECL_STRING_LEN (decl) = length;
889 GFC_DECL_ASSIGN_ADDR (decl) = addr;
892 /* Return the decl for a gfc_symbol, create it if it doesn't already
893 exist. */
895 tree
896 gfc_get_symbol_decl (gfc_symbol * sym)
898 tree decl;
899 tree length = NULL_TREE;
900 int byref;
902 gcc_assert (sym->attr.referenced
903 || sym->attr.use_assoc
904 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
906 if (sym->ns && sym->ns->proc_name->attr.function)
907 byref = gfc_return_by_reference (sym->ns->proc_name);
908 else
909 byref = 0;
911 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
913 /* Return via extra parameter. */
914 if (sym->attr.result && byref
915 && !sym->backend_decl)
917 sym->backend_decl =
918 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
919 /* For entry master function skip over the __entry
920 argument. */
921 if (sym->ns->proc_name->attr.entry_master)
922 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
925 /* Dummy variables should already have been created. */
926 gcc_assert (sym->backend_decl);
928 /* Create a character length variable. */
929 if (sym->ts.type == BT_CHARACTER)
931 if (sym->ts.cl->backend_decl == NULL_TREE)
932 length = gfc_create_string_length (sym);
933 else
934 length = sym->ts.cl->backend_decl;
935 if (TREE_CODE (length) == VAR_DECL
936 && DECL_CONTEXT (length) == NULL_TREE)
938 /* Add the string length to the same context as the symbol. */
939 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
940 gfc_add_decl_to_function (length);
941 else
942 gfc_add_decl_to_parent_function (length);
944 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
945 DECL_CONTEXT (length));
947 gfc_defer_symbol_init (sym);
951 /* Use a copy of the descriptor for dummy arrays. */
952 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
954 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
955 /* Prevent the dummy from being detected as unused if it is copied. */
956 if (sym->backend_decl != NULL && decl != sym->backend_decl)
957 DECL_ARTIFICIAL (sym->backend_decl) = 1;
958 sym->backend_decl = decl;
961 TREE_USED (sym->backend_decl) = 1;
962 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
964 gfc_add_assign_aux_vars (sym);
966 return sym->backend_decl;
969 if (sym->backend_decl)
970 return sym->backend_decl;
972 /* Catch function declarations. Only used for actual parameters. */
973 if (sym->attr.flavor == FL_PROCEDURE)
975 decl = gfc_get_extern_function_decl (sym);
976 return decl;
979 if (sym->attr.intrinsic)
980 internal_error ("intrinsic variable which isn't a procedure");
982 /* Create string length decl first so that they can be used in the
983 type declaration. */
984 if (sym->ts.type == BT_CHARACTER)
985 length = gfc_create_string_length (sym);
987 /* Create the decl for the variable. */
988 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
990 gfc_set_decl_location (decl, &sym->declared_at);
992 /* Symbols from modules should have their assembler names mangled.
993 This is done here rather than in gfc_finish_var_decl because it
994 is different for string length variables. */
995 if (sym->module)
996 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
998 if (sym->attr.dimension)
1000 /* Create variables to hold the non-constant bits of array info. */
1001 gfc_build_qualified_array (decl, sym);
1003 /* Remember this variable for allocation/cleanup. */
1004 gfc_defer_symbol_init (sym);
1006 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1007 GFC_DECL_PACKED_ARRAY (decl) = 1;
1010 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1011 gfc_defer_symbol_init (sym);
1012 /* This applies a derived type default initializer. */
1013 else if (sym->ts.type == BT_DERIVED
1014 && sym->attr.save == SAVE_NONE
1015 && !sym->attr.data
1016 && !sym->attr.allocatable
1017 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1018 && !sym->attr.use_assoc)
1019 gfc_defer_symbol_init (sym);
1021 gfc_finish_var_decl (decl, sym);
1023 if (sym->ts.type == BT_CHARACTER)
1025 /* Character variables need special handling. */
1026 gfc_allocate_lang_decl (decl);
1028 if (TREE_CODE (length) != INTEGER_CST)
1030 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1032 if (sym->module)
1034 /* Also prefix the mangled name for symbols from modules. */
1035 strcpy (&name[1], sym->name);
1036 name[0] = '.';
1037 strcpy (&name[1],
1038 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1039 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1041 gfc_finish_var_decl (length, sym);
1042 gcc_assert (!sym->value);
1045 else if (sym->attr.subref_array_pointer)
1047 /* We need the span for these beasts. */
1048 gfc_allocate_lang_decl (decl);
1051 if (sym->attr.subref_array_pointer)
1053 tree span;
1054 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1055 span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1056 gfc_array_index_type);
1057 gfc_finish_var_decl (span, sym);
1058 TREE_STATIC (span) = 1;
1059 DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
1061 GFC_DECL_SPAN (decl) = span;
1064 sym->backend_decl = decl;
1066 if (sym->attr.assign)
1067 gfc_add_assign_aux_vars (sym);
1069 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1071 /* Add static initializer. */
1072 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1073 TREE_TYPE (decl), sym->attr.dimension,
1074 sym->attr.pointer || sym->attr.allocatable);
1077 return decl;
1081 /* Substitute a temporary variable in place of the real one. */
1083 void
1084 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1086 save->attr = sym->attr;
1087 save->decl = sym->backend_decl;
1089 gfc_clear_attr (&sym->attr);
1090 sym->attr.referenced = 1;
1091 sym->attr.flavor = FL_VARIABLE;
1093 sym->backend_decl = decl;
1097 /* Restore the original variable. */
1099 void
1100 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1102 sym->attr = save->attr;
1103 sym->backend_decl = save->decl;
1107 /* Get a basic decl for an external function. */
1109 tree
1110 gfc_get_extern_function_decl (gfc_symbol * sym)
1112 tree type;
1113 tree fndecl;
1114 gfc_expr e;
1115 gfc_intrinsic_sym *isym;
1116 gfc_expr argexpr;
1117 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1118 tree name;
1119 tree mangled_name;
1121 if (sym->backend_decl)
1122 return sym->backend_decl;
1124 /* We should never be creating external decls for alternate entry points.
1125 The procedure may be an alternate entry point, but we don't want/need
1126 to know that. */
1127 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1129 if (sym->attr.intrinsic)
1131 /* Call the resolution function to get the actual name. This is
1132 a nasty hack which relies on the resolution functions only looking
1133 at the first argument. We pass NULL for the second argument
1134 otherwise things like AINT get confused. */
1135 isym = gfc_find_function (sym->name);
1136 gcc_assert (isym->resolve.f0 != NULL);
1138 memset (&e, 0, sizeof (e));
1139 e.expr_type = EXPR_FUNCTION;
1141 memset (&argexpr, 0, sizeof (argexpr));
1142 gcc_assert (isym->formal);
1143 argexpr.ts = isym->formal->ts;
1145 if (isym->formal->next == NULL)
1146 isym->resolve.f1 (&e, &argexpr);
1147 else
1149 if (isym->formal->next->next == NULL)
1150 isym->resolve.f2 (&e, &argexpr, NULL);
1151 else
1153 if (isym->formal->next->next->next == NULL)
1154 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1155 else
1157 /* All specific intrinsics take less than 5 arguments. */
1158 gcc_assert (isym->formal->next->next->next->next == NULL);
1159 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1164 if (gfc_option.flag_f2c
1165 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1166 || e.ts.type == BT_COMPLEX))
1168 /* Specific which needs a different implementation if f2c
1169 calling conventions are used. */
1170 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1172 else
1173 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1175 name = get_identifier (s);
1176 mangled_name = name;
1178 else
1180 name = gfc_sym_identifier (sym);
1181 mangled_name = gfc_sym_mangled_function_id (sym);
1184 type = gfc_get_function_type (sym);
1185 fndecl = build_decl (FUNCTION_DECL, name, type);
1187 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1188 /* If the return type is a pointer, avoid alias issues by setting
1189 DECL_IS_MALLOC to nonzero. This means that the function should be
1190 treated as if it were a malloc, meaning it returns a pointer that
1191 is not an alias. */
1192 if (POINTER_TYPE_P (type))
1193 DECL_IS_MALLOC (fndecl) = 1;
1195 /* Set the context of this decl. */
1196 if (0 && sym->ns && sym->ns->proc_name)
1198 /* TODO: Add external decls to the appropriate scope. */
1199 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1201 else
1203 /* Global declaration, e.g. intrinsic subroutine. */
1204 DECL_CONTEXT (fndecl) = NULL_TREE;
1207 DECL_EXTERNAL (fndecl) = 1;
1209 /* This specifies if a function is globally addressable, i.e. it is
1210 the opposite of declaring static in C. */
1211 TREE_PUBLIC (fndecl) = 1;
1213 /* Set attributes for PURE functions. A call to PURE function in the
1214 Fortran 95 sense is both pure and without side effects in the C
1215 sense. */
1216 if (sym->attr.pure || sym->attr.elemental)
1218 if (sym->attr.function && !gfc_return_by_reference (sym))
1219 DECL_PURE_P (fndecl) = 1;
1220 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1221 parameters and don't use alternate returns (is this
1222 allowed?). In that case, calls to them are meaningless, and
1223 can be optimized away. See also in build_function_decl(). */
1224 TREE_SIDE_EFFECTS (fndecl) = 0;
1227 /* Mark non-returning functions. */
1228 if (sym->attr.noreturn)
1229 TREE_THIS_VOLATILE(fndecl) = 1;
1231 sym->backend_decl = fndecl;
1233 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1234 pushdecl_top_level (fndecl);
1236 return fndecl;
1240 /* Create a declaration for a procedure. For external functions (in the C
1241 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1242 a master function with alternate entry points. */
1244 static void
1245 build_function_decl (gfc_symbol * sym)
1247 tree fndecl, type;
1248 symbol_attribute attr;
1249 tree result_decl;
1250 gfc_formal_arglist *f;
1252 gcc_assert (!sym->backend_decl);
1253 gcc_assert (!sym->attr.external);
1255 /* Set the line and filename. sym->declared_at seems to point to the
1256 last statement for subroutines, but it'll do for now. */
1257 gfc_set_backend_locus (&sym->declared_at);
1259 /* Allow only one nesting level. Allow public declarations. */
1260 gcc_assert (current_function_decl == NULL_TREE
1261 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1263 type = gfc_get_function_type (sym);
1264 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1266 /* Perform name mangling if this is a top level or module procedure. */
1267 if (current_function_decl == NULL_TREE)
1268 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1270 /* Figure out the return type of the declared function, and build a
1271 RESULT_DECL for it. If this is a subroutine with alternate
1272 returns, build a RESULT_DECL for it. */
1273 attr = sym->attr;
1275 result_decl = NULL_TREE;
1276 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1277 if (attr.function)
1279 if (gfc_return_by_reference (sym))
1280 type = void_type_node;
1281 else
1283 if (sym->result != sym)
1284 result_decl = gfc_sym_identifier (sym->result);
1286 type = TREE_TYPE (TREE_TYPE (fndecl));
1289 else
1291 /* Look for alternate return placeholders. */
1292 int has_alternate_returns = 0;
1293 for (f = sym->formal; f; f = f->next)
1295 if (f->sym == NULL)
1297 has_alternate_returns = 1;
1298 break;
1302 if (has_alternate_returns)
1303 type = integer_type_node;
1304 else
1305 type = void_type_node;
1308 result_decl = build_decl (RESULT_DECL, result_decl, type);
1309 DECL_ARTIFICIAL (result_decl) = 1;
1310 DECL_IGNORED_P (result_decl) = 1;
1311 DECL_CONTEXT (result_decl) = fndecl;
1312 DECL_RESULT (fndecl) = result_decl;
1314 /* Don't call layout_decl for a RESULT_DECL.
1315 layout_decl (result_decl, 0); */
1317 /* If the return type is a pointer, avoid alias issues by setting
1318 DECL_IS_MALLOC to nonzero. This means that the function should be
1319 treated as if it were a malloc, meaning it returns a pointer that
1320 is not an alias. */
1321 if (POINTER_TYPE_P (type))
1322 DECL_IS_MALLOC (fndecl) = 1;
1324 /* Set up all attributes for the function. */
1325 DECL_CONTEXT (fndecl) = current_function_decl;
1326 DECL_EXTERNAL (fndecl) = 0;
1328 /* This specifies if a function is globally visible, i.e. it is
1329 the opposite of declaring static in C. */
1330 if (DECL_CONTEXT (fndecl) == NULL_TREE
1331 && !sym->attr.entry_master)
1332 TREE_PUBLIC (fndecl) = 1;
1334 /* TREE_STATIC means the function body is defined here. */
1335 TREE_STATIC (fndecl) = 1;
1337 /* Set attributes for PURE functions. A call to a PURE function in the
1338 Fortran 95 sense is both pure and without side effects in the C
1339 sense. */
1340 if (attr.pure || attr.elemental)
1342 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1343 including an alternate return. In that case it can also be
1344 marked as PURE. See also in gfc_get_extern_function_decl(). */
1345 if (attr.function && !gfc_return_by_reference (sym))
1346 DECL_PURE_P (fndecl) = 1;
1347 TREE_SIDE_EFFECTS (fndecl) = 0;
1350 /* For -fwhole-program to work well, the main program needs to have the
1351 "externally_visible" attribute. */
1352 if (attr.is_main_program)
1353 DECL_ATTRIBUTES (fndecl)
1354 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
1356 /* Layout the function declaration and put it in the binding level
1357 of the current function. */
1358 pushdecl (fndecl);
1360 sym->backend_decl = fndecl;
1364 /* Create the DECL_ARGUMENTS for a procedure. */
1366 static void
1367 create_function_arglist (gfc_symbol * sym)
1369 tree fndecl;
1370 gfc_formal_arglist *f;
1371 tree typelist, hidden_typelist;
1372 tree arglist, hidden_arglist;
1373 tree type;
1374 tree parm;
1376 fndecl = sym->backend_decl;
1378 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1379 the new FUNCTION_DECL node. */
1380 arglist = NULL_TREE;
1381 hidden_arglist = NULL_TREE;
1382 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1384 if (sym->attr.entry_master)
1386 type = TREE_VALUE (typelist);
1387 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1389 DECL_CONTEXT (parm) = fndecl;
1390 DECL_ARG_TYPE (parm) = type;
1391 TREE_READONLY (parm) = 1;
1392 gfc_finish_decl (parm);
1393 DECL_ARTIFICIAL (parm) = 1;
1395 arglist = chainon (arglist, parm);
1396 typelist = TREE_CHAIN (typelist);
1399 if (gfc_return_by_reference (sym))
1401 tree type = TREE_VALUE (typelist), length = NULL;
1403 if (sym->ts.type == BT_CHARACTER)
1405 /* Length of character result. */
1406 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1407 gcc_assert (len_type == gfc_charlen_type_node);
1409 length = build_decl (PARM_DECL,
1410 get_identifier (".__result"),
1411 len_type);
1412 if (!sym->ts.cl->length)
1414 sym->ts.cl->backend_decl = length;
1415 TREE_USED (length) = 1;
1417 gcc_assert (TREE_CODE (length) == PARM_DECL);
1418 DECL_CONTEXT (length) = fndecl;
1419 DECL_ARG_TYPE (length) = len_type;
1420 TREE_READONLY (length) = 1;
1421 DECL_ARTIFICIAL (length) = 1;
1422 gfc_finish_decl (length);
1423 if (sym->ts.cl->backend_decl == NULL
1424 || sym->ts.cl->backend_decl == length)
1426 gfc_symbol *arg;
1427 tree backend_decl;
1429 if (sym->ts.cl->backend_decl == NULL)
1431 tree len = build_decl (VAR_DECL,
1432 get_identifier ("..__result"),
1433 gfc_charlen_type_node);
1434 DECL_ARTIFICIAL (len) = 1;
1435 TREE_USED (len) = 1;
1436 sym->ts.cl->backend_decl = len;
1439 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1440 arg = sym->result ? sym->result : sym;
1441 backend_decl = arg->backend_decl;
1442 /* Temporary clear it, so that gfc_sym_type creates complete
1443 type. */
1444 arg->backend_decl = NULL;
1445 type = gfc_sym_type (arg);
1446 arg->backend_decl = backend_decl;
1447 type = build_reference_type (type);
1451 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1453 DECL_CONTEXT (parm) = fndecl;
1454 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1455 TREE_READONLY (parm) = 1;
1456 DECL_ARTIFICIAL (parm) = 1;
1457 gfc_finish_decl (parm);
1459 arglist = chainon (arglist, parm);
1460 typelist = TREE_CHAIN (typelist);
1462 if (sym->ts.type == BT_CHARACTER)
1464 gfc_allocate_lang_decl (parm);
1465 arglist = chainon (arglist, length);
1466 typelist = TREE_CHAIN (typelist);
1470 hidden_typelist = typelist;
1471 for (f = sym->formal; f; f = f->next)
1472 if (f->sym != NULL) /* Ignore alternate returns. */
1473 hidden_typelist = TREE_CHAIN (hidden_typelist);
1475 for (f = sym->formal; f; f = f->next)
1477 char name[GFC_MAX_SYMBOL_LEN + 2];
1479 /* Ignore alternate returns. */
1480 if (f->sym == NULL)
1481 continue;
1483 type = TREE_VALUE (typelist);
1485 if (f->sym->ts.type == BT_CHARACTER)
1487 tree len_type = TREE_VALUE (hidden_typelist);
1488 tree length = NULL_TREE;
1489 gcc_assert (len_type == gfc_charlen_type_node);
1491 strcpy (&name[1], f->sym->name);
1492 name[0] = '_';
1493 length = build_decl (PARM_DECL, get_identifier (name), len_type);
1495 hidden_arglist = chainon (hidden_arglist, length);
1496 DECL_CONTEXT (length) = fndecl;
1497 DECL_ARTIFICIAL (length) = 1;
1498 DECL_ARG_TYPE (length) = len_type;
1499 TREE_READONLY (length) = 1;
1500 gfc_finish_decl (length);
1502 /* TODO: Check string lengths when -fbounds-check. */
1504 /* Use the passed value for assumed length variables. */
1505 if (!f->sym->ts.cl->length)
1507 TREE_USED (length) = 1;
1508 gcc_assert (!f->sym->ts.cl->backend_decl);
1509 f->sym->ts.cl->backend_decl = length;
1512 hidden_typelist = TREE_CHAIN (hidden_typelist);
1514 if (f->sym->ts.cl->backend_decl == NULL
1515 || f->sym->ts.cl->backend_decl == length)
1517 if (f->sym->ts.cl->backend_decl == NULL)
1518 gfc_create_string_length (f->sym);
1520 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1521 if (f->sym->attr.flavor == FL_PROCEDURE)
1522 type = build_pointer_type (gfc_get_function_type (f->sym));
1523 else
1524 type = gfc_sym_type (f->sym);
1528 /* For non-constant length array arguments, make sure they use
1529 a different type node from TYPE_ARG_TYPES type. */
1530 if (f->sym->attr.dimension
1531 && type == TREE_VALUE (typelist)
1532 && TREE_CODE (type) == POINTER_TYPE
1533 && GFC_ARRAY_TYPE_P (type)
1534 && f->sym->as->type != AS_ASSUMED_SIZE
1535 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1537 if (f->sym->attr.flavor == FL_PROCEDURE)
1538 type = build_pointer_type (gfc_get_function_type (f->sym));
1539 else
1540 type = gfc_sym_type (f->sym);
1543 /* Build a the argument declaration. */
1544 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1546 /* Fill in arg stuff. */
1547 DECL_CONTEXT (parm) = fndecl;
1548 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1549 /* All implementation args are read-only. */
1550 TREE_READONLY (parm) = 1;
1552 gfc_finish_decl (parm);
1554 f->sym->backend_decl = parm;
1556 arglist = chainon (arglist, parm);
1557 typelist = TREE_CHAIN (typelist);
1560 /* Add the hidden string length parameters, unless the procedure
1561 is bind(C). */
1562 if (!sym->attr.is_bind_c)
1563 arglist = chainon (arglist, hidden_arglist);
1565 gcc_assert (hidden_typelist == NULL_TREE
1566 || TREE_VALUE (hidden_typelist) == void_type_node);
1567 DECL_ARGUMENTS (fndecl) = arglist;
1570 /* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1572 static void
1573 gfc_gimplify_function (tree fndecl)
1575 struct cgraph_node *cgn;
1577 gimplify_function_tree (fndecl);
1578 dump_function (TDI_generic, fndecl);
1580 /* Generate errors for structured block violations. */
1581 /* ??? Could be done as part of resolve_labels. */
1582 if (flag_openmp)
1583 diagnose_omp_structured_block_errors (fndecl);
1585 /* Convert all nested functions to GIMPLE now. We do things in this order
1586 so that items like VLA sizes are expanded properly in the context of the
1587 correct function. */
1588 cgn = cgraph_node (fndecl);
1589 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1590 gfc_gimplify_function (cgn->decl);
1594 /* Do the setup necessary before generating the body of a function. */
1596 static void
1597 trans_function_start (gfc_symbol * sym)
1599 tree fndecl;
1601 fndecl = sym->backend_decl;
1603 /* Let GCC know the current scope is this function. */
1604 current_function_decl = fndecl;
1606 /* Let the world know what we're about to do. */
1607 announce_function (fndecl);
1609 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1611 /* Create RTL for function declaration. */
1612 rest_of_decl_compilation (fndecl, 1, 0);
1615 /* Create RTL for function definition. */
1616 make_decl_rtl (fndecl);
1618 init_function_start (fndecl);
1620 /* Even though we're inside a function body, we still don't want to
1621 call expand_expr to calculate the size of a variable-sized array.
1622 We haven't necessarily assigned RTL to all variables yet, so it's
1623 not safe to try to expand expressions involving them. */
1624 cfun->dont_save_pending_sizes_p = 1;
1626 /* function.c requires a push at the start of the function. */
1627 pushlevel (0);
1630 /* Create thunks for alternate entry points. */
1632 static void
1633 build_entry_thunks (gfc_namespace * ns)
1635 gfc_formal_arglist *formal;
1636 gfc_formal_arglist *thunk_formal;
1637 gfc_entry_list *el;
1638 gfc_symbol *thunk_sym;
1639 stmtblock_t body;
1640 tree thunk_fndecl;
1641 tree args;
1642 tree string_args;
1643 tree tmp;
1644 locus old_loc;
1646 /* This should always be a toplevel function. */
1647 gcc_assert (current_function_decl == NULL_TREE);
1649 gfc_get_backend_locus (&old_loc);
1650 for (el = ns->entries; el; el = el->next)
1652 thunk_sym = el->sym;
1654 build_function_decl (thunk_sym);
1655 create_function_arglist (thunk_sym);
1657 trans_function_start (thunk_sym);
1659 thunk_fndecl = thunk_sym->backend_decl;
1661 gfc_start_block (&body);
1663 /* Pass extra parameter identifying this entry point. */
1664 tmp = build_int_cst (gfc_array_index_type, el->id);
1665 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1666 string_args = NULL_TREE;
1668 if (thunk_sym->attr.function)
1670 if (gfc_return_by_reference (ns->proc_name))
1672 tree ref = DECL_ARGUMENTS (current_function_decl);
1673 args = tree_cons (NULL_TREE, ref, args);
1674 if (ns->proc_name->ts.type == BT_CHARACTER)
1675 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1676 args);
1680 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1682 /* Ignore alternate returns. */
1683 if (formal->sym == NULL)
1684 continue;
1686 /* We don't have a clever way of identifying arguments, so resort to
1687 a brute-force search. */
1688 for (thunk_formal = thunk_sym->formal;
1689 thunk_formal;
1690 thunk_formal = thunk_formal->next)
1692 if (thunk_formal->sym == formal->sym)
1693 break;
1696 if (thunk_formal)
1698 /* Pass the argument. */
1699 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1700 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1701 args);
1702 if (formal->sym->ts.type == BT_CHARACTER)
1704 tmp = thunk_formal->sym->ts.cl->backend_decl;
1705 string_args = tree_cons (NULL_TREE, tmp, string_args);
1708 else
1710 /* Pass NULL for a missing argument. */
1711 args = tree_cons (NULL_TREE, null_pointer_node, args);
1712 if (formal->sym->ts.type == BT_CHARACTER)
1714 tmp = build_int_cst (gfc_charlen_type_node, 0);
1715 string_args = tree_cons (NULL_TREE, tmp, string_args);
1720 /* Call the master function. */
1721 args = nreverse (args);
1722 args = chainon (args, nreverse (string_args));
1723 tmp = ns->proc_name->backend_decl;
1724 tmp = build_function_call_expr (tmp, args);
1725 if (ns->proc_name->attr.mixed_entry_master)
1727 tree union_decl, field;
1728 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1730 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1731 TREE_TYPE (master_type));
1732 DECL_ARTIFICIAL (union_decl) = 1;
1733 DECL_EXTERNAL (union_decl) = 0;
1734 TREE_PUBLIC (union_decl) = 0;
1735 TREE_USED (union_decl) = 1;
1736 layout_decl (union_decl, 0);
1737 pushdecl (union_decl);
1739 DECL_CONTEXT (union_decl) = current_function_decl;
1740 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1741 union_decl, tmp);
1742 gfc_add_expr_to_block (&body, tmp);
1744 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1745 field; field = TREE_CHAIN (field))
1746 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1747 thunk_sym->result->name) == 0)
1748 break;
1749 gcc_assert (field != NULL_TREE);
1750 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1751 union_decl, field, NULL_TREE);
1752 tmp = fold_build2 (MODIFY_EXPR,
1753 TREE_TYPE (DECL_RESULT (current_function_decl)),
1754 DECL_RESULT (current_function_decl), tmp);
1755 tmp = build1_v (RETURN_EXPR, tmp);
1757 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1758 != void_type_node)
1760 tmp = fold_build2 (MODIFY_EXPR,
1761 TREE_TYPE (DECL_RESULT (current_function_decl)),
1762 DECL_RESULT (current_function_decl), tmp);
1763 tmp = build1_v (RETURN_EXPR, tmp);
1765 gfc_add_expr_to_block (&body, tmp);
1767 /* Finish off this function and send it for code generation. */
1768 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1769 poplevel (1, 0, 1);
1770 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1772 /* Output the GENERIC tree. */
1773 dump_function (TDI_original, thunk_fndecl);
1775 /* Store the end of the function, so that we get good line number
1776 info for the epilogue. */
1777 cfun->function_end_locus = input_location;
1779 /* We're leaving the context of this function, so zap cfun.
1780 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1781 tree_rest_of_compilation. */
1782 set_cfun (NULL);
1784 current_function_decl = NULL_TREE;
1786 gfc_gimplify_function (thunk_fndecl);
1787 cgraph_finalize_function (thunk_fndecl, false);
1789 /* We share the symbols in the formal argument list with other entry
1790 points and the master function. Clear them so that they are
1791 recreated for each function. */
1792 for (formal = thunk_sym->formal; formal; formal = formal->next)
1793 if (formal->sym != NULL) /* Ignore alternate returns. */
1795 formal->sym->backend_decl = NULL_TREE;
1796 if (formal->sym->ts.type == BT_CHARACTER)
1797 formal->sym->ts.cl->backend_decl = NULL_TREE;
1800 if (thunk_sym->attr.function)
1802 if (thunk_sym->ts.type == BT_CHARACTER)
1803 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1804 if (thunk_sym->result->ts.type == BT_CHARACTER)
1805 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1809 gfc_set_backend_locus (&old_loc);
1813 /* Create a decl for a function, and create any thunks for alternate entry
1814 points. */
1816 void
1817 gfc_create_function_decl (gfc_namespace * ns)
1819 /* Create a declaration for the master function. */
1820 build_function_decl (ns->proc_name);
1822 /* Compile the entry thunks. */
1823 if (ns->entries)
1824 build_entry_thunks (ns);
1826 /* Now create the read argument list. */
1827 create_function_arglist (ns->proc_name);
1830 /* Return the decl used to hold the function return value. If
1831 parent_flag is set, the context is the parent_scope. */
1833 tree
1834 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1836 tree decl;
1837 tree length;
1838 tree this_fake_result_decl;
1839 tree this_function_decl;
1841 char name[GFC_MAX_SYMBOL_LEN + 10];
1843 if (parent_flag)
1845 this_fake_result_decl = parent_fake_result_decl;
1846 this_function_decl = DECL_CONTEXT (current_function_decl);
1848 else
1850 this_fake_result_decl = current_fake_result_decl;
1851 this_function_decl = current_function_decl;
1854 if (sym
1855 && sym->ns->proc_name->backend_decl == this_function_decl
1856 && sym->ns->proc_name->attr.entry_master
1857 && sym != sym->ns->proc_name)
1859 tree t = NULL, var;
1860 if (this_fake_result_decl != NULL)
1861 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1862 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1863 break;
1864 if (t)
1865 return TREE_VALUE (t);
1866 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1868 if (parent_flag)
1869 this_fake_result_decl = parent_fake_result_decl;
1870 else
1871 this_fake_result_decl = current_fake_result_decl;
1873 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1875 tree field;
1877 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1878 field; field = TREE_CHAIN (field))
1879 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1880 sym->name) == 0)
1881 break;
1883 gcc_assert (field != NULL_TREE);
1884 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1885 decl, field, NULL_TREE);
1888 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1889 if (parent_flag)
1890 gfc_add_decl_to_parent_function (var);
1891 else
1892 gfc_add_decl_to_function (var);
1894 SET_DECL_VALUE_EXPR (var, decl);
1895 DECL_HAS_VALUE_EXPR_P (var) = 1;
1896 GFC_DECL_RESULT (var) = 1;
1898 TREE_CHAIN (this_fake_result_decl)
1899 = tree_cons (get_identifier (sym->name), var,
1900 TREE_CHAIN (this_fake_result_decl));
1901 return var;
1904 if (this_fake_result_decl != NULL_TREE)
1905 return TREE_VALUE (this_fake_result_decl);
1907 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1908 sym is NULL. */
1909 if (!sym)
1910 return NULL_TREE;
1912 if (sym->ts.type == BT_CHARACTER)
1914 if (sym->ts.cl->backend_decl == NULL_TREE)
1915 length = gfc_create_string_length (sym);
1916 else
1917 length = sym->ts.cl->backend_decl;
1918 if (TREE_CODE (length) == VAR_DECL
1919 && DECL_CONTEXT (length) == NULL_TREE)
1920 gfc_add_decl_to_function (length);
1923 if (gfc_return_by_reference (sym))
1925 decl = DECL_ARGUMENTS (this_function_decl);
1927 if (sym->ns->proc_name->backend_decl == this_function_decl
1928 && sym->ns->proc_name->attr.entry_master)
1929 decl = TREE_CHAIN (decl);
1931 TREE_USED (decl) = 1;
1932 if (sym->as)
1933 decl = gfc_build_dummy_array_decl (sym, decl);
1935 else
1937 sprintf (name, "__result_%.20s",
1938 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1940 if (!sym->attr.mixed_entry_master && sym->attr.function)
1941 decl = build_decl (VAR_DECL, get_identifier (name),
1942 gfc_sym_type (sym));
1943 else
1944 decl = build_decl (VAR_DECL, get_identifier (name),
1945 TREE_TYPE (TREE_TYPE (this_function_decl)));
1946 DECL_ARTIFICIAL (decl) = 1;
1947 DECL_EXTERNAL (decl) = 0;
1948 TREE_PUBLIC (decl) = 0;
1949 TREE_USED (decl) = 1;
1950 GFC_DECL_RESULT (decl) = 1;
1951 TREE_ADDRESSABLE (decl) = 1;
1953 layout_decl (decl, 0);
1955 if (parent_flag)
1956 gfc_add_decl_to_parent_function (decl);
1957 else
1958 gfc_add_decl_to_function (decl);
1961 if (parent_flag)
1962 parent_fake_result_decl = build_tree_list (NULL, decl);
1963 else
1964 current_fake_result_decl = build_tree_list (NULL, decl);
1966 return decl;
1970 /* Builds a function decl. The remaining parameters are the types of the
1971 function arguments. Negative nargs indicates a varargs function. */
1973 tree
1974 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1976 tree arglist;
1977 tree argtype;
1978 tree fntype;
1979 tree fndecl;
1980 va_list p;
1981 int n;
1983 /* Library functions must be declared with global scope. */
1984 gcc_assert (current_function_decl == NULL_TREE);
1986 va_start (p, nargs);
1989 /* Create a list of the argument types. */
1990 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1992 argtype = va_arg (p, tree);
1993 arglist = gfc_chainon_list (arglist, argtype);
1996 if (nargs >= 0)
1998 /* Terminate the list. */
1999 arglist = gfc_chainon_list (arglist, void_type_node);
2002 /* Build the function type and decl. */
2003 fntype = build_function_type (rettype, arglist);
2004 fndecl = build_decl (FUNCTION_DECL, name, fntype);
2006 /* Mark this decl as external. */
2007 DECL_EXTERNAL (fndecl) = 1;
2008 TREE_PUBLIC (fndecl) = 1;
2010 va_end (p);
2012 pushdecl (fndecl);
2014 rest_of_decl_compilation (fndecl, 1, 0);
2016 return fndecl;
2019 static void
2020 gfc_build_intrinsic_function_decls (void)
2022 tree gfc_int4_type_node = gfc_get_int_type (4);
2023 tree gfc_int8_type_node = gfc_get_int_type (8);
2024 tree gfc_int16_type_node = gfc_get_int_type (16);
2025 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2026 tree pchar1_type_node = gfc_get_pchar_type (1);
2027 tree pchar4_type_node = gfc_get_pchar_type (4);
2029 /* String functions. */
2030 gfor_fndecl_compare_string =
2031 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2032 integer_type_node, 4,
2033 gfc_charlen_type_node, pchar1_type_node,
2034 gfc_charlen_type_node, pchar1_type_node);
2036 gfor_fndecl_concat_string =
2037 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2038 void_type_node, 6,
2039 gfc_charlen_type_node, pchar1_type_node,
2040 gfc_charlen_type_node, pchar1_type_node,
2041 gfc_charlen_type_node, pchar1_type_node);
2043 gfor_fndecl_string_len_trim =
2044 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2045 gfc_int4_type_node, 2,
2046 gfc_charlen_type_node, pchar1_type_node);
2048 gfor_fndecl_string_index =
2049 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2050 gfc_int4_type_node, 5,
2051 gfc_charlen_type_node, pchar1_type_node,
2052 gfc_charlen_type_node, pchar1_type_node,
2053 gfc_logical4_type_node);
2055 gfor_fndecl_string_scan =
2056 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2057 gfc_int4_type_node, 5,
2058 gfc_charlen_type_node, pchar1_type_node,
2059 gfc_charlen_type_node, pchar1_type_node,
2060 gfc_logical4_type_node);
2062 gfor_fndecl_string_verify =
2063 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2064 gfc_int4_type_node, 5,
2065 gfc_charlen_type_node, pchar1_type_node,
2066 gfc_charlen_type_node, pchar1_type_node,
2067 gfc_logical4_type_node);
2069 gfor_fndecl_string_trim =
2070 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2071 void_type_node, 4,
2072 build_pointer_type (gfc_charlen_type_node),
2073 build_pointer_type (pchar1_type_node),
2074 gfc_charlen_type_node, pchar1_type_node);
2076 gfor_fndecl_string_minmax =
2077 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2078 void_type_node, -4,
2079 build_pointer_type (gfc_charlen_type_node),
2080 build_pointer_type (pchar1_type_node),
2081 integer_type_node, integer_type_node);
2083 gfor_fndecl_adjustl =
2084 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2085 void_type_node, 3, pchar1_type_node,
2086 gfc_charlen_type_node, pchar1_type_node);
2088 gfor_fndecl_adjustr =
2089 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2090 void_type_node, 3, pchar1_type_node,
2091 gfc_charlen_type_node, pchar1_type_node);
2093 gfor_fndecl_select_string =
2094 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2095 integer_type_node, 4, pvoid_type_node,
2096 integer_type_node, pchar1_type_node,
2097 gfc_charlen_type_node);
2099 gfor_fndecl_compare_string_char4 =
2100 gfc_build_library_function_decl (get_identifier
2101 (PREFIX("compare_string_char4")),
2102 integer_type_node, 4,
2103 gfc_charlen_type_node, pchar4_type_node,
2104 gfc_charlen_type_node, pchar4_type_node);
2106 gfor_fndecl_concat_string_char4 =
2107 gfc_build_library_function_decl (get_identifier
2108 (PREFIX("concat_string_char4")),
2109 void_type_node, 6,
2110 gfc_charlen_type_node, pchar4_type_node,
2111 gfc_charlen_type_node, pchar4_type_node,
2112 gfc_charlen_type_node, pchar4_type_node);
2114 gfor_fndecl_string_len_trim_char4 =
2115 gfc_build_library_function_decl (get_identifier
2116 (PREFIX("string_len_trim_char4")),
2117 gfc_charlen_type_node, 2,
2118 gfc_charlen_type_node, pchar4_type_node);
2120 gfor_fndecl_string_index_char4 =
2121 gfc_build_library_function_decl (get_identifier
2122 (PREFIX("string_index_char4")),
2123 gfc_charlen_type_node, 5,
2124 gfc_charlen_type_node, pchar4_type_node,
2125 gfc_charlen_type_node, pchar4_type_node,
2126 gfc_logical4_type_node);
2128 gfor_fndecl_string_scan_char4 =
2129 gfc_build_library_function_decl (get_identifier
2130 (PREFIX("string_scan_char4")),
2131 gfc_charlen_type_node, 5,
2132 gfc_charlen_type_node, pchar4_type_node,
2133 gfc_charlen_type_node, pchar4_type_node,
2134 gfc_logical4_type_node);
2136 gfor_fndecl_string_verify_char4 =
2137 gfc_build_library_function_decl (get_identifier
2138 (PREFIX("string_verify_char4")),
2139 gfc_charlen_type_node, 5,
2140 gfc_charlen_type_node, pchar4_type_node,
2141 gfc_charlen_type_node, pchar4_type_node,
2142 gfc_logical4_type_node);
2144 gfor_fndecl_string_trim_char4 =
2145 gfc_build_library_function_decl (get_identifier
2146 (PREFIX("string_trim_char4")),
2147 void_type_node, 4,
2148 build_pointer_type (gfc_charlen_type_node),
2149 build_pointer_type (pchar4_type_node),
2150 gfc_charlen_type_node, pchar4_type_node);
2152 gfor_fndecl_string_minmax_char4 =
2153 gfc_build_library_function_decl (get_identifier
2154 (PREFIX("string_minmax_char4")),
2155 void_type_node, -4,
2156 build_pointer_type (gfc_charlen_type_node),
2157 build_pointer_type (pchar4_type_node),
2158 integer_type_node, integer_type_node);
2160 gfor_fndecl_adjustl_char4 =
2161 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2162 void_type_node, 3, pchar4_type_node,
2163 gfc_charlen_type_node, pchar4_type_node);
2165 gfor_fndecl_adjustr_char4 =
2166 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2167 void_type_node, 3, pchar4_type_node,
2168 gfc_charlen_type_node, pchar4_type_node);
2170 gfor_fndecl_select_string_char4 =
2171 gfc_build_library_function_decl (get_identifier
2172 (PREFIX("select_string_char4")),
2173 integer_type_node, 4, pvoid_type_node,
2174 integer_type_node, pvoid_type_node,
2175 gfc_charlen_type_node);
2178 /* Conversion between character kinds. */
2180 gfor_fndecl_convert_char1_to_char4 =
2181 gfc_build_library_function_decl (get_identifier
2182 (PREFIX("convert_char1_to_char4")),
2183 void_type_node, 3,
2184 build_pointer_type (pchar4_type_node),
2185 gfc_charlen_type_node, pchar1_type_node);
2187 gfor_fndecl_convert_char4_to_char1 =
2188 gfc_build_library_function_decl (get_identifier
2189 (PREFIX("convert_char4_to_char1")),
2190 void_type_node, 3,
2191 build_pointer_type (pchar1_type_node),
2192 gfc_charlen_type_node, pchar4_type_node);
2194 /* Misc. functions. */
2196 gfor_fndecl_ttynam =
2197 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2198 void_type_node,
2200 pchar_type_node,
2201 gfc_charlen_type_node,
2202 integer_type_node);
2204 gfor_fndecl_fdate =
2205 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2206 void_type_node,
2208 pchar_type_node,
2209 gfc_charlen_type_node);
2211 gfor_fndecl_ctime =
2212 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2213 void_type_node,
2215 pchar_type_node,
2216 gfc_charlen_type_node,
2217 gfc_int8_type_node);
2219 gfor_fndecl_sc_kind =
2220 gfc_build_library_function_decl (get_identifier
2221 (PREFIX("selected_char_kind")),
2222 gfc_int4_type_node, 2,
2223 gfc_charlen_type_node, pchar_type_node);
2225 gfor_fndecl_si_kind =
2226 gfc_build_library_function_decl (get_identifier
2227 (PREFIX("selected_int_kind")),
2228 gfc_int4_type_node, 1, pvoid_type_node);
2230 gfor_fndecl_sr_kind =
2231 gfc_build_library_function_decl (get_identifier
2232 (PREFIX("selected_real_kind")),
2233 gfc_int4_type_node, 2,
2234 pvoid_type_node, pvoid_type_node);
2236 /* Power functions. */
2238 tree ctype, rtype, itype, jtype;
2239 int rkind, ikind, jkind;
2240 #define NIKINDS 3
2241 #define NRKINDS 4
2242 static int ikinds[NIKINDS] = {4, 8, 16};
2243 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2244 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2246 for (ikind=0; ikind < NIKINDS; ikind++)
2248 itype = gfc_get_int_type (ikinds[ikind]);
2250 for (jkind=0; jkind < NIKINDS; jkind++)
2252 jtype = gfc_get_int_type (ikinds[jkind]);
2253 if (itype && jtype)
2255 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2256 ikinds[jkind]);
2257 gfor_fndecl_math_powi[jkind][ikind].integer =
2258 gfc_build_library_function_decl (get_identifier (name),
2259 jtype, 2, jtype, itype);
2260 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2264 for (rkind = 0; rkind < NRKINDS; rkind ++)
2266 rtype = gfc_get_real_type (rkinds[rkind]);
2267 if (rtype && itype)
2269 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2270 ikinds[ikind]);
2271 gfor_fndecl_math_powi[rkind][ikind].real =
2272 gfc_build_library_function_decl (get_identifier (name),
2273 rtype, 2, rtype, itype);
2274 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2277 ctype = gfc_get_complex_type (rkinds[rkind]);
2278 if (ctype && itype)
2280 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2281 ikinds[ikind]);
2282 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2283 gfc_build_library_function_decl (get_identifier (name),
2284 ctype, 2,ctype, itype);
2285 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2289 #undef NIKINDS
2290 #undef NRKINDS
2293 gfor_fndecl_math_ishftc4 =
2294 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2295 gfc_int4_type_node,
2296 3, gfc_int4_type_node,
2297 gfc_int4_type_node, gfc_int4_type_node);
2298 gfor_fndecl_math_ishftc8 =
2299 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2300 gfc_int8_type_node,
2301 3, gfc_int8_type_node,
2302 gfc_int4_type_node, gfc_int4_type_node);
2303 if (gfc_int16_type_node)
2304 gfor_fndecl_math_ishftc16 =
2305 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2306 gfc_int16_type_node, 3,
2307 gfc_int16_type_node,
2308 gfc_int4_type_node,
2309 gfc_int4_type_node);
2311 /* BLAS functions. */
2313 tree pint = build_pointer_type (integer_type_node);
2314 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2315 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2316 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2317 tree pz = build_pointer_type
2318 (gfc_get_complex_type (gfc_default_double_kind));
2320 gfor_fndecl_sgemm = gfc_build_library_function_decl
2321 (get_identifier
2322 (gfc_option.flag_underscoring ? "sgemm_"
2323 : "sgemm"),
2324 void_type_node, 15, pchar_type_node,
2325 pchar_type_node, pint, pint, pint, ps, ps, pint,
2326 ps, pint, ps, ps, pint, integer_type_node,
2327 integer_type_node);
2328 gfor_fndecl_dgemm = gfc_build_library_function_decl
2329 (get_identifier
2330 (gfc_option.flag_underscoring ? "dgemm_"
2331 : "dgemm"),
2332 void_type_node, 15, pchar_type_node,
2333 pchar_type_node, pint, pint, pint, pd, pd, pint,
2334 pd, pint, pd, pd, pint, integer_type_node,
2335 integer_type_node);
2336 gfor_fndecl_cgemm = gfc_build_library_function_decl
2337 (get_identifier
2338 (gfc_option.flag_underscoring ? "cgemm_"
2339 : "cgemm"),
2340 void_type_node, 15, pchar_type_node,
2341 pchar_type_node, pint, pint, pint, pc, pc, pint,
2342 pc, pint, pc, pc, pint, integer_type_node,
2343 integer_type_node);
2344 gfor_fndecl_zgemm = gfc_build_library_function_decl
2345 (get_identifier
2346 (gfc_option.flag_underscoring ? "zgemm_"
2347 : "zgemm"),
2348 void_type_node, 15, pchar_type_node,
2349 pchar_type_node, pint, pint, pint, pz, pz, pint,
2350 pz, pint, pz, pz, pint, integer_type_node,
2351 integer_type_node);
2354 /* Other functions. */
2355 gfor_fndecl_size0 =
2356 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2357 gfc_array_index_type,
2358 1, pvoid_type_node);
2359 gfor_fndecl_size1 =
2360 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2361 gfc_array_index_type,
2362 2, pvoid_type_node,
2363 gfc_array_index_type);
2365 gfor_fndecl_iargc =
2366 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2367 gfc_int4_type_node,
2372 /* Make prototypes for runtime library functions. */
2374 void
2375 gfc_build_builtin_function_decls (void)
2377 tree gfc_int4_type_node = gfc_get_int_type (4);
2379 gfor_fndecl_stop_numeric =
2380 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2381 void_type_node, 1, gfc_int4_type_node);
2382 /* Stop doesn't return. */
2383 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2385 gfor_fndecl_stop_string =
2386 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2387 void_type_node, 2, pchar_type_node,
2388 gfc_int4_type_node);
2389 /* Stop doesn't return. */
2390 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2392 gfor_fndecl_pause_numeric =
2393 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2394 void_type_node, 1, gfc_int4_type_node);
2396 gfor_fndecl_pause_string =
2397 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2398 void_type_node, 2, pchar_type_node,
2399 gfc_int4_type_node);
2401 gfor_fndecl_runtime_error =
2402 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2403 void_type_node, -1, pchar_type_node);
2404 /* The runtime_error function does not return. */
2405 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2407 gfor_fndecl_runtime_error_at =
2408 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2409 void_type_node, -2, pchar_type_node,
2410 pchar_type_node);
2411 /* The runtime_error_at function does not return. */
2412 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2414 gfor_fndecl_generate_error =
2415 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2416 void_type_node, 3, pvoid_type_node,
2417 integer_type_node, pchar_type_node);
2419 gfor_fndecl_os_error =
2420 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2421 void_type_node, 1, pchar_type_node);
2422 /* The runtime_error function does not return. */
2423 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2425 gfor_fndecl_set_fpe =
2426 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2427 void_type_node, 1, integer_type_node);
2429 /* Keep the array dimension in sync with the call, later in this file. */
2430 gfor_fndecl_set_options =
2431 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2432 void_type_node, 2, integer_type_node,
2433 pvoid_type_node);
2435 gfor_fndecl_set_convert =
2436 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2437 void_type_node, 1, integer_type_node);
2439 gfor_fndecl_set_record_marker =
2440 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2441 void_type_node, 1, integer_type_node);
2443 gfor_fndecl_set_max_subrecord_length =
2444 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2445 void_type_node, 1, integer_type_node);
2447 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2448 get_identifier (PREFIX("internal_pack")),
2449 pvoid_type_node, 1, pvoid_type_node);
2451 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2452 get_identifier (PREFIX("internal_unpack")),
2453 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2455 gfor_fndecl_associated =
2456 gfc_build_library_function_decl (
2457 get_identifier (PREFIX("associated")),
2458 integer_type_node, 2, ppvoid_type_node,
2459 ppvoid_type_node);
2461 gfc_build_intrinsic_function_decls ();
2462 gfc_build_intrinsic_lib_fndecls ();
2463 gfc_build_io_library_fndecls ();
2467 /* Evaluate the length of dummy character variables. */
2469 static tree
2470 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2472 stmtblock_t body;
2474 gfc_finish_decl (cl->backend_decl);
2476 gfc_start_block (&body);
2478 /* Evaluate the string length expression. */
2479 gfc_conv_string_length (cl, &body);
2481 gfc_trans_vla_type_sizes (sym, &body);
2483 gfc_add_expr_to_block (&body, fnbody);
2484 return gfc_finish_block (&body);
2488 /* Allocate and cleanup an automatic character variable. */
2490 static tree
2491 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2493 stmtblock_t body;
2494 tree decl;
2495 tree tmp;
2497 gcc_assert (sym->backend_decl);
2498 gcc_assert (sym->ts.cl && sym->ts.cl->length);
2500 gfc_start_block (&body);
2502 /* Evaluate the string length expression. */
2503 gfc_conv_string_length (sym->ts.cl, &body);
2505 gfc_trans_vla_type_sizes (sym, &body);
2507 decl = sym->backend_decl;
2509 /* Emit a DECL_EXPR for this variable, which will cause the
2510 gimplifier to allocate storage, and all that good stuff. */
2511 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2512 gfc_add_expr_to_block (&body, tmp);
2514 gfc_add_expr_to_block (&body, fnbody);
2515 return gfc_finish_block (&body);
2518 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2520 static tree
2521 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2523 stmtblock_t body;
2525 gcc_assert (sym->backend_decl);
2526 gfc_start_block (&body);
2528 /* Set the initial value to length. See the comments in
2529 function gfc_add_assign_aux_vars in this file. */
2530 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2531 build_int_cst (NULL_TREE, -2));
2533 gfc_add_expr_to_block (&body, fnbody);
2534 return gfc_finish_block (&body);
2537 static void
2538 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2540 tree t = *tp, var, val;
2542 if (t == NULL || t == error_mark_node)
2543 return;
2544 if (TREE_CONSTANT (t) || DECL_P (t))
2545 return;
2547 if (TREE_CODE (t) == SAVE_EXPR)
2549 if (SAVE_EXPR_RESOLVED_P (t))
2551 *tp = TREE_OPERAND (t, 0);
2552 return;
2554 val = TREE_OPERAND (t, 0);
2556 else
2557 val = t;
2559 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2560 gfc_add_decl_to_function (var);
2561 gfc_add_modify_expr (body, var, val);
2562 if (TREE_CODE (t) == SAVE_EXPR)
2563 TREE_OPERAND (t, 0) = var;
2564 *tp = var;
2567 static void
2568 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2570 tree t;
2572 if (type == NULL || type == error_mark_node)
2573 return;
2575 type = TYPE_MAIN_VARIANT (type);
2577 if (TREE_CODE (type) == INTEGER_TYPE)
2579 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2580 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2582 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2584 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2585 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2588 else if (TREE_CODE (type) == ARRAY_TYPE)
2590 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2591 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2592 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2593 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2595 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2597 TYPE_SIZE (t) = TYPE_SIZE (type);
2598 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2603 /* Make sure all type sizes and array domains are either constant,
2604 or variable or parameter decls. This is a simplified variant
2605 of gimplify_type_sizes, but we can't use it here, as none of the
2606 variables in the expressions have been gimplified yet.
2607 As type sizes and domains for various variable length arrays
2608 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2609 time, without this routine gimplify_type_sizes in the middle-end
2610 could result in the type sizes being gimplified earlier than where
2611 those variables are initialized. */
2613 void
2614 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2616 tree type = TREE_TYPE (sym->backend_decl);
2618 if (TREE_CODE (type) == FUNCTION_TYPE
2619 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2621 if (! current_fake_result_decl)
2622 return;
2624 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2627 while (POINTER_TYPE_P (type))
2628 type = TREE_TYPE (type);
2630 if (GFC_DESCRIPTOR_TYPE_P (type))
2632 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2634 while (POINTER_TYPE_P (etype))
2635 etype = TREE_TYPE (etype);
2637 gfc_trans_vla_type_sizes_1 (etype, body);
2640 gfc_trans_vla_type_sizes_1 (type, body);
2644 /* Initialize a derived type by building an lvalue from the symbol
2645 and using trans_assignment to do the work. */
2646 tree
2647 gfc_init_default_dt (gfc_symbol * sym, tree body)
2649 stmtblock_t fnblock;
2650 gfc_expr *e;
2651 tree tmp;
2652 tree present;
2654 gfc_init_block (&fnblock);
2655 gcc_assert (!sym->attr.allocatable);
2656 gfc_set_sym_referenced (sym);
2657 e = gfc_lval_expr_from_sym (sym);
2658 tmp = gfc_trans_assignment (e, sym->value, false);
2659 if (sym->attr.dummy)
2661 present = gfc_conv_expr_present (sym);
2662 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2663 tmp, build_empty_stmt ());
2665 gfc_add_expr_to_block (&fnblock, tmp);
2666 gfc_free_expr (e);
2667 if (body)
2668 gfc_add_expr_to_block (&fnblock, body);
2669 return gfc_finish_block (&fnblock);
2673 /* Initialize INTENT(OUT) derived type dummies. */
2674 static tree
2675 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2677 stmtblock_t fnblock;
2678 gfc_formal_arglist *f;
2680 gfc_init_block (&fnblock);
2681 for (f = proc_sym->formal; f; f = f->next)
2682 if (f->sym && f->sym->attr.intent == INTENT_OUT
2683 && f->sym->ts.type == BT_DERIVED
2684 && !f->sym->ts.derived->attr.alloc_comp
2685 && f->sym->value)
2686 body = gfc_init_default_dt (f->sym, body);
2688 gfc_add_expr_to_block (&fnblock, body);
2689 return gfc_finish_block (&fnblock);
2693 /* Generate function entry and exit code, and add it to the function body.
2694 This includes:
2695 Allocation and initialization of array variables.
2696 Allocation of character string variables.
2697 Initialization and possibly repacking of dummy arrays.
2698 Initialization of ASSIGN statement auxiliary variable. */
2700 static tree
2701 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2703 locus loc;
2704 gfc_symbol *sym;
2705 gfc_formal_arglist *f;
2706 stmtblock_t body;
2707 bool seen_trans_deferred_array = false;
2709 /* Deal with implicit return variables. Explicit return variables will
2710 already have been added. */
2711 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2713 if (!current_fake_result_decl)
2715 gfc_entry_list *el = NULL;
2716 if (proc_sym->attr.entry_master)
2718 for (el = proc_sym->ns->entries; el; el = el->next)
2719 if (el->sym != el->sym->result)
2720 break;
2722 /* TODO: move to the appropriate place in resolve.c. */
2723 if (warn_return_type && el == NULL)
2724 gfc_warning ("Return value of function '%s' at %L not set",
2725 proc_sym->name, &proc_sym->declared_at);
2727 else if (proc_sym->as)
2729 tree result = TREE_VALUE (current_fake_result_decl);
2730 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2732 /* An automatic character length, pointer array result. */
2733 if (proc_sym->ts.type == BT_CHARACTER
2734 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2735 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2736 fnbody);
2738 else if (proc_sym->ts.type == BT_CHARACTER)
2740 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2741 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2742 fnbody);
2744 else
2745 gcc_assert (gfc_option.flag_f2c
2746 && proc_sym->ts.type == BT_COMPLEX);
2749 /* Initialize the INTENT(OUT) derived type dummy arguments. This
2750 should be done here so that the offsets and lbounds of arrays
2751 are available. */
2752 fnbody = init_intent_out_dt (proc_sym, fnbody);
2754 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2756 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2757 && sym->ts.derived->attr.alloc_comp;
2758 if (sym->attr.dimension)
2760 switch (sym->as->type)
2762 case AS_EXPLICIT:
2763 if (sym->attr.dummy || sym->attr.result)
2764 fnbody =
2765 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2766 else if (sym->attr.pointer || sym->attr.allocatable)
2768 if (TREE_STATIC (sym->backend_decl))
2769 gfc_trans_static_array_pointer (sym);
2770 else
2772 seen_trans_deferred_array = true;
2773 fnbody = gfc_trans_deferred_array (sym, fnbody);
2776 else
2778 if (sym_has_alloc_comp)
2780 seen_trans_deferred_array = true;
2781 fnbody = gfc_trans_deferred_array (sym, fnbody);
2783 else if (sym->ts.type == BT_DERIVED
2784 && sym->value
2785 && !sym->attr.data
2786 && sym->attr.save == SAVE_NONE)
2787 fnbody = gfc_init_default_dt (sym, fnbody);
2789 gfc_get_backend_locus (&loc);
2790 gfc_set_backend_locus (&sym->declared_at);
2791 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2792 sym, fnbody);
2793 gfc_set_backend_locus (&loc);
2795 break;
2797 case AS_ASSUMED_SIZE:
2798 /* Must be a dummy parameter. */
2799 gcc_assert (sym->attr.dummy);
2801 /* We should always pass assumed size arrays the g77 way. */
2802 fnbody = gfc_trans_g77_array (sym, fnbody);
2803 break;
2805 case AS_ASSUMED_SHAPE:
2806 /* Must be a dummy parameter. */
2807 gcc_assert (sym->attr.dummy);
2809 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2810 fnbody);
2811 break;
2813 case AS_DEFERRED:
2814 seen_trans_deferred_array = true;
2815 fnbody = gfc_trans_deferred_array (sym, fnbody);
2816 break;
2818 default:
2819 gcc_unreachable ();
2821 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2822 fnbody = gfc_trans_deferred_array (sym, fnbody);
2824 else if (sym_has_alloc_comp)
2825 fnbody = gfc_trans_deferred_array (sym, fnbody);
2826 else if (sym->ts.type == BT_CHARACTER)
2828 gfc_get_backend_locus (&loc);
2829 gfc_set_backend_locus (&sym->declared_at);
2830 if (sym->attr.dummy || sym->attr.result)
2831 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2832 else
2833 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2834 gfc_set_backend_locus (&loc);
2836 else if (sym->attr.assign)
2838 gfc_get_backend_locus (&loc);
2839 gfc_set_backend_locus (&sym->declared_at);
2840 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2841 gfc_set_backend_locus (&loc);
2843 else if (sym->ts.type == BT_DERIVED
2844 && sym->value
2845 && !sym->attr.data
2846 && sym->attr.save == SAVE_NONE)
2847 fnbody = gfc_init_default_dt (sym, fnbody);
2848 else
2849 gcc_unreachable ();
2852 gfc_init_block (&body);
2854 for (f = proc_sym->formal; f; f = f->next)
2856 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2858 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2859 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2860 gfc_trans_vla_type_sizes (f->sym, &body);
2864 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2865 && current_fake_result_decl != NULL)
2867 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2868 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2869 gfc_trans_vla_type_sizes (proc_sym, &body);
2872 gfc_add_expr_to_block (&body, fnbody);
2873 return gfc_finish_block (&body);
2877 /* Output an initialized decl for a module variable. */
2879 static void
2880 gfc_create_module_variable (gfc_symbol * sym)
2882 tree decl;
2884 /* Module functions with alternate entries are dealt with later and
2885 would get caught by the next condition. */
2886 if (sym->attr.entry)
2887 return;
2889 /* Make sure we convert the types of the derived types from iso_c_binding
2890 into (void *). */
2891 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2892 && sym->ts.type == BT_DERIVED)
2893 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2895 /* Only output variables and array valued, or derived type,
2896 parameters. */
2897 if (sym->attr.flavor != FL_VARIABLE
2898 && !(sym->attr.flavor == FL_PARAMETER
2899 && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
2900 return;
2902 /* Don't generate variables from other modules. Variables from
2903 COMMONs will already have been generated. */
2904 if (sym->attr.use_assoc || sym->attr.in_common)
2905 return;
2907 /* Equivalenced variables arrive here after creation. */
2908 if (sym->backend_decl
2909 && (sym->equiv_built || sym->attr.in_equivalence))
2910 return;
2912 if (sym->backend_decl)
2913 internal_error ("backend decl for module variable %s already exists",
2914 sym->name);
2916 /* We always want module variables to be created. */
2917 sym->attr.referenced = 1;
2918 /* Create the decl. */
2919 decl = gfc_get_symbol_decl (sym);
2921 /* Create the variable. */
2922 pushdecl (decl);
2923 rest_of_decl_compilation (decl, 1, 0);
2925 /* Also add length of strings. */
2926 if (sym->ts.type == BT_CHARACTER)
2928 tree length;
2930 length = sym->ts.cl->backend_decl;
2931 if (!INTEGER_CST_P (length))
2933 pushdecl (length);
2934 rest_of_decl_compilation (length, 1, 0);
2940 /* Generate all the required code for module variables. */
2942 void
2943 gfc_generate_module_vars (gfc_namespace * ns)
2945 module_namespace = ns;
2947 /* Check if the frontend left the namespace in a reasonable state. */
2948 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2950 /* Generate COMMON blocks. */
2951 gfc_trans_common (ns);
2953 /* Create decls for all the module variables. */
2954 gfc_traverse_ns (ns, gfc_create_module_variable);
2957 static void
2958 gfc_generate_contained_functions (gfc_namespace * parent)
2960 gfc_namespace *ns;
2962 /* We create all the prototypes before generating any code. */
2963 for (ns = parent->contained; ns; ns = ns->sibling)
2965 /* Skip namespaces from used modules. */
2966 if (ns->parent != parent)
2967 continue;
2969 gfc_create_function_decl (ns);
2972 for (ns = parent->contained; ns; ns = ns->sibling)
2974 /* Skip namespaces from used modules. */
2975 if (ns->parent != parent)
2976 continue;
2978 gfc_generate_function_code (ns);
2983 /* Drill down through expressions for the array specification bounds and
2984 character length calling generate_local_decl for all those variables
2985 that have not already been declared. */
2987 static void
2988 generate_local_decl (gfc_symbol *);
2990 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2992 static bool
2993 expr_decls (gfc_expr *e, gfc_symbol *sym,
2994 int *f ATTRIBUTE_UNUSED)
2996 if (e->expr_type != EXPR_VARIABLE
2997 || sym == e->symtree->n.sym
2998 || e->symtree->n.sym->mark
2999 || e->symtree->n.sym->ns != sym->ns)
3000 return false;
3002 generate_local_decl (e->symtree->n.sym);
3003 return false;
3006 static void
3007 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3009 gfc_traverse_expr (e, sym, expr_decls, 0);
3013 /* Check for dependencies in the character length and array spec. */
3015 static void
3016 generate_dependency_declarations (gfc_symbol *sym)
3018 int i;
3020 if (sym->ts.type == BT_CHARACTER
3021 && sym->ts.cl
3022 && sym->ts.cl->length
3023 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3024 generate_expr_decls (sym, sym->ts.cl->length);
3026 if (sym->as && sym->as->rank)
3028 for (i = 0; i < sym->as->rank; i++)
3030 generate_expr_decls (sym, sym->as->lower[i]);
3031 generate_expr_decls (sym, sym->as->upper[i]);
3037 /* Generate decls for all local variables. We do this to ensure correct
3038 handling of expressions which only appear in the specification of
3039 other functions. */
3041 static void
3042 generate_local_decl (gfc_symbol * sym)
3044 if (sym->attr.flavor == FL_VARIABLE)
3046 /* Check for dependencies in the array specification and string
3047 length, adding the necessary declarations to the function. We
3048 mark the symbol now, as well as in traverse_ns, to prevent
3049 getting stuck in a circular dependency. */
3050 sym->mark = 1;
3051 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3052 generate_dependency_declarations (sym);
3054 if (sym->attr.referenced)
3055 gfc_get_symbol_decl (sym);
3056 /* INTENT(out) dummy arguments are likely meant to be set. */
3057 else if (warn_unused_variable
3058 && sym->attr.dummy
3059 && sym->attr.intent == INTENT_OUT)
3060 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3061 sym->name, &sym->declared_at);
3062 /* Specific warning for unused dummy arguments. */
3063 else if (warn_unused_variable && sym->attr.dummy)
3064 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3065 &sym->declared_at);
3066 /* Warn for unused variables, but not if they're inside a common
3067 block or are use-associated. */
3068 else if (warn_unused_variable
3069 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3070 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3071 &sym->declared_at);
3072 /* For variable length CHARACTER parameters, the PARM_DECL already
3073 references the length variable, so force gfc_get_symbol_decl
3074 even when not referenced. If optimize > 0, it will be optimized
3075 away anyway. But do this only after emitting -Wunused-parameter
3076 warning if requested. */
3077 if (sym->attr.dummy && ! sym->attr.referenced
3078 && sym->ts.type == BT_CHARACTER
3079 && sym->ts.cl->backend_decl != NULL
3080 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3082 sym->attr.referenced = 1;
3083 gfc_get_symbol_decl (sym);
3086 /* We do not want the middle-end to warn about unused parameters
3087 as this was already done above. */
3088 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3089 TREE_NO_WARNING(sym->backend_decl) = 1;
3091 else if (sym->attr.flavor == FL_PARAMETER)
3093 if (warn_unused_parameter
3094 && !sym->attr.referenced
3095 && !sym->attr.use_assoc)
3096 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3097 &sym->declared_at);
3099 else if (sym->attr.flavor == FL_PROCEDURE)
3101 /* TODO: move to the appropriate place in resolve.c. */
3102 if (warn_return_type
3103 && sym->attr.function
3104 && sym->result
3105 && sym != sym->result
3106 && !sym->result->attr.referenced
3107 && !sym->attr.use_assoc
3108 && sym->attr.if_source != IFSRC_IFBODY)
3110 gfc_warning ("Return value '%s' of function '%s' declared at "
3111 "%L not set", sym->result->name, sym->name,
3112 &sym->result->declared_at);
3114 /* Prevents "Unused variable" warning for RESULT variables. */
3115 sym->mark = sym->result->mark = 1;
3119 if (sym->attr.dummy == 1)
3121 /* Modify the tree type for scalar character dummy arguments of bind(c)
3122 procedures if they are passed by value. The tree type for them will
3123 be promoted to INTEGER_TYPE for the middle end, which appears to be
3124 what C would do with characters passed by-value. The value attribute
3125 implies the dummy is a scalar. */
3126 if (sym->attr.value == 1 && sym->backend_decl != NULL
3127 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3128 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3129 gfc_conv_scalar_char_value (sym, NULL, NULL);
3132 /* Make sure we convert the types of the derived types from iso_c_binding
3133 into (void *). */
3134 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3135 && sym->ts.type == BT_DERIVED)
3136 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3139 static void
3140 generate_local_vars (gfc_namespace * ns)
3142 gfc_traverse_ns (ns, generate_local_decl);
3146 /* Generate a switch statement to jump to the correct entry point. Also
3147 creates the label decls for the entry points. */
3149 static tree
3150 gfc_trans_entry_master_switch (gfc_entry_list * el)
3152 stmtblock_t block;
3153 tree label;
3154 tree tmp;
3155 tree val;
3157 gfc_init_block (&block);
3158 for (; el; el = el->next)
3160 /* Add the case label. */
3161 label = gfc_build_label_decl (NULL_TREE);
3162 val = build_int_cst (gfc_array_index_type, el->id);
3163 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3164 gfc_add_expr_to_block (&block, tmp);
3166 /* And jump to the actual entry point. */
3167 label = gfc_build_label_decl (NULL_TREE);
3168 tmp = build1_v (GOTO_EXPR, label);
3169 gfc_add_expr_to_block (&block, tmp);
3171 /* Save the label decl. */
3172 el->label = label;
3174 tmp = gfc_finish_block (&block);
3175 /* The first argument selects the entry point. */
3176 val = DECL_ARGUMENTS (current_function_decl);
3177 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3178 return tmp;
3182 /* Generate code for a function. */
3184 void
3185 gfc_generate_function_code (gfc_namespace * ns)
3187 tree fndecl;
3188 tree old_context;
3189 tree decl;
3190 tree tmp;
3191 tree tmp2;
3192 stmtblock_t block;
3193 stmtblock_t body;
3194 tree result;
3195 gfc_symbol *sym;
3196 int rank;
3198 sym = ns->proc_name;
3200 /* Check that the frontend isn't still using this. */
3201 gcc_assert (sym->tlink == NULL);
3202 sym->tlink = sym;
3204 /* Create the declaration for functions with global scope. */
3205 if (!sym->backend_decl)
3206 gfc_create_function_decl (ns);
3208 fndecl = sym->backend_decl;
3209 old_context = current_function_decl;
3211 if (old_context)
3213 push_function_context ();
3214 saved_parent_function_decls = saved_function_decls;
3215 saved_function_decls = NULL_TREE;
3218 trans_function_start (sym);
3220 gfc_start_block (&block);
3222 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3224 /* Copy length backend_decls to all entry point result
3225 symbols. */
3226 gfc_entry_list *el;
3227 tree backend_decl;
3229 gfc_conv_const_charlen (ns->proc_name->ts.cl);
3230 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3231 for (el = ns->entries; el; el = el->next)
3232 el->sym->result->ts.cl->backend_decl = backend_decl;
3235 /* Translate COMMON blocks. */
3236 gfc_trans_common (ns);
3238 /* Null the parent fake result declaration if this namespace is
3239 a module function or an external procedures. */
3240 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3241 || ns->parent == NULL)
3242 parent_fake_result_decl = NULL_TREE;
3244 gfc_generate_contained_functions (ns);
3246 generate_local_vars (ns);
3248 /* Keep the parent fake result declaration in module functions
3249 or external procedures. */
3250 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3251 || ns->parent == NULL)
3252 current_fake_result_decl = parent_fake_result_decl;
3253 else
3254 current_fake_result_decl = NULL_TREE;
3256 current_function_return_label = NULL;
3258 /* Now generate the code for the body of this function. */
3259 gfc_init_block (&body);
3261 /* If this is the main program, add a call to set_options to set up the
3262 runtime library Fortran language standard parameters. */
3263 if (sym->attr.is_main_program)
3265 tree array_type, array, var;
3267 /* Passing a new option to the library requires four modifications:
3268 + add it to the tree_cons list below
3269 + change the array size in the call to build_array_type
3270 + change the first argument to the library call
3271 gfor_fndecl_set_options
3272 + modify the library (runtime/compile_options.c)! */
3273 array = tree_cons (NULL_TREE,
3274 build_int_cst (integer_type_node,
3275 gfc_option.warn_std), NULL_TREE);
3276 array = tree_cons (NULL_TREE,
3277 build_int_cst (integer_type_node,
3278 gfc_option.allow_std), array);
3279 array = tree_cons (NULL_TREE,
3280 build_int_cst (integer_type_node, pedantic), array);
3281 array = tree_cons (NULL_TREE,
3282 build_int_cst (integer_type_node,
3283 gfc_option.flag_dump_core), array);
3284 array = tree_cons (NULL_TREE,
3285 build_int_cst (integer_type_node,
3286 gfc_option.flag_backtrace), array);
3287 array = tree_cons (NULL_TREE,
3288 build_int_cst (integer_type_node,
3289 gfc_option.flag_sign_zero), array);
3291 array = tree_cons (NULL_TREE,
3292 build_int_cst (integer_type_node,
3293 flag_bounds_check), array);
3295 array_type = build_array_type (integer_type_node,
3296 build_index_type (build_int_cst (NULL_TREE,
3297 6)));
3298 array = build_constructor_from_list (array_type, nreverse (array));
3299 TREE_CONSTANT (array) = 1;
3300 TREE_STATIC (array) = 1;
3302 /* Create a static variable to hold the jump table. */
3303 var = gfc_create_var (array_type, "options");
3304 TREE_CONSTANT (var) = 1;
3305 TREE_STATIC (var) = 1;
3306 TREE_READONLY (var) = 1;
3307 DECL_INITIAL (var) = array;
3308 var = gfc_build_addr_expr (pvoid_type_node, var);
3310 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3311 build_int_cst (integer_type_node, 7), var);
3312 gfc_add_expr_to_block (&body, tmp);
3315 /* If this is the main program and a -ffpe-trap option was provided,
3316 add a call to set_fpe so that the library will raise a FPE when
3317 needed. */
3318 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3320 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3321 build_int_cst (integer_type_node,
3322 gfc_option.fpe));
3323 gfc_add_expr_to_block (&body, tmp);
3326 /* If this is the main program and an -fconvert option was provided,
3327 add a call to set_convert. */
3329 if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3331 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3332 build_int_cst (integer_type_node,
3333 gfc_option.convert));
3334 gfc_add_expr_to_block (&body, tmp);
3337 /* If this is the main program and an -frecord-marker option was provided,
3338 add a call to set_record_marker. */
3340 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3342 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3343 build_int_cst (integer_type_node,
3344 gfc_option.record_marker));
3345 gfc_add_expr_to_block (&body, tmp);
3348 if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3350 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3352 build_int_cst (integer_type_node,
3353 gfc_option.max_subrecord_length));
3354 gfc_add_expr_to_block (&body, tmp);
3357 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3358 && sym->attr.subroutine)
3360 tree alternate_return;
3361 alternate_return = gfc_get_fake_result_decl (sym, 0);
3362 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3365 if (ns->entries)
3367 /* Jump to the correct entry point. */
3368 tmp = gfc_trans_entry_master_switch (ns->entries);
3369 gfc_add_expr_to_block (&body, tmp);
3372 tmp = gfc_trans_code (ns->code);
3373 gfc_add_expr_to_block (&body, tmp);
3375 /* Add a return label if needed. */
3376 if (current_function_return_label)
3378 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3379 gfc_add_expr_to_block (&body, tmp);
3382 tmp = gfc_finish_block (&body);
3383 /* Add code to create and cleanup arrays. */
3384 tmp = gfc_trans_deferred_vars (sym, tmp);
3386 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3388 if (sym->attr.subroutine || sym == sym->result)
3390 if (current_fake_result_decl != NULL)
3391 result = TREE_VALUE (current_fake_result_decl);
3392 else
3393 result = NULL_TREE;
3394 current_fake_result_decl = NULL_TREE;
3396 else
3397 result = sym->result->backend_decl;
3399 if (result != NULL_TREE && sym->attr.function
3400 && sym->ts.type == BT_DERIVED
3401 && sym->ts.derived->attr.alloc_comp
3402 && !sym->attr.pointer)
3404 rank = sym->as ? sym->as->rank : 0;
3405 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3406 gfc_add_expr_to_block (&block, tmp2);
3409 gfc_add_expr_to_block (&block, tmp);
3411 if (result == NULL_TREE)
3413 /* TODO: move to the appropriate place in resolve.c. */
3414 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
3415 gfc_warning ("Return value of function '%s' at %L not set",
3416 sym->name, &sym->declared_at);
3418 TREE_NO_WARNING(sym->backend_decl) = 1;
3420 else
3422 /* Set the return value to the dummy result variable. The
3423 types may be different for scalar default REAL functions
3424 with -ff2c, therefore we have to convert. */
3425 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3426 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3427 DECL_RESULT (fndecl), tmp);
3428 tmp = build1_v (RETURN_EXPR, tmp);
3429 gfc_add_expr_to_block (&block, tmp);
3432 else
3433 gfc_add_expr_to_block (&block, tmp);
3436 /* Add all the decls we created during processing. */
3437 decl = saved_function_decls;
3438 while (decl)
3440 tree next;
3442 next = TREE_CHAIN (decl);
3443 TREE_CHAIN (decl) = NULL_TREE;
3444 pushdecl (decl);
3445 decl = next;
3447 saved_function_decls = NULL_TREE;
3449 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3451 /* Finish off this function and send it for code generation. */
3452 poplevel (1, 0, 1);
3453 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3455 /* Output the GENERIC tree. */
3456 dump_function (TDI_original, fndecl);
3458 /* Store the end of the function, so that we get good line number
3459 info for the epilogue. */
3460 cfun->function_end_locus = input_location;
3462 /* We're leaving the context of this function, so zap cfun.
3463 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3464 tree_rest_of_compilation. */
3465 set_cfun (NULL);
3467 if (old_context)
3469 pop_function_context ();
3470 saved_function_decls = saved_parent_function_decls;
3472 current_function_decl = old_context;
3474 if (decl_function_context (fndecl))
3475 /* Register this function with cgraph just far enough to get it
3476 added to our parent's nested function list. */
3477 (void) cgraph_node (fndecl);
3478 else
3480 gfc_gimplify_function (fndecl);
3481 cgraph_finalize_function (fndecl, false);
3485 void
3486 gfc_generate_constructors (void)
3488 gcc_assert (gfc_static_ctors == NULL_TREE);
3489 #if 0
3490 tree fnname;
3491 tree type;
3492 tree fndecl;
3493 tree decl;
3494 tree tmp;
3496 if (gfc_static_ctors == NULL_TREE)
3497 return;
3499 fnname = get_file_function_name ("I");
3500 type = build_function_type (void_type_node,
3501 gfc_chainon_list (NULL_TREE, void_type_node));
3503 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3504 TREE_PUBLIC (fndecl) = 1;
3506 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3507 DECL_ARTIFICIAL (decl) = 1;
3508 DECL_IGNORED_P (decl) = 1;
3509 DECL_CONTEXT (decl) = fndecl;
3510 DECL_RESULT (fndecl) = decl;
3512 pushdecl (fndecl);
3514 current_function_decl = fndecl;
3516 rest_of_decl_compilation (fndecl, 1, 0);
3518 make_decl_rtl (fndecl);
3520 init_function_start (fndecl);
3522 pushlevel (0);
3524 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3526 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3527 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3530 poplevel (1, 0, 1);
3532 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3534 free_after_parsing (cfun);
3535 free_after_compilation (cfun);
3537 tree_rest_of_compilation (fndecl);
3539 current_function_decl = NULL_TREE;
3540 #endif
3543 /* Translates a BLOCK DATA program unit. This means emitting the
3544 commons contained therein plus their initializations. We also emit
3545 a globally visible symbol to make sure that each BLOCK DATA program
3546 unit remains unique. */
3548 void
3549 gfc_generate_block_data (gfc_namespace * ns)
3551 tree decl;
3552 tree id;
3554 /* Tell the backend the source location of the block data. */
3555 if (ns->proc_name)
3556 gfc_set_backend_locus (&ns->proc_name->declared_at);
3557 else
3558 gfc_set_backend_locus (&gfc_current_locus);
3560 /* Process the DATA statements. */
3561 gfc_trans_common (ns);
3563 /* Create a global symbol with the mane of the block data. This is to
3564 generate linker errors if the same name is used twice. It is never
3565 really used. */
3566 if (ns->proc_name)
3567 id = gfc_sym_mangled_function_id (ns->proc_name);
3568 else
3569 id = get_identifier ("__BLOCK_DATA__");
3571 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3572 TREE_PUBLIC (decl) = 1;
3573 TREE_STATIC (decl) = 1;
3575 pushdecl (decl);
3576 rest_of_decl_compilation (decl, 1, 0);
3580 #include "gt-fortran-trans-decl.h"