1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GNU G95.
7 GNU G95 is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU G95 is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU G95; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
26 #include "coretypes.h"
28 #include "tree-dump.h"
29 #include "tree-gimple.h"
41 #include "trans-types.h"
42 #include "trans-array.h"
43 #include "trans-const.h"
44 /* Only for gfc_trans_code. Shouldn't need to include this. */
45 #include "trans-stmt.h"
47 #define MAX_LABEL_VALUE 99999
50 /* Holds the result of the function if no result variable specified. */
52 static GTY(()) tree current_fake_result_decl;
54 static GTY(()) tree current_function_return_label;
57 /* Holds the variable DECLs for the current function. */
59 static GTY(()) tree saved_function_decls = NULL_TREE;
60 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
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_internal_malloc;
77 tree gfor_fndecl_internal_malloc64;
78 tree gfor_fndecl_internal_free;
79 tree gfor_fndecl_allocate;
80 tree gfor_fndecl_allocate64;
81 tree gfor_fndecl_deallocate;
82 tree gfor_fndecl_pause_numeric;
83 tree gfor_fndecl_pause_string;
84 tree gfor_fndecl_stop_numeric;
85 tree gfor_fndecl_stop_string;
86 tree gfor_fndecl_select_string;
87 tree gfor_fndecl_runtime_error;
88 tree gfor_fndecl_in_pack;
89 tree gfor_fndecl_in_unpack;
90 tree gfor_fndecl_associated;
93 /* Math functions. Many other math functions are handled in
96 tree gfor_fndecl_math_powf;
97 tree gfor_fndecl_math_pow;
98 tree gfor_fndecl_math_cpowf;
99 tree gfor_fndecl_math_cpow;
100 tree gfor_fndecl_math_cabsf;
101 tree gfor_fndecl_math_cabs;
102 tree gfor_fndecl_math_sign4;
103 tree gfor_fndecl_math_sign8;
104 tree gfor_fndecl_math_ishftc4;
105 tree gfor_fndecl_math_ishftc8;
106 tree gfor_fndecl_math_exponent4;
107 tree gfor_fndecl_math_exponent8;
110 /* String functions. */
112 tree gfor_fndecl_copy_string;
113 tree gfor_fndecl_compare_string;
114 tree gfor_fndecl_concat_string;
115 tree gfor_fndecl_string_len_trim;
116 tree gfor_fndecl_string_index;
117 tree gfor_fndecl_string_scan;
118 tree gfor_fndecl_string_verify;
119 tree gfor_fndecl_string_trim;
120 tree gfor_fndecl_string_repeat;
121 tree gfor_fndecl_adjustl;
122 tree gfor_fndecl_adjustr;
125 /* Other misc. runtime library functions. */
127 tree gfor_fndecl_size0;
128 tree gfor_fndecl_size1;
130 /* Intrinsic functions implemented in FORTRAN. */
131 tree gfor_fndecl_si_kind;
132 tree gfor_fndecl_sr_kind;
136 gfc_add_decl_to_parent_function (tree decl)
139 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
140 DECL_NONLOCAL (decl) = 1;
141 TREE_CHAIN (decl) = saved_parent_function_decls;
142 saved_parent_function_decls = decl;
146 gfc_add_decl_to_function (tree decl)
149 TREE_USED (decl) = 1;
150 DECL_CONTEXT (decl) = current_function_decl;
151 TREE_CHAIN (decl) = saved_function_decls;
152 saved_function_decls = decl;
156 /* Build a backend label declaration.
157 Set TREE_USED for named lables. For artificial labels it's up to the
158 caller to mark the label as used. */
161 gfc_build_label_decl (tree label_id)
163 /* 2^32 temporaries should be enough. */
164 static unsigned int tmp_num = 1;
168 if (label_id == NULL_TREE)
170 /* Build an internal label name. */
171 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
172 label_id = get_identifier (label_name);
177 /* Build the LABEL_DECL node. Labels have no type. */
178 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
179 DECL_CONTEXT (label_decl) = current_function_decl;
180 DECL_MODE (label_decl) = VOIDmode;
184 DECL_ARTIFICIAL (label_decl) = 1;
188 /* We always define the label as used, even if the original source
189 file never references the label. We don't want all kinds of
190 spurious warnings for old-style Fortran code with too many
192 TREE_USED (label_decl) = 1;
199 /* Returns the return label for the current function. */
202 gfc_get_return_label (void)
204 char name[GFC_MAX_SYMBOL_LEN + 10];
206 if (current_function_return_label)
207 return current_function_return_label;
209 sprintf (name, "__return_%s",
210 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
212 current_function_return_label =
213 gfc_build_label_decl (get_identifier (name));
215 DECL_ARTIFICIAL (current_function_return_label) = 1;
217 return current_function_return_label;
221 /* Return the backend label declaration for a given label structure,
222 or create it if it doesn't exist yet. */
225 gfc_get_label_decl (gfc_st_label * lp)
228 if (lp->backend_decl)
229 return lp->backend_decl;
232 char label_name[GFC_MAX_SYMBOL_LEN + 1];
235 /* Validate the label declaration from the front end. */
236 assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
238 /* Build a mangled name for the label. */
239 sprintf (label_name, "__label_%.6d", lp->value);
241 /* Build the LABEL_DECL node. */
242 label_decl = gfc_build_label_decl (get_identifier (label_name));
244 /* Tell the debugger where the label came from. */
245 if (lp->value <= MAX_LABEL_VALUE) /* An internal label */
247 DECL_SOURCE_LINE (label_decl) = lp->where.line;
248 DECL_SOURCE_FILE (label_decl) = lp->where.file->filename;
251 DECL_ARTIFICIAL (label_decl) = 1;
253 /* Store the label in the label list and return the LABEL_DECL. */
254 lp->backend_decl = label_decl;
260 /* Convert a gfc_symbol to an identifier of the same name. */
263 gfc_sym_identifier (gfc_symbol * sym)
265 return (get_identifier (sym->name));
269 /* Construct mangled name from symbol name. */
272 gfc_sym_mangled_identifier (gfc_symbol * sym)
274 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
276 if (sym->module[0] == 0)
277 return gfc_sym_identifier (sym);
280 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
281 return get_identifier (name);
286 /* Construct mangled function name from symbol name. */
289 gfc_sym_mangled_function_id (gfc_symbol * sym)
292 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
294 if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL
295 || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY))
297 if (strcmp (sym->name, "MAIN__") == 0
298 || sym->attr.proc == PROC_INTRINSIC)
299 return get_identifier (sym->name);
301 if (gfc_option.flag_underscoring)
303 has_underscore = strchr (sym->name, '_') != 0;
304 if (gfc_option.flag_second_underscore && has_underscore)
305 snprintf (name, sizeof name, "%s__", sym->name);
307 snprintf (name, sizeof name, "%s_", sym->name);
308 return get_identifier (name);
311 return get_identifier (sym->name);
315 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
316 return get_identifier (name);
321 /* Finish processing of a declaration and install its initial value. */
324 gfc_finish_decl (tree decl, tree init)
326 if (TREE_CODE (decl) == PARM_DECL)
327 assert (init == NULL_TREE);
328 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
329 -- it overlaps DECL_ARG_TYPE. */
330 else if (init == NULL_TREE)
331 assert (DECL_INITIAL (decl) == NULL_TREE);
333 assert (DECL_INITIAL (decl) == error_mark_node);
335 if (init != NULL_TREE)
337 if (TREE_CODE (decl) != TYPE_DECL)
338 DECL_INITIAL (decl) = init;
341 /* typedef foo = bar; store the type of bar as the type of foo. */
342 TREE_TYPE (decl) = TREE_TYPE (init);
343 DECL_INITIAL (decl) = init = 0;
347 if (TREE_CODE (decl) == VAR_DECL)
349 if (DECL_SIZE (decl) == NULL_TREE
350 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
351 layout_decl (decl, 0);
353 /* A static variable with an incomplete type is an error if it is
354 initialized. Also if it is not file scope. Otherwise, let it
355 through, but if it is not `extern' then it may cause an error
357 /* An automatic variable with an incomplete type is an error. */
358 if (DECL_SIZE (decl) == NULL_TREE
359 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
360 || DECL_CONTEXT (decl) != 0)
361 : !DECL_EXTERNAL (decl)))
363 gfc_fatal_error ("storage size not known");
366 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
367 && (DECL_SIZE (decl) != 0)
368 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
370 gfc_fatal_error ("storage size not constant");
377 /* Apply symbol attributes to a variable, and add it to the function scope. */
380 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
382 /* TREE_ADDRESSABLE means the address of this variable is acualy needed.
383 This is the equivalent of the TARGET variables.
384 We also need to set this if the variable is passed by reference in a
386 if (sym->attr.target)
387 TREE_ADDRESSABLE (decl) = 1;
388 /* If it wasn't used we wouldn't be getting it. */
389 TREE_USED (decl) = 1;
391 /* Chain this decl to the pending declarations. Don't do pushdecl()
392 because this would add them to the current scope rather than the
394 if (current_function_decl != NULL_TREE)
396 if (sym->ns->proc_name->backend_decl == current_function_decl)
397 gfc_add_decl_to_function (decl);
399 gfc_add_decl_to_parent_function (decl);
402 /* If a variable is USE associated, it's always external. */
403 if (sym->attr.use_assoc)
405 DECL_EXTERNAL (decl) = 1;
406 TREE_PUBLIC (decl) = 1;
408 else if (sym->module[0] && !sym->attr.result)
410 /* TODO: Don't set sym->module for result variables. */
411 assert (current_function_decl == NULL_TREE);
412 /* This is the declaration of a module variable. */
413 TREE_PUBLIC (decl) = 1;
414 TREE_STATIC (decl) = 1;
417 if ((sym->attr.save || sym->attr.data || sym->value)
418 && !sym->attr.use_assoc)
419 TREE_STATIC (decl) = 1;
421 /* Keep variables larger than max-stack-var-size off stack. */
422 if (!sym->ns->proc_name->attr.recursive
423 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
424 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
425 TREE_STATIC (decl) = 1;
429 /* Allocate the lang-specific part of a decl. */
432 gfc_allocate_lang_decl (tree decl)
434 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
435 ggc_alloc_cleared (sizeof (struct lang_decl));
438 /* Remember a symbol to generate initialization/cleanup code at function
442 gfc_defer_symbol_init (gfc_symbol * sym)
448 /* Don't add a symbol twice. */
452 last = head = sym->ns->proc_name;
455 /* Make sure that setup code for dummy variables which are used in the
456 setup of other variables is generated first. */
459 /* Find the first dummy arg seen after us, or the first non-dummy arg.
460 This is a circular list, so don't go past the head. */
462 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
468 /* Insert in between last and p. */
474 /* Create an array index type variable with function scope. */
477 create_index_var (const char * pfx, int nest)
481 decl = gfc_create_var_np (gfc_array_index_type, pfx);
483 gfc_add_decl_to_parent_function (decl);
485 gfc_add_decl_to_function (decl);
490 /* Create variables to hold all the non-constant bits of info for a
491 descriptorless array. Remember these in the lang-specific part of the
495 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
501 type = TREE_TYPE (decl);
503 /* We just use the descriptor, if there is one. */
504 if (GFC_DESCRIPTOR_TYPE_P (type))
507 assert (GFC_ARRAY_TYPE_P (type));
508 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
509 && !sym->attr.contained;
511 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
513 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
514 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
515 /* Don't try to use the unkown bound for assumed shape arrays. */
516 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
517 && (sym->as->type != AS_ASSUMED_SIZE
518 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
519 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
521 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
522 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
524 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
526 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
529 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
531 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
536 /* For some dummy arguments we don't use the actual argument directly.
537 Instead we create a local decl and use that. This allows us to preform
538 initialization, and construct full type information. */
541 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
551 if (sym->attr.pointer || sym->attr.allocatable)
554 /* Add to list of variables if not a fake result variable. */
555 if (sym->attr.result || sym->attr.dummy)
556 gfc_defer_symbol_init (sym);
558 type = TREE_TYPE (dummy);
559 assert (TREE_CODE (dummy) == PARM_DECL
560 && POINTER_TYPE_P (type));
562 /* Do we know the element size. */
563 known_size = sym->ts.type != BT_CHARACTER
564 || INTEGER_CST_P (sym->ts.cl->backend_decl);
566 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
568 /* For descriptorless arrays with known element size the actual
569 argument is sufficient. */
570 assert (GFC_ARRAY_TYPE_P (type));
571 gfc_build_qualified_array (dummy, sym);
575 type = TREE_TYPE (type);
576 if (GFC_DESCRIPTOR_TYPE_P (type))
578 /* Create a decriptorless array pointer. */
581 if (!gfc_option.flag_repack_arrays)
583 if (as->type == AS_ASSUMED_SIZE)
588 if (as->type == AS_EXPLICIT)
591 for (n = 0; n < as->rank; n++)
595 && as->upper[n]->expr_type == EXPR_CONSTANT
596 && as->lower[n]->expr_type == EXPR_CONSTANT))
604 type = gfc_typenode_for_spec (&sym->ts);
605 type = gfc_get_nodesc_array_type (type, sym->as, packed);
609 /* We now have an expression for the element size, so create a fully
610 qualified type. Reset sym->backend decl or this will just return the
612 sym->backend_decl = NULL_TREE;
613 type = gfc_sym_type (sym);
617 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
618 decl = build_decl (VAR_DECL, get_identifier (name), type);
620 DECL_ARTIFICIAL (decl) = 1;
621 TREE_PUBLIC (decl) = 0;
622 TREE_STATIC (decl) = 0;
623 DECL_EXTERNAL (decl) = 0;
625 /* We should never get deferred shape arrays here. We used to because of
627 assert (sym->as->type != AS_DEFERRED);
632 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
636 GFC_DECL_PACKED_ARRAY (decl) = 1;
640 gfc_build_qualified_array (decl, sym);
642 if (DECL_LANG_SPECIFIC (dummy))
643 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
645 gfc_allocate_lang_decl (decl);
647 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
649 if (sym->ns->proc_name->backend_decl == current_function_decl
650 || sym->attr.contained)
651 gfc_add_decl_to_function (decl);
653 gfc_add_decl_to_parent_function (decl);
659 /* Return a constant or a variable to use as a string length. Does not
660 add the decl to the current scope. */
663 gfc_create_string_length (gfc_symbol * sym)
668 gfc_conv_const_charlen (sym->ts.cl);
670 if (sym->ts.cl->backend_decl == NULL_TREE)
672 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
674 /* Also prefix the mangled name. */
675 strcpy (&name[1], sym->name);
677 length = build_decl (VAR_DECL, get_identifier (name),
678 gfc_strlen_type_node);
679 DECL_ARTIFICIAL (length) = 1;
680 TREE_USED (length) = 1;
681 gfc_defer_symbol_init (sym);
682 sym->ts.cl->backend_decl = length;
685 return sym->ts.cl->backend_decl;
689 /* Return the decl for a gfc_symbol, create it if it doesn't already
693 gfc_get_symbol_decl (gfc_symbol * sym)
696 tree length = NULL_TREE;
700 assert (sym->attr.referenced);
702 if (sym->ns && sym->ns->proc_name->attr.function)
703 byref = gfc_return_by_reference (sym->ns->proc_name);
707 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
709 /* Return via extra parameter. */
710 if (sym->attr.result && byref
711 && !sym->backend_decl)
714 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
717 /* Dummy variables should already have been created. */
718 assert (sym->backend_decl);
720 /* Create a character length variable. */
721 if (sym->ts.type == BT_CHARACTER)
723 if (sym->ts.cl->backend_decl == NULL_TREE)
725 length = gfc_create_string_length (sym);
726 if (TREE_CODE (length) != INTEGER_CST)
728 gfc_finish_var_decl (length, sym);
729 gfc_defer_symbol_init (sym);
734 /* Use a copy of the descriptor for dummy arrays. */
735 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
738 gfc_build_dummy_array_decl (sym, sym->backend_decl);
741 TREE_USED (sym->backend_decl) = 1;
742 return sym->backend_decl;
745 if (sym->backend_decl)
746 return sym->backend_decl;
749 gfc_todo_error ("alternate entry");
751 /* Catch function declarations. Only used for actual parameters. */
752 if (sym->attr.flavor == FL_PROCEDURE)
754 decl = gfc_get_extern_function_decl (sym);
758 if (sym->attr.intrinsic)
759 internal_error ("intrinsic variable which isn't a procedure");
761 /* Create string length decl first so that they can be used in the
763 if (sym->ts.type == BT_CHARACTER)
764 length = gfc_create_string_length (sym);
766 /* Create the decl for the variable. */
767 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
769 /* Symbols from modules have its assembler name should be mangled.
770 This is done here rather than in gfc_finish_var_decl because it
771 is different for string length variables. */
773 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
775 if (sym->attr.dimension)
777 /* Create variables to hold the non-constant bits of array info. */
778 gfc_build_qualified_array (decl, sym);
780 /* Remember this variable for allocation/cleanup. */
781 gfc_defer_symbol_init (sym);
783 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
784 GFC_DECL_PACKED_ARRAY (decl) = 1;
787 gfc_finish_var_decl (decl, sym);
789 if (sym->attr.assign)
791 gfc_allocate_lang_decl (decl);
792 GFC_DECL_ASSIGN (decl) = 1;
793 length = gfc_create_var (gfc_strlen_type_node, sym->name);
794 GFC_DECL_STRING_LEN (decl) = length;
795 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
796 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
797 TREE_STATIC (length) = TREE_STATIC (decl);
798 /* STRING_LENGTH is also used as flag. Less than -1 means that
799 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
800 target label's address. Other value is the length of format string
801 and ASSIGN_ADDR is the address of format string. */
802 DECL_INITIAL (length) = build_int_2 (-2, -1);
805 /* TODO: Initialization of pointer variables. */
806 switch (sym->ts.type)
809 /* Character variables need special handling. */
810 gfc_allocate_lang_decl (decl);
812 if (TREE_CODE (length) == INTEGER_CST)
814 /* Static initializer for string scalars.
815 Initialization of string arrays is handled elsewhere. */
816 if (sym->value && sym->attr.dimension == 0)
818 assert (TREE_STATIC (decl));
819 if (sym->attr.pointer)
820 gfc_todo_error ("initialization of character pointers");
821 DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
826 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
830 /* Also prefix the mangled name for symbols from modules. */
831 strcpy (&name[1], sym->name);
834 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
835 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
837 gfc_finish_var_decl (length, sym);
838 assert (!sym->value);
843 if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
845 gfc_init_se (&se, NULL);
846 gfc_conv_structure (&se, sym->value, 1);
847 DECL_INITIAL (decl) = se.expr;
852 /* Static initializers for SAVEd variables. Arrays have already been
853 remembered. Module variables are initialized when the module is
855 if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
857 assert (TREE_STATIC (decl));
858 gfc_init_se (&se, NULL);
859 gfc_conv_constant (&se, sym->value);
860 DECL_INITIAL (decl) = se.expr;
864 sym->backend_decl = decl;
870 /* Get a basic decl for an external function. */
873 gfc_get_extern_function_decl (gfc_symbol * sym)
878 gfc_intrinsic_sym *isym;
880 char s[GFC_MAX_SYMBOL_LEN];
884 if (sym->backend_decl)
885 return sym->backend_decl;
887 if (sym->attr.intrinsic)
889 /* Call the resolution function to get the actual name. This is
890 a nasty hack which relies on the resolution functions only looking
891 at the first argument. We pass NULL for the second argument
892 otherwise things like AINT get confused. */
893 isym = gfc_find_function (sym->name);
894 assert (isym->resolve.f0 != NULL);
896 memset (&e, 0, sizeof (e));
897 e.expr_type = EXPR_FUNCTION;
899 memset (&argexpr, 0, sizeof (argexpr));
900 assert (isym->formal);
901 argexpr.ts = isym->formal->ts;
903 if (isym->formal->next == NULL)
904 isym->resolve.f1 (&e, &argexpr);
907 /* All specific intrinsics take one or two arguments. */
908 assert (isym->formal->next->next == NULL);
909 isym->resolve.f2 (&e, &argexpr, NULL);
911 sprintf (s, "specific%s", e.value.function.name);
912 name = get_identifier (s);
917 name = gfc_sym_identifier (sym);
918 mangled_name = gfc_sym_mangled_function_id (sym);
921 type = gfc_get_function_type (sym);
922 fndecl = build_decl (FUNCTION_DECL, name, type);
924 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
925 /* If the return type is a pointer, avoid alias issues by setting
926 DECL_IS_MALLOC to nonzero. This means that the function should be
927 treated as if it were a malloc, meaning it returns a pointer that
929 if (POINTER_TYPE_P (type))
930 DECL_IS_MALLOC (fndecl) = 1;
932 /* Set the context of this decl. */
933 if (0 && sym->ns && sym->ns->proc_name)
935 /* TODO: Add external decls to the appropriate scope. */
936 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
940 /* Global declaration, eg. intrinsic subroutine. */
941 DECL_CONTEXT (fndecl) = NULL_TREE;
944 DECL_EXTERNAL (fndecl) = 1;
946 /* This specifies if a function is globaly addressable, ie. it is
947 the opposite of declaring static in C. */
948 TREE_PUBLIC (fndecl) = 1;
950 /* Set attributes for PURE functions. A call to PURE function in the
951 Fortran 95 sense is both pure and without side effects in the C
953 if (sym->attr.pure || sym->attr.elemental)
955 DECL_IS_PURE (fndecl) = 1;
956 /* TODO: check if pure/elemental procedures can have INTENT(OUT) parameters.
957 TREE_SIDE_EFFECTS (fndecl) = 0;*/
960 sym->backend_decl = fndecl;
962 if (DECL_CONTEXT (fndecl) == NULL_TREE)
963 pushdecl_top_level (fndecl);
969 /* Create a declaration for a procedure. For external functions (in the C
970 sense) use gfc_get_extern_function_decl. */
973 gfc_build_function_decl (gfc_symbol * sym)
975 tree fndecl, type, result_decl, typelist, arglist;
977 symbol_attribute attr;
978 gfc_formal_arglist *f;
980 assert (!sym->backend_decl);
981 assert (!sym->attr.external);
983 /* Allow only one nesting level. Allow public declarations. */
984 assert (current_function_decl == NULL_TREE
985 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
987 type = gfc_get_function_type (sym);
988 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
990 /* Perform name mangling if this is a top level or module procedure. */
991 if (current_function_decl == NULL_TREE)
992 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
994 /* Figure out the return type of the declared function, and build a
995 RESULT_DECL for it. If this is subroutine with alternate
996 returns, build a RESULT_DECL for it. */
999 result_decl = NULL_TREE;
1000 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1003 if (gfc_return_by_reference (sym))
1004 type = void_type_node;
1007 if (sym->result != sym)
1008 result_decl = gfc_sym_identifier (sym->result);
1010 type = TREE_TYPE (TREE_TYPE (fndecl));
1015 /* Look for alternate return placeholders. */
1016 int has_alternate_returns = 0;
1017 for (f = sym->formal; f; f = f->next)
1021 has_alternate_returns = 1;
1026 if (has_alternate_returns)
1027 type = integer_type_node;
1029 type = void_type_node;
1032 result_decl = build_decl (RESULT_DECL, result_decl, type);
1033 DECL_CONTEXT (result_decl) = fndecl;
1034 DECL_RESULT (fndecl) = result_decl;
1036 /* Don't call layout_decl for a RESULT_DECL.
1037 layout_decl (result_decl, 0); */
1039 /* If the return type is a pointer, avoid alias issues by setting
1040 DECL_IS_MALLOC to nonzero. This means that the function should be
1041 treated as if it were a malloc, meaning it returns a pointer that
1043 if (POINTER_TYPE_P (type))
1044 DECL_IS_MALLOC (fndecl) = 1;
1046 /* Set up all attributes for the function. */
1047 DECL_CONTEXT (fndecl) = current_function_decl;
1048 DECL_EXTERNAL (fndecl) = 0;
1050 /* This specifies if a function is globaly addressable, ie. it is
1051 the opposite of decalring static in C. */
1052 if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
1053 TREE_PUBLIC (fndecl) = 1;
1055 /* TREE_STATIC means the function body is defined here. */
1057 TREE_STATIC (fndecl) = 1;
1059 /* Set attributes for PURE functions. A call to PURE function in the
1060 Fortran 95 sense is both pure and without side effects in the C
1062 if (attr.pure || attr.elemental)
1064 DECL_IS_PURE (fndecl) = 1;
1065 TREE_SIDE_EFFECTS (fndecl) = 0;
1068 /* Layout the function declaration and put it in the binding level
1069 of the current function. */
1075 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1076 the new FUNCTION_DECL node. */
1077 current_function_decl = fndecl;
1078 arglist = NULL_TREE;
1079 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1080 if (gfc_return_by_reference (sym))
1082 type = TREE_VALUE (typelist);
1083 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1085 DECL_CONTEXT (parm) = fndecl;
1086 DECL_ARG_TYPE (parm) = type;
1087 TREE_READONLY (parm) = 1;
1088 gfc_finish_decl (parm, NULL_TREE);
1090 arglist = chainon (arglist, parm);
1091 typelist = TREE_CHAIN (typelist);
1093 if (sym->ts.type == BT_CHARACTER)
1095 gfc_allocate_lang_decl (parm);
1097 /* Length of character result */
1098 type = TREE_VALUE (typelist);
1099 assert (type == gfc_strlen_type_node);
1101 length = build_decl (PARM_DECL,
1102 get_identifier (".__result"),
1104 if (!sym->ts.cl->length)
1106 sym->ts.cl->backend_decl = length;
1107 TREE_USED (length) = 1;
1109 assert (TREE_CODE (length) == PARM_DECL);
1110 arglist = chainon (arglist, length);
1111 typelist = TREE_CHAIN (typelist);
1112 DECL_CONTEXT (length) = fndecl;
1113 DECL_ARG_TYPE (length) = type;
1114 TREE_READONLY (length) = 1;
1115 gfc_finish_decl (length, NULL_TREE);
1119 for (f = sym->formal; f; f = f->next)
1121 if (f->sym != NULL) /* ignore alternate returns. */
1125 type = TREE_VALUE (typelist);
1127 /* Build a the argument declaration. */
1128 parm = build_decl (PARM_DECL,
1129 gfc_sym_identifier (f->sym), type);
1131 /* Fill in arg stuff. */
1132 DECL_CONTEXT (parm) = fndecl;
1133 DECL_ARG_TYPE (parm) = type;
1134 DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1135 /* All implementation args are read-only. */
1136 TREE_READONLY (parm) = 1;
1138 gfc_finish_decl (parm, NULL_TREE);
1140 f->sym->backend_decl = parm;
1142 arglist = chainon (arglist, parm);
1143 typelist = TREE_CHAIN (typelist);
1147 /* Add the hidden string length parameters. */
1149 for (f = sym->formal; f; f = f->next)
1151 char name[GFC_MAX_SYMBOL_LEN + 2];
1152 /* Ignore alternate returns. */
1156 if (f->sym->ts.type != BT_CHARACTER)
1159 parm = f->sym->backend_decl;
1160 type = TREE_VALUE (typelist);
1161 assert (type == gfc_strlen_type_node);
1163 strcpy (&name[1], f->sym->name);
1165 length = build_decl (PARM_DECL, get_identifier (name), type);
1167 arglist = chainon (arglist, length);
1168 DECL_CONTEXT (length) = fndecl;
1169 DECL_ARG_TYPE (length) = type;
1170 TREE_READONLY (length) = 1;
1171 gfc_finish_decl (length, NULL_TREE);
1173 /* TODO: Check string lengths when -fbounds-check. */
1175 /* Use the passed value for assumed length variables. */
1176 if (!f->sym->ts.cl->length)
1178 TREE_USED (length) = 1;
1179 f->sym->ts.cl->backend_decl = length;
1182 parm = TREE_CHAIN (parm);
1183 typelist = TREE_CHAIN (typelist);
1186 assert (TREE_VALUE (typelist) == void_type_node);
1187 DECL_ARGUMENTS (fndecl) = arglist;
1189 /* Restore the old context. */
1190 current_function_decl = DECL_CONTEXT (fndecl);
1192 sym->backend_decl = fndecl;
1196 /* Return the decl used to hold the function return value. */
1199 gfc_get_fake_result_decl (gfc_symbol * sym)
1204 char name[GFC_MAX_SYMBOL_LEN + 10];
1206 if (current_fake_result_decl != NULL_TREE)
1207 return current_fake_result_decl;
1209 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1214 if (sym->ts.type == BT_CHARACTER
1215 && !sym->ts.cl->backend_decl)
1217 length = gfc_create_string_length (sym);
1218 gfc_finish_var_decl (length, sym);
1221 if (gfc_return_by_reference (sym))
1223 decl = DECL_ARGUMENTS (sym->backend_decl);
1225 TREE_USED (decl) = 1;
1227 decl = gfc_build_dummy_array_decl (sym, decl);
1231 sprintf (name, "__result_%.20s",
1232 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1234 decl = build_decl (VAR_DECL, get_identifier (name),
1235 TREE_TYPE (TREE_TYPE (current_function_decl)));
1237 DECL_ARTIFICIAL (decl) = 1;
1238 DECL_EXTERNAL (decl) = 0;
1239 TREE_PUBLIC (decl) = 0;
1240 TREE_USED (decl) = 1;
1242 layout_decl (decl, 0);
1244 gfc_add_decl_to_function (decl);
1247 current_fake_result_decl = decl;
1253 /* Builds a function decl. The remaining parameters are the types of the
1254 function arguments. Negative nargs indicates a varargs function. */
1257 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1266 /* Library functions must be declared with global scope. */
1267 assert (current_function_decl == NULL_TREE);
1269 va_start (p, nargs);
1272 /* Create a list of the argument types. */
1273 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1275 argtype = va_arg (p, tree);
1276 arglist = gfc_chainon_list (arglist, argtype);
1281 /* Terminate the list. */
1282 arglist = gfc_chainon_list (arglist, void_type_node);
1285 /* Build the function type and decl. */
1286 fntype = build_function_type (rettype, arglist);
1287 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1289 /* Mark this decl as external. */
1290 DECL_EXTERNAL (fndecl) = 1;
1291 TREE_PUBLIC (fndecl) = 1;
1297 rest_of_decl_compilation (fndecl, NULL, 1, 0);
1303 gfc_build_intrinsic_function_decls (void)
1305 /* String functions. */
1306 gfor_fndecl_copy_string =
1307 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1310 gfc_strlen_type_node, pchar_type_node,
1311 gfc_strlen_type_node, pchar_type_node);
1313 gfor_fndecl_compare_string =
1314 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1317 gfc_strlen_type_node, pchar_type_node,
1318 gfc_strlen_type_node, pchar_type_node);
1320 gfor_fndecl_concat_string =
1321 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1324 gfc_strlen_type_node, pchar_type_node,
1325 gfc_strlen_type_node, pchar_type_node,
1326 gfc_strlen_type_node, pchar_type_node);
1328 gfor_fndecl_string_len_trim =
1329 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1331 2, gfc_strlen_type_node,
1334 gfor_fndecl_string_index =
1335 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1337 5, gfc_strlen_type_node, pchar_type_node,
1338 gfc_strlen_type_node, pchar_type_node,
1339 gfc_logical4_type_node);
1341 gfor_fndecl_string_scan =
1342 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1344 5, gfc_strlen_type_node, pchar_type_node,
1345 gfc_strlen_type_node, pchar_type_node,
1346 gfc_logical4_type_node);
1348 gfor_fndecl_string_verify =
1349 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1351 5, gfc_strlen_type_node, pchar_type_node,
1352 gfc_strlen_type_node, pchar_type_node,
1353 gfc_logical4_type_node);
1355 gfor_fndecl_string_trim =
1356 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1359 build_pointer_type (gfc_strlen_type_node),
1361 gfc_strlen_type_node,
1364 gfor_fndecl_string_repeat =
1365 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1369 gfc_strlen_type_node,
1371 gfc_int4_type_node);
1373 gfor_fndecl_adjustl =
1374 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1378 gfc_strlen_type_node, pchar_type_node);
1380 gfor_fndecl_adjustr =
1381 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1385 gfc_strlen_type_node, pchar_type_node);
1387 gfor_fndecl_si_kind =
1388 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1393 gfor_fndecl_sr_kind =
1394 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1400 /* Power functions. */
1401 gfor_fndecl_math_powf =
1402 gfc_build_library_function_decl (get_identifier ("powf"),
1403 gfc_real4_type_node,
1404 1, gfc_real4_type_node);
1405 gfor_fndecl_math_pow =
1406 gfc_build_library_function_decl (get_identifier ("pow"),
1407 gfc_real8_type_node,
1408 1, gfc_real8_type_node);
1409 gfor_fndecl_math_cpowf =
1410 gfc_build_library_function_decl (get_identifier ("cpowf"),
1411 gfc_complex4_type_node,
1412 1, gfc_complex4_type_node);
1413 gfor_fndecl_math_cpow =
1414 gfc_build_library_function_decl (get_identifier ("cpow"),
1415 gfc_complex8_type_node,
1416 1, gfc_complex8_type_node);
1417 gfor_fndecl_math_cabsf =
1418 gfc_build_library_function_decl (get_identifier ("cabsf"),
1419 gfc_real4_type_node,
1420 1, gfc_complex4_type_node);
1421 gfor_fndecl_math_cabs =
1422 gfc_build_library_function_decl (get_identifier ("cabs"),
1423 gfc_real8_type_node,
1424 1, gfc_complex8_type_node);
1425 gfor_fndecl_math_sign4 =
1426 gfc_build_library_function_decl (get_identifier ("copysignf"),
1427 gfc_real4_type_node,
1428 1, gfc_real4_type_node);
1429 gfor_fndecl_math_sign8 =
1430 gfc_build_library_function_decl (get_identifier ("copysign"),
1431 gfc_real8_type_node,
1432 1, gfc_real8_type_node);
1433 gfor_fndecl_math_ishftc4 =
1434 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1436 3, gfc_int4_type_node,
1437 gfc_int4_type_node, gfc_int4_type_node);
1438 gfor_fndecl_math_ishftc8 =
1439 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1441 3, gfc_int8_type_node,
1442 gfc_int8_type_node, gfc_int8_type_node);
1443 gfor_fndecl_math_exponent4 =
1444 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1446 1, gfc_real4_type_node);
1447 gfor_fndecl_math_exponent8 =
1448 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1450 1, gfc_real8_type_node);
1452 /* Other functions. */
1454 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1455 gfc_array_index_type,
1456 1, pvoid_type_node);
1458 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1459 gfc_array_index_type,
1461 gfc_array_index_type);
1465 /* Make prototypes for runtime library functions. */
1468 gfc_build_builtin_function_decls (void)
1470 gfor_fndecl_internal_malloc =
1471 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1472 pvoid_type_node, 1, gfc_int4_type_node);
1474 gfor_fndecl_internal_malloc64 =
1475 gfc_build_library_function_decl (get_identifier
1476 (PREFIX("internal_malloc64")),
1477 pvoid_type_node, 1, gfc_int8_type_node);
1479 gfor_fndecl_internal_free =
1480 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1481 void_type_node, 1, pvoid_type_node);
1483 gfor_fndecl_allocate =
1484 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1485 void_type_node, 2, ppvoid_type_node,
1486 gfc_int4_type_node);
1488 gfor_fndecl_allocate64 =
1489 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1490 void_type_node, 2, ppvoid_type_node,
1491 gfc_int8_type_node);
1493 gfor_fndecl_deallocate =
1494 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1495 void_type_node, 1, ppvoid_type_node);
1497 gfor_fndecl_stop_numeric =
1498 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1499 void_type_node, 1, gfc_int4_type_node);
1501 gfor_fndecl_stop_string =
1502 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1503 void_type_node, 2, pchar_type_node,
1504 gfc_int4_type_node);
1506 gfor_fndecl_pause_numeric =
1507 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1508 void_type_node, 1, gfc_int4_type_node);
1510 gfor_fndecl_pause_string =
1511 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1512 void_type_node, 2, pchar_type_node,
1513 gfc_int4_type_node);
1515 gfor_fndecl_select_string =
1516 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1517 pvoid_type_node, 0);
1519 gfor_fndecl_runtime_error =
1520 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1523 pchar_type_node, pchar_type_node,
1524 gfc_int4_type_node);
1526 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1527 get_identifier (PREFIX("internal_pack")),
1528 pvoid_type_node, 1, pvoid_type_node);
1530 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1531 get_identifier (PREFIX("internal_unpack")),
1532 pvoid_type_node, 1, pvoid_type_node);
1534 gfor_fndecl_associated =
1535 gfc_build_library_function_decl (
1536 get_identifier (PREFIX("associated")),
1537 gfc_logical4_type_node,
1542 gfc_build_intrinsic_function_decls ();
1543 gfc_build_intrinsic_lib_fndecls ();
1544 gfc_build_io_library_fndecls ();
1548 /* Exaluate the length of dummy character variables. */
1551 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1555 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1557 gfc_start_block (&body);
1559 /* Evaluate the string length expression. */
1560 gfc_trans_init_string_length (cl, &body);
1562 gfc_add_expr_to_block (&body, fnbody);
1563 return gfc_finish_block (&body);
1567 /* Allocate and cleanup an automatic character variable. */
1570 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1577 assert (sym->backend_decl);
1578 assert (sym->ts.cl && sym->ts.cl->length);
1580 gfc_start_block (&body);
1582 /* Evaluate the string length expression. */
1583 gfc_trans_init_string_length (sym->ts.cl, &body);
1585 decl = sym->backend_decl;
1587 DECL_DEFER_OUTPUT (decl) = 1;
1589 /* Generate code to allocate the automatic variable. It will be freed
1591 tmp = gfc_build_addr_expr (NULL, decl);
1592 args = gfc_chainon_list (NULL_TREE, tmp);
1593 args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
1594 tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
1595 gfc_add_expr_to_block (&body, tmp);
1596 gfc_add_expr_to_block (&body, fnbody);
1597 return gfc_finish_block (&body);
1601 /* Generate function entry and exit code, and add it to the function body.
1603 Allocation and initialisation of array variables.
1604 Allocation of character string variables.
1605 Initialization and possibly repacking of dummy arrays. */
1608 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1613 /* Deal with implicit return variables. Explicit return variables will
1614 already have been added. */
1615 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1617 if (!current_fake_result_decl)
1619 warning ("Function does not return a value");
1625 fnbody = gfc_trans_dummy_array_bias (proc_sym,
1626 current_fake_result_decl,
1629 else if (proc_sym->ts.type == BT_CHARACTER)
1631 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1632 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1635 gfc_todo_error ("Deferred non-array return by reference");
1638 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1640 if (sym->attr.dimension)
1642 switch (sym->as->type)
1645 if (sym->attr.dummy || sym->attr.result)
1647 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1648 else if (sym->attr.pointer || sym->attr.allocatable)
1650 if (TREE_STATIC (sym->backend_decl))
1651 gfc_trans_static_array_pointer (sym);
1653 fnbody = gfc_trans_deferred_array (sym, fnbody);
1657 gfc_get_backend_locus (&loc);
1658 gfc_set_backend_locus (&sym->declared_at);
1659 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1661 gfc_set_backend_locus (&loc);
1665 case AS_ASSUMED_SIZE:
1666 /* Must be a dummy parameter. */
1667 assert (sym->attr.dummy);
1669 /* We should always pass assumed size arrays the g77 way. */
1670 assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
1671 fnbody = gfc_trans_g77_array (sym, fnbody);
1674 case AS_ASSUMED_SHAPE:
1675 /* Must be a dummy parameter. */
1676 assert (sym->attr.dummy);
1678 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1683 fnbody = gfc_trans_deferred_array (sym, fnbody);
1690 else if (sym->ts.type == BT_CHARACTER)
1692 gfc_get_backend_locus (&loc);
1693 gfc_set_backend_locus (&sym->declared_at);
1694 if (sym->attr.dummy || sym->attr.result)
1695 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1697 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1698 gfc_set_backend_locus (&loc);
1708 /* Output an initialized decl for a module variable. */
1711 gfc_create_module_variable (gfc_symbol * sym)
1716 /* Only output symbols from this module. */
1717 if (sym->ns != module_namespace)
1719 /* I don't think this should ever happen. */
1720 internal_error ("module symbol %s in wrong namespace", sym->name);
1723 /* Don't ouptut symbols from common blocks. */
1724 if (sym->attr.common)
1727 /* Only output variables and array valued parametes. */
1728 if (sym->attr.flavor != FL_VARIABLE
1729 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1732 /* Don't generate variables from other modules. */
1733 if (sym->attr.use_assoc)
1736 if (sym->backend_decl)
1737 internal_error ("backend decl for module variable %s already exists",
1740 /* We always want module variables to be created. */
1741 sym->attr.referenced = 1;
1742 /* Create the decl. */
1743 decl = gfc_get_symbol_decl (sym);
1745 /* We want to allocate storage for this variable. */
1746 TREE_STATIC (decl) = 1;
1748 if (sym->attr.dimension)
1750 assert (sym->attr.pointer || sym->attr.allocatable
1751 || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
1752 if (sym->attr.pointer || sym->attr.allocatable)
1753 gfc_trans_static_array_pointer (sym);
1755 gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
1757 else if (sym->ts.type == BT_DERIVED)
1760 gfc_todo_error ("Initialization of derived type module variables");
1766 gfc_init_se (&se, NULL);
1767 gfc_conv_constant (&se, sym->value);
1768 DECL_INITIAL (decl) = se.expr;
1772 /* Create the variable. */
1774 rest_of_decl_compilation (decl, NULL, 1, 0);
1776 /* Also add length of strings. */
1777 if (sym->ts.type == BT_CHARACTER)
1781 length = sym->ts.cl->backend_decl;
1782 if (!INTEGER_CST_P (length))
1785 rest_of_decl_compilation (length, NULL, 1, 0);
1791 /* Generate all the required code for module variables. */
1794 gfc_generate_module_vars (gfc_namespace * ns)
1796 module_namespace = ns;
1798 /* Check the frontend left the namespace in a reasonable state. */
1799 assert (ns->proc_name && !ns->proc_name->tlink);
1801 /* Create decls for all the module varuiables. */
1802 gfc_traverse_ns (ns, gfc_create_module_variable);
1806 gfc_generate_contained_functions (gfc_namespace * parent)
1810 /* We create all the prototypes before generating any code. */
1811 for (ns = parent->contained; ns; ns = ns->sibling)
1813 /* Skip namespaces from used modules. */
1814 if (ns->parent != parent)
1817 gfc_build_function_decl (ns->proc_name);
1820 for (ns = parent->contained; ns; ns = ns->sibling)
1822 /* Skip namespaces from used modules. */
1823 if (ns->parent != parent)
1826 gfc_generate_function_code (ns);
1831 /* Generate decls for all local variables. We do this to ensure correct
1832 handling of expressions which only appear in the specification of
1836 generate_local_decl (gfc_symbol * sym)
1838 if (sym->attr.flavor == FL_VARIABLE)
1840 /* TODO: The frontend sometimes creates symbols for things which don't
1841 actually exist. E.g. common block names and the names of formal
1842 arguments. The latter are created while attempting to parse
1843 the argument list as a substring reference.
1845 The proper fix is to avoid adding these symbols in the first place.
1846 For now we hack round it by ignoring anything with an unknown type.
1848 if (sym->ts.type == BT_UNKNOWN)
1851 if (sym->attr.referenced)
1852 gfc_get_symbol_decl (sym);
1853 else if (sym->attr.dummy)
1855 if (warn_unused_parameter)
1856 warning ("unused parameter `%s'", sym->name);
1858 /* warn for unused variables, but not if they're inside a common
1860 else if (warn_unused_variable && !sym->attr.in_common)
1861 warning ("unused variable `%s'", sym->name);
1866 generate_local_vars (gfc_namespace * ns)
1868 gfc_traverse_ns (ns, generate_local_decl);
1872 /* Finalize DECL and all nested functions with cgraph. */
1875 gfc_finalize (tree decl)
1877 struct cgraph_node *cgn;
1879 cgn = cgraph_node (decl);
1880 for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1881 gfc_finalize (cgn->decl);
1883 cgraph_finalize_function (decl, false);
1886 /* Generate code for a function. */
1889 gfc_generate_function_code (gfc_namespace * ns)
1900 sym = ns->proc_name;
1901 /* Check that the frontend isn't still using this. */
1902 assert (sym->tlink == NULL);
1906 /* Create the declaration for functions with global scope. */
1907 if (!sym->backend_decl)
1908 gfc_build_function_decl (ns->proc_name);
1910 fndecl = sym->backend_decl;
1911 old_context = current_function_decl;
1915 push_function_context ();
1916 saved_parent_function_decls = saved_function_decls;
1917 saved_function_decls = NULL_TREE;
1920 /* let GCC know the current scope is this function */
1921 current_function_decl = fndecl;
1923 /* print function name on the console at compile time
1924 (unless this feature was switched of by command line option "-quiet" */
1925 announce_function (fndecl);
1927 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1929 /* create RTL for function declaration */
1930 rest_of_decl_compilation (fndecl, NULL, 1, 0);
1933 /* create RTL for function definition */
1934 make_decl_rtl (fndecl, NULL);
1936 /* Set the line and filename. sym->decalred_at seems to point to the last
1937 statement for subroutines, but it'll do for now. */
1938 gfc_set_backend_locus (&sym->declared_at);
1940 /* line and file should not be 0 */
1941 init_function_start (fndecl);
1943 /* We're in function-at-a-time mode. */
1944 cfun->x_whole_function_mode_p = 1;
1946 /* Even though we're inside a function body, we still don't want to
1947 call expand_expr to calculate the size of a variable-sized array.
1948 We haven't necessarily assigned RTL to all variables yet, so it's
1949 not safe to try to expand expressions involving them. */
1950 immediate_size_expand = 0;
1951 cfun->x_dont_save_pending_sizes_p = 1;
1953 /* Will be created as needed. */
1954 current_fake_result_decl = NULL_TREE;
1956 /* function.c requires a push at the start of the function */
1959 gfc_start_block (&block);
1961 gfc_generate_contained_functions (ns);
1963 /* Translate COMMON blocks. */
1964 gfc_trans_common (ns);
1966 generate_local_vars (ns);
1968 current_function_return_label = NULL;
1970 /* Now generate the code for the body of this function. */
1971 gfc_init_block (&body);
1973 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
1974 && sym->attr.subroutine)
1976 tree alternate_return;
1977 alternate_return = gfc_get_fake_result_decl (sym);
1978 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
1981 tmp = gfc_trans_code (ns->code);
1982 gfc_add_expr_to_block (&body, tmp);
1984 /* Add a return label if needed. */
1985 if (current_function_return_label)
1987 tmp = build1_v (LABEL_EXPR, current_function_return_label);
1988 gfc_add_expr_to_block (&body, tmp);
1991 tmp = gfc_finish_block (&body);
1992 /* Add code to create and cleanup arrays. */
1993 tmp = gfc_trans_deferred_vars (sym, tmp);
1994 gfc_add_expr_to_block (&block, tmp);
1996 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
1998 if (sym->attr.subroutine ||sym == sym->result)
2000 result = current_fake_result_decl;
2001 current_fake_result_decl = NULL_TREE;
2004 result = sym->result->backend_decl;
2006 if (result == NULL_TREE)
2007 warning ("Function return value not set");
2010 /* Set the return value to the the dummy result variable. */
2011 tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2012 DECL_RESULT (fndecl), result);
2013 tmp = build_v (RETURN_EXPR, tmp);
2014 gfc_add_expr_to_block (&block, tmp);
2018 /* Add all the decls we created during processing. */
2019 decl = saved_function_decls;
2024 next = TREE_CHAIN (decl);
2025 TREE_CHAIN (decl) = NULL_TREE;
2029 saved_function_decls = NULL_TREE;
2031 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2033 /* Finish off this function and send it for code generation. */
2035 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2037 /* Output the GENERIC tree. */
2038 dump_function (TDI_original, fndecl);
2040 /* Store the end of the function, so that we get good line number
2041 info for the epilogue. */
2042 cfun->function_end_locus = input_location;
2044 /* We're leaving the context of this function, so zap cfun.
2045 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2046 tree_rest_of_compilation. */
2051 pop_function_context ();
2052 saved_function_decls = saved_parent_function_decls;
2054 current_function_decl = old_context;
2056 if (decl_function_context (fndecl))
2058 /* Register this function with cgraph just far enough to get it
2059 added to our parent's nested function list. */
2060 (void) cgraph_node (fndecl);
2062 /* Lowering nested functions requires gimple input. */
2063 gimplify_function_tree (fndecl);
2067 if (cgraph_node (fndecl)->nested)
2069 gimplify_function_tree (fndecl);
2070 lower_nested_functions (fndecl);
2072 gfc_finalize (fndecl);
2078 gfc_generate_constructors (void)
2080 if (gfc_static_ctors != NULL_TREE)
2089 if (gfc_static_ctors == NULL_TREE)
2092 fnname = get_file_function_name ('I');
2093 type = build_function_type (void_type_node,
2094 gfc_chainon_list (NULL_TREE, void_type_node));
2096 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2097 TREE_PUBLIC (fndecl) = 1;
2099 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2100 DECL_CONTEXT (decl) = fndecl;
2101 DECL_RESULT (fndecl) = decl;
2105 current_function_decl = fndecl;
2107 rest_of_decl_compilation (fndecl, NULL, 1, 0);
2109 make_decl_rtl (fndecl, NULL);
2111 init_function_start (fndecl, input_filename, input_line);
2113 cfun->x_whole_function_mode_p = 1;
2115 immediate_size_expand = 0;
2119 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2122 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2123 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2128 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2130 free_after_parsing (cfun);
2131 free_after_compilation (cfun);
2133 tree_rest_of_compilation (fndecl, 0);
2135 current_function_decl = NULL_TREE;
2139 #include "gt-fortran-trans-decl.h"