?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2009-10-02 Tobias Burnus <burnus@net-b.de>
[official-gcc/alias-decl.git] / gcc / fortran / trans-decl.c
blobee38efbe27c14b1abda01ff4eab7f6834f5200e6
1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook
5
6 This file is part of GCC.
7
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.
12
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.
17
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/>. */
21
22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
23
24 #include "config.h"
25 #include "system.h"
26 #include "coretypes.h"
27 #include "tree.h"
28 #include "tree-dump.h"
29 #include "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 "debug.h"
39 #include "gfortran.h"
40 #include "pointer-set.h"
41 #include "trans.h"
42 #include "trans-types.h"
43 #include "trans-array.h"
44 #include "trans-const.h"
45 /* Only for gfc_trans_code. Shouldn't need to include this. */
46 #include "trans-stmt.h"
47
48 #define MAX_LABEL_VALUE 99999
49
50
51 /* Holds the result of the function if no result variable specified. */
52
53 static GTY(()) tree current_fake_result_decl;
54 static GTY(()) tree parent_fake_result_decl;
55
56 static GTY(()) tree current_function_return_label;
57
58
59 /* Holds the variable DECLs for the current function. */
60
61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls;
63
64 static struct pointer_set_t *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
66
67 /* Holds the variable DECLs that are locals. */
68
69 static GTY(()) tree saved_local_decls;
70
71 /* The namespace of the module we're currently generating. Only used while
72 outputting decls for module variables. Do not rely on this being set. */
73
74 static gfc_namespace *module_namespace;
75
76
77 /* List of static constructor functions. */
78
79 tree gfc_static_ctors;
80
81
82 /* Function declarations for builtin library functions. */
83
84 tree gfor_fndecl_pause_numeric;
85 tree gfor_fndecl_pause_string;
86 tree gfor_fndecl_stop_numeric;
87 tree gfor_fndecl_stop_string;
88 tree gfor_fndecl_runtime_error;
89 tree gfor_fndecl_runtime_error_at;
90 tree gfor_fndecl_runtime_warning_at;
91 tree gfor_fndecl_os_error;
92 tree gfor_fndecl_generate_error;
93 tree gfor_fndecl_set_args;
94 tree gfor_fndecl_set_fpe;
95 tree gfor_fndecl_set_options;
96 tree gfor_fndecl_set_convert;
97 tree gfor_fndecl_set_record_marker;
98 tree gfor_fndecl_set_max_subrecord_length;
99 tree gfor_fndecl_ctime;
100 tree gfor_fndecl_fdate;
101 tree gfor_fndecl_ttynam;
102 tree gfor_fndecl_in_pack;
103 tree gfor_fndecl_in_unpack;
104 tree gfor_fndecl_associated;
105
106
107 /* Math functions. Many other math functions are handled in
108 trans-intrinsic.c. */
109
110 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
111 tree gfor_fndecl_math_ishftc4;
112 tree gfor_fndecl_math_ishftc8;
113 tree gfor_fndecl_math_ishftc16;
114
115
116 /* String functions. */
117
118 tree gfor_fndecl_compare_string;
119 tree gfor_fndecl_concat_string;
120 tree gfor_fndecl_string_len_trim;
121 tree gfor_fndecl_string_index;
122 tree gfor_fndecl_string_scan;
123 tree gfor_fndecl_string_verify;
124 tree gfor_fndecl_string_trim;
125 tree gfor_fndecl_string_minmax;
126 tree gfor_fndecl_adjustl;
127 tree gfor_fndecl_adjustr;
128 tree gfor_fndecl_select_string;
129 tree gfor_fndecl_compare_string_char4;
130 tree gfor_fndecl_concat_string_char4;
131 tree gfor_fndecl_string_len_trim_char4;
132 tree gfor_fndecl_string_index_char4;
133 tree gfor_fndecl_string_scan_char4;
134 tree gfor_fndecl_string_verify_char4;
135 tree gfor_fndecl_string_trim_char4;
136 tree gfor_fndecl_string_minmax_char4;
137 tree gfor_fndecl_adjustl_char4;
138 tree gfor_fndecl_adjustr_char4;
139 tree gfor_fndecl_select_string_char4;
140
141
142 /* Conversion between character kinds. */
143 tree gfor_fndecl_convert_char1_to_char4;
144 tree gfor_fndecl_convert_char4_to_char1;
145
146
147 /* Other misc. runtime library functions. */
148
149 tree gfor_fndecl_size0;
150 tree gfor_fndecl_size1;
151 tree gfor_fndecl_iargc;
152 tree gfor_fndecl_clz128;
153 tree gfor_fndecl_ctz128;
154
155 /* Intrinsic functions implemented in Fortran. */
156 tree gfor_fndecl_sc_kind;
157 tree gfor_fndecl_si_kind;
158 tree gfor_fndecl_sr_kind;
159
160 /* BLAS gemm functions. */
161 tree gfor_fndecl_sgemm;
162 tree gfor_fndecl_dgemm;
163 tree gfor_fndecl_cgemm;
164 tree gfor_fndecl_zgemm;
165
166
167 static void
168 gfc_add_decl_to_parent_function (tree decl)
169 {
170 gcc_assert (decl);
171 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
172 DECL_NONLOCAL (decl) = 1;
173 TREE_CHAIN (decl) = saved_parent_function_decls;
174 saved_parent_function_decls = decl;
175 }
176
177 void
178 gfc_add_decl_to_function (tree decl)
179 {
180 gcc_assert (decl);
181 TREE_USED (decl) = 1;
182 DECL_CONTEXT (decl) = current_function_decl;
183 TREE_CHAIN (decl) = saved_function_decls;
184 saved_function_decls = decl;
185 }
186
187 static void
188 add_decl_as_local (tree decl)
189 {
190 gcc_assert (decl);
191 TREE_USED (decl) = 1;
192 DECL_CONTEXT (decl) = current_function_decl;
193 TREE_CHAIN (decl) = saved_local_decls;
194 saved_local_decls = decl;
195 }
196
197
198 /* Build a backend label declaration. Set TREE_USED for named labels.
199 The context of the label is always the current_function_decl. All
200 labels are marked artificial. */
201
202 tree
203 gfc_build_label_decl (tree label_id)
204 {
205 /* 2^32 temporaries should be enough. */
206 static unsigned int tmp_num = 1;
207 tree label_decl;
208 char *label_name;
209
210 if (label_id == NULL_TREE)
211 {
212 /* Build an internal label name. */
213 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
214 label_id = get_identifier (label_name);
215 }
216 else
217 label_name = NULL;
218
219 /* Build the LABEL_DECL node. Labels have no type. */
220 label_decl = build_decl (input_location,
221 LABEL_DECL, label_id, void_type_node);
222 DECL_CONTEXT (label_decl) = current_function_decl;
223 DECL_MODE (label_decl) = VOIDmode;
224
225 /* We always define the label as used, even if the original source
226 file never references the label. We don't want all kinds of
227 spurious warnings for old-style Fortran code with too many
228 labels. */
229 TREE_USED (label_decl) = 1;
230
231 DECL_ARTIFICIAL (label_decl) = 1;
232 return label_decl;
233 }
234
235
236 /* Returns the return label for the current function. */
237
238 tree
239 gfc_get_return_label (void)
240 {
241 char name[GFC_MAX_SYMBOL_LEN + 10];
242
243 if (current_function_return_label)
244 return current_function_return_label;
245
246 sprintf (name, "__return_%s",
247 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
248
249 current_function_return_label =
250 gfc_build_label_decl (get_identifier (name));
251
252 DECL_ARTIFICIAL (current_function_return_label) = 1;
253
254 return current_function_return_label;
255 }
256
257
258 /* Set the backend source location of a decl. */
259
260 void
261 gfc_set_decl_location (tree decl, locus * loc)
262 {
263 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
264 }
265
266
267 /* Return the backend label declaration for a given label structure,
268 or create it if it doesn't exist yet. */
269
270 tree
271 gfc_get_label_decl (gfc_st_label * lp)
272 {
273 if (lp->backend_decl)
274 return lp->backend_decl;
275 else
276 {
277 char label_name[GFC_MAX_SYMBOL_LEN + 1];
278 tree label_decl;
279
280 /* Validate the label declaration from the front end. */
281 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
282
283 /* Build a mangled name for the label. */
284 sprintf (label_name, "__label_%.6d", lp->value);
285
286 /* Build the LABEL_DECL node. */
287 label_decl = gfc_build_label_decl (get_identifier (label_name));
288
289 /* Tell the debugger where the label came from. */
290 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
291 gfc_set_decl_location (label_decl, &lp->where);
292 else
293 DECL_ARTIFICIAL (label_decl) = 1;
294
295 /* Store the label in the label list and return the LABEL_DECL. */
296 lp->backend_decl = label_decl;
297 return label_decl;
298 }
299 }
300
301
302 /* Convert a gfc_symbol to an identifier of the same name. */
303
304 static tree
305 gfc_sym_identifier (gfc_symbol * sym)
306 {
307 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
308 return (get_identifier ("MAIN__"));
309 else
310 return (get_identifier (sym->name));
311 }
312
313
314 /* Construct mangled name from symbol name. */
315
316 static tree
317 gfc_sym_mangled_identifier (gfc_symbol * sym)
318 {
319 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
320
321 /* Prevent the mangling of identifiers that have an assigned
322 binding label (mainly those that are bind(c)). */
323 if (sym->attr.is_bind_c == 1
324 && sym->binding_label[0] != '\0')
325 return get_identifier(sym->binding_label);
326
327 if (sym->module == NULL)
328 return gfc_sym_identifier (sym);
329 else
330 {
331 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
332 return get_identifier (name);
333 }
334 }
335
336
337 /* Construct mangled function name from symbol name. */
338
339 static tree
340 gfc_sym_mangled_function_id (gfc_symbol * sym)
341 {
342 int has_underscore;
343 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
344
345 /* It may be possible to simply use the binding label if it's
346 provided, and remove the other checks. Then we could use it
347 for other things if we wished. */
348 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
349 sym->binding_label[0] != '\0')
350 /* use the binding label rather than the mangled name */
351 return get_identifier (sym->binding_label);
352
353 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
354 || (sym->module != NULL && (sym->attr.external
355 || sym->attr.if_source == IFSRC_IFBODY)))
356 {
357 /* Main program is mangled into MAIN__. */
358 if (sym->attr.is_main_program)
359 return get_identifier ("MAIN__");
360
361 /* Intrinsic procedures are never mangled. */
362 if (sym->attr.proc == PROC_INTRINSIC)
363 return get_identifier (sym->name);
364
365 if (gfc_option.flag_underscoring)
366 {
367 has_underscore = strchr (sym->name, '_') != 0;
368 if (gfc_option.flag_second_underscore && has_underscore)
369 snprintf (name, sizeof name, "%s__", sym->name);
370 else
371 snprintf (name, sizeof name, "%s_", sym->name);
372 return get_identifier (name);
373 }
374 else
375 return get_identifier (sym->name);
376 }
377 else
378 {
379 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
380 return get_identifier (name);
381 }
382 }
383
384
385 void
386 gfc_set_decl_assembler_name (tree decl, tree name)
387 {
388 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
389 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
390 }
391
392
393 /* Returns true if a variable of specified size should go on the stack. */
394
395 int
396 gfc_can_put_var_on_stack (tree size)
397 {
398 unsigned HOST_WIDE_INT low;
399
400 if (!INTEGER_CST_P (size))
401 return 0;
402
403 if (gfc_option.flag_max_stack_var_size < 0)
404 return 1;
405
406 if (TREE_INT_CST_HIGH (size) != 0)
407 return 0;
408
409 low = TREE_INT_CST_LOW (size);
410 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
411 return 0;
412
413 /* TODO: Set a per-function stack size limit. */
414
415 return 1;
416 }
417
418
419 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
420 an expression involving its corresponding pointer. There are
421 2 cases; one for variable size arrays, and one for everything else,
422 because variable-sized arrays require one fewer level of
423 indirection. */
424
425 static void
426 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
427 {
428 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
429 tree value;
430
431 /* Parameters need to be dereferenced. */
432 if (sym->cp_pointer->attr.dummy)
433 ptr_decl = build_fold_indirect_ref_loc (input_location,
434 ptr_decl);
435
436 /* Check to see if we're dealing with a variable-sized array. */
437 if (sym->attr.dimension
438 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
439 {
440 /* These decls will be dereferenced later, so we don't dereference
441 them here. */
442 value = convert (TREE_TYPE (decl), ptr_decl);
443 }
444 else
445 {
446 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
447 ptr_decl);
448 value = build_fold_indirect_ref_loc (input_location,
449 ptr_decl);
450 }
451
452 SET_DECL_VALUE_EXPR (decl, value);
453 DECL_HAS_VALUE_EXPR_P (decl) = 1;
454 GFC_DECL_CRAY_POINTEE (decl) = 1;
455 /* This is a fake variable just for debugging purposes. */
456 TREE_ASM_WRITTEN (decl) = 1;
457 }
458
459
460 /* Finish processing of a declaration without an initial value. */
461
462 static void
463 gfc_finish_decl (tree decl)
464 {
465 gcc_assert (TREE_CODE (decl) == PARM_DECL
466 || DECL_INITIAL (decl) == NULL_TREE);
467
468 if (TREE_CODE (decl) != VAR_DECL)
469 return;
470
471 if (DECL_SIZE (decl) == NULL_TREE
472 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
473 layout_decl (decl, 0);
474
475 /* A few consistency checks. */
476 /* A static variable with an incomplete type is an error if it is
477 initialized. Also if it is not file scope. Otherwise, let it
478 through, but if it is not `extern' then it may cause an error
479 message later. */
480 /* An automatic variable with an incomplete type is an error. */
481
482 /* We should know the storage size. */
483 gcc_assert (DECL_SIZE (decl) != NULL_TREE
484 || (TREE_STATIC (decl)
485 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
486 : DECL_EXTERNAL (decl)));
487
488 /* The storage size should be constant. */
489 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
490 || !DECL_SIZE (decl)
491 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
492 }
493
494
495 /* Apply symbol attributes to a variable, and add it to the function scope. */
496
497 static void
498 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
499 {
500 tree new_type;
501 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
502 This is the equivalent of the TARGET variables.
503 We also need to set this if the variable is passed by reference in a
504 CALL statement. */
505
506 /* Set DECL_VALUE_EXPR for Cray Pointees. */
507 if (sym->attr.cray_pointee)
508 gfc_finish_cray_pointee (decl, sym);
509
510 if (sym->attr.target)
511 TREE_ADDRESSABLE (decl) = 1;
512 /* If it wasn't used we wouldn't be getting it. */
513 TREE_USED (decl) = 1;
514
515 /* Chain this decl to the pending declarations. Don't do pushdecl()
516 because this would add them to the current scope rather than the
517 function scope. */
518 if (current_function_decl != NULL_TREE)
519 {
520 if (sym->ns->proc_name->backend_decl == current_function_decl
521 || sym->result == sym)
522 gfc_add_decl_to_function (decl);
523 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
524 /* This is a BLOCK construct. */
525 add_decl_as_local (decl);
526 else
527 gfc_add_decl_to_parent_function (decl);
528 }
529
530 if (sym->attr.cray_pointee)
531 return;
532
533 if(sym->attr.is_bind_c == 1)
534 {
535 /* We need to put variables that are bind(c) into the common
536 segment of the object file, because this is what C would do.
537 gfortran would typically put them in either the BSS or
538 initialized data segments, and only mark them as common if
539 they were part of common blocks. However, if they are not put
540 into common space, then C cannot initialize global fortran
541 variables that it interoperates with and the draft says that
542 either Fortran or C should be able to initialize it (but not
543 both, of course.) (J3/04-007, section 15.3). */
544 TREE_PUBLIC(decl) = 1;
545 DECL_COMMON(decl) = 1;
546 }
547
548 /* If a variable is USE associated, it's always external. */
549 if (sym->attr.use_assoc)
550 {
551 DECL_EXTERNAL (decl) = 1;
552 TREE_PUBLIC (decl) = 1;
553 }
554 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
555 {
556 /* TODO: Don't set sym->module for result or dummy variables. */
557 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
558 /* This is the declaration of a module variable. */
559 TREE_PUBLIC (decl) = 1;
560 TREE_STATIC (decl) = 1;
561 }
562
563 /* Derived types are a bit peculiar because of the possibility of
564 a default initializer; this must be applied each time the variable
565 comes into scope it therefore need not be static. These variables
566 are SAVE_NONE but have an initializer. Otherwise explicitly
567 initialized variables are SAVE_IMPLICIT and explicitly saved are
568 SAVE_EXPLICIT. */
569 if (!sym->attr.use_assoc
570 && (sym->attr.save != SAVE_NONE || sym->attr.data
571 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
572 TREE_STATIC (decl) = 1;
573
574 if (sym->attr.volatile_)
575 {
576 TREE_THIS_VOLATILE (decl) = 1;
577 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
578 TREE_TYPE (decl) = new_type;
579 }
580
581 /* Keep variables larger than max-stack-var-size off stack. */
582 if (!sym->ns->proc_name->attr.recursive
583 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
584 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
585 /* Put variable length auto array pointers always into stack. */
586 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
587 || sym->attr.dimension == 0
588 || sym->as->type != AS_EXPLICIT
589 || sym->attr.pointer
590 || sym->attr.allocatable)
591 && !DECL_ARTIFICIAL (decl))
592 TREE_STATIC (decl) = 1;
593
594 /* Handle threadprivate variables. */
595 if (sym->attr.threadprivate
596 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
597 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
598
599 if (!sym->attr.target
600 && !sym->attr.pointer
601 && !sym->attr.proc_pointer)
602 DECL_RESTRICTED_P (decl) = 1;
603 }
604
605
606 /* Allocate the lang-specific part of a decl. */
607
608 void
609 gfc_allocate_lang_decl (tree decl)
610 {
611 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
612 ggc_alloc_cleared (sizeof (struct lang_decl));
613 }
614
615 /* Remember a symbol to generate initialization/cleanup code at function
616 entry/exit. */
617
618 static void
619 gfc_defer_symbol_init (gfc_symbol * sym)
620 {
621 gfc_symbol *p;
622 gfc_symbol *last;
623 gfc_symbol *head;
624
625 /* Don't add a symbol twice. */
626 if (sym->tlink)
627 return;
628
629 last = head = sym->ns->proc_name;
630 p = last->tlink;
631
632 /* Make sure that setup code for dummy variables which are used in the
633 setup of other variables is generated first. */
634 if (sym->attr.dummy)
635 {
636 /* Find the first dummy arg seen after us, or the first non-dummy arg.
637 This is a circular list, so don't go past the head. */
638 while (p != head
639 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
640 {
641 last = p;
642 p = p->tlink;
643 }
644 }
645 /* Insert in between last and p. */
646 last->tlink = sym;
647 sym->tlink = p;
648 }
649
650
651 /* Create an array index type variable with function scope. */
652
653 static tree
654 create_index_var (const char * pfx, int nest)
655 {
656 tree decl;
657
658 decl = gfc_create_var_np (gfc_array_index_type, pfx);
659 if (nest)
660 gfc_add_decl_to_parent_function (decl);
661 else
662 gfc_add_decl_to_function (decl);
663 return decl;
664 }
665
666
667 /* Create variables to hold all the non-constant bits of info for a
668 descriptorless array. Remember these in the lang-specific part of the
669 type. */
670
671 static void
672 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
673 {
674 tree type;
675 int dim;
676 int nest;
677
678 type = TREE_TYPE (decl);
679
680 /* We just use the descriptor, if there is one. */
681 if (GFC_DESCRIPTOR_TYPE_P (type))
682 return;
683
684 gcc_assert (GFC_ARRAY_TYPE_P (type));
685 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
686 && !sym->attr.contained;
687
688 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
689 {
690 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
691 {
692 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
693 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
694 }
695 /* Don't try to use the unknown bound for assumed shape arrays. */
696 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
697 && (sym->as->type != AS_ASSUMED_SIZE
698 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
699 {
700 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
701 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
702 }
703
704 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
705 {
706 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
707 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
708 }
709 }
710 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
711 {
712 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
713 "offset");
714 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
715
716 if (nest)
717 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
718 else
719 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
720 }
721
722 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
723 && sym->as->type != AS_ASSUMED_SIZE)
724 {
725 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
726 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
727 }
728
729 if (POINTER_TYPE_P (type))
730 {
731 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
732 gcc_assert (TYPE_LANG_SPECIFIC (type)
733 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
734 type = TREE_TYPE (type);
735 }
736
737 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
738 {
739 tree size, range;
740
741 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
742 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
743 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
744 size);
745 TYPE_DOMAIN (type) = range;
746 layout_type (type);
747 }
748
749 if (TYPE_NAME (type) != NULL_TREE
750 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
751 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
752 {
753 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
754
755 for (dim = 0; dim < sym->as->rank - 1; dim++)
756 {
757 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
758 gtype = TREE_TYPE (gtype);
759 }
760 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
761 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
762 TYPE_NAME (type) = NULL_TREE;
763 }
764
765 if (TYPE_NAME (type) == NULL_TREE)
766 {
767 tree gtype = TREE_TYPE (type), rtype, type_decl;
768
769 for (dim = sym->as->rank - 1; dim >= 0; dim--)
770 {
771 rtype = build_range_type (gfc_array_index_type,
772 GFC_TYPE_ARRAY_LBOUND (type, dim),
773 GFC_TYPE_ARRAY_UBOUND (type, dim));
774 gtype = build_array_type (gtype, rtype);
775 /* Ensure the bound variables aren't optimized out at -O0. */
776 if (!optimize)
777 {
778 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
779 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
780 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
781 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
782 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
783 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
784 }
785 }
786 TYPE_NAME (type) = type_decl = build_decl (input_location,
787 TYPE_DECL, NULL, gtype);
788 DECL_ORIGINAL_TYPE (type_decl) = gtype;
789 }
790 }
791
792
793 /* For some dummy arguments we don't use the actual argument directly.
794 Instead we create a local decl and use that. This allows us to perform
795 initialization, and construct full type information. */
796
797 static tree
798 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
799 {
800 tree decl;
801 tree type;
802 gfc_array_spec *as;
803 char *name;
804 gfc_packed packed;
805 int n;
806 bool known_size;
807
808 if (sym->attr.pointer || sym->attr.allocatable)
809 return dummy;
810
811 /* Add to list of variables if not a fake result variable. */
812 if (sym->attr.result || sym->attr.dummy)
813 gfc_defer_symbol_init (sym);
814
815 type = TREE_TYPE (dummy);
816 gcc_assert (TREE_CODE (dummy) == PARM_DECL
817 && POINTER_TYPE_P (type));
818
819 /* Do we know the element size? */
820 known_size = sym->ts.type != BT_CHARACTER
821 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
822
823 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
824 {
825 /* For descriptorless arrays with known element size the actual
826 argument is sufficient. */
827 gcc_assert (GFC_ARRAY_TYPE_P (type));
828 gfc_build_qualified_array (dummy, sym);
829 return dummy;
830 }
831
832 type = TREE_TYPE (type);
833 if (GFC_DESCRIPTOR_TYPE_P (type))
834 {
835 /* Create a descriptorless array pointer. */
836 as = sym->as;
837 packed = PACKED_NO;
838
839 /* Even when -frepack-arrays is used, symbols with TARGET attribute
840 are not repacked. */
841 if (!gfc_option.flag_repack_arrays || sym->attr.target)
842 {
843 if (as->type == AS_ASSUMED_SIZE)
844 packed = PACKED_FULL;
845 }
846 else
847 {
848 if (as->type == AS_EXPLICIT)
849 {
850 packed = PACKED_FULL;
851 for (n = 0; n < as->rank; n++)
852 {
853 if (!(as->upper[n]
854 && as->lower[n]
855 && as->upper[n]->expr_type == EXPR_CONSTANT
856 && as->lower[n]->expr_type == EXPR_CONSTANT))
857 packed = PACKED_PARTIAL;
858 }
859 }
860 else
861 packed = PACKED_PARTIAL;
862 }
863
864 type = gfc_typenode_for_spec (&sym->ts);
865 type = gfc_get_nodesc_array_type (type, sym->as, packed,
866 !sym->attr.target);
867 }
868 else
869 {
870 /* We now have an expression for the element size, so create a fully
871 qualified type. Reset sym->backend decl or this will just return the
872 old type. */
873 DECL_ARTIFICIAL (sym->backend_decl) = 1;
874 sym->backend_decl = NULL_TREE;
875 type = gfc_sym_type (sym);
876 packed = PACKED_FULL;
877 }
878
879 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
880 decl = build_decl (input_location,
881 VAR_DECL, get_identifier (name), type);
882
883 DECL_ARTIFICIAL (decl) = 1;
884 TREE_PUBLIC (decl) = 0;
885 TREE_STATIC (decl) = 0;
886 DECL_EXTERNAL (decl) = 0;
887
888 /* We should never get deferred shape arrays here. We used to because of
889 frontend bugs. */
890 gcc_assert (sym->as->type != AS_DEFERRED);
891
892 if (packed == PACKED_PARTIAL)
893 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
894 else if (packed == PACKED_FULL)
895 GFC_DECL_PACKED_ARRAY (decl) = 1;
896
897 gfc_build_qualified_array (decl, sym);
898
899 if (DECL_LANG_SPECIFIC (dummy))
900 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
901 else
902 gfc_allocate_lang_decl (decl);
903
904 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
905
906 if (sym->ns->proc_name->backend_decl == current_function_decl
907 || sym->attr.contained)
908 gfc_add_decl_to_function (decl);
909 else
910 gfc_add_decl_to_parent_function (decl);
911
912 return decl;
913 }
914
915 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
916 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
917 pointing to the artificial variable for debug info purposes. */
918
919 static void
920 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
921 {
922 tree decl, dummy;
923
924 if (! nonlocal_dummy_decl_pset)
925 nonlocal_dummy_decl_pset = pointer_set_create ();
926
927 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
928 return;
929
930 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
931 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
932 TREE_TYPE (sym->backend_decl));
933 DECL_ARTIFICIAL (decl) = 0;
934 TREE_USED (decl) = 1;
935 TREE_PUBLIC (decl) = 0;
936 TREE_STATIC (decl) = 0;
937 DECL_EXTERNAL (decl) = 0;
938 if (DECL_BY_REFERENCE (dummy))
939 DECL_BY_REFERENCE (decl) = 1;
940 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
941 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
942 DECL_HAS_VALUE_EXPR_P (decl) = 1;
943 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
944 TREE_CHAIN (decl) = nonlocal_dummy_decls;
945 nonlocal_dummy_decls = decl;
946 }
947
948 /* Return a constant or a variable to use as a string length. Does not
949 add the decl to the current scope. */
950
951 static tree
952 gfc_create_string_length (gfc_symbol * sym)
953 {
954 gcc_assert (sym->ts.u.cl);
955 gfc_conv_const_charlen (sym->ts.u.cl);
956
957 if (sym->ts.u.cl->backend_decl == NULL_TREE)
958 {
959 tree length;
960 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
961
962 /* Also prefix the mangled name. */
963 strcpy (&name[1], sym->name);
964 name[0] = '.';
965 length = build_decl (input_location,
966 VAR_DECL, get_identifier (name),
967 gfc_charlen_type_node);
968 DECL_ARTIFICIAL (length) = 1;
969 TREE_USED (length) = 1;
970 if (sym->ns->proc_name->tlink != NULL)
971 gfc_defer_symbol_init (sym);
972
973 sym->ts.u.cl->backend_decl = length;
974 }
975
976 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
977 return sym->ts.u.cl->backend_decl;
978 }
979
980 /* If a variable is assigned a label, we add another two auxiliary
981 variables. */
982
983 static void
984 gfc_add_assign_aux_vars (gfc_symbol * sym)
985 {
986 tree addr;
987 tree length;
988 tree decl;
989
990 gcc_assert (sym->backend_decl);
991
992 decl = sym->backend_decl;
993 gfc_allocate_lang_decl (decl);
994 GFC_DECL_ASSIGN (decl) = 1;
995 length = build_decl (input_location,
996 VAR_DECL, create_tmp_var_name (sym->name),
997 gfc_charlen_type_node);
998 addr = build_decl (input_location,
999 VAR_DECL, create_tmp_var_name (sym->name),
1000 pvoid_type_node);
1001 gfc_finish_var_decl (length, sym);
1002 gfc_finish_var_decl (addr, sym);
1003 /* STRING_LENGTH is also used as flag. Less than -1 means that
1004 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1005 target label's address. Otherwise, value is the length of a format string
1006 and ASSIGN_ADDR is its address. */
1007 if (TREE_STATIC (length))
1008 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
1009 else
1010 gfc_defer_symbol_init (sym);
1011
1012 GFC_DECL_STRING_LEN (decl) = length;
1013 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1014 }
1015
1016
1017 static tree
1018 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1019 {
1020 unsigned id;
1021 tree attr;
1022
1023 for (id = 0; id < EXT_ATTR_NUM; id++)
1024 if (sym_attr.ext_attr & (1 << id))
1025 {
1026 attr = build_tree_list (
1027 get_identifier (ext_attr_list[id].middle_end_name),
1028 NULL_TREE);
1029 list = chainon (list, attr);
1030 }
1031
1032 return list;
1033 }
1034
1035
1036 /* Return the decl for a gfc_symbol, create it if it doesn't already
1037 exist. */
1038
1039 tree
1040 gfc_get_symbol_decl (gfc_symbol * sym)
1041 {
1042 tree decl;
1043 tree length = NULL_TREE;
1044 tree attributes;
1045 int byref;
1046
1047 gcc_assert (sym->attr.referenced
1048 || sym->attr.use_assoc
1049 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
1050
1051 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1052 byref = gfc_return_by_reference (sym->ns->proc_name);
1053 else
1054 byref = 0;
1055
1056 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1057 {
1058 /* Return via extra parameter. */
1059 if (sym->attr.result && byref
1060 && !sym->backend_decl)
1061 {
1062 sym->backend_decl =
1063 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1064 /* For entry master function skip over the __entry
1065 argument. */
1066 if (sym->ns->proc_name->attr.entry_master)
1067 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1068 }
1069
1070 /* Dummy variables should already have been created. */
1071 gcc_assert (sym->backend_decl);
1072
1073 /* Create a character length variable. */
1074 if (sym->ts.type == BT_CHARACTER)
1075 {
1076 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1077 length = gfc_create_string_length (sym);
1078 else
1079 length = sym->ts.u.cl->backend_decl;
1080 if (TREE_CODE (length) == VAR_DECL
1081 && DECL_CONTEXT (length) == NULL_TREE)
1082 {
1083 /* Add the string length to the same context as the symbol. */
1084 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1085 gfc_add_decl_to_function (length);
1086 else
1087 gfc_add_decl_to_parent_function (length);
1088
1089 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1090 DECL_CONTEXT (length));
1091
1092 gfc_defer_symbol_init (sym);
1093 }
1094 }
1095
1096 /* Use a copy of the descriptor for dummy arrays. */
1097 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1098 {
1099 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1100 /* Prevent the dummy from being detected as unused if it is copied. */
1101 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1102 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1103 sym->backend_decl = decl;
1104 }
1105
1106 TREE_USED (sym->backend_decl) = 1;
1107 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1108 {
1109 gfc_add_assign_aux_vars (sym);
1110 }
1111
1112 if (sym->attr.dimension
1113 && DECL_LANG_SPECIFIC (sym->backend_decl)
1114 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1115 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1116 gfc_nonlocal_dummy_array_decl (sym);
1117
1118 return sym->backend_decl;
1119 }
1120
1121 if (sym->backend_decl)
1122 return sym->backend_decl;
1123
1124 /* If use associated and whole file compilation, use the module
1125 declaration. This is only needed for intrinsic types because
1126 they are substituted for one another during optimization. */
1127 if (gfc_option.flag_whole_file
1128 && sym->attr.flavor == FL_VARIABLE
1129 && sym->ts.type != BT_DERIVED
1130 && sym->attr.use_assoc
1131 && sym->module)
1132 {
1133 gfc_gsymbol *gsym;
1134
1135 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1136 if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
1137 {
1138 gfc_symbol *s;
1139 s = NULL;
1140 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1141 if (s && s->backend_decl)
1142 {
1143 if (sym->ts.type == BT_CHARACTER)
1144 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1145 return s->backend_decl;
1146 }
1147 }
1148 }
1149
1150 /* Catch function declarations. Only used for actual parameters and
1151 procedure pointers. */
1152 if (sym->attr.flavor == FL_PROCEDURE)
1153 {
1154 decl = gfc_get_extern_function_decl (sym);
1155 gfc_set_decl_location (decl, &sym->declared_at);
1156 return decl;
1157 }
1158
1159 if (sym->attr.intrinsic)
1160 internal_error ("intrinsic variable which isn't a procedure");
1161
1162 /* Create string length decl first so that they can be used in the
1163 type declaration. */
1164 if (sym->ts.type == BT_CHARACTER)
1165 length = gfc_create_string_length (sym);
1166
1167 /* Create the decl for the variable. */
1168 decl = build_decl (sym->declared_at.lb->location,
1169 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1170
1171 /* Add attributes to variables. Functions are handled elsewhere. */
1172 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1173 decl_attributes (&decl, attributes, 0);
1174
1175 /* Symbols from modules should have their assembler names mangled.
1176 This is done here rather than in gfc_finish_var_decl because it
1177 is different for string length variables. */
1178 if (sym->module)
1179 {
1180 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1181 if (sym->attr.use_assoc)
1182 DECL_IGNORED_P (decl) = 1;
1183 }
1184
1185 if (sym->attr.dimension)
1186 {
1187 /* Create variables to hold the non-constant bits of array info. */
1188 gfc_build_qualified_array (decl, sym);
1189
1190 /* Remember this variable for allocation/cleanup. */
1191 gfc_defer_symbol_init (sym);
1192
1193 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1194 GFC_DECL_PACKED_ARRAY (decl) = 1;
1195 }
1196
1197 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1198 gfc_defer_symbol_init (sym);
1199 /* This applies a derived type default initializer. */
1200 else if (sym->ts.type == BT_DERIVED
1201 && sym->attr.save == SAVE_NONE
1202 && !sym->attr.data
1203 && !sym->attr.allocatable
1204 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1205 && !sym->attr.use_assoc)
1206 gfc_defer_symbol_init (sym);
1207
1208 gfc_finish_var_decl (decl, sym);
1209
1210 if (sym->ts.type == BT_CHARACTER)
1211 {
1212 /* Character variables need special handling. */
1213 gfc_allocate_lang_decl (decl);
1214
1215 if (TREE_CODE (length) != INTEGER_CST)
1216 {
1217 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1218
1219 if (sym->module)
1220 {
1221 /* Also prefix the mangled name for symbols from modules. */
1222 strcpy (&name[1], sym->name);
1223 name[0] = '.';
1224 strcpy (&name[1],
1225 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1226 gfc_set_decl_assembler_name (decl, get_identifier (name));
1227 }
1228 gfc_finish_var_decl (length, sym);
1229 gcc_assert (!sym->value);
1230 }
1231 }
1232 else if (sym->attr.subref_array_pointer)
1233 {
1234 /* We need the span for these beasts. */
1235 gfc_allocate_lang_decl (decl);
1236 }
1237
1238 if (sym->attr.subref_array_pointer)
1239 {
1240 tree span;
1241 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1242 span = build_decl (input_location,
1243 VAR_DECL, create_tmp_var_name ("span"),
1244 gfc_array_index_type);
1245 gfc_finish_var_decl (span, sym);
1246 TREE_STATIC (span) = TREE_STATIC (decl);
1247 DECL_ARTIFICIAL (span) = 1;
1248 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1249
1250 GFC_DECL_SPAN (decl) = span;
1251 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1252 }
1253
1254 sym->backend_decl = decl;
1255
1256 if (sym->attr.assign)
1257 gfc_add_assign_aux_vars (sym);
1258
1259 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1260 {
1261 /* Add static initializer. */
1262 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1263 TREE_TYPE (decl), sym->attr.dimension,
1264 sym->attr.pointer || sym->attr.allocatable);
1265 }
1266
1267 if (!TREE_STATIC (decl)
1268 && POINTER_TYPE_P (TREE_TYPE (decl))
1269 && !sym->attr.pointer
1270 && !sym->attr.allocatable
1271 && !sym->attr.proc_pointer)
1272 DECL_BY_REFERENCE (decl) = 1;
1273
1274 return decl;
1275 }
1276
1277
1278 /* Substitute a temporary variable in place of the real one. */
1279
1280 void
1281 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1282 {
1283 save->attr = sym->attr;
1284 save->decl = sym->backend_decl;
1285
1286 gfc_clear_attr (&sym->attr);
1287 sym->attr.referenced = 1;
1288 sym->attr.flavor = FL_VARIABLE;
1289
1290 sym->backend_decl = decl;
1291 }
1292
1293
1294 /* Restore the original variable. */
1295
1296 void
1297 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1298 {
1299 sym->attr = save->attr;
1300 sym->backend_decl = save->decl;
1301 }
1302
1303
1304 /* Declare a procedure pointer. */
1305
1306 static tree
1307 get_proc_pointer_decl (gfc_symbol *sym)
1308 {
1309 tree decl;
1310 tree attributes;
1311
1312 decl = sym->backend_decl;
1313 if (decl)
1314 return decl;
1315
1316 decl = build_decl (input_location,
1317 VAR_DECL, get_identifier (sym->name),
1318 build_pointer_type (gfc_get_function_type (sym)));
1319
1320 if ((sym->ns->proc_name
1321 && sym->ns->proc_name->backend_decl == current_function_decl)
1322 || sym->attr.contained)
1323 gfc_add_decl_to_function (decl);
1324 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1325 gfc_add_decl_to_parent_function (decl);
1326
1327 sym->backend_decl = decl;
1328
1329 /* If a variable is USE associated, it's always external. */
1330 if (sym->attr.use_assoc)
1331 {
1332 DECL_EXTERNAL (decl) = 1;
1333 TREE_PUBLIC (decl) = 1;
1334 }
1335 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1336 {
1337 /* This is the declaration of a module variable. */
1338 TREE_PUBLIC (decl) = 1;
1339 TREE_STATIC (decl) = 1;
1340 }
1341
1342 if (!sym->attr.use_assoc
1343 && (sym->attr.save != SAVE_NONE || sym->attr.data
1344 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1345 TREE_STATIC (decl) = 1;
1346
1347 if (TREE_STATIC (decl) && sym->value)
1348 {
1349 /* Add static initializer. */
1350 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1351 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1352 }
1353
1354 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1355 decl_attributes (&decl, attributes, 0);
1356
1357 return decl;
1358 }
1359
1360
1361 /* Get a basic decl for an external function. */
1362
1363 tree
1364 gfc_get_extern_function_decl (gfc_symbol * sym)
1365 {
1366 tree type;
1367 tree fndecl;
1368 tree attributes;
1369 gfc_expr e;
1370 gfc_intrinsic_sym *isym;
1371 gfc_expr argexpr;
1372 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1373 tree name;
1374 tree mangled_name;
1375 gfc_gsymbol *gsym;
1376
1377 if (sym->backend_decl)
1378 return sym->backend_decl;
1379
1380 /* We should never be creating external decls for alternate entry points.
1381 The procedure may be an alternate entry point, but we don't want/need
1382 to know that. */
1383 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1384
1385 if (sym->attr.proc_pointer)
1386 return get_proc_pointer_decl (sym);
1387
1388 /* See if this is an external procedure from the same file. If so,
1389 return the backend_decl. */
1390 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1391
1392 if (gfc_option.flag_whole_file
1393 && !sym->attr.use_assoc
1394 && !sym->backend_decl
1395 && gsym && gsym->ns
1396 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1397 && gsym->ns->proc_name->backend_decl)
1398 {
1399 /* If the namespace has entries, the proc_name is the
1400 entry master. Find the entry and use its backend_decl.
1401 otherwise, use the proc_name backend_decl. */
1402 if (gsym->ns->entries)
1403 {
1404 gfc_entry_list *entry = gsym->ns->entries;
1405
1406 for (; entry; entry = entry->next)
1407 {
1408 if (strcmp (gsym->name, entry->sym->name) == 0)
1409 {
1410 sym->backend_decl = entry->sym->backend_decl;
1411 break;
1412 }
1413 }
1414 }
1415 else
1416 {
1417 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1418 }
1419
1420 if (sym->backend_decl)
1421 return sym->backend_decl;
1422 }
1423
1424 /* See if this is a module procedure from the same file. If so,
1425 return the backend_decl. */
1426 if (sym->module)
1427 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1428
1429 if (gfc_option.flag_whole_file
1430 && gsym && gsym->ns
1431 && gsym->type == GSYM_MODULE)
1432 {
1433 gfc_symbol *s;
1434
1435 s = NULL;
1436 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1437 if (s && s->backend_decl)
1438 {
1439 sym->backend_decl = s->backend_decl;
1440 return sym->backend_decl;
1441 }
1442 }
1443
1444 if (sym->attr.intrinsic)
1445 {
1446 /* Call the resolution function to get the actual name. This is
1447 a nasty hack which relies on the resolution functions only looking
1448 at the first argument. We pass NULL for the second argument
1449 otherwise things like AINT get confused. */
1450 isym = gfc_find_function (sym->name);
1451 gcc_assert (isym->resolve.f0 != NULL);
1452
1453 memset (&e, 0, sizeof (e));
1454 e.expr_type = EXPR_FUNCTION;
1455
1456 memset (&argexpr, 0, sizeof (argexpr));
1457 gcc_assert (isym->formal);
1458 argexpr.ts = isym->formal->ts;
1459
1460 if (isym->formal->next == NULL)
1461 isym->resolve.f1 (&e, &argexpr);
1462 else
1463 {
1464 if (isym->formal->next->next == NULL)
1465 isym->resolve.f2 (&e, &argexpr, NULL);
1466 else
1467 {
1468 if (isym->formal->next->next->next == NULL)
1469 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1470 else
1471 {
1472 /* All specific intrinsics take less than 5 arguments. */
1473 gcc_assert (isym->formal->next->next->next->next == NULL);
1474 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1475 }
1476 }
1477 }
1478
1479 if (gfc_option.flag_f2c
1480 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1481 || e.ts.type == BT_COMPLEX))
1482 {
1483 /* Specific which needs a different implementation if f2c
1484 calling conventions are used. */
1485 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1486 }
1487 else
1488 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1489
1490 name = get_identifier (s);
1491 mangled_name = name;
1492 }
1493 else
1494 {
1495 name = gfc_sym_identifier (sym);
1496 mangled_name = gfc_sym_mangled_function_id (sym);
1497 }
1498
1499 type = gfc_get_function_type (sym);
1500 fndecl = build_decl (input_location,
1501 FUNCTION_DECL, name, type);
1502
1503 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1504 decl_attributes (&fndecl, attributes, 0);
1505
1506 gfc_set_decl_assembler_name (fndecl, mangled_name);
1507
1508 /* Set the context of this decl. */
1509 if (0 && sym->ns && sym->ns->proc_name)
1510 {
1511 /* TODO: Add external decls to the appropriate scope. */
1512 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1513 }
1514 else
1515 {
1516 /* Global declaration, e.g. intrinsic subroutine. */
1517 DECL_CONTEXT (fndecl) = NULL_TREE;
1518 }
1519
1520 DECL_EXTERNAL (fndecl) = 1;
1521
1522 /* This specifies if a function is globally addressable, i.e. it is
1523 the opposite of declaring static in C. */
1524 TREE_PUBLIC (fndecl) = 1;
1525
1526 /* Set attributes for PURE functions. A call to PURE function in the
1527 Fortran 95 sense is both pure and without side effects in the C
1528 sense. */
1529 if (sym->attr.pure || sym->attr.elemental)
1530 {
1531 if (sym->attr.function && !gfc_return_by_reference (sym))
1532 DECL_PURE_P (fndecl) = 1;
1533 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1534 parameters and don't use alternate returns (is this
1535 allowed?). In that case, calls to them are meaningless, and
1536 can be optimized away. See also in build_function_decl(). */
1537 TREE_SIDE_EFFECTS (fndecl) = 0;
1538 }
1539
1540 /* Mark non-returning functions. */
1541 if (sym->attr.noreturn)
1542 TREE_THIS_VOLATILE(fndecl) = 1;
1543
1544 sym->backend_decl = fndecl;
1545
1546 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1547 pushdecl_top_level (fndecl);
1548
1549 return fndecl;
1550 }
1551
1552
1553 /* Create a declaration for a procedure. For external functions (in the C
1554 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1555 a master function with alternate entry points. */
1556
1557 static void
1558 build_function_decl (gfc_symbol * sym)
1559 {
1560 tree fndecl, type, attributes;
1561 symbol_attribute attr;
1562 tree result_decl;
1563 gfc_formal_arglist *f;
1564
1565 gcc_assert (!sym->backend_decl);
1566 gcc_assert (!sym->attr.external);
1567
1568 /* Set the line and filename. sym->declared_at seems to point to the
1569 last statement for subroutines, but it'll do for now. */
1570 gfc_set_backend_locus (&sym->declared_at);
1571
1572 /* Allow only one nesting level. Allow public declarations. */
1573 gcc_assert (current_function_decl == NULL_TREE
1574 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1575 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1576 == NAMESPACE_DECL);
1577
1578 type = gfc_get_function_type (sym);
1579 fndecl = build_decl (input_location,
1580 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1581
1582 attr = sym->attr;
1583
1584 attributes = add_attributes_to_decl (attr, NULL_TREE);
1585 decl_attributes (&fndecl, attributes, 0);
1586
1587 /* Perform name mangling if this is a top level or module procedure. */
1588 if (current_function_decl == NULL_TREE)
1589 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1590
1591 /* Figure out the return type of the declared function, and build a
1592 RESULT_DECL for it. If this is a subroutine with alternate
1593 returns, build a RESULT_DECL for it. */
1594 result_decl = NULL_TREE;
1595 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1596 if (attr.function)
1597 {
1598 if (gfc_return_by_reference (sym))
1599 type = void_type_node;
1600 else
1601 {
1602 if (sym->result != sym)
1603 result_decl = gfc_sym_identifier (sym->result);
1604
1605 type = TREE_TYPE (TREE_TYPE (fndecl));
1606 }
1607 }
1608 else
1609 {
1610 /* Look for alternate return placeholders. */
1611 int has_alternate_returns = 0;
1612 for (f = sym->formal; f; f = f->next)
1613 {
1614 if (f->sym == NULL)
1615 {
1616 has_alternate_returns = 1;
1617 break;
1618 }
1619 }
1620
1621 if (has_alternate_returns)
1622 type = integer_type_node;
1623 else
1624 type = void_type_node;
1625 }
1626
1627 result_decl = build_decl (input_location,
1628 RESULT_DECL, result_decl, type);
1629 DECL_ARTIFICIAL (result_decl) = 1;
1630 DECL_IGNORED_P (result_decl) = 1;
1631 DECL_CONTEXT (result_decl) = fndecl;
1632 DECL_RESULT (fndecl) = result_decl;
1633
1634 /* Don't call layout_decl for a RESULT_DECL.
1635 layout_decl (result_decl, 0); */
1636
1637 /* Set up all attributes for the function. */
1638 DECL_CONTEXT (fndecl) = current_function_decl;
1639 DECL_EXTERNAL (fndecl) = 0;
1640
1641 /* This specifies if a function is globally visible, i.e. it is
1642 the opposite of declaring static in C. */
1643 if (DECL_CONTEXT (fndecl) == NULL_TREE
1644 && !sym->attr.entry_master && !sym->attr.is_main_program)
1645 TREE_PUBLIC (fndecl) = 1;
1646
1647 /* TREE_STATIC means the function body is defined here. */
1648 TREE_STATIC (fndecl) = 1;
1649
1650 /* Set attributes for PURE functions. A call to a PURE function in the
1651 Fortran 95 sense is both pure and without side effects in the C
1652 sense. */
1653 if (attr.pure || attr.elemental)
1654 {
1655 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1656 including an alternate return. In that case it can also be
1657 marked as PURE. See also in gfc_get_extern_function_decl(). */
1658 if (attr.function && !gfc_return_by_reference (sym))
1659 DECL_PURE_P (fndecl) = 1;
1660 TREE_SIDE_EFFECTS (fndecl) = 0;
1661 }
1662
1663
1664 /* Layout the function declaration and put it in the binding level
1665 of the current function. */
1666 pushdecl (fndecl);
1667
1668 sym->backend_decl = fndecl;
1669 }
1670
1671
1672 /* Create the DECL_ARGUMENTS for a procedure. */
1673
1674 static void
1675 create_function_arglist (gfc_symbol * sym)
1676 {
1677 tree fndecl;
1678 gfc_formal_arglist *f;
1679 tree typelist, hidden_typelist;
1680 tree arglist, hidden_arglist;
1681 tree type;
1682 tree parm;
1683
1684 fndecl = sym->backend_decl;
1685
1686 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1687 the new FUNCTION_DECL node. */
1688 arglist = NULL_TREE;
1689 hidden_arglist = NULL_TREE;
1690 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1691
1692 if (sym->attr.entry_master)
1693 {
1694 type = TREE_VALUE (typelist);
1695 parm = build_decl (input_location,
1696 PARM_DECL, get_identifier ("__entry"), type);
1697
1698 DECL_CONTEXT (parm) = fndecl;
1699 DECL_ARG_TYPE (parm) = type;
1700 TREE_READONLY (parm) = 1;
1701 gfc_finish_decl (parm);
1702 DECL_ARTIFICIAL (parm) = 1;
1703
1704 arglist = chainon (arglist, parm);
1705 typelist = TREE_CHAIN (typelist);
1706 }
1707
1708 if (gfc_return_by_reference (sym))
1709 {
1710 tree type = TREE_VALUE (typelist), length = NULL;
1711
1712 if (sym->ts.type == BT_CHARACTER)
1713 {
1714 /* Length of character result. */
1715 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1716 gcc_assert (len_type == gfc_charlen_type_node);
1717
1718 length = build_decl (input_location,
1719 PARM_DECL,
1720 get_identifier (".__result"),
1721 len_type);
1722 if (!sym->ts.u.cl->length)
1723 {
1724 sym->ts.u.cl->backend_decl = length;
1725 TREE_USED (length) = 1;
1726 }
1727 gcc_assert (TREE_CODE (length) == PARM_DECL);
1728 DECL_CONTEXT (length) = fndecl;
1729 DECL_ARG_TYPE (length) = len_type;
1730 TREE_READONLY (length) = 1;
1731 DECL_ARTIFICIAL (length) = 1;
1732 gfc_finish_decl (length);
1733 if (sym->ts.u.cl->backend_decl == NULL
1734 || sym->ts.u.cl->backend_decl == length)
1735 {
1736 gfc_symbol *arg;
1737 tree backend_decl;
1738
1739 if (sym->ts.u.cl->backend_decl == NULL)
1740 {
1741 tree len = build_decl (input_location,
1742 VAR_DECL,
1743 get_identifier ("..__result"),
1744 gfc_charlen_type_node);
1745 DECL_ARTIFICIAL (len) = 1;
1746 TREE_USED (len) = 1;
1747 sym->ts.u.cl->backend_decl = len;
1748 }
1749
1750 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1751 arg = sym->result ? sym->result : sym;
1752 backend_decl = arg->backend_decl;
1753 /* Temporary clear it, so that gfc_sym_type creates complete
1754 type. */
1755 arg->backend_decl = NULL;
1756 type = gfc_sym_type (arg);
1757 arg->backend_decl = backend_decl;
1758 type = build_reference_type (type);
1759 }
1760 }
1761
1762 parm = build_decl (input_location,
1763 PARM_DECL, get_identifier ("__result"), type);
1764
1765 DECL_CONTEXT (parm) = fndecl;
1766 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1767 TREE_READONLY (parm) = 1;
1768 DECL_ARTIFICIAL (parm) = 1;
1769 gfc_finish_decl (parm);
1770
1771 arglist = chainon (arglist, parm);
1772 typelist = TREE_CHAIN (typelist);
1773
1774 if (sym->ts.type == BT_CHARACTER)
1775 {
1776 gfc_allocate_lang_decl (parm);
1777 arglist = chainon (arglist, length);
1778 typelist = TREE_CHAIN (typelist);
1779 }
1780 }
1781
1782 hidden_typelist = typelist;
1783 for (f = sym->formal; f; f = f->next)
1784 if (f->sym != NULL) /* Ignore alternate returns. */
1785 hidden_typelist = TREE_CHAIN (hidden_typelist);
1786
1787 for (f = sym->formal; f; f = f->next)
1788 {
1789 char name[GFC_MAX_SYMBOL_LEN + 2];
1790
1791 /* Ignore alternate returns. */
1792 if (f->sym == NULL)
1793 continue;
1794
1795 type = TREE_VALUE (typelist);
1796
1797 if (f->sym->ts.type == BT_CHARACTER
1798 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1799 {
1800 tree len_type = TREE_VALUE (hidden_typelist);
1801 tree length = NULL_TREE;
1802 gcc_assert (len_type == gfc_charlen_type_node);
1803
1804 strcpy (&name[1], f->sym->name);
1805 name[0] = '_';
1806 length = build_decl (input_location,
1807 PARM_DECL, get_identifier (name), len_type);
1808
1809 hidden_arglist = chainon (hidden_arglist, length);
1810 DECL_CONTEXT (length) = fndecl;
1811 DECL_ARTIFICIAL (length) = 1;
1812 DECL_ARG_TYPE (length) = len_type;
1813 TREE_READONLY (length) = 1;
1814 gfc_finish_decl (length);
1815
1816 /* Remember the passed value. */
1817 if (f->sym->ts.u.cl->passed_length != NULL)
1818 {
1819 /* This can happen if the same type is used for multiple
1820 arguments. We need to copy cl as otherwise
1821 cl->passed_length gets overwritten. */
1822 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1823 }
1824 f->sym->ts.u.cl->passed_length = length;
1825
1826 /* Use the passed value for assumed length variables. */
1827 if (!f->sym->ts.u.cl->length)
1828 {
1829 TREE_USED (length) = 1;
1830 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1831 f->sym->ts.u.cl->backend_decl = length;
1832 }
1833
1834 hidden_typelist = TREE_CHAIN (hidden_typelist);
1835
1836 if (f->sym->ts.u.cl->backend_decl == NULL
1837 || f->sym->ts.u.cl->backend_decl == length)
1838 {
1839 if (f->sym->ts.u.cl->backend_decl == NULL)
1840 gfc_create_string_length (f->sym);
1841
1842 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1843 if (f->sym->attr.flavor == FL_PROCEDURE)
1844 type = build_pointer_type (gfc_get_function_type (f->sym));
1845 else
1846 type = gfc_sym_type (f->sym);
1847 }
1848 }
1849
1850 /* For non-constant length array arguments, make sure they use
1851 a different type node from TYPE_ARG_TYPES type. */
1852 if (f->sym->attr.dimension
1853 && type == TREE_VALUE (typelist)
1854 && TREE_CODE (type) == POINTER_TYPE
1855 && GFC_ARRAY_TYPE_P (type)
1856 && f->sym->as->type != AS_ASSUMED_SIZE
1857 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1858 {
1859 if (f->sym->attr.flavor == FL_PROCEDURE)
1860 type = build_pointer_type (gfc_get_function_type (f->sym));
1861 else
1862 type = gfc_sym_type (f->sym);
1863 }
1864
1865 if (f->sym->attr.proc_pointer)
1866 type = build_pointer_type (type);
1867
1868 /* Build the argument declaration. */
1869 parm = build_decl (input_location,
1870 PARM_DECL, gfc_sym_identifier (f->sym), type);
1871
1872 /* Fill in arg stuff. */
1873 DECL_CONTEXT (parm) = fndecl;
1874 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1875 /* All implementation args are read-only. */
1876 TREE_READONLY (parm) = 1;
1877 if (POINTER_TYPE_P (type)
1878 && (!f->sym->attr.proc_pointer
1879 && f->sym->attr.flavor != FL_PROCEDURE))
1880 DECL_BY_REFERENCE (parm) = 1;
1881
1882 gfc_finish_decl (parm);
1883
1884 f->sym->backend_decl = parm;
1885
1886 arglist = chainon (arglist, parm);
1887 typelist = TREE_CHAIN (typelist);
1888 }
1889
1890 /* Add the hidden string length parameters, unless the procedure
1891 is bind(C). */
1892 if (!sym->attr.is_bind_c)
1893 arglist = chainon (arglist, hidden_arglist);
1894
1895 gcc_assert (hidden_typelist == NULL_TREE
1896 || TREE_VALUE (hidden_typelist) == void_type_node);
1897 DECL_ARGUMENTS (fndecl) = arglist;
1898 }
1899
1900 /* Do the setup necessary before generating the body of a function. */
1901
1902 static void
1903 trans_function_start (gfc_symbol * sym)
1904 {
1905 tree fndecl;
1906
1907 fndecl = sym->backend_decl;
1908
1909 /* Let GCC know the current scope is this function. */
1910 current_function_decl = fndecl;
1911
1912 /* Let the world know what we're about to do. */
1913 announce_function (fndecl);
1914
1915 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1916 {
1917 /* Create RTL for function declaration. */
1918 rest_of_decl_compilation (fndecl, 1, 0);
1919 }
1920
1921 /* Create RTL for function definition. */
1922 make_decl_rtl (fndecl);
1923
1924 init_function_start (fndecl);
1925
1926 /* Even though we're inside a function body, we still don't want to
1927 call expand_expr to calculate the size of a variable-sized array.
1928 We haven't necessarily assigned RTL to all variables yet, so it's
1929 not safe to try to expand expressions involving them. */
1930 cfun->dont_save_pending_sizes_p = 1;
1931
1932 /* function.c requires a push at the start of the function. */
1933 pushlevel (0);
1934 }
1935
1936 /* Create thunks for alternate entry points. */
1937
1938 static void
1939 build_entry_thunks (gfc_namespace * ns)
1940 {
1941 gfc_formal_arglist *formal;
1942 gfc_formal_arglist *thunk_formal;
1943 gfc_entry_list *el;
1944 gfc_symbol *thunk_sym;
1945 stmtblock_t body;
1946 tree thunk_fndecl;
1947 tree args;
1948 tree string_args;
1949 tree tmp;
1950 locus old_loc;
1951
1952 /* This should always be a toplevel function. */
1953 gcc_assert (current_function_decl == NULL_TREE);
1954
1955 gfc_get_backend_locus (&old_loc);
1956 for (el = ns->entries; el; el = el->next)
1957 {
1958 thunk_sym = el->sym;
1959
1960 build_function_decl (thunk_sym);
1961 create_function_arglist (thunk_sym);
1962
1963 trans_function_start (thunk_sym);
1964
1965 thunk_fndecl = thunk_sym->backend_decl;
1966
1967 gfc_init_block (&body);
1968
1969 /* Pass extra parameter identifying this entry point. */
1970 tmp = build_int_cst (gfc_array_index_type, el->id);
1971 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1972 string_args = NULL_TREE;
1973
1974 if (thunk_sym->attr.function)
1975 {
1976 if (gfc_return_by_reference (ns->proc_name))
1977 {
1978 tree ref = DECL_ARGUMENTS (current_function_decl);
1979 args = tree_cons (NULL_TREE, ref, args);
1980 if (ns->proc_name->ts.type == BT_CHARACTER)
1981 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1982 args);
1983 }
1984 }
1985
1986 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1987 {
1988 /* Ignore alternate returns. */
1989 if (formal->sym == NULL)
1990 continue;
1991
1992 /* We don't have a clever way of identifying arguments, so resort to
1993 a brute-force search. */
1994 for (thunk_formal = thunk_sym->formal;
1995 thunk_formal;
1996 thunk_formal = thunk_formal->next)
1997 {
1998 if (thunk_formal->sym == formal->sym)
1999 break;
2000 }
2001
2002 if (thunk_formal)
2003 {
2004 /* Pass the argument. */
2005 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2006 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2007 args);
2008 if (formal->sym->ts.type == BT_CHARACTER)
2009 {
2010 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2011 string_args = tree_cons (NULL_TREE, tmp, string_args);
2012 }
2013 }
2014 else
2015 {
2016 /* Pass NULL for a missing argument. */
2017 args = tree_cons (NULL_TREE, null_pointer_node, args);
2018 if (formal->sym->ts.type == BT_CHARACTER)
2019 {
2020 tmp = build_int_cst (gfc_charlen_type_node, 0);
2021 string_args = tree_cons (NULL_TREE, tmp, string_args);
2022 }
2023 }
2024 }
2025
2026 /* Call the master function. */
2027 args = nreverse (args);
2028 args = chainon (args, nreverse (string_args));
2029 tmp = ns->proc_name->backend_decl;
2030 tmp = build_function_call_expr (input_location, tmp, args);
2031 if (ns->proc_name->attr.mixed_entry_master)
2032 {
2033 tree union_decl, field;
2034 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2035
2036 union_decl = build_decl (input_location,
2037 VAR_DECL, get_identifier ("__result"),
2038 TREE_TYPE (master_type));
2039 DECL_ARTIFICIAL (union_decl) = 1;
2040 DECL_EXTERNAL (union_decl) = 0;
2041 TREE_PUBLIC (union_decl) = 0;
2042 TREE_USED (union_decl) = 1;
2043 layout_decl (union_decl, 0);
2044 pushdecl (union_decl);
2045
2046 DECL_CONTEXT (union_decl) = current_function_decl;
2047 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2048 union_decl, tmp);
2049 gfc_add_expr_to_block (&body, tmp);
2050
2051 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2052 field; field = TREE_CHAIN (field))
2053 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2054 thunk_sym->result->name) == 0)
2055 break;
2056 gcc_assert (field != NULL_TREE);
2057 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2058 union_decl, field, NULL_TREE);
2059 tmp = fold_build2 (MODIFY_EXPR,
2060 TREE_TYPE (DECL_RESULT (current_function_decl)),
2061 DECL_RESULT (current_function_decl), tmp);
2062 tmp = build1_v (RETURN_EXPR, tmp);
2063 }
2064 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2065 != void_type_node)
2066 {
2067 tmp = fold_build2 (MODIFY_EXPR,
2068 TREE_TYPE (DECL_RESULT (current_function_decl)),
2069 DECL_RESULT (current_function_decl), tmp);
2070 tmp = build1_v (RETURN_EXPR, tmp);
2071 }
2072 gfc_add_expr_to_block (&body, tmp);
2073
2074 /* Finish off this function and send it for code generation. */
2075 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2076 tmp = getdecls ();
2077 poplevel (1, 0, 1);
2078 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2079 DECL_SAVED_TREE (thunk_fndecl)
2080 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2081 DECL_INITIAL (thunk_fndecl));
2082
2083 /* Output the GENERIC tree. */
2084 dump_function (TDI_original, thunk_fndecl);
2085
2086 /* Store the end of the function, so that we get good line number
2087 info for the epilogue. */
2088 cfun->function_end_locus = input_location;
2089
2090 /* We're leaving the context of this function, so zap cfun.
2091 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2092 tree_rest_of_compilation. */
2093 set_cfun (NULL);
2094
2095 current_function_decl = NULL_TREE;
2096
2097 cgraph_finalize_function (thunk_fndecl, true);
2098
2099 /* We share the symbols in the formal argument list with other entry
2100 points and the master function. Clear them so that they are
2101 recreated for each function. */
2102 for (formal = thunk_sym->formal; formal; formal = formal->next)
2103 if (formal->sym != NULL) /* Ignore alternate returns. */
2104 {
2105 formal->sym->backend_decl = NULL_TREE;
2106 if (formal->sym->ts.type == BT_CHARACTER)
2107 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2108 }
2109
2110 if (thunk_sym->attr.function)
2111 {
2112 if (thunk_sym->ts.type == BT_CHARACTER)
2113 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2114 if (thunk_sym->result->ts.type == BT_CHARACTER)
2115 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2116 }
2117 }
2118
2119 gfc_set_backend_locus (&old_loc);
2120 }
2121
2122
2123 /* Create a decl for a function, and create any thunks for alternate entry
2124 points. */
2125
2126 void
2127 gfc_create_function_decl (gfc_namespace * ns)
2128 {
2129 /* Create a declaration for the master function. */
2130 build_function_decl (ns->proc_name);
2131
2132 /* Compile the entry thunks. */
2133 if (ns->entries)
2134 build_entry_thunks (ns);
2135
2136 /* Now create the read argument list. */
2137 create_function_arglist (ns->proc_name);
2138 }
2139
2140 /* Return the decl used to hold the function return value. If
2141 parent_flag is set, the context is the parent_scope. */
2142
2143 tree
2144 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2145 {
2146 tree decl;
2147 tree length;
2148 tree this_fake_result_decl;
2149 tree this_function_decl;
2150
2151 char name[GFC_MAX_SYMBOL_LEN + 10];
2152
2153 if (parent_flag)
2154 {
2155 this_fake_result_decl = parent_fake_result_decl;
2156 this_function_decl = DECL_CONTEXT (current_function_decl);
2157 }
2158 else
2159 {
2160 this_fake_result_decl = current_fake_result_decl;
2161 this_function_decl = current_function_decl;
2162 }
2163
2164 if (sym
2165 && sym->ns->proc_name->backend_decl == this_function_decl
2166 && sym->ns->proc_name->attr.entry_master
2167 && sym != sym->ns->proc_name)
2168 {
2169 tree t = NULL, var;
2170 if (this_fake_result_decl != NULL)
2171 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2172 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2173 break;
2174 if (t)
2175 return TREE_VALUE (t);
2176 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2177
2178 if (parent_flag)
2179 this_fake_result_decl = parent_fake_result_decl;
2180 else
2181 this_fake_result_decl = current_fake_result_decl;
2182
2183 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2184 {
2185 tree field;
2186
2187 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2188 field; field = TREE_CHAIN (field))
2189 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2190 sym->name) == 0)
2191 break;
2192
2193 gcc_assert (field != NULL_TREE);
2194 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2195 decl, field, NULL_TREE);
2196 }
2197
2198 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2199 if (parent_flag)
2200 gfc_add_decl_to_parent_function (var);
2201 else
2202 gfc_add_decl_to_function (var);
2203
2204 SET_DECL_VALUE_EXPR (var, decl);
2205 DECL_HAS_VALUE_EXPR_P (var) = 1;
2206 GFC_DECL_RESULT (var) = 1;
2207
2208 TREE_CHAIN (this_fake_result_decl)
2209 = tree_cons (get_identifier (sym->name), var,
2210 TREE_CHAIN (this_fake_result_decl));
2211 return var;
2212 }
2213
2214 if (this_fake_result_decl != NULL_TREE)
2215 return TREE_VALUE (this_fake_result_decl);
2216
2217 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2218 sym is NULL. */
2219 if (!sym)
2220 return NULL_TREE;
2221
2222 if (sym->ts.type == BT_CHARACTER)
2223 {
2224 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2225 length = gfc_create_string_length (sym);
2226 else
2227 length = sym->ts.u.cl->backend_decl;
2228 if (TREE_CODE (length) == VAR_DECL
2229 && DECL_CONTEXT (length) == NULL_TREE)
2230 gfc_add_decl_to_function (length);
2231 }
2232
2233 if (gfc_return_by_reference (sym))
2234 {
2235 decl = DECL_ARGUMENTS (this_function_decl);
2236
2237 if (sym->ns->proc_name->backend_decl == this_function_decl
2238 && sym->ns->proc_name->attr.entry_master)
2239 decl = TREE_CHAIN (decl);
2240
2241 TREE_USED (decl) = 1;
2242 if (sym->as)
2243 decl = gfc_build_dummy_array_decl (sym, decl);
2244 }
2245 else
2246 {
2247 sprintf (name, "__result_%.20s",
2248 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2249
2250 if (!sym->attr.mixed_entry_master && sym->attr.function)
2251 decl = build_decl (input_location,
2252 VAR_DECL, get_identifier (name),
2253 gfc_sym_type (sym));
2254 else
2255 decl = build_decl (input_location,
2256 VAR_DECL, get_identifier (name),
2257 TREE_TYPE (TREE_TYPE (this_function_decl)));
2258 DECL_ARTIFICIAL (decl) = 1;
2259 DECL_EXTERNAL (decl) = 0;
2260 TREE_PUBLIC (decl) = 0;
2261 TREE_USED (decl) = 1;
2262 GFC_DECL_RESULT (decl) = 1;
2263 TREE_ADDRESSABLE (decl) = 1;
2264
2265 layout_decl (decl, 0);
2266
2267 if (parent_flag)
2268 gfc_add_decl_to_parent_function (decl);
2269 else
2270 gfc_add_decl_to_function (decl);
2271 }
2272
2273 if (parent_flag)
2274 parent_fake_result_decl = build_tree_list (NULL, decl);
2275 else
2276 current_fake_result_decl = build_tree_list (NULL, decl);
2277
2278 return decl;
2279 }
2280
2281
2282 /* Builds a function decl. The remaining parameters are the types of the
2283 function arguments. Negative nargs indicates a varargs function. */
2284
2285 tree
2286 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2287 {
2288 tree arglist;
2289 tree argtype;
2290 tree fntype;
2291 tree fndecl;
2292 va_list p;
2293 int n;
2294
2295 /* Library functions must be declared with global scope. */
2296 gcc_assert (current_function_decl == NULL_TREE);
2297
2298 va_start (p, nargs);
2299
2300
2301 /* Create a list of the argument types. */
2302 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2303 {
2304 argtype = va_arg (p, tree);
2305 arglist = gfc_chainon_list (arglist, argtype);
2306 }
2307
2308 if (nargs >= 0)
2309 {
2310 /* Terminate the list. */
2311 arglist = gfc_chainon_list (arglist, void_type_node);
2312 }
2313
2314 /* Build the function type and decl. */
2315 fntype = build_function_type (rettype, arglist);
2316 fndecl = build_decl (input_location,
2317 FUNCTION_DECL, name, fntype);
2318
2319 /* Mark this decl as external. */
2320 DECL_EXTERNAL (fndecl) = 1;
2321 TREE_PUBLIC (fndecl) = 1;
2322
2323 va_end (p);
2324
2325 pushdecl (fndecl);
2326
2327 rest_of_decl_compilation (fndecl, 1, 0);
2328
2329 return fndecl;
2330 }
2331
2332 static void
2333 gfc_build_intrinsic_function_decls (void)
2334 {
2335 tree gfc_int4_type_node = gfc_get_int_type (4);
2336 tree gfc_int8_type_node = gfc_get_int_type (8);
2337 tree gfc_int16_type_node = gfc_get_int_type (16);
2338 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2339 tree pchar1_type_node = gfc_get_pchar_type (1);
2340 tree pchar4_type_node = gfc_get_pchar_type (4);
2341
2342 /* String functions. */
2343 gfor_fndecl_compare_string =
2344 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2345 integer_type_node, 4,
2346 gfc_charlen_type_node, pchar1_type_node,
2347 gfc_charlen_type_node, pchar1_type_node);
2348
2349 gfor_fndecl_concat_string =
2350 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2351 void_type_node, 6,
2352 gfc_charlen_type_node, pchar1_type_node,
2353 gfc_charlen_type_node, pchar1_type_node,
2354 gfc_charlen_type_node, pchar1_type_node);
2355
2356 gfor_fndecl_string_len_trim =
2357 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2358 gfc_int4_type_node, 2,
2359 gfc_charlen_type_node, pchar1_type_node);
2360
2361 gfor_fndecl_string_index =
2362 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2363 gfc_int4_type_node, 5,
2364 gfc_charlen_type_node, pchar1_type_node,
2365 gfc_charlen_type_node, pchar1_type_node,
2366 gfc_logical4_type_node);
2367
2368 gfor_fndecl_string_scan =
2369 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2370 gfc_int4_type_node, 5,
2371 gfc_charlen_type_node, pchar1_type_node,
2372 gfc_charlen_type_node, pchar1_type_node,
2373 gfc_logical4_type_node);
2374
2375 gfor_fndecl_string_verify =
2376 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2377 gfc_int4_type_node, 5,
2378 gfc_charlen_type_node, pchar1_type_node,
2379 gfc_charlen_type_node, pchar1_type_node,
2380 gfc_logical4_type_node);
2381
2382 gfor_fndecl_string_trim =
2383 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2384 void_type_node, 4,
2385 build_pointer_type (gfc_charlen_type_node),
2386 build_pointer_type (pchar1_type_node),
2387 gfc_charlen_type_node, pchar1_type_node);
2388
2389 gfor_fndecl_string_minmax =
2390 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2391 void_type_node, -4,
2392 build_pointer_type (gfc_charlen_type_node),
2393 build_pointer_type (pchar1_type_node),
2394 integer_type_node, integer_type_node);
2395
2396 gfor_fndecl_adjustl =
2397 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2398 void_type_node, 3, pchar1_type_node,
2399 gfc_charlen_type_node, pchar1_type_node);
2400
2401 gfor_fndecl_adjustr =
2402 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2403 void_type_node, 3, pchar1_type_node,
2404 gfc_charlen_type_node, pchar1_type_node);
2405
2406 gfor_fndecl_select_string =
2407 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2408 integer_type_node, 4, pvoid_type_node,
2409 integer_type_node, pchar1_type_node,
2410 gfc_charlen_type_node);
2411
2412 gfor_fndecl_compare_string_char4 =
2413 gfc_build_library_function_decl (get_identifier
2414 (PREFIX("compare_string_char4")),
2415 integer_type_node, 4,
2416 gfc_charlen_type_node, pchar4_type_node,
2417 gfc_charlen_type_node, pchar4_type_node);
2418
2419 gfor_fndecl_concat_string_char4 =
2420 gfc_build_library_function_decl (get_identifier
2421 (PREFIX("concat_string_char4")),
2422 void_type_node, 6,
2423 gfc_charlen_type_node, pchar4_type_node,
2424 gfc_charlen_type_node, pchar4_type_node,
2425 gfc_charlen_type_node, pchar4_type_node);
2426
2427 gfor_fndecl_string_len_trim_char4 =
2428 gfc_build_library_function_decl (get_identifier
2429 (PREFIX("string_len_trim_char4")),
2430 gfc_charlen_type_node, 2,
2431 gfc_charlen_type_node, pchar4_type_node);
2432
2433 gfor_fndecl_string_index_char4 =
2434 gfc_build_library_function_decl (get_identifier
2435 (PREFIX("string_index_char4")),
2436 gfc_charlen_type_node, 5,
2437 gfc_charlen_type_node, pchar4_type_node,
2438 gfc_charlen_type_node, pchar4_type_node,
2439 gfc_logical4_type_node);
2440
2441 gfor_fndecl_string_scan_char4 =
2442 gfc_build_library_function_decl (get_identifier
2443 (PREFIX("string_scan_char4")),
2444 gfc_charlen_type_node, 5,
2445 gfc_charlen_type_node, pchar4_type_node,
2446 gfc_charlen_type_node, pchar4_type_node,
2447 gfc_logical4_type_node);
2448
2449 gfor_fndecl_string_verify_char4 =
2450 gfc_build_library_function_decl (get_identifier
2451 (PREFIX("string_verify_char4")),
2452 gfc_charlen_type_node, 5,
2453 gfc_charlen_type_node, pchar4_type_node,
2454 gfc_charlen_type_node, pchar4_type_node,
2455 gfc_logical4_type_node);
2456
2457 gfor_fndecl_string_trim_char4 =
2458 gfc_build_library_function_decl (get_identifier
2459 (PREFIX("string_trim_char4")),
2460 void_type_node, 4,
2461 build_pointer_type (gfc_charlen_type_node),
2462 build_pointer_type (pchar4_type_node),
2463 gfc_charlen_type_node, pchar4_type_node);
2464
2465 gfor_fndecl_string_minmax_char4 =
2466 gfc_build_library_function_decl (get_identifier
2467 (PREFIX("string_minmax_char4")),
2468 void_type_node, -4,
2469 build_pointer_type (gfc_charlen_type_node),
2470 build_pointer_type (pchar4_type_node),
2471 integer_type_node, integer_type_node);
2472
2473 gfor_fndecl_adjustl_char4 =
2474 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2475 void_type_node, 3, pchar4_type_node,
2476 gfc_charlen_type_node, pchar4_type_node);
2477
2478 gfor_fndecl_adjustr_char4 =
2479 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2480 void_type_node, 3, pchar4_type_node,
2481 gfc_charlen_type_node, pchar4_type_node);
2482
2483 gfor_fndecl_select_string_char4 =
2484 gfc_build_library_function_decl (get_identifier
2485 (PREFIX("select_string_char4")),
2486 integer_type_node, 4, pvoid_type_node,
2487 integer_type_node, pvoid_type_node,
2488 gfc_charlen_type_node);
2489
2490
2491 /* Conversion between character kinds. */
2492
2493 gfor_fndecl_convert_char1_to_char4 =
2494 gfc_build_library_function_decl (get_identifier
2495 (PREFIX("convert_char1_to_char4")),
2496 void_type_node, 3,
2497 build_pointer_type (pchar4_type_node),
2498 gfc_charlen_type_node, pchar1_type_node);
2499
2500 gfor_fndecl_convert_char4_to_char1 =
2501 gfc_build_library_function_decl (get_identifier
2502 (PREFIX("convert_char4_to_char1")),
2503 void_type_node, 3,
2504 build_pointer_type (pchar1_type_node),
2505 gfc_charlen_type_node, pchar4_type_node);
2506
2507 /* Misc. functions. */
2508
2509 gfor_fndecl_ttynam =
2510 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2511 void_type_node,
2512 3,
2513 pchar_type_node,
2514 gfc_charlen_type_node,
2515 integer_type_node);
2516
2517 gfor_fndecl_fdate =
2518 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2519 void_type_node,
2520 2,
2521 pchar_type_node,
2522 gfc_charlen_type_node);
2523
2524 gfor_fndecl_ctime =
2525 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2526 void_type_node,
2527 3,
2528 pchar_type_node,
2529 gfc_charlen_type_node,
2530 gfc_int8_type_node);
2531
2532 gfor_fndecl_sc_kind =
2533 gfc_build_library_function_decl (get_identifier
2534 (PREFIX("selected_char_kind")),
2535 gfc_int4_type_node, 2,
2536 gfc_charlen_type_node, pchar_type_node);
2537
2538 gfor_fndecl_si_kind =
2539 gfc_build_library_function_decl (get_identifier
2540 (PREFIX("selected_int_kind")),
2541 gfc_int4_type_node, 1, pvoid_type_node);
2542
2543 gfor_fndecl_sr_kind =
2544 gfc_build_library_function_decl (get_identifier
2545 (PREFIX("selected_real_kind")),
2546 gfc_int4_type_node, 2,
2547 pvoid_type_node, pvoid_type_node);
2548
2549 /* Power functions. */
2550 {
2551 tree ctype, rtype, itype, jtype;
2552 int rkind, ikind, jkind;
2553 #define NIKINDS 3
2554 #define NRKINDS 4
2555 static int ikinds[NIKINDS] = {4, 8, 16};
2556 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2557 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2558
2559 for (ikind=0; ikind < NIKINDS; ikind++)
2560 {
2561 itype = gfc_get_int_type (ikinds[ikind]);
2562
2563 for (jkind=0; jkind < NIKINDS; jkind++)
2564 {
2565 jtype = gfc_get_int_type (ikinds[jkind]);
2566 if (itype && jtype)
2567 {
2568 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2569 ikinds[jkind]);
2570 gfor_fndecl_math_powi[jkind][ikind].integer =
2571 gfc_build_library_function_decl (get_identifier (name),
2572 jtype, 2, jtype, itype);
2573 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2574 }
2575 }
2576
2577 for (rkind = 0; rkind < NRKINDS; rkind ++)
2578 {
2579 rtype = gfc_get_real_type (rkinds[rkind]);
2580 if (rtype && itype)
2581 {
2582 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2583 ikinds[ikind]);
2584 gfor_fndecl_math_powi[rkind][ikind].real =
2585 gfc_build_library_function_decl (get_identifier (name),
2586 rtype, 2, rtype, itype);
2587 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2588 }
2589
2590 ctype = gfc_get_complex_type (rkinds[rkind]);
2591 if (ctype && itype)
2592 {
2593 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2594 ikinds[ikind]);
2595 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2596 gfc_build_library_function_decl (get_identifier (name),
2597 ctype, 2,ctype, itype);
2598 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2599 }
2600 }
2601 }
2602 #undef NIKINDS
2603 #undef NRKINDS
2604 }
2605
2606 gfor_fndecl_math_ishftc4 =
2607 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2608 gfc_int4_type_node,
2609 3, gfc_int4_type_node,
2610 gfc_int4_type_node, gfc_int4_type_node);
2611 gfor_fndecl_math_ishftc8 =
2612 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2613 gfc_int8_type_node,
2614 3, gfc_int8_type_node,
2615 gfc_int4_type_node, gfc_int4_type_node);
2616 if (gfc_int16_type_node)
2617 gfor_fndecl_math_ishftc16 =
2618 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2619 gfc_int16_type_node, 3,
2620 gfc_int16_type_node,
2621 gfc_int4_type_node,
2622 gfc_int4_type_node);
2623
2624 /* BLAS functions. */
2625 {
2626 tree pint = build_pointer_type (integer_type_node);
2627 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2628 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2629 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2630 tree pz = build_pointer_type
2631 (gfc_get_complex_type (gfc_default_double_kind));
2632
2633 gfor_fndecl_sgemm = gfc_build_library_function_decl
2634 (get_identifier
2635 (gfc_option.flag_underscoring ? "sgemm_"
2636 : "sgemm"),
2637 void_type_node, 15, pchar_type_node,
2638 pchar_type_node, pint, pint, pint, ps, ps, pint,
2639 ps, pint, ps, ps, pint, integer_type_node,
2640 integer_type_node);
2641 gfor_fndecl_dgemm = gfc_build_library_function_decl
2642 (get_identifier
2643 (gfc_option.flag_underscoring ? "dgemm_"
2644 : "dgemm"),
2645 void_type_node, 15, pchar_type_node,
2646 pchar_type_node, pint, pint, pint, pd, pd, pint,
2647 pd, pint, pd, pd, pint, integer_type_node,
2648 integer_type_node);
2649 gfor_fndecl_cgemm = gfc_build_library_function_decl
2650 (get_identifier
2651 (gfc_option.flag_underscoring ? "cgemm_"
2652 : "cgemm"),
2653 void_type_node, 15, pchar_type_node,
2654 pchar_type_node, pint, pint, pint, pc, pc, pint,
2655 pc, pint, pc, pc, pint, integer_type_node,
2656 integer_type_node);
2657 gfor_fndecl_zgemm = gfc_build_library_function_decl
2658 (get_identifier
2659 (gfc_option.flag_underscoring ? "zgemm_"
2660 : "zgemm"),
2661 void_type_node, 15, pchar_type_node,
2662 pchar_type_node, pint, pint, pint, pz, pz, pint,
2663 pz, pint, pz, pz, pint, integer_type_node,
2664 integer_type_node);
2665 }
2666
2667 /* Other functions. */
2668 gfor_fndecl_size0 =
2669 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2670 gfc_array_index_type,
2671 1, pvoid_type_node);
2672 gfor_fndecl_size1 =
2673 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2674 gfc_array_index_type,
2675 2, pvoid_type_node,
2676 gfc_array_index_type);
2677
2678 gfor_fndecl_iargc =
2679 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2680 gfc_int4_type_node,
2681 0);
2682
2683 if (gfc_type_for_size (128, true))
2684 {
2685 tree uint128 = gfc_type_for_size (128, true);
2686
2687 gfor_fndecl_clz128 =
2688 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2689 integer_type_node, 1, uint128);
2690
2691 gfor_fndecl_ctz128 =
2692 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2693 integer_type_node, 1, uint128);
2694 }
2695 }
2696
2697
2698 /* Make prototypes for runtime library functions. */
2699
2700 void
2701 gfc_build_builtin_function_decls (void)
2702 {
2703 tree gfc_int4_type_node = gfc_get_int_type (4);
2704
2705 gfor_fndecl_stop_numeric =
2706 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2707 void_type_node, 1, gfc_int4_type_node);
2708 /* Stop doesn't return. */
2709 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2710
2711 gfor_fndecl_stop_string =
2712 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2713 void_type_node, 2, pchar_type_node,
2714 gfc_int4_type_node);
2715 /* Stop doesn't return. */
2716 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2717
2718 gfor_fndecl_pause_numeric =
2719 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2720 void_type_node, 1, gfc_int4_type_node);
2721
2722 gfor_fndecl_pause_string =
2723 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2724 void_type_node, 2, pchar_type_node,
2725 gfc_int4_type_node);
2726
2727 gfor_fndecl_runtime_error =
2728 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2729 void_type_node, -1, pchar_type_node);
2730 /* The runtime_error function does not return. */
2731 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2732
2733 gfor_fndecl_runtime_error_at =
2734 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2735 void_type_node, -2, pchar_type_node,
2736 pchar_type_node);
2737 /* The runtime_error_at function does not return. */
2738 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2739
2740 gfor_fndecl_runtime_warning_at =
2741 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2742 void_type_node, -2, pchar_type_node,
2743 pchar_type_node);
2744 gfor_fndecl_generate_error =
2745 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2746 void_type_node, 3, pvoid_type_node,
2747 integer_type_node, pchar_type_node);
2748
2749 gfor_fndecl_os_error =
2750 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2751 void_type_node, 1, pchar_type_node);
2752 /* The runtime_error function does not return. */
2753 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2754
2755 gfor_fndecl_set_args =
2756 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2757 void_type_node, 2, integer_type_node,
2758 build_pointer_type (pchar_type_node));
2759
2760 gfor_fndecl_set_fpe =
2761 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2762 void_type_node, 1, integer_type_node);
2763
2764 /* Keep the array dimension in sync with the call, later in this file. */
2765 gfor_fndecl_set_options =
2766 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2767 void_type_node, 2, integer_type_node,
2768 build_pointer_type (integer_type_node));
2769
2770 gfor_fndecl_set_convert =
2771 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2772 void_type_node, 1, integer_type_node);
2773
2774 gfor_fndecl_set_record_marker =
2775 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2776 void_type_node, 1, integer_type_node);
2777
2778 gfor_fndecl_set_max_subrecord_length =
2779 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2780 void_type_node, 1, integer_type_node);
2781
2782 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2783 get_identifier (PREFIX("internal_pack")),
2784 pvoid_type_node, 1, pvoid_type_node);
2785
2786 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2787 get_identifier (PREFIX("internal_unpack")),
2788 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2789
2790 gfor_fndecl_associated =
2791 gfc_build_library_function_decl (
2792 get_identifier (PREFIX("associated")),
2793 integer_type_node, 2, ppvoid_type_node,
2794 ppvoid_type_node);
2795
2796 gfc_build_intrinsic_function_decls ();
2797 gfc_build_intrinsic_lib_fndecls ();
2798 gfc_build_io_library_fndecls ();
2799 }
2800
2801
2802 /* Evaluate the length of dummy character variables. */
2803
2804 static tree
2805 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2806 {
2807 stmtblock_t body;
2808
2809 gfc_finish_decl (cl->backend_decl);
2810
2811 gfc_start_block (&body);
2812
2813 /* Evaluate the string length expression. */
2814 gfc_conv_string_length (cl, NULL, &body);
2815
2816 gfc_trans_vla_type_sizes (sym, &body);
2817
2818 gfc_add_expr_to_block (&body, fnbody);
2819 return gfc_finish_block (&body);
2820 }
2821
2822
2823 /* Allocate and cleanup an automatic character variable. */
2824
2825 static tree
2826 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2827 {
2828 stmtblock_t body;
2829 tree decl;
2830 tree tmp;
2831
2832 gcc_assert (sym->backend_decl);
2833 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2834
2835 gfc_start_block (&body);
2836
2837 /* Evaluate the string length expression. */
2838 gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2839
2840 gfc_trans_vla_type_sizes (sym, &body);
2841
2842 decl = sym->backend_decl;
2843
2844 /* Emit a DECL_EXPR for this variable, which will cause the
2845 gimplifier to allocate storage, and all that good stuff. */
2846 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2847 gfc_add_expr_to_block (&body, tmp);
2848
2849 gfc_add_expr_to_block (&body, fnbody);
2850 return gfc_finish_block (&body);
2851 }
2852
2853 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2854
2855 static tree
2856 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2857 {
2858 stmtblock_t body;
2859
2860 gcc_assert (sym->backend_decl);
2861 gfc_start_block (&body);
2862
2863 /* Set the initial value to length. See the comments in
2864 function gfc_add_assign_aux_vars in this file. */
2865 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2866 build_int_cst (NULL_TREE, -2));
2867
2868 gfc_add_expr_to_block (&body, fnbody);
2869 return gfc_finish_block (&body);
2870 }
2871
2872 static void
2873 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2874 {
2875 tree t = *tp, var, val;
2876
2877 if (t == NULL || t == error_mark_node)
2878 return;
2879 if (TREE_CONSTANT (t) || DECL_P (t))
2880 return;
2881
2882 if (TREE_CODE (t) == SAVE_EXPR)
2883 {
2884 if (SAVE_EXPR_RESOLVED_P (t))
2885 {
2886 *tp = TREE_OPERAND (t, 0);
2887 return;
2888 }
2889 val = TREE_OPERAND (t, 0);
2890 }
2891 else
2892 val = t;
2893
2894 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2895 gfc_add_decl_to_function (var);
2896 gfc_add_modify (body, var, val);
2897 if (TREE_CODE (t) == SAVE_EXPR)
2898 TREE_OPERAND (t, 0) = var;
2899 *tp = var;
2900 }
2901
2902 static void
2903 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2904 {
2905 tree t;
2906
2907 if (type == NULL || type == error_mark_node)
2908 return;
2909
2910 type = TYPE_MAIN_VARIANT (type);
2911
2912 if (TREE_CODE (type) == INTEGER_TYPE)
2913 {
2914 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2915 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2916
2917 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2918 {
2919 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2920 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2921 }
2922 }
2923 else if (TREE_CODE (type) == ARRAY_TYPE)
2924 {
2925 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2926 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2927 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2928 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2929
2930 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2931 {
2932 TYPE_SIZE (t) = TYPE_SIZE (type);
2933 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2934 }
2935 }
2936 }
2937
2938 /* Make sure all type sizes and array domains are either constant,
2939 or variable or parameter decls. This is a simplified variant
2940 of gimplify_type_sizes, but we can't use it here, as none of the
2941 variables in the expressions have been gimplified yet.
2942 As type sizes and domains for various variable length arrays
2943 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2944 time, without this routine gimplify_type_sizes in the middle-end
2945 could result in the type sizes being gimplified earlier than where
2946 those variables are initialized. */
2947
2948 void
2949 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2950 {
2951 tree type = TREE_TYPE (sym->backend_decl);
2952
2953 if (TREE_CODE (type) == FUNCTION_TYPE
2954 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2955 {
2956 if (! current_fake_result_decl)
2957 return;
2958
2959 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2960 }
2961
2962 while (POINTER_TYPE_P (type))
2963 type = TREE_TYPE (type);
2964
2965 if (GFC_DESCRIPTOR_TYPE_P (type))
2966 {
2967 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2968
2969 while (POINTER_TYPE_P (etype))
2970 etype = TREE_TYPE (etype);
2971
2972 gfc_trans_vla_type_sizes_1 (etype, body);
2973 }
2974
2975 gfc_trans_vla_type_sizes_1 (type, body);
2976 }
2977
2978
2979 /* Initialize a derived type by building an lvalue from the symbol
2980 and using trans_assignment to do the work. */
2981 tree
2982 gfc_init_default_dt (gfc_symbol * sym, tree body)
2983 {
2984 stmtblock_t fnblock;
2985 gfc_expr *e;
2986 tree tmp;
2987 tree present;
2988
2989 gfc_init_block (&fnblock);
2990 gcc_assert (!sym->attr.allocatable);
2991 gfc_set_sym_referenced (sym);
2992 e = gfc_lval_expr_from_sym (sym);
2993 tmp = gfc_trans_assignment (e, sym->value, false);
2994 if (sym->attr.dummy && (sym->attr.optional
2995 || sym->ns->proc_name->attr.entry_master))
2996 {
2997 present = gfc_conv_expr_present (sym);
2998 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2999 tmp, build_empty_stmt (input_location));
3000 }
3001 gfc_add_expr_to_block (&fnblock, tmp);
3002 gfc_free_expr (e);
3003 if (body)
3004 gfc_add_expr_to_block (&fnblock, body);
3005 return gfc_finish_block (&fnblock);
3006 }
3007
3008
3009 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3010 them their default initializer, if they do not have allocatable
3011 components, they have their allocatable components deallocated. */
3012
3013 static tree
3014 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3015 {
3016 stmtblock_t fnblock;
3017 gfc_formal_arglist *f;
3018 tree tmp;
3019 tree present;
3020
3021 gfc_init_block (&fnblock);
3022 for (f = proc_sym->formal; f; f = f->next)
3023 if (f->sym && f->sym->attr.intent == INTENT_OUT
3024 && !f->sym->attr.pointer
3025 && f->sym->ts.type == BT_DERIVED)
3026 {
3027 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3028 {
3029 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3030 f->sym->backend_decl,
3031 f->sym->as ? f->sym->as->rank : 0);
3032
3033 if (f->sym->attr.optional
3034 || f->sym->ns->proc_name->attr.entry_master)
3035 {
3036 present = gfc_conv_expr_present (f->sym);
3037 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3038 tmp, build_empty_stmt (input_location));
3039 }
3040
3041 gfc_add_expr_to_block (&fnblock, tmp);
3042 }
3043 else if (f->sym->value)
3044 body = gfc_init_default_dt (f->sym, body);
3045 }
3046
3047 gfc_add_expr_to_block (&fnblock, body);
3048 return gfc_finish_block (&fnblock);
3049 }
3050
3051
3052 /* Generate function entry and exit code, and add it to the function body.
3053 This includes:
3054 Allocation and initialization of array variables.
3055 Allocation of character string variables.
3056 Initialization and possibly repacking of dummy arrays.
3057 Initialization of ASSIGN statement auxiliary variable. */
3058
3059 tree
3060 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3061 {
3062 locus loc;
3063 gfc_symbol *sym;
3064 gfc_formal_arglist *f;
3065 stmtblock_t body;
3066 bool seen_trans_deferred_array = false;
3067
3068 /* Deal with implicit return variables. Explicit return variables will
3069 already have been added. */
3070 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3071 {
3072 if (!current_fake_result_decl)
3073 {
3074 gfc_entry_list *el = NULL;
3075 if (proc_sym->attr.entry_master)
3076 {
3077 for (el = proc_sym->ns->entries; el; el = el->next)
3078 if (el->sym != el->sym->result)
3079 break;
3080 }
3081 /* TODO: move to the appropriate place in resolve.c. */
3082 if (warn_return_type && el == NULL)
3083 gfc_warning ("Return value of function '%s' at %L not set",
3084 proc_sym->name, &proc_sym->declared_at);
3085 }
3086 else if (proc_sym->as)
3087 {
3088 tree result = TREE_VALUE (current_fake_result_decl);
3089 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3090
3091 /* An automatic character length, pointer array result. */
3092 if (proc_sym->ts.type == BT_CHARACTER
3093 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3094 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3095 fnbody);
3096 }
3097 else if (proc_sym->ts.type == BT_CHARACTER)
3098 {
3099 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3100 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3101 fnbody);
3102 }
3103 else
3104 gcc_assert (gfc_option.flag_f2c
3105 && proc_sym->ts.type == BT_COMPLEX);
3106 }
3107
3108 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3109 should be done here so that the offsets and lbounds of arrays
3110 are available. */
3111 fnbody = init_intent_out_dt (proc_sym, fnbody);
3112
3113 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3114 {
3115 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3116 && sym->ts.u.derived->attr.alloc_comp;
3117 if (sym->attr.dimension)
3118 {
3119 switch (sym->as->type)
3120 {
3121 case AS_EXPLICIT:
3122 if (sym->attr.dummy || sym->attr.result)
3123 fnbody =
3124 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3125 else if (sym->attr.pointer || sym->attr.allocatable)
3126 {
3127 if (TREE_STATIC (sym->backend_decl))
3128 gfc_trans_static_array_pointer (sym);
3129 else
3130 {
3131 seen_trans_deferred_array = true;
3132 fnbody = gfc_trans_deferred_array (sym, fnbody);
3133 }
3134 }
3135 else
3136 {
3137 if (sym_has_alloc_comp)
3138 {
3139 seen_trans_deferred_array = true;
3140 fnbody = gfc_trans_deferred_array (sym, fnbody);
3141 }
3142 else if (sym->ts.type == BT_DERIVED
3143 && sym->value
3144 && !sym->attr.data
3145 && sym->attr.save == SAVE_NONE)
3146 fnbody = gfc_init_default_dt (sym, fnbody);
3147
3148 gfc_get_backend_locus (&loc);
3149 gfc_set_backend_locus (&sym->declared_at);
3150 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3151 sym, fnbody);
3152 gfc_set_backend_locus (&loc);
3153 }
3154 break;
3155
3156 case AS_ASSUMED_SIZE:
3157 /* Must be a dummy parameter. */
3158 gcc_assert (sym->attr.dummy);
3159
3160 /* We should always pass assumed size arrays the g77 way. */
3161 fnbody = gfc_trans_g77_array (sym, fnbody);
3162 break;
3163
3164 case AS_ASSUMED_SHAPE:
3165 /* Must be a dummy parameter. */
3166 gcc_assert (sym->attr.dummy);
3167
3168 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3169 fnbody);
3170 break;
3171
3172 case AS_DEFERRED:
3173 seen_trans_deferred_array = true;
3174 fnbody = gfc_trans_deferred_array (sym, fnbody);
3175 break;
3176
3177 default:
3178 gcc_unreachable ();
3179 }
3180 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3181 fnbody = gfc_trans_deferred_array (sym, fnbody);
3182 }
3183 else if (sym_has_alloc_comp)
3184 fnbody = gfc_trans_deferred_array (sym, fnbody);
3185 else if (sym->ts.type == BT_CHARACTER)
3186 {
3187 gfc_get_backend_locus (&loc);
3188 gfc_set_backend_locus (&sym->declared_at);
3189 if (sym->attr.dummy || sym->attr.result)
3190 fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3191 else
3192 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3193 gfc_set_backend_locus (&loc);
3194 }
3195 else if (sym->attr.assign)
3196 {
3197 gfc_get_backend_locus (&loc);
3198 gfc_set_backend_locus (&sym->declared_at);
3199 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3200 gfc_set_backend_locus (&loc);
3201 }
3202 else if (sym->ts.type == BT_DERIVED
3203 && sym->value
3204 && !sym->attr.data
3205 && sym->attr.save == SAVE_NONE)
3206 fnbody = gfc_init_default_dt (sym, fnbody);
3207 else
3208 gcc_unreachable ();
3209 }
3210
3211 gfc_init_block (&body);
3212
3213 for (f = proc_sym->formal; f; f = f->next)
3214 {
3215 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3216 {
3217 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3218 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3219 gfc_trans_vla_type_sizes (f->sym, &body);
3220 }
3221 }
3222
3223 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3224 && current_fake_result_decl != NULL)
3225 {
3226 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3227 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3228 gfc_trans_vla_type_sizes (proc_sym, &body);
3229 }
3230
3231 gfc_add_expr_to_block (&body, fnbody);
3232 return gfc_finish_block (&body);
3233 }
3234
3235 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3236
3237 /* Hash and equality functions for module_htab. */
3238
3239 static hashval_t
3240 module_htab_do_hash (const void *x)
3241 {
3242 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3243 }
3244
3245 static int
3246 module_htab_eq (const void *x1, const void *x2)
3247 {
3248 return strcmp ((((const struct module_htab_entry *)x1)->name),
3249 (const char *)x2) == 0;
3250 }
3251
3252 /* Hash and equality functions for module_htab's decls. */
3253
3254 static hashval_t
3255 module_htab_decls_hash (const void *x)
3256 {
3257 const_tree t = (const_tree) x;
3258 const_tree n = DECL_NAME (t);
3259 if (n == NULL_TREE)
3260 n = TYPE_NAME (TREE_TYPE (t));
3261 return htab_hash_string (IDENTIFIER_POINTER (n));
3262 }
3263
3264 static int
3265 module_htab_decls_eq (const void *x1, const void *x2)
3266 {
3267 const_tree t1 = (const_tree) x1;
3268 const_tree n1 = DECL_NAME (t1);
3269 if (n1 == NULL_TREE)
3270 n1 = TYPE_NAME (TREE_TYPE (t1));
3271 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3272 }
3273
3274 struct module_htab_entry *
3275 gfc_find_module (const char *name)
3276 {
3277 void **slot;
3278
3279 if (! module_htab)
3280 module_htab = htab_create_ggc (10, module_htab_do_hash,
3281 module_htab_eq, NULL);
3282
3283 slot = htab_find_slot_with_hash (module_htab, name,
3284 htab_hash_string (name), INSERT);
3285 if (*slot == NULL)
3286 {
3287 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3288
3289 entry->name = gfc_get_string (name);
3290 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3291 module_htab_decls_eq, NULL);
3292 *slot = (void *) entry;
3293 }
3294 return (struct module_htab_entry *) *slot;
3295 }
3296
3297 void
3298 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3299 {
3300 void **slot;
3301 const char *name;
3302
3303 if (DECL_NAME (decl))
3304 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3305 else
3306 {
3307 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3308 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3309 }
3310 slot = htab_find_slot_with_hash (entry->decls, name,
3311 htab_hash_string (name), INSERT);
3312 if (*slot == NULL)
3313 *slot = (void *) decl;
3314 }
3315
3316 static struct module_htab_entry *cur_module;
3317
3318 /* Output an initialized decl for a module variable. */
3319
3320 static void
3321 gfc_create_module_variable (gfc_symbol * sym)
3322 {
3323 tree decl;
3324
3325 /* Module functions with alternate entries are dealt with later and
3326 would get caught by the next condition. */
3327 if (sym->attr.entry)
3328 return;
3329
3330 /* Make sure we convert the types of the derived types from iso_c_binding
3331 into (void *). */
3332 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3333 && sym->ts.type == BT_DERIVED)
3334 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3335
3336 if (sym->attr.flavor == FL_DERIVED
3337 && sym->backend_decl
3338 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3339 {
3340 decl = sym->backend_decl;
3341 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3342 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3343 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3344 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3345 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3346 == sym->ns->proc_name->backend_decl);
3347 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3348 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3349 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3350 }
3351
3352 /* Only output variables, procedure pointers and array valued,
3353 or derived type, parameters. */
3354 if (sym->attr.flavor != FL_VARIABLE
3355 && !(sym->attr.flavor == FL_PARAMETER
3356 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3357 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3358 return;
3359
3360 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3361 {
3362 decl = sym->backend_decl;
3363 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3364 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3365 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3366 gfc_module_add_decl (cur_module, decl);
3367 }
3368
3369 /* Don't generate variables from other modules. Variables from
3370 COMMONs will already have been generated. */
3371 if (sym->attr.use_assoc || sym->attr.in_common)
3372 return;
3373
3374 /* Equivalenced variables arrive here after creation. */
3375 if (sym->backend_decl
3376 && (sym->equiv_built || sym->attr.in_equivalence))
3377 return;
3378
3379 if (sym->backend_decl)
3380 internal_error ("backend decl for module variable %s already exists",
3381 sym->name);
3382
3383 /* We always want module variables to be created. */
3384 sym->attr.referenced = 1;
3385 /* Create the decl. */
3386 decl = gfc_get_symbol_decl (sym);
3387
3388 /* Create the variable. */
3389 pushdecl (decl);
3390 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3391 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3392 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3393 rest_of_decl_compilation (decl, 1, 0);
3394 gfc_module_add_decl (cur_module, decl);
3395
3396 /* Also add length of strings. */
3397 if (sym->ts.type == BT_CHARACTER)
3398 {
3399 tree length;
3400
3401 length = sym->ts.u.cl->backend_decl;
3402 if (!INTEGER_CST_P (length))
3403 {
3404 pushdecl (length);
3405 rest_of_decl_compilation (length, 1, 0);
3406 }
3407 }
3408 }
3409
3410 /* Emit debug information for USE statements. */
3411
3412 static void
3413 gfc_trans_use_stmts (gfc_namespace * ns)
3414 {
3415 gfc_use_list *use_stmt;
3416 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3417 {
3418 struct module_htab_entry *entry
3419 = gfc_find_module (use_stmt->module_name);
3420 gfc_use_rename *rent;
3421
3422 if (entry->namespace_decl == NULL)
3423 {
3424 entry->namespace_decl
3425 = build_decl (input_location,
3426 NAMESPACE_DECL,
3427 get_identifier (use_stmt->module_name),
3428 void_type_node);
3429 DECL_EXTERNAL (entry->namespace_decl) = 1;
3430 }
3431 gfc_set_backend_locus (&use_stmt->where);
3432 if (!use_stmt->only_flag)
3433 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3434 NULL_TREE,
3435 ns->proc_name->backend_decl,
3436 false);
3437 for (rent = use_stmt->rename; rent; rent = rent->next)
3438 {
3439 tree decl, local_name;
3440 void **slot;
3441
3442 if (rent->op != INTRINSIC_NONE)
3443 continue;
3444
3445 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3446 htab_hash_string (rent->use_name),
3447 INSERT);
3448 if (*slot == NULL)
3449 {
3450 gfc_symtree *st;
3451
3452 st = gfc_find_symtree (ns->sym_root,
3453 rent->local_name[0]
3454 ? rent->local_name : rent->use_name);
3455 gcc_assert (st);
3456
3457 /* Sometimes, generic interfaces wind up being over-ruled by a
3458 local symbol (see PR41062). */
3459 if (!st->n.sym->attr.use_assoc)
3460 continue;
3461
3462 if (st->n.sym->backend_decl
3463 && DECL_P (st->n.sym->backend_decl)
3464 && st->n.sym->module
3465 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3466 {
3467 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3468 || (TREE_CODE (st->n.sym->backend_decl)
3469 != VAR_DECL));
3470 decl = copy_node (st->n.sym->backend_decl);
3471 DECL_CONTEXT (decl) = entry->namespace_decl;
3472 DECL_EXTERNAL (decl) = 1;
3473 DECL_IGNORED_P (decl) = 0;
3474 DECL_INITIAL (decl) = NULL_TREE;
3475 }
3476 else
3477 {
3478 *slot = error_mark_node;
3479 htab_clear_slot (entry->decls, slot);
3480 continue;
3481 }
3482 *slot = decl;
3483 }
3484 decl = (tree) *slot;
3485 if (rent->local_name[0])
3486 local_name = get_identifier (rent->local_name);
3487 else
3488 local_name = NULL_TREE;
3489 gfc_set_backend_locus (&rent->where);
3490 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3491 ns->proc_name->backend_decl,
3492 !use_stmt->only_flag);
3493 }
3494 }
3495 }
3496
3497
3498 /* Return true if expr is a constant initializer that gfc_conv_initializer
3499 will handle. */
3500
3501 static bool
3502 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3503 bool pointer)
3504 {
3505 gfc_constructor *c;
3506 gfc_component *cm;
3507
3508 if (pointer)
3509 return true;
3510 else if (array)
3511 {
3512 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3513 return true;
3514 else if (expr->expr_type == EXPR_STRUCTURE)
3515 return check_constant_initializer (expr, ts, false, false);
3516 else if (expr->expr_type != EXPR_ARRAY)
3517 return false;
3518 for (c = expr->value.constructor; c; c = c->next)
3519 {
3520 if (c->iterator)
3521 return false;
3522 if (c->expr->expr_type == EXPR_STRUCTURE)
3523 {
3524 if (!check_constant_initializer (c->expr, ts, false, false))
3525 return false;
3526 }
3527 else if (c->expr->expr_type != EXPR_CONSTANT)
3528 return false;
3529 }
3530 return true;
3531 }
3532 else switch (ts->type)
3533 {
3534 case BT_DERIVED:
3535 if (expr->expr_type != EXPR_STRUCTURE)
3536 return false;
3537 cm = expr->ts.u.derived->components;
3538 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3539 {
3540 if (!c->expr || cm->attr.allocatable)
3541 continue;
3542 if (!check_constant_initializer (c->expr, &cm->ts,
3543 cm->attr.dimension,
3544 cm->attr.pointer))
3545 return false;
3546 }
3547 return true;
3548 default:
3549 return expr->expr_type == EXPR_CONSTANT;
3550 }
3551 }
3552
3553 /* Emit debug info for parameters and unreferenced variables with
3554 initializers. */
3555
3556 static void
3557 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3558 {
3559 tree decl;
3560
3561 if (sym->attr.flavor != FL_PARAMETER
3562 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3563 return;
3564
3565 if (sym->backend_decl != NULL
3566 || sym->value == NULL
3567 || sym->attr.use_assoc
3568 || sym->attr.dummy
3569 || sym->attr.result
3570 || sym->attr.function
3571 || sym->attr.intrinsic
3572 || sym->attr.pointer
3573 || sym->attr.allocatable
3574 || sym->attr.cray_pointee
3575 || sym->attr.threadprivate
3576 || sym->attr.is_bind_c
3577 || sym->attr.subref_array_pointer
3578 || sym->attr.assign)
3579 return;
3580
3581 if (sym->ts.type == BT_CHARACTER)
3582 {
3583 gfc_conv_const_charlen (sym->ts.u.cl);
3584 if (sym->ts.u.cl->backend_decl == NULL
3585 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3586 return;
3587 }
3588 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3589 return;
3590
3591 if (sym->as)
3592 {
3593 int n;
3594
3595 if (sym->as->type != AS_EXPLICIT)
3596 return;
3597 for (n = 0; n < sym->as->rank; n++)
3598 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3599 || sym->as->upper[n] == NULL
3600 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3601 return;
3602 }
3603
3604 if (!check_constant_initializer (sym->value, &sym->ts,
3605 sym->attr.dimension, false))
3606 return;
3607
3608 /* Create the decl for the variable or constant. */
3609 decl = build_decl (input_location,
3610 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3611 gfc_sym_identifier (sym), gfc_sym_type (sym));
3612 if (sym->attr.flavor == FL_PARAMETER)
3613 TREE_READONLY (decl) = 1;
3614 gfc_set_decl_location (decl, &sym->declared_at);
3615 if (sym->attr.dimension)
3616 GFC_DECL_PACKED_ARRAY (decl) = 1;
3617 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3618 TREE_STATIC (decl) = 1;
3619 TREE_USED (decl) = 1;
3620 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3621 TREE_PUBLIC (decl) = 1;
3622 DECL_INITIAL (decl)
3623 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3624 sym->attr.dimension, 0);
3625 debug_hooks->global_decl (decl);
3626 }
3627
3628 /* Generate all the required code for module variables. */
3629
3630 void
3631 gfc_generate_module_vars (gfc_namespace * ns)
3632 {
3633 module_namespace = ns;
3634 cur_module = gfc_find_module (ns->proc_name->name);
3635
3636 /* Check if the frontend left the namespace in a reasonable state. */
3637 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3638
3639 /* Generate COMMON blocks. */
3640 gfc_trans_common (ns);
3641
3642 /* Create decls for all the module variables. */
3643 gfc_traverse_ns (ns, gfc_create_module_variable);
3644
3645 cur_module = NULL;
3646
3647 gfc_trans_use_stmts (ns);
3648 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3649 }
3650
3651
3652 static void
3653 gfc_generate_contained_functions (gfc_namespace * parent)
3654 {
3655 gfc_namespace *ns;
3656
3657 /* We create all the prototypes before generating any code. */
3658 for (ns = parent->contained; ns; ns = ns->sibling)
3659 {
3660 /* Skip namespaces from used modules. */
3661 if (ns->parent != parent)
3662 continue;
3663
3664 gfc_create_function_decl (ns);
3665 }
3666
3667 for (ns = parent->contained; ns; ns = ns->sibling)
3668 {
3669 /* Skip namespaces from used modules. */
3670 if (ns->parent != parent)
3671 continue;
3672
3673 gfc_generate_function_code (ns);
3674 }
3675 }
3676
3677
3678 /* Drill down through expressions for the array specification bounds and
3679 character length calling generate_local_decl for all those variables
3680 that have not already been declared. */
3681
3682 static void
3683 generate_local_decl (gfc_symbol *);
3684
3685 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3686
3687 static bool
3688 expr_decls (gfc_expr *e, gfc_symbol *sym,
3689 int *f ATTRIBUTE_UNUSED)
3690 {
3691 if (e->expr_type != EXPR_VARIABLE
3692 || sym == e->symtree->n.sym
3693 || e->symtree->n.sym->mark
3694 || e->symtree->n.sym->ns != sym->ns)
3695 return false;
3696
3697 generate_local_decl (e->symtree->n.sym);
3698 return false;
3699 }
3700
3701 static void
3702 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3703 {
3704 gfc_traverse_expr (e, sym, expr_decls, 0);
3705 }
3706
3707
3708 /* Check for dependencies in the character length and array spec. */
3709
3710 static void
3711 generate_dependency_declarations (gfc_symbol *sym)
3712 {
3713 int i;
3714
3715 if (sym->ts.type == BT_CHARACTER
3716 && sym->ts.u.cl
3717 && sym->ts.u.cl->length
3718 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3719 generate_expr_decls (sym, sym->ts.u.cl->length);
3720
3721 if (sym->as && sym->as->rank)
3722 {
3723 for (i = 0; i < sym->as->rank; i++)
3724 {
3725 generate_expr_decls (sym, sym->as->lower[i]);
3726 generate_expr_decls (sym, sym->as->upper[i]);
3727 }
3728 }
3729 }
3730
3731
3732 /* Generate decls for all local variables. We do this to ensure correct
3733 handling of expressions which only appear in the specification of
3734 other functions. */
3735
3736 static void
3737 generate_local_decl (gfc_symbol * sym)
3738 {
3739 if (sym->attr.flavor == FL_VARIABLE)
3740 {
3741 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3742 generate_dependency_declarations (sym);
3743
3744 if (sym->attr.referenced)
3745 gfc_get_symbol_decl (sym);
3746 /* INTENT(out) dummy arguments are likely meant to be set. */
3747 else if (warn_unused_variable
3748 && sym->attr.dummy
3749 && sym->attr.intent == INTENT_OUT)
3750 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3751 sym->name, &sym->declared_at);
3752 /* Specific warning for unused dummy arguments. */
3753 else if (warn_unused_variable && sym->attr.dummy)
3754 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3755 &sym->declared_at);
3756 /* Warn for unused variables, but not if they're inside a common
3757 block or are use-associated. */
3758 else if (warn_unused_variable
3759 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3760 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3761 &sym->declared_at);
3762
3763 /* For variable length CHARACTER parameters, the PARM_DECL already
3764 references the length variable, so force gfc_get_symbol_decl
3765 even when not referenced. If optimize > 0, it will be optimized
3766 away anyway. But do this only after emitting -Wunused-parameter
3767 warning if requested. */
3768 if (sym->attr.dummy && !sym->attr.referenced
3769 && sym->ts.type == BT_CHARACTER
3770 && sym->ts.u.cl->backend_decl != NULL
3771 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3772 {
3773 sym->attr.referenced = 1;
3774 gfc_get_symbol_decl (sym);
3775 }
3776
3777 /* INTENT(out) dummy arguments and result variables with allocatable
3778 components are reset by default and need to be set referenced to
3779 generate the code for nullification and automatic lengths. */
3780 if (!sym->attr.referenced
3781 && sym->ts.type == BT_DERIVED
3782 && sym->ts.u.derived->attr.alloc_comp
3783 && !sym->attr.pointer
3784 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3785 ||
3786 (sym->attr.result && sym != sym->result)))
3787 {
3788 sym->attr.referenced = 1;
3789 gfc_get_symbol_decl (sym);
3790 }
3791
3792 /* Check for dependencies in the array specification and string
3793 length, adding the necessary declarations to the function. We
3794 mark the symbol now, as well as in traverse_ns, to prevent
3795 getting stuck in a circular dependency. */
3796 sym->mark = 1;
3797
3798 /* We do not want the middle-end to warn about unused parameters
3799 as this was already done above. */
3800 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3801 TREE_NO_WARNING(sym->backend_decl) = 1;
3802 }
3803 else if (sym->attr.flavor == FL_PARAMETER)
3804 {
3805 if (warn_unused_parameter
3806 && !sym->attr.referenced
3807 && !sym->attr.use_assoc)
3808 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3809 &sym->declared_at);
3810 }
3811 else if (sym->attr.flavor == FL_PROCEDURE)
3812 {
3813 /* TODO: move to the appropriate place in resolve.c. */
3814 if (warn_return_type
3815 && sym->attr.function
3816 && sym->result
3817 && sym != sym->result
3818 && !sym->result->attr.referenced
3819 && !sym->attr.use_assoc
3820 && sym->attr.if_source != IFSRC_IFBODY)
3821 {
3822 gfc_warning ("Return value '%s' of function '%s' declared at "
3823 "%L not set", sym->result->name, sym->name,
3824 &sym->result->declared_at);
3825
3826 /* Prevents "Unused variable" warning for RESULT variables. */
3827 sym->result->mark = 1;
3828 }
3829 }
3830
3831 if (sym->attr.dummy == 1)
3832 {
3833 /* Modify the tree type for scalar character dummy arguments of bind(c)
3834 procedures if they are passed by value. The tree type for them will
3835 be promoted to INTEGER_TYPE for the middle end, which appears to be
3836 what C would do with characters passed by-value. The value attribute
3837 implies the dummy is a scalar. */
3838 if (sym->attr.value == 1 && sym->backend_decl != NULL
3839 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3840 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3841 gfc_conv_scalar_char_value (sym, NULL, NULL);
3842 }
3843
3844 /* Make sure we convert the types of the derived types from iso_c_binding
3845 into (void *). */
3846 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3847 && sym->ts.type == BT_DERIVED)
3848 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3849 }
3850
3851 static void
3852 generate_local_vars (gfc_namespace * ns)
3853 {
3854 gfc_traverse_ns (ns, generate_local_decl);
3855 }
3856
3857
3858 /* Generate a switch statement to jump to the correct entry point. Also
3859 creates the label decls for the entry points. */
3860
3861 static tree
3862 gfc_trans_entry_master_switch (gfc_entry_list * el)
3863 {
3864 stmtblock_t block;
3865 tree label;
3866 tree tmp;
3867 tree val;
3868
3869 gfc_init_block (&block);
3870 for (; el; el = el->next)
3871 {
3872 /* Add the case label. */
3873 label = gfc_build_label_decl (NULL_TREE);
3874 val = build_int_cst (gfc_array_index_type, el->id);
3875 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3876 gfc_add_expr_to_block (&block, tmp);
3877
3878 /* And jump to the actual entry point. */
3879 label = gfc_build_label_decl (NULL_TREE);
3880 tmp = build1_v (GOTO_EXPR, label);
3881 gfc_add_expr_to_block (&block, tmp);
3882
3883 /* Save the label decl. */
3884 el->label = label;
3885 }
3886 tmp = gfc_finish_block (&block);
3887 /* The first argument selects the entry point. */
3888 val = DECL_ARGUMENTS (current_function_decl);
3889 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3890 return tmp;
3891 }
3892
3893
3894 /* Add code to string lengths of actual arguments passed to a function against
3895 the expected lengths of the dummy arguments. */
3896
3897 static void
3898 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3899 {
3900 gfc_formal_arglist *formal;
3901
3902 for (formal = sym->formal; formal; formal = formal->next)
3903 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3904 {
3905 enum tree_code comparison;
3906 tree cond;
3907 tree argname;
3908 gfc_symbol *fsym;
3909 gfc_charlen *cl;
3910 const char *message;
3911
3912 fsym = formal->sym;
3913 cl = fsym->ts.u.cl;
3914
3915 gcc_assert (cl);
3916 gcc_assert (cl->passed_length != NULL_TREE);
3917 gcc_assert (cl->backend_decl != NULL_TREE);
3918
3919 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3920 string lengths must match exactly. Otherwise, it is only required
3921 that the actual string length is *at least* the expected one.
3922 Sequence association allows for a mismatch of the string length
3923 if the actual argument is (part of) an array, but only if the
3924 dummy argument is an array. (See "Sequence association" in
3925 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
3926 if (fsym->attr.pointer || fsym->attr.allocatable
3927 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3928 {
3929 comparison = NE_EXPR;
3930 message = _("Actual string length does not match the declared one"
3931 " for dummy argument '%s' (%ld/%ld)");
3932 }
3933 else if (fsym->as && fsym->as->rank != 0)
3934 continue;
3935 else
3936 {
3937 comparison = LT_EXPR;
3938 message = _("Actual string length is shorter than the declared one"
3939 " for dummy argument '%s' (%ld/%ld)");
3940 }
3941
3942 /* Build the condition. For optional arguments, an actual length
3943 of 0 is also acceptable if the associated string is NULL, which
3944 means the argument was not passed. */
3945 cond = fold_build2 (comparison, boolean_type_node,
3946 cl->passed_length, cl->backend_decl);
3947 if (fsym->attr.optional)
3948 {
3949 tree not_absent;
3950 tree not_0length;
3951 tree absent_failed;
3952
3953 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3954 cl->passed_length,
3955 fold_convert (gfc_charlen_type_node,
3956 integer_zero_node));
3957 not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3958 fsym->backend_decl, null_pointer_node);
3959
3960 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3961 not_0length, not_absent);
3962
3963 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3964 cond, absent_failed);
3965 }
3966
3967 /* Build the runtime check. */
3968 argname = gfc_build_cstring_const (fsym->name);
3969 argname = gfc_build_addr_expr (pchar_type_node, argname);
3970 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3971 message, argname,
3972 fold_convert (long_integer_type_node,
3973 cl->passed_length),
3974 fold_convert (long_integer_type_node,
3975 cl->backend_decl));
3976 }
3977 }
3978
3979
3980 static void
3981 create_main_function (tree fndecl)
3982 {
3983 tree old_context;
3984 tree ftn_main;
3985 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3986 stmtblock_t body;
3987
3988 old_context = current_function_decl;
3989
3990 if (old_context)
3991 {
3992 push_function_context ();
3993 saved_parent_function_decls = saved_function_decls;
3994 saved_function_decls = NULL_TREE;
3995 }
3996
3997 /* main() function must be declared with global scope. */
3998 gcc_assert (current_function_decl == NULL_TREE);
3999
4000 /* Declare the function. */
4001 tmp = build_function_type_list (integer_type_node, integer_type_node,
4002 build_pointer_type (pchar_type_node),
4003 NULL_TREE);
4004 main_identifier_node = get_identifier ("main");
4005 ftn_main = build_decl (input_location, FUNCTION_DECL,
4006 main_identifier_node, tmp);
4007 DECL_EXTERNAL (ftn_main) = 0;
4008 TREE_PUBLIC (ftn_main) = 1;
4009 TREE_STATIC (ftn_main) = 1;
4010 DECL_ATTRIBUTES (ftn_main)
4011 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4012
4013 /* Setup the result declaration (for "return 0"). */
4014 result_decl = build_decl (input_location,
4015 RESULT_DECL, NULL_TREE, integer_type_node);
4016 DECL_ARTIFICIAL (result_decl) = 1;
4017 DECL_IGNORED_P (result_decl) = 1;
4018 DECL_CONTEXT (result_decl) = ftn_main;
4019 DECL_RESULT (ftn_main) = result_decl;
4020
4021 pushdecl (ftn_main);
4022
4023 /* Get the arguments. */
4024
4025 arglist = NULL_TREE;
4026 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4027
4028 tmp = TREE_VALUE (typelist);
4029 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4030 DECL_CONTEXT (argc) = ftn_main;
4031 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4032 TREE_READONLY (argc) = 1;
4033 gfc_finish_decl (argc);
4034 arglist = chainon (arglist, argc);
4035
4036 typelist = TREE_CHAIN (typelist);
4037 tmp = TREE_VALUE (typelist);
4038 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4039 DECL_CONTEXT (argv) = ftn_main;
4040 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4041 TREE_READONLY (argv) = 1;
4042 DECL_BY_REFERENCE (argv) = 1;
4043 gfc_finish_decl (argv);
4044 arglist = chainon (arglist, argv);
4045
4046 DECL_ARGUMENTS (ftn_main) = arglist;
4047 current_function_decl = ftn_main;
4048 announce_function (ftn_main);
4049
4050 rest_of_decl_compilation (ftn_main, 1, 0);
4051 make_decl_rtl (ftn_main);
4052 init_function_start (ftn_main);
4053 pushlevel (0);
4054
4055 gfc_init_block (&body);
4056
4057 /* Call some libgfortran initialization routines, call then MAIN__(). */
4058
4059 /* Call _gfortran_set_args (argc, argv). */
4060 TREE_USED (argc) = 1;
4061 TREE_USED (argv) = 1;
4062 tmp = build_call_expr_loc (input_location,
4063 gfor_fndecl_set_args, 2, argc, argv);
4064 gfc_add_expr_to_block (&body, tmp);
4065
4066 /* Add a call to set_options to set up the runtime library Fortran
4067 language standard parameters. */
4068 {
4069 tree array_type, array, var;
4070
4071 /* Passing a new option to the library requires four modifications:
4072 + add it to the tree_cons list below
4073 + change the array size in the call to build_array_type
4074 + change the first argument to the library call
4075 gfor_fndecl_set_options
4076 + modify the library (runtime/compile_options.c)! */
4077
4078 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4079 gfc_option.warn_std), NULL_TREE);
4080 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4081 gfc_option.allow_std), array);
4082 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4083 array);
4084 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4085 gfc_option.flag_dump_core), array);
4086 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4087 gfc_option.flag_backtrace), array);
4088 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4089 gfc_option.flag_sign_zero), array);
4090
4091 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4092 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4093
4094 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4095 gfc_option.flag_range_check), array);
4096
4097 array_type = build_array_type (integer_type_node,
4098 build_index_type (build_int_cst (NULL_TREE, 7)));
4099 array = build_constructor_from_list (array_type, nreverse (array));
4100 TREE_CONSTANT (array) = 1;
4101 TREE_STATIC (array) = 1;
4102
4103 /* Create a static variable to hold the jump table. */
4104 var = gfc_create_var (array_type, "options");
4105 TREE_CONSTANT (var) = 1;
4106 TREE_STATIC (var) = 1;
4107 TREE_READONLY (var) = 1;
4108 DECL_INITIAL (var) = array;
4109 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4110
4111 tmp = build_call_expr_loc (input_location,
4112 gfor_fndecl_set_options, 2,
4113 build_int_cst (integer_type_node, 8), var);
4114 gfc_add_expr_to_block (&body, tmp);
4115 }
4116
4117 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4118 the library will raise a FPE when needed. */
4119 if (gfc_option.fpe != 0)
4120 {
4121 tmp = build_call_expr_loc (input_location,
4122 gfor_fndecl_set_fpe, 1,
4123 build_int_cst (integer_type_node,
4124 gfc_option.fpe));
4125 gfc_add_expr_to_block (&body, tmp);
4126 }
4127
4128 /* If this is the main program and an -fconvert option was provided,
4129 add a call to set_convert. */
4130
4131 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4132 {
4133 tmp = build_call_expr_loc (input_location,
4134 gfor_fndecl_set_convert, 1,
4135 build_int_cst (integer_type_node,
4136 gfc_option.convert));
4137 gfc_add_expr_to_block (&body, tmp);
4138 }
4139
4140 /* If this is the main program and an -frecord-marker option was provided,
4141 add a call to set_record_marker. */
4142
4143 if (gfc_option.record_marker != 0)
4144 {
4145 tmp = build_call_expr_loc (input_location,
4146 gfor_fndecl_set_record_marker, 1,
4147 build_int_cst (integer_type_node,
4148 gfc_option.record_marker));
4149 gfc_add_expr_to_block (&body, tmp);
4150 }
4151
4152 if (gfc_option.max_subrecord_length != 0)
4153 {
4154 tmp = build_call_expr_loc (input_location,
4155 gfor_fndecl_set_max_subrecord_length, 1,
4156 build_int_cst (integer_type_node,
4157 gfc_option.max_subrecord_length));
4158 gfc_add_expr_to_block (&body, tmp);
4159 }
4160
4161 /* Call MAIN__(). */
4162 tmp = build_call_expr_loc (input_location,
4163 fndecl, 0);
4164 gfc_add_expr_to_block (&body, tmp);
4165
4166 /* Mark MAIN__ as used. */
4167 TREE_USED (fndecl) = 1;
4168
4169 /* "return 0". */
4170 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4171 build_int_cst (integer_type_node, 0));
4172 tmp = build1_v (RETURN_EXPR, tmp);
4173 gfc_add_expr_to_block (&body, tmp);
4174
4175
4176 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4177 decl = getdecls ();
4178
4179 /* Finish off this function and send it for code generation. */
4180 poplevel (1, 0, 1);
4181 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4182
4183 DECL_SAVED_TREE (ftn_main)
4184 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4185 DECL_INITIAL (ftn_main));
4186
4187 /* Output the GENERIC tree. */
4188 dump_function (TDI_original, ftn_main);
4189
4190 cgraph_finalize_function (ftn_main, true);
4191
4192 if (old_context)
4193 {
4194 pop_function_context ();
4195 saved_function_decls = saved_parent_function_decls;
4196 }
4197 current_function_decl = old_context;
4198 }
4199
4200
4201 /* Generate code for a function. */
4202
4203 void
4204 gfc_generate_function_code (gfc_namespace * ns)
4205 {
4206 tree fndecl;
4207 tree old_context;
4208 tree decl;
4209 tree tmp;
4210 tree tmp2;
4211 stmtblock_t block;
4212 stmtblock_t body;
4213 tree result;
4214 tree recurcheckvar = NULL;
4215 gfc_symbol *sym;
4216 int rank;
4217 bool is_recursive;
4218
4219 sym = ns->proc_name;
4220
4221 /* Check that the frontend isn't still using this. */
4222 gcc_assert (sym->tlink == NULL);
4223 sym->tlink = sym;
4224
4225 /* Create the declaration for functions with global scope. */
4226 if (!sym->backend_decl)
4227 gfc_create_function_decl (ns);
4228
4229 fndecl = sym->backend_decl;
4230 old_context = current_function_decl;
4231
4232 if (old_context)
4233 {
4234 push_function_context ();
4235 saved_parent_function_decls = saved_function_decls;
4236 saved_function_decls = NULL_TREE;
4237 }
4238
4239 trans_function_start (sym);
4240
4241 gfc_init_block (&block);
4242
4243 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4244 {
4245 /* Copy length backend_decls to all entry point result
4246 symbols. */
4247 gfc_entry_list *el;
4248 tree backend_decl;
4249
4250 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4251 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4252 for (el = ns->entries; el; el = el->next)
4253 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4254 }
4255
4256 /* Translate COMMON blocks. */
4257 gfc_trans_common (ns);
4258
4259 /* Null the parent fake result declaration if this namespace is
4260 a module function or an external procedures. */
4261 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4262 || ns->parent == NULL)
4263 parent_fake_result_decl = NULL_TREE;
4264
4265 gfc_generate_contained_functions (ns);
4266
4267 nonlocal_dummy_decls = NULL;
4268 nonlocal_dummy_decl_pset = NULL;
4269
4270 generate_local_vars (ns);
4271
4272 /* Keep the parent fake result declaration in module functions
4273 or external procedures. */
4274 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4275 || ns->parent == NULL)
4276 current_fake_result_decl = parent_fake_result_decl;
4277 else
4278 current_fake_result_decl = NULL_TREE;
4279
4280 current_function_return_label = NULL;
4281
4282 /* Now generate the code for the body of this function. */
4283 gfc_init_block (&body);
4284
4285 is_recursive = sym->attr.recursive
4286 || (sym->attr.entry_master
4287 && sym->ns->entries->sym->attr.recursive);
4288 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4289 {
4290 char * msg;
4291
4292 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4293 sym->name);
4294 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4295 TREE_STATIC (recurcheckvar) = 1;
4296 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4297 gfc_add_expr_to_block (&block, recurcheckvar);
4298 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4299 &sym->declared_at, msg);
4300 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4301 gfc_free (msg);
4302 }
4303
4304 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4305 && sym->attr.subroutine)
4306 {
4307 tree alternate_return;
4308 alternate_return = gfc_get_fake_result_decl (sym, 0);
4309 gfc_add_modify (&body, alternate_return, integer_zero_node);
4310 }
4311
4312 if (ns->entries)
4313 {
4314 /* Jump to the correct entry point. */
4315 tmp = gfc_trans_entry_master_switch (ns->entries);
4316 gfc_add_expr_to_block (&body, tmp);
4317 }
4318
4319 /* If bounds-checking is enabled, generate code to check passed in actual
4320 arguments against the expected dummy argument attributes (e.g. string
4321 lengths). */
4322 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4323 add_argument_checking (&body, sym);
4324
4325 tmp = gfc_trans_code (ns->code);
4326 gfc_add_expr_to_block (&body, tmp);
4327
4328 /* Add a return label if needed. */
4329 if (current_function_return_label)
4330 {
4331 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4332 gfc_add_expr_to_block (&body, tmp);
4333 }
4334
4335 tmp = gfc_finish_block (&body);
4336 /* Add code to create and cleanup arrays. */
4337 tmp = gfc_trans_deferred_vars (sym, tmp);
4338
4339 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4340 {
4341 if (sym->attr.subroutine || sym == sym->result)
4342 {
4343 if (current_fake_result_decl != NULL)
4344 result = TREE_VALUE (current_fake_result_decl);
4345 else
4346 result = NULL_TREE;
4347 current_fake_result_decl = NULL_TREE;
4348 }
4349 else
4350 result = sym->result->backend_decl;
4351
4352 if (result != NULL_TREE && sym->attr.function
4353 && sym->ts.type == BT_DERIVED
4354 && sym->ts.u.derived->attr.alloc_comp
4355 && !sym->attr.pointer)
4356 {
4357 rank = sym->as ? sym->as->rank : 0;
4358 tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4359 gfc_add_expr_to_block (&block, tmp2);
4360 }
4361
4362 gfc_add_expr_to_block (&block, tmp);
4363
4364 /* Reset recursion-check variable. */
4365 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4366 {
4367 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4368 recurcheckvar = NULL;
4369 }
4370
4371 if (result == NULL_TREE)
4372 {
4373 /* TODO: move to the appropriate place in resolve.c. */
4374 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4375 gfc_warning ("Return value of function '%s' at %L not set",
4376 sym->name, &sym->declared_at);
4377
4378 TREE_NO_WARNING(sym->backend_decl) = 1;
4379 }
4380 else
4381 {
4382 /* Set the return value to the dummy result variable. The
4383 types may be different for scalar default REAL functions
4384 with -ff2c, therefore we have to convert. */
4385 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4386 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4387 DECL_RESULT (fndecl), tmp);
4388 tmp = build1_v (RETURN_EXPR, tmp);
4389 gfc_add_expr_to_block (&block, tmp);
4390 }
4391 }
4392 else
4393 {
4394 gfc_add_expr_to_block (&block, tmp);
4395 /* Reset recursion-check variable. */
4396 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4397 {
4398 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4399 recurcheckvar = NULL;
4400 }
4401 }
4402
4403
4404 /* Add all the decls we created during processing. */
4405 decl = saved_function_decls;
4406 while (decl)
4407 {
4408 tree next;
4409
4410 next = TREE_CHAIN (decl);
4411 TREE_CHAIN (decl) = NULL_TREE;
4412 pushdecl (decl);
4413 decl = next;
4414 }
4415 saved_function_decls = NULL_TREE;
4416
4417 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4418 decl = getdecls ();
4419
4420 /* Finish off this function and send it for code generation. */
4421 poplevel (1, 0, 1);
4422 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4423
4424 DECL_SAVED_TREE (fndecl)
4425 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4426 DECL_INITIAL (fndecl));
4427
4428 if (nonlocal_dummy_decls)
4429 {
4430 BLOCK_VARS (DECL_INITIAL (fndecl))
4431 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4432 pointer_set_destroy (nonlocal_dummy_decl_pset);
4433 nonlocal_dummy_decls = NULL;
4434 nonlocal_dummy_decl_pset = NULL;
4435 }
4436
4437 /* Output the GENERIC tree. */
4438 dump_function (TDI_original, fndecl);
4439
4440 /* Store the end of the function, so that we get good line number
4441 info for the epilogue. */
4442 cfun->function_end_locus = input_location;
4443
4444 /* We're leaving the context of this function, so zap cfun.
4445 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4446 tree_rest_of_compilation. */
4447 set_cfun (NULL);
4448
4449 if (old_context)
4450 {
4451 pop_function_context ();
4452 saved_function_decls = saved_parent_function_decls;
4453 }
4454 current_function_decl = old_context;
4455
4456 if (decl_function_context (fndecl))
4457 /* Register this function with cgraph just far enough to get it
4458 added to our parent's nested function list. */
4459 (void) cgraph_node (fndecl);
4460 else
4461 cgraph_finalize_function (fndecl, true);
4462
4463 gfc_trans_use_stmts (ns);
4464 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4465
4466 if (sym->attr.is_main_program)
4467 create_main_function (fndecl);
4468 }
4469
4470
4471 void
4472 gfc_generate_constructors (void)
4473 {
4474 gcc_assert (gfc_static_ctors == NULL_TREE);
4475 #if 0
4476 tree fnname;
4477 tree type;
4478 tree fndecl;
4479 tree decl;
4480 tree tmp;
4481
4482 if (gfc_static_ctors == NULL_TREE)
4483 return;
4484
4485 fnname = get_file_function_name ("I");
4486 type = build_function_type (void_type_node,
4487 gfc_chainon_list (NULL_TREE, void_type_node));
4488
4489 fndecl = build_decl (input_location,
4490 FUNCTION_DECL, fnname, type);
4491 TREE_PUBLIC (fndecl) = 1;
4492
4493 decl = build_decl (input_location,
4494 RESULT_DECL, NULL_TREE, void_type_node);
4495 DECL_ARTIFICIAL (decl) = 1;
4496 DECL_IGNORED_P (decl) = 1;
4497 DECL_CONTEXT (decl) = fndecl;
4498 DECL_RESULT (fndecl) = decl;
4499
4500 pushdecl (fndecl);
4501
4502 current_function_decl = fndecl;
4503
4504 rest_of_decl_compilation (fndecl, 1, 0);
4505
4506 make_decl_rtl (fndecl);
4507
4508 init_function_start (fndecl);
4509
4510 pushlevel (0);
4511
4512 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4513 {
4514 tmp = build_call_expr_loc (input_location,
4515 TREE_VALUE (gfc_static_ctors), 0);
4516 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4517 }
4518
4519 decl = getdecls ();
4520 poplevel (1, 0, 1);
4521
4522 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4523 DECL_SAVED_TREE (fndecl)
4524 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4525 DECL_INITIAL (fndecl));
4526
4527 free_after_parsing (cfun);
4528 free_after_compilation (cfun);
4529
4530 tree_rest_of_compilation (fndecl);
4531
4532 current_function_decl = NULL_TREE;
4533 #endif
4534 }
4535
4536 /* Translates a BLOCK DATA program unit. This means emitting the
4537 commons contained therein plus their initializations. We also emit
4538 a globally visible symbol to make sure that each BLOCK DATA program
4539 unit remains unique. */
4540
4541 void
4542 gfc_generate_block_data (gfc_namespace * ns)
4543 {
4544 tree decl;
4545 tree id;
4546
4547 /* Tell the backend the source location of the block data. */
4548 if (ns->proc_name)
4549 gfc_set_backend_locus (&ns->proc_name->declared_at);
4550 else
4551 gfc_set_backend_locus (&gfc_current_locus);
4552
4553 /* Process the DATA statements. */
4554 gfc_trans_common (ns);
4555
4556 /* Create a global symbol with the mane of the block data. This is to
4557 generate linker errors if the same name is used twice. It is never
4558 really used. */
4559 if (ns->proc_name)
4560 id = gfc_sym_mangled_function_id (ns->proc_name);
4561 else
4562 id = get_identifier ("__BLOCK_DATA__");
4563
4564 decl = build_decl (input_location,
4565 VAR_DECL, id, gfc_array_index_type);
4566 TREE_PUBLIC (decl) = 1;
4567 TREE_STATIC (decl) = 1;
4568 DECL_IGNORED_P (decl) = 1;
4569
4570 pushdecl (decl);
4571 rest_of_decl_compilation (decl, 1, 0);
4572 }
4573
4574
4575 /* Process the local variables of a BLOCK construct. */
4576
4577 void
4578 gfc_process_block_locals (gfc_namespace* ns)
4579 {
4580 tree decl;
4581
4582 gcc_assert (saved_local_decls == NULL_TREE);
4583 generate_local_vars (ns);
4584
4585 decl = saved_local_decls;
4586 while (decl)
4587 {
4588 tree next;
4589
4590 next = TREE_CHAIN (decl);
4591 TREE_CHAIN (decl) = NULL_TREE;
4592 pushdecl (decl);
4593 decl = next;
4594 }
4595 saved_local_decls = NULL_TREE;
4596 }
4597
4598
4599 #include "gt-fortran-trans-decl.h"