projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/54107 ([F03] Memory hog with abstract interface)
[gcc.git] / gcc / fortran / trans-decl.c
1 /* Backend function setup
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Paul Brook
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 /* trans-decl.c -- Handling of backend function and variable decls, etc */
22
23 #include "config.h"
24 #include "system.h"
25 #include "coretypes.h"
26 #include "tm.h"
27 #include "tree.h"
28 #include "tree-dump.h"
29 #include "gimple.h" /* For create_tmp_var_raw. */
30 #include "ggc.h"
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For announce_function. */
33 #include "target.h"
34 #include "function.h"
35 #include "flags.h"
36 #include "cgraph.h"
37 #include "debug.h"
38 #include "gfortran.h"
39 #include "pointer-set.h"
40 #include "constructor.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
57 /* Holds the variable DECLs for the current function. */
58
59 static GTY(()) tree saved_function_decls;
60 static GTY(()) tree saved_parent_function_decls;
61
62 static struct pointer_set_t *nonlocal_dummy_decl_pset;
63 static GTY(()) tree nonlocal_dummy_decls;
64
65 /* Holds the variable DECLs that are locals. */
66
67 static GTY(()) tree saved_local_decls;
68
69 /* The namespace of the module we're currently generating. Only used while
70 outputting decls for module variables. Do not rely on this being set. */
71
72 static gfc_namespace *module_namespace;
73
74 /* The currently processed procedure symbol. */
75 static gfc_symbol* current_procedure_symbol = NULL;
76
77
78 /* With -fcoarray=lib: For generating the registering call
79 of static coarrays. */
80 static bool has_coarray_vars;
81 static stmtblock_t caf_init_block;
82
83
84 /* List of static constructor functions. */
85
86 tree gfc_static_ctors;
87
88
89 /* Function declarations for builtin library functions. */
90
91 tree gfor_fndecl_pause_numeric;
92 tree gfor_fndecl_pause_string;
93 tree gfor_fndecl_stop_numeric;
94 tree gfor_fndecl_stop_numeric_f08;
95 tree gfor_fndecl_stop_string;
96 tree gfor_fndecl_error_stop_numeric;
97 tree gfor_fndecl_error_stop_string;
98 tree gfor_fndecl_runtime_error;
99 tree gfor_fndecl_runtime_error_at;
100 tree gfor_fndecl_runtime_warning_at;
101 tree gfor_fndecl_os_error;
102 tree gfor_fndecl_generate_error;
103 tree gfor_fndecl_set_args;
104 tree gfor_fndecl_set_fpe;
105 tree gfor_fndecl_set_options;
106 tree gfor_fndecl_set_convert;
107 tree gfor_fndecl_set_record_marker;
108 tree gfor_fndecl_set_max_subrecord_length;
109 tree gfor_fndecl_ctime;
110 tree gfor_fndecl_fdate;
111 tree gfor_fndecl_ttynam;
112 tree gfor_fndecl_in_pack;
113 tree gfor_fndecl_in_unpack;
114 tree gfor_fndecl_associated;
115
116
117 /* Coarray run-time library function decls. */
118 tree gfor_fndecl_caf_init;
119 tree gfor_fndecl_caf_finalize;
120 tree gfor_fndecl_caf_register;
121 tree gfor_fndecl_caf_deregister;
122 tree gfor_fndecl_caf_critical;
123 tree gfor_fndecl_caf_end_critical;
124 tree gfor_fndecl_caf_sync_all;
125 tree gfor_fndecl_caf_sync_images;
126 tree gfor_fndecl_caf_error_stop;
127 tree gfor_fndecl_caf_error_stop_str;
128
129 /* Coarray global variables for num_images/this_image. */
130
131 tree gfort_gvar_caf_num_images;
132 tree gfort_gvar_caf_this_image;
133
134
135 /* Math functions. Many other math functions are handled in
136 trans-intrinsic.c. */
137
138 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
139 tree gfor_fndecl_math_ishftc4;
140 tree gfor_fndecl_math_ishftc8;
141 tree gfor_fndecl_math_ishftc16;
142
143
144 /* String functions. */
145
146 tree gfor_fndecl_compare_string;
147 tree gfor_fndecl_concat_string;
148 tree gfor_fndecl_string_len_trim;
149 tree gfor_fndecl_string_index;
150 tree gfor_fndecl_string_scan;
151 tree gfor_fndecl_string_verify;
152 tree gfor_fndecl_string_trim;
153 tree gfor_fndecl_string_minmax;
154 tree gfor_fndecl_adjustl;
155 tree gfor_fndecl_adjustr;
156 tree gfor_fndecl_select_string;
157 tree gfor_fndecl_compare_string_char4;
158 tree gfor_fndecl_concat_string_char4;
159 tree gfor_fndecl_string_len_trim_char4;
160 tree gfor_fndecl_string_index_char4;
161 tree gfor_fndecl_string_scan_char4;
162 tree gfor_fndecl_string_verify_char4;
163 tree gfor_fndecl_string_trim_char4;
164 tree gfor_fndecl_string_minmax_char4;
165 tree gfor_fndecl_adjustl_char4;
166 tree gfor_fndecl_adjustr_char4;
167 tree gfor_fndecl_select_string_char4;
168
169
170 /* Conversion between character kinds. */
171 tree gfor_fndecl_convert_char1_to_char4;
172 tree gfor_fndecl_convert_char4_to_char1;
173
174
175 /* Other misc. runtime library functions. */
176 tree gfor_fndecl_size0;
177 tree gfor_fndecl_size1;
178 tree gfor_fndecl_iargc;
179
180 /* Intrinsic functions implemented in Fortran. */
181 tree gfor_fndecl_sc_kind;
182 tree gfor_fndecl_si_kind;
183 tree gfor_fndecl_sr_kind;
184
185 /* BLAS gemm functions. */
186 tree gfor_fndecl_sgemm;
187 tree gfor_fndecl_dgemm;
188 tree gfor_fndecl_cgemm;
189 tree gfor_fndecl_zgemm;
190
191
192 static void
193 gfc_add_decl_to_parent_function (tree decl)
194 {
195 gcc_assert (decl);
196 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
197 DECL_NONLOCAL (decl) = 1;
198 DECL_CHAIN (decl) = saved_parent_function_decls;
199 saved_parent_function_decls = decl;
200 }
201
202 void
203 gfc_add_decl_to_function (tree decl)
204 {
205 gcc_assert (decl);
206 TREE_USED (decl) = 1;
207 DECL_CONTEXT (decl) = current_function_decl;
208 DECL_CHAIN (decl) = saved_function_decls;
209 saved_function_decls = decl;
210 }
211
212 static void
213 add_decl_as_local (tree decl)
214 {
215 gcc_assert (decl);
216 TREE_USED (decl) = 1;
217 DECL_CONTEXT (decl) = current_function_decl;
218 DECL_CHAIN (decl) = saved_local_decls;
219 saved_local_decls = decl;
220 }
221
222
223 /* Build a backend label declaration. Set TREE_USED for named labels.
224 The context of the label is always the current_function_decl. All
225 labels are marked artificial. */
226
227 tree
228 gfc_build_label_decl (tree label_id)
229 {
230 /* 2^32 temporaries should be enough. */
231 static unsigned int tmp_num = 1;
232 tree label_decl;
233 char *label_name;
234
235 if (label_id == NULL_TREE)
236 {
237 /* Build an internal label name. */
238 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
239 label_id = get_identifier (label_name);
240 }
241 else
242 label_name = NULL;
243
244 /* Build the LABEL_DECL node. Labels have no type. */
245 label_decl = build_decl (input_location,
246 LABEL_DECL, label_id, void_type_node);
247 DECL_CONTEXT (label_decl) = current_function_decl;
248 DECL_MODE (label_decl) = VOIDmode;
249
250 /* We always define the label as used, even if the original source
251 file never references the label. We don't want all kinds of
252 spurious warnings for old-style Fortran code with too many
253 labels. */
254 TREE_USED (label_decl) = 1;
255
256 DECL_ARTIFICIAL (label_decl) = 1;
257 return label_decl;
258 }
259
260
261 /* Set the backend source location of a decl. */
262
263 void
264 gfc_set_decl_location (tree decl, locus * loc)
265 {
266 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
267 }
268
269
270 /* Return the backend label declaration for a given label structure,
271 or create it if it doesn't exist yet. */
272
273 tree
274 gfc_get_label_decl (gfc_st_label * lp)
275 {
276 if (lp->backend_decl)
277 return lp->backend_decl;
278 else
279 {
280 char label_name[GFC_MAX_SYMBOL_LEN + 1];
281 tree label_decl;
282
283 /* Validate the label declaration from the front end. */
284 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
285
286 /* Build a mangled name for the label. */
287 sprintf (label_name, "__label_%.6d", lp->value);
288
289 /* Build the LABEL_DECL node. */
290 label_decl = gfc_build_label_decl (get_identifier (label_name));
291
292 /* Tell the debugger where the label came from. */
293 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
294 gfc_set_decl_location (label_decl, &lp->where);
295 else
296 DECL_ARTIFICIAL (label_decl) = 1;
297
298 /* Store the label in the label list and return the LABEL_DECL. */
299 lp->backend_decl = label_decl;
300 return label_decl;
301 }
302 }
303
304
305 /* Convert a gfc_symbol to an identifier of the same name. */
306
307 static tree
308 gfc_sym_identifier (gfc_symbol * sym)
309 {
310 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
311 return (get_identifier ("MAIN__"));
312 else
313 return (get_identifier (sym->name));
314 }
315
316
317 /* Construct mangled name from symbol name. */
318
319 static tree
320 gfc_sym_mangled_identifier (gfc_symbol * sym)
321 {
322 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
323
324 /* Prevent the mangling of identifiers that have an assigned
325 binding label (mainly those that are bind(c)). */
326 if (sym->attr.is_bind_c == 1 && sym->binding_label)
327 return get_identifier (sym->binding_label);
328
329 if (sym->module == NULL)
330 return gfc_sym_identifier (sym);
331 else
332 {
333 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
334 return get_identifier (name);
335 }
336 }
337
338
339 /* Construct mangled function name from symbol name. */
340
341 static tree
342 gfc_sym_mangled_function_id (gfc_symbol * sym)
343 {
344 int has_underscore;
345 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
346
347 /* It may be possible to simply use the binding label if it's
348 provided, and remove the other checks. Then we could use it
349 for other things if we wished. */
350 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
351 sym->binding_label)
352 /* use the binding label rather than the mangled name */
353 return get_identifier (sym->binding_label);
354
355 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
356 || (sym->module != NULL && (sym->attr.external
357 || sym->attr.if_source == IFSRC_IFBODY)))
358 {
359 /* Main program is mangled into MAIN__. */
360 if (sym->attr.is_main_program)
361 return get_identifier ("MAIN__");
362
363 /* Intrinsic procedures are never mangled. */
364 if (sym->attr.proc == PROC_INTRINSIC)
365 return get_identifier (sym->name);
366
367 if (gfc_option.flag_underscoring)
368 {
369 has_underscore = strchr (sym->name, '_') != 0;
370 if (gfc_option.flag_second_underscore && has_underscore)
371 snprintf (name, sizeof name, "%s__", sym->name);
372 else
373 snprintf (name, sizeof name, "%s_", sym->name);
374 return get_identifier (name);
375 }
376 else
377 return get_identifier (sym->name);
378 }
379 else
380 {
381 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
382 return get_identifier (name);
383 }
384 }
385
386
387 void
388 gfc_set_decl_assembler_name (tree decl, tree name)
389 {
390 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
391 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
392 }
393
394
395 /* Returns true if a variable of specified size should go on the stack. */
396
397 int
398 gfc_can_put_var_on_stack (tree size)
399 {
400 unsigned HOST_WIDE_INT low;
401
402 if (!INTEGER_CST_P (size))
403 return 0;
404
405 if (gfc_option.flag_max_stack_var_size < 0)
406 return 1;
407
408 if (TREE_INT_CST_HIGH (size) != 0)
409 return 0;
410
411 low = TREE_INT_CST_LOW (size);
412 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
413 return 0;
414
415 /* TODO: Set a per-function stack size limit. */
416
417 return 1;
418 }
419
420
421 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
422 an expression involving its corresponding pointer. There are
423 2 cases; one for variable size arrays, and one for everything else,
424 because variable-sized arrays require one fewer level of
425 indirection. */
426
427 static void
428 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
429 {
430 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
431 tree value;
432
433 /* Parameters need to be dereferenced. */
434 if (sym->cp_pointer->attr.dummy)
435 ptr_decl = build_fold_indirect_ref_loc (input_location,
436 ptr_decl);
437
438 /* Check to see if we're dealing with a variable-sized array. */
439 if (sym->attr.dimension
440 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
441 {
442 /* These decls will be dereferenced later, so we don't dereference
443 them here. */
444 value = convert (TREE_TYPE (decl), ptr_decl);
445 }
446 else
447 {
448 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
449 ptr_decl);
450 value = build_fold_indirect_ref_loc (input_location,
451 ptr_decl);
452 }
453
454 SET_DECL_VALUE_EXPR (decl, value);
455 DECL_HAS_VALUE_EXPR_P (decl) = 1;
456 GFC_DECL_CRAY_POINTEE (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 if (sym->attr.flavor == FL_PARAMETER
516 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
517 TREE_READONLY (decl) = 1;
518
519 /* Chain this decl to the pending declarations. Don't do pushdecl()
520 because this would add them to the current scope rather than the
521 function scope. */
522 if (current_function_decl != NULL_TREE)
523 {
524 if (sym->ns->proc_name->backend_decl == current_function_decl
525 || sym->result == sym)
526 gfc_add_decl_to_function (decl);
527 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
528 /* This is a BLOCK construct. */
529 add_decl_as_local (decl);
530 else
531 gfc_add_decl_to_parent_function (decl);
532 }
533
534 if (sym->attr.cray_pointee)
535 return;
536
537 if(sym->attr.is_bind_c == 1 && sym->binding_label)
538 {
539 /* We need to put variables that are bind(c) into the common
540 segment of the object file, because this is what C would do.
541 gfortran would typically put them in either the BSS or
542 initialized data segments, and only mark them as common if
543 they were part of common blocks. However, if they are not put
544 into common space, then C cannot initialize global Fortran
545 variables that it interoperates with and the draft says that
546 either Fortran or C should be able to initialize it (but not
547 both, of course.) (J3/04-007, section 15.3). */
548 TREE_PUBLIC(decl) = 1;
549 DECL_COMMON(decl) = 1;
550 }
551
552 /* If a variable is USE associated, it's always external. */
553 if (sym->attr.use_assoc)
554 {
555 DECL_EXTERNAL (decl) = 1;
556 TREE_PUBLIC (decl) = 1;
557 }
558 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
559 {
560 /* TODO: Don't set sym->module for result or dummy variables. */
561 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
562 /* This is the declaration of a module variable. */
563 if (sym->attr.access == ACCESS_UNKNOWN
564 && (sym->ns->default_access == ACCESS_PRIVATE
565 || (sym->ns->default_access == ACCESS_UNKNOWN
566 && gfc_option.flag_module_private)))
567 sym->attr.access = ACCESS_PRIVATE;
568
569 if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)
570 TREE_PUBLIC (decl) = 1;
571 TREE_STATIC (decl) = 1;
572 }
573
574 /* Derived types are a bit peculiar because of the possibility of
575 a default initializer; this must be applied each time the variable
576 comes into scope it therefore need not be static. These variables
577 are SAVE_NONE but have an initializer. Otherwise explicitly
578 initialized variables are SAVE_IMPLICIT and explicitly saved are
579 SAVE_EXPLICIT. */
580 if (!sym->attr.use_assoc
581 && (sym->attr.save != SAVE_NONE || sym->attr.data
582 || (sym->value && sym->ns->proc_name->attr.is_main_program)
583 || (gfc_option.coarray == GFC_FCOARRAY_LIB
584 && sym->attr.codimension && !sym->attr.allocatable)))
585 TREE_STATIC (decl) = 1;
586
587 if (sym->attr.volatile_)
588 {
589 TREE_THIS_VOLATILE (decl) = 1;
590 TREE_SIDE_EFFECTS (decl) = 1;
591 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
592 TREE_TYPE (decl) = new_type;
593 }
594
595 /* Keep variables larger than max-stack-var-size off stack. */
596 if (!sym->ns->proc_name->attr.recursive
597 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
598 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
599 /* Put variable length auto array pointers always into stack. */
600 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
601 || sym->attr.dimension == 0
602 || sym->as->type != AS_EXPLICIT
603 || sym->attr.pointer
604 || sym->attr.allocatable)
605 && !DECL_ARTIFICIAL (decl))
606 TREE_STATIC (decl) = 1;
607
608 /* Handle threadprivate variables. */
609 if (sym->attr.threadprivate
610 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
611 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
612 }
613
614
615 /* Allocate the lang-specific part of a decl. */
616
617 void
618 gfc_allocate_lang_decl (tree decl)
619 {
620 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
621 (struct lang_decl));
622 }
623
624 /* Remember a symbol to generate initialization/cleanup code at function
625 entry/exit. */
626
627 static void
628 gfc_defer_symbol_init (gfc_symbol * sym)
629 {
630 gfc_symbol *p;
631 gfc_symbol *last;
632 gfc_symbol *head;
633
634 /* Don't add a symbol twice. */
635 if (sym->tlink)
636 return;
637
638 last = head = sym->ns->proc_name;
639 p = last->tlink;
640
641 /* Make sure that setup code for dummy variables which are used in the
642 setup of other variables is generated first. */
643 if (sym->attr.dummy)
644 {
645 /* Find the first dummy arg seen after us, or the first non-dummy arg.
646 This is a circular list, so don't go past the head. */
647 while (p != head
648 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
649 {
650 last = p;
651 p = p->tlink;
652 }
653 }
654 /* Insert in between last and p. */
655 last->tlink = sym;
656 sym->tlink = p;
657 }
658
659
660 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
661 backend_decl for a module symbol, if it all ready exists. If the
662 module gsymbol does not exist, it is created. If the symbol does
663 not exist, it is added to the gsymbol namespace. Returns true if
664 an existing backend_decl is found. */
665
666 bool
667 gfc_get_module_backend_decl (gfc_symbol *sym)
668 {
669 gfc_gsymbol *gsym;
670 gfc_symbol *s;
671 gfc_symtree *st;
672
673 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
674
675 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
676 {
677 st = NULL;
678 s = NULL;
679
680 if (gsym)
681 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
682
683 if (!s)
684 {
685 if (!gsym)
686 {
687 gsym = gfc_get_gsymbol (sym->module);
688 gsym->type = GSYM_MODULE;
689 gsym->ns = gfc_get_namespace (NULL, 0);
690 }
691
692 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
693 st->n.sym = sym;
694 sym->refs++;
695 }
696 else if (sym->attr.flavor == FL_DERIVED)
697 {
698 if (s && s->attr.flavor == FL_PROCEDURE)
699 {
700 gfc_interface *intr;
701 gcc_assert (s->attr.generic);
702 for (intr = s->generic; intr; intr = intr->next)
703 if (intr->sym->attr.flavor == FL_DERIVED)
704 {
705 s = intr->sym;
706 break;
707 }
708 }
709
710 if (!s->backend_decl)
711 s->backend_decl = gfc_get_derived_type (s);
712 gfc_copy_dt_decls_ifequal (s, sym, true);
713 return true;
714 }
715 else if (s->backend_decl)
716 {
717 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
718 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
719 true);
720 else if (sym->ts.type == BT_CHARACTER)
721 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
722 sym->backend_decl = s->backend_decl;
723 return true;
724 }
725 }
726 return false;
727 }
728
729
730 /* Create an array index type variable with function scope. */
731
732 static tree
733 create_index_var (const char * pfx, int nest)
734 {
735 tree decl;
736
737 decl = gfc_create_var_np (gfc_array_index_type, pfx);
738 if (nest)
739 gfc_add_decl_to_parent_function (decl);
740 else
741 gfc_add_decl_to_function (decl);
742 return decl;
743 }
744
745
746 /* Create variables to hold all the non-constant bits of info for a
747 descriptorless array. Remember these in the lang-specific part of the
748 type. */
749
750 static void
751 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
752 {
753 tree type;
754 int dim;
755 int nest;
756 gfc_namespace* procns;
757
758 type = TREE_TYPE (decl);
759
760 /* We just use the descriptor, if there is one. */
761 if (GFC_DESCRIPTOR_TYPE_P (type))
762 return;
763
764 gcc_assert (GFC_ARRAY_TYPE_P (type));
765 procns = gfc_find_proc_namespace (sym->ns);
766 nest = (procns->proc_name->backend_decl != current_function_decl)
767 && !sym->attr.contained;
768
769 if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
770 && sym->as->type != AS_ASSUMED_SHAPE
771 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
772 {
773 tree token;
774
775 token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
776 TYPE_QUAL_RESTRICT),
777 "caf_token");
778 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
779 DECL_ARTIFICIAL (token) = 1;
780 TREE_STATIC (token) = 1;
781 gfc_add_decl_to_function (token);
782 }
783
784 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
785 {
786 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
787 {
788 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
789 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
790 }
791 /* Don't try to use the unknown bound for assumed shape arrays. */
792 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
793 && (sym->as->type != AS_ASSUMED_SIZE
794 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
795 {
796 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
797 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
798 }
799
800 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
801 {
802 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
803 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
804 }
805 }
806 for (dim = GFC_TYPE_ARRAY_RANK (type);
807 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
808 {
809 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
810 {
811 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
812 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
813 }
814 /* Don't try to use the unknown ubound for the last coarray dimension. */
815 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
816 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
817 {
818 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
819 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
820 }
821 }
822 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
823 {
824 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
825 "offset");
826 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
827
828 if (nest)
829 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
830 else
831 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
832 }
833
834 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
835 && sym->as->type != AS_ASSUMED_SIZE)
836 {
837 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
838 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
839 }
840
841 if (POINTER_TYPE_P (type))
842 {
843 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
844 gcc_assert (TYPE_LANG_SPECIFIC (type)
845 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
846 type = TREE_TYPE (type);
847 }
848
849 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
850 {
851 tree size, range;
852
853 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
854 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
855 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
856 size);
857 TYPE_DOMAIN (type) = range;
858 layout_type (type);
859 }
860
861 if (TYPE_NAME (type) != NULL_TREE
862 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
863 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
864 {
865 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
866
867 for (dim = 0; dim < sym->as->rank - 1; dim++)
868 {
869 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
870 gtype = TREE_TYPE (gtype);
871 }
872 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
873 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
874 TYPE_NAME (type) = NULL_TREE;
875 }
876
877 if (TYPE_NAME (type) == NULL_TREE)
878 {
879 tree gtype = TREE_TYPE (type), rtype, type_decl;
880
881 for (dim = sym->as->rank - 1; dim >= 0; dim--)
882 {
883 tree lbound, ubound;
884 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
885 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
886 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
887 gtype = build_array_type (gtype, rtype);
888 /* Ensure the bound variables aren't optimized out at -O0.
889 For -O1 and above they often will be optimized out, but
890 can be tracked by VTA. Also set DECL_NAMELESS, so that
891 the artificial lbound.N or ubound.N DECL_NAME doesn't
892 end up in debug info. */
893 if (lbound && TREE_CODE (lbound) == VAR_DECL
894 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
895 {
896 if (DECL_NAME (lbound)
897 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
898 "lbound") != 0)
899 DECL_NAMELESS (lbound) = 1;
900 DECL_IGNORED_P (lbound) = 0;
901 }
902 if (ubound && TREE_CODE (ubound) == VAR_DECL
903 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
904 {
905 if (DECL_NAME (ubound)
906 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
907 "ubound") != 0)
908 DECL_NAMELESS (ubound) = 1;
909 DECL_IGNORED_P (ubound) = 0;
910 }
911 }
912 TYPE_NAME (type) = type_decl = build_decl (input_location,
913 TYPE_DECL, NULL, gtype);
914 DECL_ORIGINAL_TYPE (type_decl) = gtype;
915 }
916 }
917
918
919 /* For some dummy arguments we don't use the actual argument directly.
920 Instead we create a local decl and use that. This allows us to perform
921 initialization, and construct full type information. */
922
923 static tree
924 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
925 {
926 tree decl;
927 tree type;
928 gfc_array_spec *as;
929 char *name;
930 gfc_packed packed;
931 int n;
932 bool known_size;
933
934 if (sym->attr.pointer || sym->attr.allocatable
935 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
936 return dummy;
937
938 /* Add to list of variables if not a fake result variable. */
939 if (sym->attr.result || sym->attr.dummy)
940 gfc_defer_symbol_init (sym);
941
942 type = TREE_TYPE (dummy);
943 gcc_assert (TREE_CODE (dummy) == PARM_DECL
944 && POINTER_TYPE_P (type));
945
946 /* Do we know the element size? */
947 known_size = sym->ts.type != BT_CHARACTER
948 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
949
950 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
951 {
952 /* For descriptorless arrays with known element size the actual
953 argument is sufficient. */
954 gcc_assert (GFC_ARRAY_TYPE_P (type));
955 gfc_build_qualified_array (dummy, sym);
956 return dummy;
957 }
958
959 type = TREE_TYPE (type);
960 if (GFC_DESCRIPTOR_TYPE_P (type))
961 {
962 /* Create a descriptorless array pointer. */
963 as = sym->as;
964 packed = PACKED_NO;
965
966 /* Even when -frepack-arrays is used, symbols with TARGET attribute
967 are not repacked. */
968 if (!gfc_option.flag_repack_arrays || sym->attr.target)
969 {
970 if (as->type == AS_ASSUMED_SIZE)
971 packed = PACKED_FULL;
972 }
973 else
974 {
975 if (as->type == AS_EXPLICIT)
976 {
977 packed = PACKED_FULL;
978 for (n = 0; n < as->rank; n++)
979 {
980 if (!(as->upper[n]
981 && as->lower[n]
982 && as->upper[n]->expr_type == EXPR_CONSTANT
983 && as->lower[n]->expr_type == EXPR_CONSTANT))
984 packed = PACKED_PARTIAL;
985 }
986 }
987 else
988 packed = PACKED_PARTIAL;
989 }
990
991 type = gfc_typenode_for_spec (&sym->ts);
992 type = gfc_get_nodesc_array_type (type, sym->as, packed,
993 !sym->attr.target);
994 }
995 else
996 {
997 /* We now have an expression for the element size, so create a fully
998 qualified type. Reset sym->backend decl or this will just return the
999 old type. */
1000 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1001 sym->backend_decl = NULL_TREE;
1002 type = gfc_sym_type (sym);
1003 packed = PACKED_FULL;
1004 }
1005
1006 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1007 decl = build_decl (input_location,
1008 VAR_DECL, get_identifier (name), type);
1009
1010 DECL_ARTIFICIAL (decl) = 1;
1011 DECL_NAMELESS (decl) = 1;
1012 TREE_PUBLIC (decl) = 0;
1013 TREE_STATIC (decl) = 0;
1014 DECL_EXTERNAL (decl) = 0;
1015
1016 /* We should never get deferred shape arrays here. We used to because of
1017 frontend bugs. */
1018 gcc_assert (sym->as->type != AS_DEFERRED);
1019
1020 if (packed == PACKED_PARTIAL)
1021 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1022 else if (packed == PACKED_FULL)
1023 GFC_DECL_PACKED_ARRAY (decl) = 1;
1024
1025 gfc_build_qualified_array (decl, sym);
1026
1027 if (DECL_LANG_SPECIFIC (dummy))
1028 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1029 else
1030 gfc_allocate_lang_decl (decl);
1031
1032 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1033
1034 if (sym->ns->proc_name->backend_decl == current_function_decl
1035 || sym->attr.contained)
1036 gfc_add_decl_to_function (decl);
1037 else
1038 gfc_add_decl_to_parent_function (decl);
1039
1040 return decl;
1041 }
1042
1043 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1044 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1045 pointing to the artificial variable for debug info purposes. */
1046
1047 static void
1048 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1049 {
1050 tree decl, dummy;
1051
1052 if (! nonlocal_dummy_decl_pset)
1053 nonlocal_dummy_decl_pset = pointer_set_create ();
1054
1055 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1056 return;
1057
1058 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1059 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1060 TREE_TYPE (sym->backend_decl));
1061 DECL_ARTIFICIAL (decl) = 0;
1062 TREE_USED (decl) = 1;
1063 TREE_PUBLIC (decl) = 0;
1064 TREE_STATIC (decl) = 0;
1065 DECL_EXTERNAL (decl) = 0;
1066 if (DECL_BY_REFERENCE (dummy))
1067 DECL_BY_REFERENCE (decl) = 1;
1068 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1069 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1070 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1071 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1072 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1073 nonlocal_dummy_decls = decl;
1074 }
1075
1076 /* Return a constant or a variable to use as a string length. Does not
1077 add the decl to the current scope. */
1078
1079 static tree
1080 gfc_create_string_length (gfc_symbol * sym)
1081 {
1082 gcc_assert (sym->ts.u.cl);
1083 gfc_conv_const_charlen (sym->ts.u.cl);
1084
1085 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1086 {
1087 tree length;
1088 const char *name;
1089
1090 /* The string length variable shall be in static memory if it is either
1091 explicitly SAVED, a module variable or with -fno-automatic. Only
1092 relevant is "len=:" - otherwise, it is either a constant length or
1093 it is an automatic variable. */
1094 bool static_length = sym->attr.save
1095 || sym->ns->proc_name->attr.flavor == FL_MODULE
1096 || (gfc_option.flag_max_stack_var_size == 0
1097 && sym->ts.deferred && !sym->attr.dummy
1098 && !sym->attr.result && !sym->attr.function);
1099
1100 /* Also prefix the mangled name. We need to call GFC_PREFIX for static
1101 variables as some systems do not support the "." in the assembler name.
1102 For nonstatic variables, the "." does not appear in assembler. */
1103 if (static_length)
1104 {
1105 if (sym->module)
1106 name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module,
1107 sym->name);
1108 else
1109 name = gfc_get_string (GFC_PREFIX ("%s"), sym->name);
1110 }
1111 else if (sym->module)
1112 name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name);
1113 else
1114 name = gfc_get_string (".%s", sym->name);
1115
1116 length = build_decl (input_location,
1117 VAR_DECL, get_identifier (name),
1118 gfc_charlen_type_node);
1119 DECL_ARTIFICIAL (length) = 1;
1120 TREE_USED (length) = 1;
1121 if (sym->ns->proc_name->tlink != NULL)
1122 gfc_defer_symbol_init (sym);
1123
1124 sym->ts.u.cl->backend_decl = length;
1125
1126 if (static_length)
1127 TREE_STATIC (length) = 1;
1128
1129 if (sym->ns->proc_name->attr.flavor == FL_MODULE
1130 && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used))
1131 TREE_PUBLIC (length) = 1;
1132 }
1133
1134 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1135 return sym->ts.u.cl->backend_decl;
1136 }
1137
1138 /* If a variable is assigned a label, we add another two auxiliary
1139 variables. */
1140
1141 static void
1142 gfc_add_assign_aux_vars (gfc_symbol * sym)
1143 {
1144 tree addr;
1145 tree length;
1146 tree decl;
1147
1148 gcc_assert (sym->backend_decl);
1149
1150 decl = sym->backend_decl;
1151 gfc_allocate_lang_decl (decl);
1152 GFC_DECL_ASSIGN (decl) = 1;
1153 length = build_decl (input_location,
1154 VAR_DECL, create_tmp_var_name (sym->name),
1155 gfc_charlen_type_node);
1156 addr = build_decl (input_location,
1157 VAR_DECL, create_tmp_var_name (sym->name),
1158 pvoid_type_node);
1159 gfc_finish_var_decl (length, sym);
1160 gfc_finish_var_decl (addr, sym);
1161 /* STRING_LENGTH is also used as flag. Less than -1 means that
1162 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1163 target label's address. Otherwise, value is the length of a format string
1164 and ASSIGN_ADDR is its address. */
1165 if (TREE_STATIC (length))
1166 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1167 else
1168 gfc_defer_symbol_init (sym);
1169
1170 GFC_DECL_STRING_LEN (decl) = length;
1171 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1172 }
1173
1174
1175 static tree
1176 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1177 {
1178 unsigned id;
1179 tree attr;
1180
1181 for (id = 0; id < EXT_ATTR_NUM; id++)
1182 if (sym_attr.ext_attr & (1 << id))
1183 {
1184 attr = build_tree_list (
1185 get_identifier (ext_attr_list[id].middle_end_name),
1186 NULL_TREE);
1187 list = chainon (list, attr);
1188 }
1189
1190 return list;
1191 }
1192
1193
1194 static void build_function_decl (gfc_symbol * sym, bool global);
1195
1196
1197 /* Return the decl for a gfc_symbol, create it if it doesn't already
1198 exist. */
1199
1200 tree
1201 gfc_get_symbol_decl (gfc_symbol * sym)
1202 {
1203 tree decl;
1204 tree length = NULL_TREE;
1205 tree attributes;
1206 int byref;
1207 bool intrinsic_array_parameter = false;
1208
1209 gcc_assert (sym->attr.referenced
1210 || sym->attr.flavor == FL_PROCEDURE
1211 || sym->attr.use_assoc
1212 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1213 || (sym->module && sym->attr.if_source != IFSRC_DECL
1214 && sym->backend_decl));
1215
1216 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1217 byref = gfc_return_by_reference (sym->ns->proc_name);
1218 else
1219 byref = 0;
1220
1221 /* Make sure that the vtab for the declared type is completed. */
1222 if (sym->ts.type == BT_CLASS)
1223 {
1224 gfc_component *c = CLASS_DATA (sym);
1225 if (!c->ts.u.derived->backend_decl)
1226 {
1227 gfc_find_derived_vtab (c->ts.u.derived);
1228 gfc_get_derived_type (sym->ts.u.derived);
1229 }
1230 }
1231
1232 /* All deferred character length procedures need to retain the backend
1233 decl, which is a pointer to the character length in the caller's
1234 namespace and to declare a local character length. */
1235 if (!byref && sym->attr.function
1236 && sym->ts.type == BT_CHARACTER
1237 && sym->ts.deferred
1238 && sym->ts.u.cl->passed_length == NULL
1239 && sym->ts.u.cl->backend_decl
1240 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1241 {
1242 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1243 sym->ts.u.cl->backend_decl = NULL_TREE;
1244 length = gfc_create_string_length (sym);
1245 }
1246
1247 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1248 {
1249 /* Return via extra parameter. */
1250 if (sym->attr.result && byref
1251 && !sym->backend_decl)
1252 {
1253 sym->backend_decl =
1254 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1255 /* For entry master function skip over the __entry
1256 argument. */
1257 if (sym->ns->proc_name->attr.entry_master)
1258 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1259 }
1260
1261 /* Dummy variables should already have been created. */
1262 gcc_assert (sym->backend_decl);
1263
1264 /* Create a character length variable. */
1265 if (sym->ts.type == BT_CHARACTER)
1266 {
1267 /* For a deferred dummy, make a new string length variable. */
1268 if (sym->ts.deferred
1269 &&
1270 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1271 sym->ts.u.cl->backend_decl = NULL_TREE;
1272
1273 if (sym->ts.deferred && sym->attr.result
1274 && sym->ts.u.cl->passed_length == NULL
1275 && sym->ts.u.cl->backend_decl)
1276 {
1277 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1278 sym->ts.u.cl->backend_decl = NULL_TREE;
1279 }
1280
1281 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1282 length = gfc_create_string_length (sym);
1283 else
1284 length = sym->ts.u.cl->backend_decl;
1285 if (TREE_CODE (length) == VAR_DECL
1286 && DECL_FILE_SCOPE_P (length))
1287 {
1288 /* Add the string length to the same context as the symbol. */
1289 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1290 gfc_add_decl_to_function (length);
1291 else
1292 gfc_add_decl_to_parent_function (length);
1293
1294 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1295 DECL_CONTEXT (length));
1296
1297 gfc_defer_symbol_init (sym);
1298 }
1299 }
1300
1301 /* Use a copy of the descriptor for dummy arrays. */
1302 if ((sym->attr.dimension || sym->attr.codimension)
1303 && !TREE_USED (sym->backend_decl))
1304 {
1305 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1306 /* Prevent the dummy from being detected as unused if it is copied. */
1307 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1308 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1309 sym->backend_decl = decl;
1310 }
1311
1312 TREE_USED (sym->backend_decl) = 1;
1313 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1314 {
1315 gfc_add_assign_aux_vars (sym);
1316 }
1317
1318 if (sym->attr.dimension
1319 && DECL_LANG_SPECIFIC (sym->backend_decl)
1320 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1321 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1322 gfc_nonlocal_dummy_array_decl (sym);
1323
1324 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1325 GFC_DECL_CLASS(sym->backend_decl) = 1;
1326
1327 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1328 GFC_DECL_CLASS(sym->backend_decl) = 1;
1329 return sym->backend_decl;
1330 }
1331
1332 if (sym->backend_decl)
1333 return sym->backend_decl;
1334
1335 /* Special case for array-valued named constants from intrinsic
1336 procedures; those are inlined. */
1337 if (sym->attr.use_assoc && sym->from_intmod
1338 && sym->attr.flavor == FL_PARAMETER)
1339 intrinsic_array_parameter = true;
1340
1341 /* If use associated and whole file compilation, use the module
1342 declaration. */
1343 if (gfc_option.flag_whole_file
1344 && (sym->attr.flavor == FL_VARIABLE
1345 || sym->attr.flavor == FL_PARAMETER)
1346 && sym->attr.use_assoc
1347 && !intrinsic_array_parameter
1348 && sym->module
1349 && gfc_get_module_backend_decl (sym))
1350 {
1351 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1352 GFC_DECL_CLASS(sym->backend_decl) = 1;
1353 return sym->backend_decl;
1354 }
1355
1356 if (sym->attr.flavor == FL_PROCEDURE)
1357 {
1358 /* Catch function declarations. Only used for actual parameters,
1359 procedure pointers and procptr initialization targets. */
1360 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1361 {
1362 decl = gfc_get_extern_function_decl (sym);
1363 gfc_set_decl_location (decl, &sym->declared_at);
1364 }
1365 else
1366 {
1367 if (!sym->backend_decl)
1368 build_function_decl (sym, false);
1369 decl = sym->backend_decl;
1370 }
1371 return decl;
1372 }
1373
1374 if (sym->attr.intrinsic)
1375 internal_error ("intrinsic variable which isn't a procedure");
1376
1377 /* Create string length decl first so that they can be used in the
1378 type declaration. */
1379 if (sym->ts.type == BT_CHARACTER)
1380 length = gfc_create_string_length (sym);
1381
1382 /* Create the decl for the variable. */
1383 decl = build_decl (sym->declared_at.lb->location,
1384 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1385
1386 /* Add attributes to variables. Functions are handled elsewhere. */
1387 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1388 decl_attributes (&decl, attributes, 0);
1389
1390 /* Symbols from modules should have their assembler names mangled.
1391 This is done here rather than in gfc_finish_var_decl because it
1392 is different for string length variables. */
1393 if (sym->module)
1394 {
1395 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1396 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1397 DECL_IGNORED_P (decl) = 1;
1398 }
1399
1400 if (sym->attr.select_type_temporary)
1401 {
1402 DECL_ARTIFICIAL (decl) = 1;
1403 DECL_IGNORED_P (decl) = 1;
1404 }
1405
1406 if (sym->attr.dimension || sym->attr.codimension)
1407 {
1408 /* Create variables to hold the non-constant bits of array info. */
1409 gfc_build_qualified_array (decl, sym);
1410
1411 if (sym->attr.contiguous
1412 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1413 GFC_DECL_PACKED_ARRAY (decl) = 1;
1414 }
1415
1416 /* Remember this variable for allocation/cleanup. */
1417 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1418 || (sym->ts.type == BT_CLASS &&
1419 (CLASS_DATA (sym)->attr.dimension
1420 || CLASS_DATA (sym)->attr.allocatable))
1421 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1422 /* This applies a derived type default initializer. */
1423 || (sym->ts.type == BT_DERIVED
1424 && sym->attr.save == SAVE_NONE
1425 && !sym->attr.data
1426 && !sym->attr.allocatable
1427 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1428 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1429 gfc_defer_symbol_init (sym);
1430
1431 gfc_finish_var_decl (decl, sym);
1432
1433 if (sym->ts.type == BT_CHARACTER)
1434 {
1435 /* Character variables need special handling. */
1436 gfc_allocate_lang_decl (decl);
1437
1438 if (TREE_CODE (length) != INTEGER_CST)
1439 {
1440 gfc_finish_var_decl (length, sym);
1441 gcc_assert (!sym->value);
1442 }
1443 }
1444 else if (sym->attr.subref_array_pointer)
1445 {
1446 /* We need the span for these beasts. */
1447 gfc_allocate_lang_decl (decl);
1448 }
1449
1450 if (sym->attr.subref_array_pointer)
1451 {
1452 tree span;
1453 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1454 span = build_decl (input_location,
1455 VAR_DECL, create_tmp_var_name ("span"),
1456 gfc_array_index_type);
1457 gfc_finish_var_decl (span, sym);
1458 TREE_STATIC (span) = TREE_STATIC (decl);
1459 DECL_ARTIFICIAL (span) = 1;
1460
1461 GFC_DECL_SPAN (decl) = span;
1462 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1463 }
1464
1465 if (sym->ts.type == BT_CLASS)
1466 GFC_DECL_CLASS(decl) = 1;
1467
1468 sym->backend_decl = decl;
1469
1470 if (sym->attr.assign)
1471 gfc_add_assign_aux_vars (sym);
1472
1473 if (intrinsic_array_parameter)
1474 {
1475 TREE_STATIC (decl) = 1;
1476 DECL_EXTERNAL (decl) = 0;
1477 }
1478
1479 if (TREE_STATIC (decl)
1480 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1481 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1482 || gfc_option.flag_max_stack_var_size == 0
1483 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1484 && (gfc_option.coarray != GFC_FCOARRAY_LIB
1485 || !sym->attr.codimension || sym->attr.allocatable))
1486 {
1487 /* Add static initializer. For procedures, it is only needed if
1488 SAVE is specified otherwise they need to be reinitialized
1489 every time the procedure is entered. The TREE_STATIC is
1490 in this case due to -fmax-stack-var-size=. */
1491 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1492 TREE_TYPE (decl),
1493 sym->attr.dimension
1494 || (sym->attr.codimension
1495 && sym->attr.allocatable),
1496 sym->attr.pointer
1497 || sym->attr.allocatable,
1498 sym->attr.proc_pointer);
1499 }
1500
1501 if (!TREE_STATIC (decl)
1502 && POINTER_TYPE_P (TREE_TYPE (decl))
1503 && !sym->attr.pointer
1504 && !sym->attr.allocatable
1505 && !sym->attr.proc_pointer
1506 && !sym->attr.select_type_temporary)
1507 DECL_BY_REFERENCE (decl) = 1;
1508
1509 if (sym->attr.vtab
1510 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1511 TREE_READONLY (decl) = 1;
1512
1513 return decl;
1514 }
1515
1516
1517 /* Substitute a temporary variable in place of the real one. */
1518
1519 void
1520 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1521 {
1522 save->attr = sym->attr;
1523 save->decl = sym->backend_decl;
1524
1525 gfc_clear_attr (&sym->attr);
1526 sym->attr.referenced = 1;
1527 sym->attr.flavor = FL_VARIABLE;
1528
1529 sym->backend_decl = decl;
1530 }
1531
1532
1533 /* Restore the original variable. */
1534
1535 void
1536 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1537 {
1538 sym->attr = save->attr;
1539 sym->backend_decl = save->decl;
1540 }
1541
1542
1543 /* Declare a procedure pointer. */
1544
1545 static tree
1546 get_proc_pointer_decl (gfc_symbol *sym)
1547 {
1548 tree decl;
1549 tree attributes;
1550
1551 decl = sym->backend_decl;
1552 if (decl)
1553 return decl;
1554
1555 decl = build_decl (input_location,
1556 VAR_DECL, get_identifier (sym->name),
1557 build_pointer_type (gfc_get_function_type (sym)));
1558
1559 if (sym->module)
1560 {
1561 /* Apply name mangling. */
1562 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1563 if (sym->attr.use_assoc)
1564 DECL_IGNORED_P (decl) = 1;
1565 }
1566
1567 if ((sym->ns->proc_name
1568 && sym->ns->proc_name->backend_decl == current_function_decl)
1569 || sym->attr.contained)
1570 gfc_add_decl_to_function (decl);
1571 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1572 gfc_add_decl_to_parent_function (decl);
1573
1574 sym->backend_decl = decl;
1575
1576 /* If a variable is USE associated, it's always external. */
1577 if (sym->attr.use_assoc)
1578 {
1579 DECL_EXTERNAL (decl) = 1;
1580 TREE_PUBLIC (decl) = 1;
1581 }
1582 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1583 {
1584 /* This is the declaration of a module variable. */
1585 TREE_PUBLIC (decl) = 1;
1586 TREE_STATIC (decl) = 1;
1587 }
1588
1589 if (!sym->attr.use_assoc
1590 && (sym->attr.save != SAVE_NONE || sym->attr.data
1591 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1592 TREE_STATIC (decl) = 1;
1593
1594 if (TREE_STATIC (decl) && sym->value)
1595 {
1596 /* Add static initializer. */
1597 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1598 TREE_TYPE (decl),
1599 sym->attr.dimension,
1600 false, true);
1601 }
1602
1603 /* Handle threadprivate procedure pointers. */
1604 if (sym->attr.threadprivate
1605 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1606 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1607
1608 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1609 decl_attributes (&decl, attributes, 0);
1610
1611 return decl;
1612 }
1613
1614
1615 /* Get a basic decl for an external function. */
1616
1617 tree
1618 gfc_get_extern_function_decl (gfc_symbol * sym)
1619 {
1620 tree type;
1621 tree fndecl;
1622 tree attributes;
1623 gfc_expr e;
1624 gfc_intrinsic_sym *isym;
1625 gfc_expr argexpr;
1626 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1627 tree name;
1628 tree mangled_name;
1629 gfc_gsymbol *gsym;
1630
1631 if (sym->backend_decl)
1632 return sym->backend_decl;
1633
1634 /* We should never be creating external decls for alternate entry points.
1635 The procedure may be an alternate entry point, but we don't want/need
1636 to know that. */
1637 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1638
1639 if (sym->attr.proc_pointer)
1640 return get_proc_pointer_decl (sym);
1641
1642 /* See if this is an external procedure from the same file. If so,
1643 return the backend_decl. */
1644 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1645
1646 if (gfc_option.flag_whole_file
1647 && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1648 && !sym->backend_decl
1649 && gsym && gsym->ns
1650 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1651 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1652 {
1653 if (!gsym->ns->proc_name->backend_decl)
1654 {
1655 /* By construction, the external function cannot be
1656 a contained procedure. */
1657 locus old_loc;
1658
1659 gfc_save_backend_locus (&old_loc);
1660 push_cfun (NULL);
1661
1662 gfc_create_function_decl (gsym->ns, true);
1663
1664 pop_cfun ();
1665 gfc_restore_backend_locus (&old_loc);
1666 }
1667
1668 /* If the namespace has entries, the proc_name is the
1669 entry master. Find the entry and use its backend_decl.
1670 otherwise, use the proc_name backend_decl. */
1671 if (gsym->ns->entries)
1672 {
1673 gfc_entry_list *entry = gsym->ns->entries;
1674
1675 for (; entry; entry = entry->next)
1676 {
1677 if (strcmp (gsym->name, entry->sym->name) == 0)
1678 {
1679 sym->backend_decl = entry->sym->backend_decl;
1680 break;
1681 }
1682 }
1683 }
1684 else
1685 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1686
1687 if (sym->backend_decl)
1688 {
1689 /* Avoid problems of double deallocation of the backend declaration
1690 later in gfc_trans_use_stmts; cf. PR 45087. */
1691 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1692 sym->attr.use_assoc = 0;
1693
1694 return sym->backend_decl;
1695 }
1696 }
1697
1698 /* See if this is a module procedure from the same file. If so,
1699 return the backend_decl. */
1700 if (sym->module)
1701 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1702
1703 if (gfc_option.flag_whole_file
1704 && gsym && gsym->ns
1705 && gsym->type == GSYM_MODULE)
1706 {
1707 gfc_symbol *s;
1708
1709 s = NULL;
1710 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1711 if (s && s->backend_decl)
1712 {
1713 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1714 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1715 true);
1716 else if (sym->ts.type == BT_CHARACTER)
1717 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1718 sym->backend_decl = s->backend_decl;
1719 return sym->backend_decl;
1720 }
1721 }
1722
1723 if (sym->attr.intrinsic)
1724 {
1725 /* Call the resolution function to get the actual name. This is
1726 a nasty hack which relies on the resolution functions only looking
1727 at the first argument. We pass NULL for the second argument
1728 otherwise things like AINT get confused. */
1729 isym = gfc_find_function (sym->name);
1730 gcc_assert (isym->resolve.f0 != NULL);
1731
1732 memset (&e, 0, sizeof (e));
1733 e.expr_type = EXPR_FUNCTION;
1734
1735 memset (&argexpr, 0, sizeof (argexpr));
1736 gcc_assert (isym->formal);
1737 argexpr.ts = isym->formal->ts;
1738
1739 if (isym->formal->next == NULL)
1740 isym->resolve.f1 (&e, &argexpr);
1741 else
1742 {
1743 if (isym->formal->next->next == NULL)
1744 isym->resolve.f2 (&e, &argexpr, NULL);
1745 else
1746 {
1747 if (isym->formal->next->next->next == NULL)
1748 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1749 else
1750 {
1751 /* All specific intrinsics take less than 5 arguments. */
1752 gcc_assert (isym->formal->next->next->next->next == NULL);
1753 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1754 }
1755 }
1756 }
1757
1758 if (gfc_option.flag_f2c
1759 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1760 || e.ts.type == BT_COMPLEX))
1761 {
1762 /* Specific which needs a different implementation if f2c
1763 calling conventions are used. */
1764 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1765 }
1766 else
1767 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1768
1769 name = get_identifier (s);
1770 mangled_name = name;
1771 }
1772 else
1773 {
1774 name = gfc_sym_identifier (sym);
1775 mangled_name = gfc_sym_mangled_function_id (sym);
1776 }
1777
1778 type = gfc_get_function_type (sym);
1779 fndecl = build_decl (input_location,
1780 FUNCTION_DECL, name, type);
1781
1782 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1783 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1784 the opposite of declaring a function as static in C). */
1785 DECL_EXTERNAL (fndecl) = 1;
1786 TREE_PUBLIC (fndecl) = 1;
1787
1788 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1789 decl_attributes (&fndecl, attributes, 0);
1790
1791 gfc_set_decl_assembler_name (fndecl, mangled_name);
1792
1793 /* Set the context of this decl. */
1794 if (0 && sym->ns && sym->ns->proc_name)
1795 {
1796 /* TODO: Add external decls to the appropriate scope. */
1797 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1798 }
1799 else
1800 {
1801 /* Global declaration, e.g. intrinsic subroutine. */
1802 DECL_CONTEXT (fndecl) = NULL_TREE;
1803 }
1804
1805 /* Set attributes for PURE functions. A call to PURE function in the
1806 Fortran 95 sense is both pure and without side effects in the C
1807 sense. */
1808 if (sym->attr.pure || sym->attr.implicit_pure)
1809 {
1810 if (sym->attr.function && !gfc_return_by_reference (sym))
1811 DECL_PURE_P (fndecl) = 1;
1812 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1813 parameters and don't use alternate returns (is this
1814 allowed?). In that case, calls to them are meaningless, and
1815 can be optimized away. See also in build_function_decl(). */
1816 TREE_SIDE_EFFECTS (fndecl) = 0;
1817 }
1818
1819 /* Mark non-returning functions. */
1820 if (sym->attr.noreturn)
1821 TREE_THIS_VOLATILE(fndecl) = 1;
1822
1823 sym->backend_decl = fndecl;
1824
1825 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1826 pushdecl_top_level (fndecl);
1827
1828 return fndecl;
1829 }
1830
1831
1832 /* Create a declaration for a procedure. For external functions (in the C
1833 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1834 a master function with alternate entry points. */
1835
1836 static void
1837 build_function_decl (gfc_symbol * sym, bool global)
1838 {
1839 tree fndecl, type, attributes;
1840 symbol_attribute attr;
1841 tree result_decl;
1842 gfc_formal_arglist *f;
1843
1844 gcc_assert (!sym->attr.external);
1845
1846 if (sym->backend_decl)
1847 return;
1848
1849 /* Set the line and filename. sym->declared_at seems to point to the
1850 last statement for subroutines, but it'll do for now. */
1851 gfc_set_backend_locus (&sym->declared_at);
1852
1853 /* Allow only one nesting level. Allow public declarations. */
1854 gcc_assert (current_function_decl == NULL_TREE
1855 || DECL_FILE_SCOPE_P (current_function_decl)
1856 || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1857 == NAMESPACE_DECL));
1858
1859 type = gfc_get_function_type (sym);
1860 fndecl = build_decl (input_location,
1861 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1862
1863 attr = sym->attr;
1864
1865 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1866 TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1867 the opposite of declaring a function as static in C). */
1868 DECL_EXTERNAL (fndecl) = 0;
1869
1870 if (sym->attr.access == ACCESS_UNKNOWN && sym->module
1871 && (sym->ns->default_access == ACCESS_PRIVATE
1872 || (sym->ns->default_access == ACCESS_UNKNOWN
1873 && gfc_option.flag_module_private)))
1874 sym->attr.access = ACCESS_PRIVATE;
1875
1876 if (!current_function_decl
1877 && !sym->attr.entry_master && !sym->attr.is_main_program
1878 && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label
1879 || sym->attr.public_used))
1880 TREE_PUBLIC (fndecl) = 1;
1881
1882 if (sym->attr.referenced || sym->attr.entry_master)
1883 TREE_USED (fndecl) = 1;
1884
1885 attributes = add_attributes_to_decl (attr, NULL_TREE);
1886 decl_attributes (&fndecl, attributes, 0);
1887
1888 /* Figure out the return type of the declared function, and build a
1889 RESULT_DECL for it. If this is a subroutine with alternate
1890 returns, build a RESULT_DECL for it. */
1891 result_decl = NULL_TREE;
1892 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1893 if (attr.function)
1894 {
1895 if (gfc_return_by_reference (sym))
1896 type = void_type_node;
1897 else
1898 {
1899 if (sym->result != sym)
1900 result_decl = gfc_sym_identifier (sym->result);
1901
1902 type = TREE_TYPE (TREE_TYPE (fndecl));
1903 }
1904 }
1905 else
1906 {
1907 /* Look for alternate return placeholders. */
1908 int has_alternate_returns = 0;
1909 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
1910 {
1911 if (f->sym == NULL)
1912 {
1913 has_alternate_returns = 1;
1914 break;
1915 }
1916 }
1917
1918 if (has_alternate_returns)
1919 type = integer_type_node;
1920 else
1921 type = void_type_node;
1922 }
1923
1924 result_decl = build_decl (input_location,
1925 RESULT_DECL, result_decl, type);
1926 DECL_ARTIFICIAL (result_decl) = 1;
1927 DECL_IGNORED_P (result_decl) = 1;
1928 DECL_CONTEXT (result_decl) = fndecl;
1929 DECL_RESULT (fndecl) = result_decl;
1930
1931 /* Don't call layout_decl for a RESULT_DECL.
1932 layout_decl (result_decl, 0); */
1933
1934 /* TREE_STATIC means the function body is defined here. */
1935 TREE_STATIC (fndecl) = 1;
1936
1937 /* Set attributes for PURE functions. A call to a PURE function in the
1938 Fortran 95 sense is both pure and without side effects in the C
1939 sense. */
1940 if (attr.pure || attr.implicit_pure)
1941 {
1942 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1943 including an alternate return. In that case it can also be
1944 marked as PURE. See also in gfc_get_extern_function_decl(). */
1945 if (attr.function && !gfc_return_by_reference (sym))
1946 DECL_PURE_P (fndecl) = 1;
1947 TREE_SIDE_EFFECTS (fndecl) = 0;
1948 }
1949
1950
1951 /* Layout the function declaration and put it in the binding level
1952 of the current function. */
1953
1954 if (global)
1955 pushdecl_top_level (fndecl);
1956 else
1957 pushdecl (fndecl);
1958
1959 /* Perform name mangling if this is a top level or module procedure. */
1960 if (current_function_decl == NULL_TREE)
1961 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1962
1963 sym->backend_decl = fndecl;
1964 }
1965
1966
1967 /* Create the DECL_ARGUMENTS for a procedure. */
1968
1969 static void
1970 create_function_arglist (gfc_symbol * sym)
1971 {
1972 tree fndecl;
1973 gfc_formal_arglist *f;
1974 tree typelist, hidden_typelist;
1975 tree arglist, hidden_arglist;
1976 tree type;
1977 tree parm;
1978
1979 fndecl = sym->backend_decl;
1980
1981 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1982 the new FUNCTION_DECL node. */
1983 arglist = NULL_TREE;
1984 hidden_arglist = NULL_TREE;
1985 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1986
1987 if (sym->attr.entry_master)
1988 {
1989 type = TREE_VALUE (typelist);
1990 parm = build_decl (input_location,
1991 PARM_DECL, get_identifier ("__entry"), type);
1992
1993 DECL_CONTEXT (parm) = fndecl;
1994 DECL_ARG_TYPE (parm) = type;
1995 TREE_READONLY (parm) = 1;
1996 gfc_finish_decl (parm);
1997 DECL_ARTIFICIAL (parm) = 1;
1998
1999 arglist = chainon (arglist, parm);
2000 typelist = TREE_CHAIN (typelist);
2001 }
2002
2003 if (gfc_return_by_reference (sym))
2004 {
2005 tree type = TREE_VALUE (typelist), length = NULL;
2006
2007 if (sym->ts.type == BT_CHARACTER)
2008 {
2009 /* Length of character result. */
2010 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
2011
2012 length = build_decl (input_location,
2013 PARM_DECL,
2014 get_identifier (".__result"),
2015 len_type);
2016 if (!sym->ts.u.cl->length)
2017 {
2018 sym->ts.u.cl->backend_decl = length;
2019 TREE_USED (length) = 1;
2020 }
2021 gcc_assert (TREE_CODE (length) == PARM_DECL);
2022 DECL_CONTEXT (length) = fndecl;
2023 DECL_ARG_TYPE (length) = len_type;
2024 TREE_READONLY (length) = 1;
2025 DECL_ARTIFICIAL (length) = 1;
2026 gfc_finish_decl (length);
2027 if (sym->ts.u.cl->backend_decl == NULL
2028 || sym->ts.u.cl->backend_decl == length)
2029 {
2030 gfc_symbol *arg;
2031 tree backend_decl;
2032
2033 if (sym->ts.u.cl->backend_decl == NULL)
2034 {
2035 tree len = build_decl (input_location,
2036 VAR_DECL,
2037 get_identifier ("..__result"),
2038 gfc_charlen_type_node);
2039 DECL_ARTIFICIAL (len) = 1;
2040 TREE_USED (len) = 1;
2041 sym->ts.u.cl->backend_decl = len;
2042 }
2043
2044 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2045 arg = sym->result ? sym->result : sym;
2046 backend_decl = arg->backend_decl;
2047 /* Temporary clear it, so that gfc_sym_type creates complete
2048 type. */
2049 arg->backend_decl = NULL;
2050 type = gfc_sym_type (arg);
2051 arg->backend_decl = backend_decl;
2052 type = build_reference_type (type);
2053 }
2054 }
2055
2056 parm = build_decl (input_location,
2057 PARM_DECL, get_identifier ("__result"), type);
2058
2059 DECL_CONTEXT (parm) = fndecl;
2060 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2061 TREE_READONLY (parm) = 1;
2062 DECL_ARTIFICIAL (parm) = 1;
2063 gfc_finish_decl (parm);
2064
2065 arglist = chainon (arglist, parm);
2066 typelist = TREE_CHAIN (typelist);
2067
2068 if (sym->ts.type == BT_CHARACTER)
2069 {
2070 gfc_allocate_lang_decl (parm);
2071 arglist = chainon (arglist, length);
2072 typelist = TREE_CHAIN (typelist);
2073 }
2074 }
2075
2076 hidden_typelist = typelist;
2077 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2078 if (f->sym != NULL) /* Ignore alternate returns. */
2079 hidden_typelist = TREE_CHAIN (hidden_typelist);
2080
2081 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
2082 {
2083 char name[GFC_MAX_SYMBOL_LEN + 2];
2084
2085 /* Ignore alternate returns. */
2086 if (f->sym == NULL)
2087 continue;
2088
2089 type = TREE_VALUE (typelist);
2090
2091 if (f->sym->ts.type == BT_CHARACTER
2092 && (!sym->attr.is_bind_c || sym->attr.entry_master))
2093 {
2094 tree len_type = TREE_VALUE (hidden_typelist);
2095 tree length = NULL_TREE;
2096 if (!f->sym->ts.deferred)
2097 gcc_assert (len_type == gfc_charlen_type_node);
2098 else
2099 gcc_assert (POINTER_TYPE_P (len_type));
2100
2101 strcpy (&name[1], f->sym->name);
2102 name[0] = '_';
2103 length = build_decl (input_location,
2104 PARM_DECL, get_identifier (name), len_type);
2105
2106 hidden_arglist = chainon (hidden_arglist, length);
2107 DECL_CONTEXT (length) = fndecl;
2108 DECL_ARTIFICIAL (length) = 1;
2109 DECL_ARG_TYPE (length) = len_type;
2110 TREE_READONLY (length) = 1;
2111 gfc_finish_decl (length);
2112
2113 /* Remember the passed value. */
2114 if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length)
2115 {
2116 /* This can happen if the same type is used for multiple
2117 arguments. We need to copy cl as otherwise
2118 cl->passed_length gets overwritten. */
2119 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2120 }
2121 f->sym->ts.u.cl->passed_length = length;
2122
2123 /* Use the passed value for assumed length variables. */
2124 if (!f->sym->ts.u.cl->length)
2125 {
2126 TREE_USED (length) = 1;
2127 gcc_assert (!f->sym->ts.u.cl->backend_decl);
2128 f->sym->ts.u.cl->backend_decl = length;
2129 }
2130
2131 hidden_typelist = TREE_CHAIN (hidden_typelist);
2132
2133 if (f->sym->ts.u.cl->backend_decl == NULL
2134 || f->sym->ts.u.cl->backend_decl == length)
2135 {
2136 if (f->sym->ts.u.cl->backend_decl == NULL)
2137 gfc_create_string_length (f->sym);
2138
2139 /* Make sure PARM_DECL type doesn't point to incomplete type. */
2140 if (f->sym->attr.flavor == FL_PROCEDURE)
2141 type = build_pointer_type (gfc_get_function_type (f->sym));
2142 else
2143 type = gfc_sym_type (f->sym);
2144 }
2145 }
2146
2147 /* For non-constant length array arguments, make sure they use
2148 a different type node from TYPE_ARG_TYPES type. */
2149 if (f->sym->attr.dimension
2150 && type == TREE_VALUE (typelist)
2151 && TREE_CODE (type) == POINTER_TYPE
2152 && GFC_ARRAY_TYPE_P (type)
2153 && f->sym->as->type != AS_ASSUMED_SIZE
2154 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2155 {
2156 if (f->sym->attr.flavor == FL_PROCEDURE)
2157 type = build_pointer_type (gfc_get_function_type (f->sym));
2158 else
2159 type = gfc_sym_type (f->sym);
2160 }
2161
2162 if (f->sym->attr.proc_pointer)
2163 type = build_pointer_type (type);
2164
2165 if (f->sym->attr.volatile_)
2166 type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2167
2168 /* Build the argument declaration. */
2169 parm = build_decl (input_location,
2170 PARM_DECL, gfc_sym_identifier (f->sym), type);
2171
2172 if (f->sym->attr.volatile_)
2173 {
2174 TREE_THIS_VOLATILE (parm) = 1;
2175 TREE_SIDE_EFFECTS (parm) = 1;
2176 }
2177
2178 /* Fill in arg stuff. */
2179 DECL_CONTEXT (parm) = fndecl;
2180 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2181 /* All implementation args are read-only. */
2182 TREE_READONLY (parm) = 1;
2183 if (POINTER_TYPE_P (type)
2184 && (!f->sym->attr.proc_pointer
2185 && f->sym->attr.flavor != FL_PROCEDURE))
2186 DECL_BY_REFERENCE (parm) = 1;
2187
2188 gfc_finish_decl (parm);
2189
2190 f->sym->backend_decl = parm;
2191
2192 /* Coarrays which are descriptorless or assumed-shape pass with
2193 -fcoarray=lib the token and the offset as hidden arguments. */
2194 if (f->sym->attr.codimension
2195 && gfc_option.coarray == GFC_FCOARRAY_LIB
2196 && !f->sym->attr.allocatable)
2197 {
2198 tree caf_type;
2199 tree token;
2200 tree offset;
2201
2202 gcc_assert (f->sym->backend_decl != NULL_TREE
2203 && !sym->attr.is_bind_c);
2204 caf_type = TREE_TYPE (f->sym->backend_decl);
2205
2206 token = build_decl (input_location, PARM_DECL,
2207 create_tmp_var_name ("caf_token"),
2208 build_qualified_type (pvoid_type_node,
2209 TYPE_QUAL_RESTRICT));
2210 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2211 {
2212 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2213 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2214 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2215 gfc_allocate_lang_decl (f->sym->backend_decl);
2216 GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2217 }
2218 else
2219 {
2220 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2221 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2222 }
2223
2224 DECL_CONTEXT (token) = fndecl;
2225 DECL_ARTIFICIAL (token) = 1;
2226 DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2227 TREE_READONLY (token) = 1;
2228 hidden_arglist = chainon (hidden_arglist, token);
2229 gfc_finish_decl (token);
2230
2231 offset = build_decl (input_location, PARM_DECL,
2232 create_tmp_var_name ("caf_offset"),
2233 gfc_array_index_type);
2234
2235 if (f->sym->as->type == AS_ASSUMED_SHAPE)
2236 {
2237 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2238 == NULL_TREE);
2239 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2240 }
2241 else
2242 {
2243 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2244 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2245 }
2246 DECL_CONTEXT (offset) = fndecl;
2247 DECL_ARTIFICIAL (offset) = 1;
2248 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2249 TREE_READONLY (offset) = 1;
2250 hidden_arglist = chainon (hidden_arglist, offset);
2251 gfc_finish_decl (offset);
2252 }
2253
2254 arglist = chainon (arglist, parm);
2255 typelist = TREE_CHAIN (typelist);
2256 }
2257
2258 /* Add the hidden string length parameters, unless the procedure
2259 is bind(C). */
2260 if (!sym->attr.is_bind_c)
2261 arglist = chainon (arglist, hidden_arglist);
2262
2263 gcc_assert (hidden_typelist == NULL_TREE
2264 || TREE_VALUE (hidden_typelist) == void_type_node);
2265 DECL_ARGUMENTS (fndecl) = arglist;
2266 }
2267
2268 /* Do the setup necessary before generating the body of a function. */
2269
2270 static void
2271 trans_function_start (gfc_symbol * sym)
2272 {
2273 tree fndecl;
2274
2275 fndecl = sym->backend_decl;
2276
2277 /* Let GCC know the current scope is this function. */
2278 current_function_decl = fndecl;
2279
2280 /* Let the world know what we're about to do. */
2281 announce_function (fndecl);
2282
2283 if (DECL_FILE_SCOPE_P (fndecl))
2284 {
2285 /* Create RTL for function declaration. */
2286 rest_of_decl_compilation (fndecl, 1, 0);
2287 }
2288
2289 /* Create RTL for function definition. */
2290 make_decl_rtl (fndecl);
2291
2292 allocate_struct_function (fndecl, false);
2293
2294 /* function.c requires a push at the start of the function. */
2295 pushlevel ();
2296 }
2297
2298 /* Create thunks for alternate entry points. */
2299
2300 static void
2301 build_entry_thunks (gfc_namespace * ns, bool global)
2302 {
2303 gfc_formal_arglist *formal;
2304 gfc_formal_arglist *thunk_formal;
2305 gfc_entry_list *el;
2306 gfc_symbol *thunk_sym;
2307 stmtblock_t body;
2308 tree thunk_fndecl;
2309 tree tmp;
2310 locus old_loc;
2311
2312 /* This should always be a toplevel function. */
2313 gcc_assert (current_function_decl == NULL_TREE);
2314
2315 gfc_save_backend_locus (&old_loc);
2316 for (el = ns->entries; el; el = el->next)
2317 {
2318 vec<tree, va_gc> *args = NULL;
2319 vec<tree, va_gc> *string_args = NULL;
2320
2321 thunk_sym = el->sym;
2322
2323 build_function_decl (thunk_sym, global);
2324 create_function_arglist (thunk_sym);
2325
2326 trans_function_start (thunk_sym);
2327
2328 thunk_fndecl = thunk_sym->backend_decl;
2329
2330 gfc_init_block (&body);
2331
2332 /* Pass extra parameter identifying this entry point. */
2333 tmp = build_int_cst (gfc_array_index_type, el->id);
2334 vec_safe_push (args, tmp);
2335
2336 if (thunk_sym->attr.function)
2337 {
2338 if (gfc_return_by_reference (ns->proc_name))
2339 {
2340 tree ref = DECL_ARGUMENTS (current_function_decl);
2341 vec_safe_push (args, ref);
2342 if (ns->proc_name->ts.type == BT_CHARACTER)
2343 vec_safe_push (args, DECL_CHAIN (ref));
2344 }
2345 }
2346
2347 for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
2348 formal = formal->next)
2349 {
2350 /* Ignore alternate returns. */
2351 if (formal->sym == NULL)
2352 continue;
2353
2354 /* We don't have a clever way of identifying arguments, so resort to
2355 a brute-force search. */
2356 for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
2357 thunk_formal;
2358 thunk_formal = thunk_formal->next)
2359 {
2360 if (thunk_formal->sym == formal->sym)
2361 break;
2362 }
2363
2364 if (thunk_formal)
2365 {
2366 /* Pass the argument. */
2367 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2368 vec_safe_push (args, thunk_formal->sym->backend_decl);
2369 if (formal->sym->ts.type == BT_CHARACTER)
2370 {
2371 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2372 vec_safe_push (string_args, tmp);
2373 }
2374 }
2375 else
2376 {
2377 /* Pass NULL for a missing argument. */
2378 vec_safe_push (args, null_pointer_node);
2379 if (formal->sym->ts.type == BT_CHARACTER)
2380 {
2381 tmp = build_int_cst (gfc_charlen_type_node, 0);
2382 vec_safe_push (string_args, tmp);
2383 }
2384 }
2385 }
2386
2387 /* Call the master function. */
2388 vec_safe_splice (args, string_args);
2389 tmp = ns->proc_name->backend_decl;
2390 tmp = build_call_expr_loc_vec (input_location, tmp, args);
2391 if (ns->proc_name->attr.mixed_entry_master)
2392 {
2393 tree union_decl, field;
2394 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2395
2396 union_decl = build_decl (input_location,
2397 VAR_DECL, get_identifier ("__result"),
2398 TREE_TYPE (master_type));
2399 DECL_ARTIFICIAL (union_decl) = 1;
2400 DECL_EXTERNAL (union_decl) = 0;
2401 TREE_PUBLIC (union_decl) = 0;
2402 TREE_USED (union_decl) = 1;
2403 layout_decl (union_decl, 0);
2404 pushdecl (union_decl);
2405
2406 DECL_CONTEXT (union_decl) = current_function_decl;
2407 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2408 TREE_TYPE (union_decl), union_decl, tmp);
2409 gfc_add_expr_to_block (&body, tmp);
2410
2411 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2412 field; field = DECL_CHAIN (field))
2413 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2414 thunk_sym->result->name) == 0)
2415 break;
2416 gcc_assert (field != NULL_TREE);
2417 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2418 TREE_TYPE (field), union_decl, field,
2419 NULL_TREE);
2420 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2421 TREE_TYPE (DECL_RESULT (current_function_decl)),
2422 DECL_RESULT (current_function_decl), tmp);
2423 tmp = build1_v (RETURN_EXPR, tmp);
2424 }
2425 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2426 != void_type_node)
2427 {
2428 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2429 TREE_TYPE (DECL_RESULT (current_function_decl)),
2430 DECL_RESULT (current_function_decl), tmp);
2431 tmp = build1_v (RETURN_EXPR, tmp);
2432 }
2433 gfc_add_expr_to_block (&body, tmp);
2434
2435 /* Finish off this function and send it for code generation. */
2436 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2437 tmp = getdecls ();
2438 poplevel (1, 1);
2439 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2440 DECL_SAVED_TREE (thunk_fndecl)
2441 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2442 DECL_INITIAL (thunk_fndecl));
2443
2444 /* Output the GENERIC tree. */
2445 dump_function (TDI_original, thunk_fndecl);
2446
2447 /* Store the end of the function, so that we get good line number
2448 info for the epilogue. */
2449 cfun->function_end_locus = input_location;
2450
2451 /* We're leaving the context of this function, so zap cfun.
2452 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2453 tree_rest_of_compilation. */
2454 set_cfun (NULL);
2455
2456 current_function_decl = NULL_TREE;
2457
2458 cgraph_finalize_function (thunk_fndecl, true);
2459
2460 /* We share the symbols in the formal argument list with other entry
2461 points and the master function. Clear them so that they are
2462 recreated for each function. */
2463 for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
2464 formal = formal->next)
2465 if (formal->sym != NULL) /* Ignore alternate returns. */
2466 {
2467 formal->sym->backend_decl = NULL_TREE;
2468 if (formal->sym->ts.type == BT_CHARACTER)
2469 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2470 }
2471
2472 if (thunk_sym->attr.function)
2473 {
2474 if (thunk_sym->ts.type == BT_CHARACTER)
2475 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2476 if (thunk_sym->result->ts.type == BT_CHARACTER)
2477 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2478 }
2479 }
2480
2481 gfc_restore_backend_locus (&old_loc);
2482 }
2483
2484
2485 /* Create a decl for a function, and create any thunks for alternate entry
2486 points. If global is true, generate the function in the global binding
2487 level, otherwise in the current binding level (which can be global). */
2488
2489 void
2490 gfc_create_function_decl (gfc_namespace * ns, bool global)
2491 {
2492 /* Create a declaration for the master function. */
2493 build_function_decl (ns->proc_name, global);
2494
2495 /* Compile the entry thunks. */
2496 if (ns->entries)
2497 build_entry_thunks (ns, global);
2498
2499 /* Now create the read argument list. */
2500 create_function_arglist (ns->proc_name);
2501 }
2502
2503 /* Return the decl used to hold the function return value. If
2504 parent_flag is set, the context is the parent_scope. */
2505
2506 tree
2507 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2508 {
2509 tree decl;
2510 tree length;
2511 tree this_fake_result_decl;
2512 tree this_function_decl;
2513
2514 char name[GFC_MAX_SYMBOL_LEN + 10];
2515
2516 if (parent_flag)
2517 {
2518 this_fake_result_decl = parent_fake_result_decl;
2519 this_function_decl = DECL_CONTEXT (current_function_decl);
2520 }
2521 else
2522 {
2523 this_fake_result_decl = current_fake_result_decl;
2524 this_function_decl = current_function_decl;
2525 }
2526
2527 if (sym
2528 && sym->ns->proc_name->backend_decl == this_function_decl
2529 && sym->ns->proc_name->attr.entry_master
2530 && sym != sym->ns->proc_name)
2531 {
2532 tree t = NULL, var;
2533 if (this_fake_result_decl != NULL)
2534 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2535 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2536 break;
2537 if (t)
2538 return TREE_VALUE (t);
2539 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2540
2541 if (parent_flag)
2542 this_fake_result_decl = parent_fake_result_decl;
2543 else
2544 this_fake_result_decl = current_fake_result_decl;
2545
2546 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2547 {
2548 tree field;
2549
2550 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2551 field; field = DECL_CHAIN (field))
2552 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2553 sym->name) == 0)
2554 break;
2555
2556 gcc_assert (field != NULL_TREE);
2557 decl = fold_build3_loc (input_location, COMPONENT_REF,
2558 TREE_TYPE (field), decl, field, NULL_TREE);
2559 }
2560
2561 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2562 if (parent_flag)
2563 gfc_add_decl_to_parent_function (var);
2564 else
2565 gfc_add_decl_to_function (var);
2566
2567 SET_DECL_VALUE_EXPR (var, decl);
2568 DECL_HAS_VALUE_EXPR_P (var) = 1;
2569 GFC_DECL_RESULT (var) = 1;
2570
2571 TREE_CHAIN (this_fake_result_decl)
2572 = tree_cons (get_identifier (sym->name), var,
2573 TREE_CHAIN (this_fake_result_decl));
2574 return var;
2575 }
2576
2577 if (this_fake_result_decl != NULL_TREE)
2578 return TREE_VALUE (this_fake_result_decl);
2579
2580 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2581 sym is NULL. */
2582 if (!sym)
2583 return NULL_TREE;
2584
2585 if (sym->ts.type == BT_CHARACTER)
2586 {
2587 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2588 length = gfc_create_string_length (sym);
2589 else
2590 length = sym->ts.u.cl->backend_decl;
2591 if (TREE_CODE (length) == VAR_DECL
2592 && DECL_CONTEXT (length) == NULL_TREE)
2593 gfc_add_decl_to_function (length);
2594 }
2595
2596 if (gfc_return_by_reference (sym))
2597 {
2598 decl = DECL_ARGUMENTS (this_function_decl);
2599
2600 if (sym->ns->proc_name->backend_decl == this_function_decl
2601 && sym->ns->proc_name->attr.entry_master)
2602 decl = DECL_CHAIN (decl);
2603
2604 TREE_USED (decl) = 1;
2605 if (sym->as)
2606 decl = gfc_build_dummy_array_decl (sym, decl);
2607 }
2608 else
2609 {
2610 sprintf (name, "__result_%.20s",
2611 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2612
2613 if (!sym->attr.mixed_entry_master && sym->attr.function)
2614 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2615 VAR_DECL, get_identifier (name),
2616 gfc_sym_type (sym));
2617 else
2618 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2619 VAR_DECL, get_identifier (name),
2620 TREE_TYPE (TREE_TYPE (this_function_decl)));
2621 DECL_ARTIFICIAL (decl) = 1;
2622 DECL_EXTERNAL (decl) = 0;
2623 TREE_PUBLIC (decl) = 0;
2624 TREE_USED (decl) = 1;
2625 GFC_DECL_RESULT (decl) = 1;
2626 TREE_ADDRESSABLE (decl) = 1;
2627
2628 layout_decl (decl, 0);
2629
2630 if (parent_flag)
2631 gfc_add_decl_to_parent_function (decl);
2632 else
2633 gfc_add_decl_to_function (decl);
2634 }
2635
2636 if (parent_flag)
2637 parent_fake_result_decl = build_tree_list (NULL, decl);
2638 else
2639 current_fake_result_decl = build_tree_list (NULL, decl);
2640
2641 return decl;
2642 }
2643
2644
2645 /* Builds a function decl. The remaining parameters are the types of the
2646 function arguments. Negative nargs indicates a varargs function. */
2647
2648 static tree
2649 build_library_function_decl_1 (tree name, const char *spec,
2650 tree rettype, int nargs, va_list p)
2651 {
2652 vec<tree, va_gc> *arglist;
2653 tree fntype;
2654 tree fndecl;
2655 int n;
2656
2657 /* Library functions must be declared with global scope. */
2658 gcc_assert (current_function_decl == NULL_TREE);
2659
2660 /* Create a list of the argument types. */
2661 vec_alloc (arglist, abs (nargs));
2662 for (n = abs (nargs); n > 0; n--)
2663 {
2664 tree argtype = va_arg (p, tree);
2665 arglist->quick_push (argtype);
2666 }
2667
2668 /* Build the function type and decl. */
2669 if (nargs >= 0)
2670 fntype = build_function_type_vec (rettype, arglist);
2671 else
2672 fntype = build_varargs_function_type_vec (rettype, arglist);
2673 if (spec)
2674 {
2675 tree attr_args = build_tree_list (NULL_TREE,
2676 build_string (strlen (spec), spec));
2677 tree attrs = tree_cons (get_identifier ("fn spec"),
2678 attr_args, TYPE_ATTRIBUTES (fntype));
2679 fntype = build_type_attribute_variant (fntype, attrs);
2680 }
2681 fndecl = build_decl (input_location,
2682 FUNCTION_DECL, name, fntype);
2683
2684 /* Mark this decl as external. */
2685 DECL_EXTERNAL (fndecl) = 1;
2686 TREE_PUBLIC (fndecl) = 1;
2687
2688 pushdecl (fndecl);
2689
2690 rest_of_decl_compilation (fndecl, 1, 0);
2691
2692 return fndecl;
2693 }
2694
2695 /* Builds a function decl. The remaining parameters are the types of the
2696 function arguments. Negative nargs indicates a varargs function. */
2697
2698 tree
2699 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2700 {
2701 tree ret;
2702 va_list args;
2703 va_start (args, nargs);
2704 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2705 va_end (args);
2706 return ret;
2707 }
2708
2709 /* Builds a function decl. The remaining parameters are the types of the
2710 function arguments. Negative nargs indicates a varargs function.
2711 The SPEC parameter specifies the function argument and return type
2712 specification according to the fnspec function type attribute. */
2713
2714 tree
2715 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2716 tree rettype, int nargs, ...)
2717 {
2718 tree ret;
2719 va_list args;
2720 va_start (args, nargs);
2721 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2722 va_end (args);
2723 return ret;
2724 }
2725
2726 static void
2727 gfc_build_intrinsic_function_decls (void)
2728 {
2729 tree gfc_int4_type_node = gfc_get_int_type (4);
2730 tree gfc_int8_type_node = gfc_get_int_type (8);
2731 tree gfc_int16_type_node = gfc_get_int_type (16);
2732 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2733 tree pchar1_type_node = gfc_get_pchar_type (1);
2734 tree pchar4_type_node = gfc_get_pchar_type (4);
2735
2736 /* String functions. */
2737 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2738 get_identifier (PREFIX("compare_string")), "..R.R",
2739 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2740 gfc_charlen_type_node, pchar1_type_node);
2741 DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2742 TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2743
2744 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2745 get_identifier (PREFIX("concat_string")), "..W.R.R",
2746 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2747 gfc_charlen_type_node, pchar1_type_node,
2748 gfc_charlen_type_node, pchar1_type_node);
2749 TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2750
2751 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2752 get_identifier (PREFIX("string_len_trim")), "..R",
2753 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2754 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2755 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2756
2757 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2758 get_identifier (PREFIX("string_index")), "..R.R.",
2759 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2760 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2761 DECL_PURE_P (gfor_fndecl_string_index) = 1;
2762 TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2763
2764 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2765 get_identifier (PREFIX("string_scan")), "..R.R.",
2766 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2767 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2768 DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2769 TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2770
2771 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2772 get_identifier (PREFIX("string_verify")), "..R.R.",
2773 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2774 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2775 DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2776 TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2777
2778 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2779 get_identifier (PREFIX("string_trim")), ".Ww.R",
2780 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2781 build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2782 pchar1_type_node);
2783
2784 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2785 get_identifier (PREFIX("string_minmax")), ".Ww.R",
2786 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2787 build_pointer_type (pchar1_type_node), integer_type_node,
2788 integer_type_node);
2789
2790 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2791 get_identifier (PREFIX("adjustl")), ".W.R",
2792 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2793 pchar1_type_node);
2794 TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2795
2796 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2797 get_identifier (PREFIX("adjustr")), ".W.R",
2798 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2799 pchar1_type_node);
2800 TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2801
2802 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
2803 get_identifier (PREFIX("select_string")), ".R.R.",
2804 integer_type_node, 4, pvoid_type_node, integer_type_node,
2805 pchar1_type_node, gfc_charlen_type_node);
2806 DECL_PURE_P (gfor_fndecl_select_string) = 1;
2807 TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2808
2809 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2810 get_identifier (PREFIX("compare_string_char4")), "..R.R",
2811 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2812 gfc_charlen_type_node, pchar4_type_node);
2813 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2814 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2815
2816 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2817 get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2818 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2819 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2820 pchar4_type_node);
2821 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2822
2823 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2824 get_identifier (PREFIX("string_len_trim_char4")), "..R",
2825 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2826 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2827 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2828
2829 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2830 get_identifier (PREFIX("string_index_char4")), "..R.R.",
2831 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2832 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2833 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2834 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2835
2836 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2837 get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2838 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2839 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2840 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2841 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2842
2843 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2844 get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2845 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2846 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2847 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2848 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2849
2850 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2851 get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2852 void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2853 build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2854 pchar4_type_node);
2855
2856 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2857 get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2858 void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2859 build_pointer_type (pchar4_type_node), integer_type_node,
2860 integer_type_node);
2861
2862 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2863 get_identifier (PREFIX("adjustl_char4")), ".W.R",
2864 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2865 pchar4_type_node);
2866 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2867
2868 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2869 get_identifier (PREFIX("adjustr_char4")), ".W.R",
2870 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2871 pchar4_type_node);
2872 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2873
2874 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2875 get_identifier (PREFIX("select_string_char4")), ".R.R.",
2876 integer_type_node, 4, pvoid_type_node, integer_type_node,
2877 pvoid_type_node, gfc_charlen_type_node);
2878 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2879 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2880
2881
2882 /* Conversion between character kinds. */
2883
2884 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2885 get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2886 void_type_node, 3, build_pointer_type (pchar4_type_node),
2887 gfc_charlen_type_node, pchar1_type_node);
2888
2889 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2890 get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2891 void_type_node, 3, build_pointer_type (pchar1_type_node),
2892 gfc_charlen_type_node, pchar4_type_node);
2893
2894 /* Misc. functions. */
2895
2896 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2897 get_identifier (PREFIX("ttynam")), ".W",
2898 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2899 integer_type_node);
2900
2901 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2902 get_identifier (PREFIX("fdate")), ".W",
2903 void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2904
2905 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2906 get_identifier (PREFIX("ctime")), ".W",
2907 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2908 gfc_int8_type_node);
2909
2910 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2911 get_identifier (PREFIX("selected_char_kind")), "..R",
2912 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2913 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2914 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2915
2916 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2917 get_identifier (PREFIX("selected_int_kind")), ".R",
2918 gfc_int4_type_node, 1, pvoid_type_node);
2919 DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2920 TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2921
2922 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2923 get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2924 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2925 pvoid_type_node);
2926 DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2927 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2928
2929 /* Power functions. */
2930 {
2931 tree ctype, rtype, itype, jtype;
2932 int rkind, ikind, jkind;
2933 #define NIKINDS 3
2934 #define NRKINDS 4
2935 static int ikinds[NIKINDS] = {4, 8, 16};
2936 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2937 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2938
2939 for (ikind=0; ikind < NIKINDS; ikind++)
2940 {
2941 itype = gfc_get_int_type (ikinds[ikind]);
2942
2943 for (jkind=0; jkind < NIKINDS; jkind++)
2944 {
2945 jtype = gfc_get_int_type (ikinds[jkind]);
2946 if (itype && jtype)
2947 {
2948 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2949 ikinds[jkind]);
2950 gfor_fndecl_math_powi[jkind][ikind].integer =
2951 gfc_build_library_function_decl (get_identifier (name),
2952 jtype, 2, jtype, itype);
2953 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2954 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2955 }
2956 }
2957
2958 for (rkind = 0; rkind < NRKINDS; rkind ++)
2959 {
2960 rtype = gfc_get_real_type (rkinds[rkind]);
2961 if (rtype && itype)
2962 {
2963 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2964 ikinds[ikind]);
2965 gfor_fndecl_math_powi[rkind][ikind].real =
2966 gfc_build_library_function_decl (get_identifier (name),
2967 rtype, 2, rtype, itype);
2968 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2969 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2970 }
2971
2972 ctype = gfc_get_complex_type (rkinds[rkind]);
2973 if (ctype && itype)
2974 {
2975 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2976 ikinds[ikind]);
2977 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2978 gfc_build_library_function_decl (get_identifier (name),
2979 ctype, 2,ctype, itype);
2980 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2981 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2982 }
2983 }
2984 }
2985 #undef NIKINDS
2986 #undef NRKINDS
2987 }
2988
2989 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2990 get_identifier (PREFIX("ishftc4")),
2991 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2992 gfc_int4_type_node);
2993 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2994 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2995
2996 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2997 get_identifier (PREFIX("ishftc8")),
2998 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2999 gfc_int4_type_node);
3000 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
3001 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
3002
3003 if (gfc_int16_type_node)
3004 {
3005 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
3006 get_identifier (PREFIX("ishftc16")),
3007 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
3008 gfc_int4_type_node);
3009 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
3010 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
3011 }
3012
3013 /* BLAS functions. */
3014 {
3015 tree pint = build_pointer_type (integer_type_node);
3016 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
3017 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
3018 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
3019 tree pz = build_pointer_type
3020 (gfc_get_complex_type (gfc_default_double_kind));
3021
3022 gfor_fndecl_sgemm = gfc_build_library_function_decl
3023 (get_identifier
3024 (gfc_option.flag_underscoring ? "sgemm_"
3025 : "sgemm"),
3026 void_type_node, 15, pchar_type_node,
3027 pchar_type_node, pint, pint, pint, ps, ps, pint,
3028 ps, pint, ps, ps, pint, integer_type_node,
3029 integer_type_node);
3030 gfor_fndecl_dgemm = gfc_build_library_function_decl
3031 (get_identifier
3032 (gfc_option.flag_underscoring ? "dgemm_"
3033 : "dgemm"),
3034 void_type_node, 15, pchar_type_node,
3035 pchar_type_node, pint, pint, pint, pd, pd, pint,
3036 pd, pint, pd, pd, pint, integer_type_node,
3037 integer_type_node);
3038 gfor_fndecl_cgemm = gfc_build_library_function_decl
3039 (get_identifier
3040 (gfc_option.flag_underscoring ? "cgemm_"
3041 : "cgemm"),
3042 void_type_node, 15, pchar_type_node,
3043 pchar_type_node, pint, pint, pint, pc, pc, pint,
3044 pc, pint, pc, pc, pint, integer_type_node,
3045 integer_type_node);
3046 gfor_fndecl_zgemm = gfc_build_library_function_decl
3047 (get_identifier
3048 (gfc_option.flag_underscoring ? "zgemm_"
3049 : "zgemm"),
3050 void_type_node, 15, pchar_type_node,
3051 pchar_type_node, pint, pint, pint, pz, pz, pint,
3052 pz, pint, pz, pz, pint, integer_type_node,
3053 integer_type_node);
3054 }
3055
3056 /* Other functions. */
3057 gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3058 get_identifier (PREFIX("size0")), ".R",
3059 gfc_array_index_type, 1, pvoid_type_node);
3060 DECL_PURE_P (gfor_fndecl_size0) = 1;
3061 TREE_NOTHROW (gfor_fndecl_size0) = 1;
3062
3063 gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3064 get_identifier (PREFIX("size1")), ".R",
3065 gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3066 DECL_PURE_P (gfor_fndecl_size1) = 1;
3067 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3068
3069 gfor_fndecl_iargc = gfc_build_library_function_decl (
3070 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3071 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3072 }
3073
3074
3075 /* Make prototypes for runtime library functions. */
3076
3077 void
3078 gfc_build_builtin_function_decls (void)
3079 {
3080 tree gfc_int4_type_node = gfc_get_int_type (4);
3081
3082 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3083 get_identifier (PREFIX("stop_numeric")),
3084 void_type_node, 1, gfc_int4_type_node);
3085 /* STOP doesn't return. */
3086 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3087
3088 gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
3089 get_identifier (PREFIX("stop_numeric_f08")),
3090 void_type_node, 1, gfc_int4_type_node);
3091 /* STOP doesn't return. */
3092 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
3093
3094 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3095 get_identifier (PREFIX("stop_string")), ".R.",
3096 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3097 /* STOP doesn't return. */
3098 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3099
3100 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3101 get_identifier (PREFIX("error_stop_numeric")),
3102 void_type_node, 1, gfc_int4_type_node);
3103 /* ERROR STOP doesn't return. */
3104 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3105
3106 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3107 get_identifier (PREFIX("error_stop_string")), ".R.",
3108 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3109 /* ERROR STOP doesn't return. */
3110 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3111
3112 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3113 get_identifier (PREFIX("pause_numeric")),
3114 void_type_node, 1, gfc_int4_type_node);
3115
3116 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3117 get_identifier (PREFIX("pause_string")), ".R.",
3118 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3119
3120 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3121 get_identifier (PREFIX("runtime_error")), ".R",
3122 void_type_node, -1, pchar_type_node);
3123 /* The runtime_error function does not return. */
3124 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3125
3126 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3127 get_identifier (PREFIX("runtime_error_at")), ".RR",
3128 void_type_node, -2, pchar_type_node, pchar_type_node);
3129 /* The runtime_error_at function does not return. */
3130 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3131
3132 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3133 get_identifier (PREFIX("runtime_warning_at")), ".RR",
3134 void_type_node, -2, pchar_type_node, pchar_type_node);
3135
3136 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3137 get_identifier (PREFIX("generate_error")), ".R.R",
3138 void_type_node, 3, pvoid_type_node, integer_type_node,
3139 pchar_type_node);
3140
3141 gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3142 get_identifier (PREFIX("os_error")), ".R",
3143 void_type_node, 1, pchar_type_node);
3144 /* The runtime_error function does not return. */
3145 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3146
3147 gfor_fndecl_set_args = gfc_build_library_function_decl (
3148 get_identifier (PREFIX("set_args")),
3149 void_type_node, 2, integer_type_node,
3150 build_pointer_type (pchar_type_node));
3151
3152 gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3153 get_identifier (PREFIX("set_fpe")),
3154 void_type_node, 1, integer_type_node);
3155
3156 /* Keep the array dimension in sync with the call, later in this file. */
3157 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3158 get_identifier (PREFIX("set_options")), "..R",
3159 void_type_node, 2, integer_type_node,
3160 build_pointer_type (integer_type_node));
3161
3162 gfor_fndecl_set_convert = gfc_build_library_function_decl (
3163 get_identifier (PREFIX("set_convert")),
3164 void_type_node, 1, integer_type_node);
3165
3166 gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3167 get_identifier (PREFIX("set_record_marker")),
3168 void_type_node, 1, integer_type_node);
3169
3170 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3171 get_identifier (PREFIX("set_max_subrecord_length")),
3172 void_type_node, 1, integer_type_node);
3173
3174 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3175 get_identifier (PREFIX("internal_pack")), ".r",
3176 pvoid_type_node, 1, pvoid_type_node);
3177
3178 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3179 get_identifier (PREFIX("internal_unpack")), ".wR",
3180 void_type_node, 2, pvoid_type_node, pvoid_type_node);
3181
3182 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3183 get_identifier (PREFIX("associated")), ".RR",
3184 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3185 DECL_PURE_P (gfor_fndecl_associated) = 1;
3186 TREE_NOTHROW (gfor_fndecl_associated) = 1;
3187
3188 /* Coarray library calls. */
3189 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3190 {
3191 tree pint_type, pppchar_type;
3192
3193 pint_type = build_pointer_type (integer_type_node);
3194 pppchar_type
3195 = build_pointer_type (build_pointer_type (pchar_type_node));
3196
3197 gfor_fndecl_caf_init = gfc_build_library_function_decl (
3198 get_identifier (PREFIX("caf_init")), void_type_node,
3199 4, pint_type, pppchar_type, pint_type, pint_type);
3200
3201 gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3202 get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3203
3204 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3205 get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3206 size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3207 pchar_type_node, integer_type_node);
3208
3209 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3210 get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
3211 ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
3212
3213 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3214 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3215
3216 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3217 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3218
3219 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3220 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3221 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3222
3223 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3224 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3225 5, integer_type_node, pint_type, pint_type,
3226 build_pointer_type (pchar_type_node), integer_type_node);
3227
3228 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3229 get_identifier (PREFIX("caf_error_stop")),
3230 void_type_node, 1, gfc_int4_type_node);
3231 /* CAF's ERROR STOP doesn't return. */
3232 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3233
3234 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3235 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3236 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3237 /* CAF's ERROR STOP doesn't return. */
3238 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3239 }
3240
3241 gfc_build_intrinsic_function_decls ();
3242 gfc_build_intrinsic_lib_fndecls ();
3243 gfc_build_io_library_fndecls ();
3244 }
3245
3246
3247 /* Evaluate the length of dummy character variables. */
3248
3249 static void
3250 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3251 gfc_wrapped_block *block)
3252 {
3253 stmtblock_t init;
3254
3255 gfc_finish_decl (cl->backend_decl);
3256
3257 gfc_start_block (&init);
3258
3259 /* Evaluate the string length expression. */
3260 gfc_conv_string_length (cl, NULL, &init);
3261
3262 gfc_trans_vla_type_sizes (sym, &init);
3263
3264 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3265 }
3266
3267
3268 /* Allocate and cleanup an automatic character variable. */
3269
3270 static void
3271 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3272 {
3273 stmtblock_t init;
3274 tree decl;
3275 tree tmp;
3276
3277 gcc_assert (sym->backend_decl);
3278 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3279
3280 gfc_init_block (&init);
3281
3282 /* Evaluate the string length expression. */
3283 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3284
3285 gfc_trans_vla_type_sizes (sym, &init);
3286
3287 decl = sym->backend_decl;
3288
3289 /* Emit a DECL_EXPR for this variable, which will cause the
3290 gimplifier to allocate storage, and all that good stuff. */
3291 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3292 gfc_add_expr_to_block (&init, tmp);
3293
3294 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3295 }
3296
3297 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3298
3299 static void
3300 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3301 {
3302 stmtblock_t init;
3303
3304 gcc_assert (sym->backend_decl);
3305 gfc_start_block (&init);
3306
3307 /* Set the initial value to length. See the comments in
3308 function gfc_add_assign_aux_vars in this file. */
3309 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3310 build_int_cst (gfc_charlen_type_node, -2));
3311
3312 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3313 }
3314
3315 static void
3316 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3317 {
3318 tree t = *tp, var, val;
3319
3320 if (t == NULL || t == error_mark_node)
3321 return;
3322 if (TREE_CONSTANT (t) || DECL_P (t))
3323 return;
3324
3325 if (TREE_CODE (t) == SAVE_EXPR)
3326 {
3327 if (SAVE_EXPR_RESOLVED_P (t))
3328 {
3329 *tp = TREE_OPERAND (t, 0);
3330 return;
3331 }
3332 val = TREE_OPERAND (t, 0);
3333 }
3334 else
3335 val = t;
3336
3337 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3338 gfc_add_decl_to_function (var);
3339 gfc_add_modify (body, var, val);
3340 if (TREE_CODE (t) == SAVE_EXPR)
3341 TREE_OPERAND (t, 0) = var;
3342 *tp = var;
3343 }
3344
3345 static void
3346 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3347 {
3348 tree t;
3349
3350 if (type == NULL || type == error_mark_node)
3351 return;
3352
3353 type = TYPE_MAIN_VARIANT (type);
3354
3355 if (TREE_CODE (type) == INTEGER_TYPE)
3356 {
3357 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3358 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3359
3360 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3361 {
3362 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3363 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3364 }
3365 }
3366 else if (TREE_CODE (type) == ARRAY_TYPE)
3367 {
3368 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3369 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3370 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3371 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3372
3373 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3374 {
3375 TYPE_SIZE (t) = TYPE_SIZE (type);
3376 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3377 }
3378 }
3379 }
3380
3381 /* Make sure all type sizes and array domains are either constant,
3382 or variable or parameter decls. This is a simplified variant
3383 of gimplify_type_sizes, but we can't use it here, as none of the
3384 variables in the expressions have been gimplified yet.
3385 As type sizes and domains for various variable length arrays
3386 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3387 time, without this routine gimplify_type_sizes in the middle-end
3388 could result in the type sizes being gimplified earlier than where
3389 those variables are initialized. */
3390
3391 void
3392 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3393 {
3394 tree type = TREE_TYPE (sym->backend_decl);
3395
3396 if (TREE_CODE (type) == FUNCTION_TYPE
3397 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3398 {
3399 if (! current_fake_result_decl)
3400 return;
3401
3402 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3403 }
3404
3405 while (POINTER_TYPE_P (type))
3406 type = TREE_TYPE (type);
3407
3408 if (GFC_DESCRIPTOR_TYPE_P (type))
3409 {
3410 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3411
3412 while (POINTER_TYPE_P (etype))
3413 etype = TREE_TYPE (etype);
3414
3415 gfc_trans_vla_type_sizes_1 (etype, body);
3416 }
3417
3418 gfc_trans_vla_type_sizes_1 (type, body);
3419 }
3420
3421
3422 /* Initialize a derived type by building an lvalue from the symbol
3423 and using trans_assignment to do the work. Set dealloc to false
3424 if no deallocation prior the assignment is needed. */
3425 void
3426 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3427 {
3428 gfc_expr *e;
3429 tree tmp;
3430 tree present;
3431
3432 gcc_assert (block);
3433
3434 gcc_assert (!sym->attr.allocatable);
3435 gfc_set_sym_referenced (sym);
3436 e = gfc_lval_expr_from_sym (sym);
3437 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3438 if (sym->attr.dummy && (sym->attr.optional
3439 || sym->ns->proc_name->attr.entry_master))
3440 {
3441 present = gfc_conv_expr_present (sym);
3442 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3443 tmp, build_empty_stmt (input_location));
3444 }
3445 gfc_add_expr_to_block (block, tmp);
3446 gfc_free_expr (e);
3447 }
3448
3449
3450 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3451 them their default initializer, if they do not have allocatable
3452 components, they have their allocatable components deallocated. */
3453
3454 static void
3455 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3456 {
3457 stmtblock_t init;
3458 gfc_formal_arglist *f;
3459 tree tmp;
3460 tree present;
3461
3462 gfc_init_block (&init);
3463 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
3464 if (f->sym && f->sym->attr.intent == INTENT_OUT
3465 && !f->sym->attr.pointer
3466 && f->sym->ts.type == BT_DERIVED)
3467 {
3468 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3469 {
3470 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3471 f->sym->backend_decl,
3472 f->sym->as ? f->sym->as->rank : 0);
3473
3474 if (f->sym->attr.optional
3475 || f->sym->ns->proc_name->attr.entry_master)
3476 {
3477 present = gfc_conv_expr_present (f->sym);
3478 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3479 present, tmp,
3480 build_empty_stmt (input_location));
3481 }
3482
3483 gfc_add_expr_to_block (&init, tmp);
3484 }
3485 else if (f->sym->value)
3486 gfc_init_default_dt (f->sym, &init, true);
3487 }
3488 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3489 && f->sym->ts.type == BT_CLASS
3490 && !CLASS_DATA (f->sym)->attr.class_pointer
3491 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3492 {
3493 tmp = gfc_class_data_get (f->sym->backend_decl);
3494 if (CLASS_DATA (f->sym)->as == NULL)
3495 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3496 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3497 tmp,
3498 CLASS_DATA (f->sym)->as ?
3499 CLASS_DATA (f->sym)->as->rank : 0);
3500
3501 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3502 {
3503 present = gfc_conv_expr_present (f->sym);
3504 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3505 present, tmp,
3506 build_empty_stmt (input_location));
3507 }
3508
3509 gfc_add_expr_to_block (&init, tmp);
3510 }
3511
3512 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3513 }
3514
3515
3516 /* Generate function entry and exit code, and add it to the function body.
3517 This includes:
3518 Allocation and initialization of array variables.
3519 Allocation of character string variables.
3520 Initialization and possibly repacking of dummy arrays.
3521 Initialization of ASSIGN statement auxiliary variable.
3522 Initialization of ASSOCIATE names.
3523 Automatic deallocation. */
3524
3525 void
3526 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3527 {
3528 locus loc;
3529 gfc_symbol *sym;
3530 gfc_formal_arglist *f;
3531 stmtblock_t tmpblock;
3532 bool seen_trans_deferred_array = false;
3533 tree tmp = NULL;
3534 gfc_expr *e;
3535 gfc_se se;
3536 stmtblock_t init;
3537
3538 /* Deal with implicit return variables. Explicit return variables will
3539 already have been added. */
3540 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3541 {
3542 if (!current_fake_result_decl)
3543 {
3544 gfc_entry_list *el = NULL;
3545 if (proc_sym->attr.entry_master)
3546 {
3547 for (el = proc_sym->ns->entries; el; el = el->next)
3548 if (el->sym != el->sym->result)
3549 break;
3550 }
3551 /* TODO: move to the appropriate place in resolve.c. */
3552 if (warn_return_type && el == NULL)
3553 gfc_warning ("Return value of function '%s' at %L not set",
3554 proc_sym->name, &proc_sym->declared_at);
3555 }
3556 else if (proc_sym->as)
3557 {
3558 tree result = TREE_VALUE (current_fake_result_decl);
3559 gfc_trans_dummy_array_bias (proc_sym, result, block);
3560
3561 /* An automatic character length, pointer array result. */
3562 if (proc_sym->ts.type == BT_CHARACTER
3563 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3564 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3565 }
3566 else if (proc_sym->ts.type == BT_CHARACTER)
3567 {
3568 if (proc_sym->ts.deferred)
3569 {
3570 tmp = NULL;
3571 gfc_save_backend_locus (&loc);
3572 gfc_set_backend_locus (&proc_sym->declared_at);
3573 gfc_start_block (&init);
3574 /* Zero the string length on entry. */
3575 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3576 build_int_cst (gfc_charlen_type_node, 0));
3577 /* Null the pointer. */
3578 e = gfc_lval_expr_from_sym (proc_sym);
3579 gfc_init_se (&se, NULL);
3580 se.want_pointer = 1;
3581 gfc_conv_expr (&se, e);
3582 gfc_free_expr (e);
3583 tmp = se.expr;
3584 gfc_add_modify (&init, tmp,
3585 fold_convert (TREE_TYPE (se.expr),
3586 null_pointer_node));
3587 gfc_restore_backend_locus (&loc);
3588
3589 /* Pass back the string length on exit. */
3590 tmp = proc_sym->ts.u.cl->passed_length;
3591 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3592 tmp = fold_convert (gfc_charlen_type_node, tmp);
3593 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3594 gfc_charlen_type_node, tmp,
3595 proc_sym->ts.u.cl->backend_decl);
3596 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3597 }
3598 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3599 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3600 }
3601 else
3602 gcc_assert (gfc_option.flag_f2c
3603 && proc_sym->ts.type == BT_COMPLEX);
3604 }
3605
3606 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3607 should be done here so that the offsets and lbounds of arrays
3608 are available. */
3609 gfc_save_backend_locus (&loc);
3610 gfc_set_backend_locus (&proc_sym->declared_at);
3611 init_intent_out_dt (proc_sym, block);
3612 gfc_restore_backend_locus (&loc);
3613
3614 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3615 {
3616 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3617 && sym->ts.u.derived->attr.alloc_comp;
3618 if (sym->assoc)
3619 continue;
3620
3621 if (sym->attr.subref_array_pointer
3622 && GFC_DECL_SPAN (sym->backend_decl)
3623 && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
3624 {
3625 gfc_init_block (&tmpblock);
3626 gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
3627 build_int_cst (gfc_array_index_type, 0));
3628 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3629 NULL_TREE);
3630 }
3631
3632 if (sym->attr.dimension || sym->attr.codimension)
3633 {
3634 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3635 array_type tmp = sym->as->type;
3636 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3637 tmp = AS_EXPLICIT;
3638 switch (tmp)
3639 {
3640 case AS_EXPLICIT:
3641 if (sym->attr.dummy || sym->attr.result)
3642 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3643 else if (sym->attr.pointer || sym->attr.allocatable)
3644 {
3645 if (TREE_STATIC (sym->backend_decl))
3646 {
3647 gfc_save_backend_locus (&loc);
3648 gfc_set_backend_locus (&sym->declared_at);
3649 gfc_trans_static_array_pointer (sym);
3650 gfc_restore_backend_locus (&loc);
3651 }
3652 else
3653 {
3654 seen_trans_deferred_array = true;
3655 gfc_trans_deferred_array (sym, block);
3656 }
3657 }
3658 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3659 {
3660 gfc_init_block (&tmpblock);
3661 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3662 &tmpblock, sym);
3663 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3664 NULL_TREE);
3665 continue;
3666 }
3667 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3668 {
3669 gfc_save_backend_locus (&loc);
3670 gfc_set_backend_locus (&sym->declared_at);
3671
3672 if (sym_has_alloc_comp)
3673 {
3674 seen_trans_deferred_array = true;
3675 gfc_trans_deferred_array (sym, block);
3676 }
3677 else if (sym->ts.type == BT_DERIVED
3678 && sym->value
3679 && !sym->attr.data
3680 && sym->attr.save == SAVE_NONE)
3681 {
3682 gfc_start_block (&tmpblock);
3683 gfc_init_default_dt (sym, &tmpblock, false);
3684 gfc_add_init_cleanup (block,
3685 gfc_finish_block (&tmpblock),
3686 NULL_TREE);
3687 }
3688
3689 gfc_trans_auto_array_allocation (sym->backend_decl,
3690 sym, block);
3691 gfc_restore_backend_locus (&loc);
3692 }
3693 break;
3694
3695 case AS_ASSUMED_SIZE:
3696 /* Must be a dummy parameter. */
3697 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3698
3699 /* We should always pass assumed size arrays the g77 way. */
3700 if (sym->attr.dummy)
3701 gfc_trans_g77_array (sym, block);
3702 break;
3703
3704 case AS_ASSUMED_SHAPE:
3705 /* Must be a dummy parameter. */
3706 gcc_assert (sym->attr.dummy);
3707
3708 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3709 break;
3710
3711 case AS_ASSUMED_RANK:
3712 case AS_DEFERRED:
3713 seen_trans_deferred_array = true;
3714 gfc_trans_deferred_array (sym, block);
3715 break;
3716
3717 default:
3718 gcc_unreachable ();
3719 }
3720 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3721 gfc_trans_deferred_array (sym, block);
3722 }
3723 else if ((!sym->attr.dummy || sym->ts.deferred)
3724 && (sym->ts.type == BT_CLASS
3725 && CLASS_DATA (sym)->attr.class_pointer))
3726 continue;
3727 else if ((!sym->attr.dummy || sym->ts.deferred)
3728 && (sym->attr.allocatable
3729 || (sym->ts.type == BT_CLASS
3730 && CLASS_DATA (sym)->attr.allocatable)))
3731 {
3732 if (!sym->attr.save && gfc_option.flag_max_stack_var_size != 0)
3733 {
3734 tree descriptor = NULL_TREE;
3735
3736 /* Nullify and automatic deallocation of allocatable
3737 scalars. */
3738 e = gfc_lval_expr_from_sym (sym);
3739 if (sym->ts.type == BT_CLASS)
3740 gfc_add_data_component (e);
3741
3742 gfc_init_se (&se, NULL);
3743 if (sym->ts.type != BT_CLASS
3744 || sym->ts.u.derived->attr.dimension
3745 || sym->ts.u.derived->attr.codimension)
3746 {
3747 se.want_pointer = 1;
3748 gfc_conv_expr (&se, e);
3749 }
3750 else if (sym->ts.type == BT_CLASS
3751 && !CLASS_DATA (sym)->attr.dimension
3752 && !CLASS_DATA (sym)->attr.codimension)
3753 {
3754 se.want_pointer = 1;
3755 gfc_conv_expr (&se, e);
3756 }
3757 else
3758 {
3759 gfc_conv_expr (&se, e);
3760 descriptor = se.expr;
3761 se.expr = gfc_conv_descriptor_data_addr (se.expr);
3762 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3763 }
3764 gfc_free_expr (e);
3765
3766 gfc_save_backend_locus (&loc);
3767 gfc_set_backend_locus (&sym->declared_at);
3768 gfc_start_block (&init);
3769
3770 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3771 {
3772 /* Nullify when entering the scope. */
3773 gfc_add_modify (&init, se.expr,
3774 fold_convert (TREE_TYPE (se.expr),
3775 null_pointer_node));
3776 }
3777
3778 if ((sym->attr.dummy ||sym->attr.result)
3779 && sym->ts.type == BT_CHARACTER
3780 && sym->ts.deferred)
3781 {
3782 /* Character length passed by reference. */
3783 tmp = sym->ts.u.cl->passed_length;
3784 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3785 tmp = fold_convert (gfc_charlen_type_node, tmp);
3786
3787 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3788 /* Zero the string length when entering the scope. */
3789 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3790 build_int_cst (gfc_charlen_type_node, 0));
3791 else
3792 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3793
3794 gfc_restore_backend_locus (&loc);
3795
3796 /* Pass the final character length back. */
3797 if (sym->attr.intent != INTENT_IN)
3798 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3799 gfc_charlen_type_node, tmp,
3800 sym->ts.u.cl->backend_decl);
3801 else
3802 tmp = NULL_TREE;
3803 }
3804 else
3805 gfc_restore_backend_locus (&loc);
3806
3807 /* Deallocate when leaving the scope. Nullifying is not
3808 needed. */
3809 if (!sym->attr.result && !sym->attr.dummy)
3810 {
3811 if (sym->ts.type == BT_CLASS
3812 && CLASS_DATA (sym)->attr.codimension)
3813 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
3814 NULL_TREE, NULL_TREE,
3815 NULL_TREE, true, NULL,
3816 true);
3817 else
3818 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
3819 true,
3820 gfc_lval_expr_from_sym (sym),
3821 sym->ts);
3822 }
3823 if (sym->ts.type == BT_CLASS)
3824 {
3825 /* Initialize _vptr to declared type. */
3826 gfc_symbol *vtab;
3827 tree rhs;
3828
3829 gfc_save_backend_locus (&loc);
3830 gfc_set_backend_locus (&sym->declared_at);
3831 e = gfc_lval_expr_from_sym (sym);
3832 gfc_add_vptr_component (e);
3833 gfc_init_se (&se, NULL);
3834 se.want_pointer = 1;
3835 gfc_conv_expr (&se, e);
3836 gfc_free_expr (e);
3837 if (UNLIMITED_POLY (sym))
3838 rhs = build_int_cst (TREE_TYPE (se.expr), 0);
3839 else
3840 {
3841 vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3842 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3843 gfc_get_symbol_decl (vtab));
3844 }
3845 gfc_add_modify (&init, se.expr, rhs);
3846 gfc_restore_backend_locus (&loc);
3847 }
3848
3849 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3850 }
3851 }
3852 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3853 {
3854 tree tmp = NULL;
3855 stmtblock_t init;
3856
3857 /* If we get to here, all that should be left are pointers. */
3858 gcc_assert (sym->attr.pointer);
3859
3860 if (sym->attr.dummy)
3861 {
3862 gfc_start_block (&init);
3863
3864 /* Character length passed by reference. */
3865 tmp = sym->ts.u.cl->passed_length;
3866 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3867 tmp = fold_convert (gfc_charlen_type_node, tmp);
3868 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3869 /* Pass the final character length back. */
3870 if (sym->attr.intent != INTENT_IN)
3871 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3872 gfc_charlen_type_node, tmp,
3873 sym->ts.u.cl->backend_decl);
3874 else
3875 tmp = NULL_TREE;
3876 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3877 }
3878 }
3879 else if (sym->ts.deferred)
3880 gfc_fatal_error ("Deferred type parameter not yet supported");
3881 else if (sym_has_alloc_comp)
3882 gfc_trans_deferred_array (sym, block);
3883 else if (sym->ts.type == BT_CHARACTER)
3884 {
3885 gfc_save_backend_locus (&loc);
3886 gfc_set_backend_locus (&sym->declared_at);
3887 if (sym->attr.dummy || sym->attr.result)
3888 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3889 else
3890 gfc_trans_auto_character_variable (sym, block);
3891 gfc_restore_backend_locus (&loc);
3892 }
3893 else if (sym->attr.assign)
3894 {
3895 gfc_save_backend_locus (&loc);
3896 gfc_set_backend_locus (&sym->declared_at);
3897 gfc_trans_assign_aux_var (sym, block);
3898 gfc_restore_backend_locus (&loc);
3899 }
3900 else if (sym->ts.type == BT_DERIVED
3901 && sym->value
3902 && !sym->attr.data
3903 && sym->attr.save == SAVE_NONE)
3904 {
3905 gfc_start_block (&tmpblock);
3906 gfc_init_default_dt (sym, &tmpblock, false);
3907 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3908 NULL_TREE);
3909 }
3910 else if (!(UNLIMITED_POLY(sym)))
3911 gcc_unreachable ();
3912 }
3913
3914 gfc_init_block (&tmpblock);
3915
3916 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
3917 {
3918 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3919 {
3920 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3921 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3922 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3923 }
3924 }
3925
3926 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3927 && current_fake_result_decl != NULL)
3928 {
3929 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3930 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3931 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3932 }
3933
3934 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3935 }
3936
3937 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3938
3939 /* Hash and equality functions for module_htab. */
3940
3941 static hashval_t
3942 module_htab_do_hash (const void *x)
3943 {
3944 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3945 }
3946
3947 static int
3948 module_htab_eq (const void *x1, const void *x2)
3949 {
3950 return strcmp ((((const struct module_htab_entry *)x1)->name),
3951 (const char *)x2) == 0;
3952 }
3953
3954 /* Hash and equality functions for module_htab's decls. */
3955
3956 static hashval_t
3957 module_htab_decls_hash (const void *x)
3958 {
3959 const_tree t = (const_tree) x;
3960 const_tree n = DECL_NAME (t);
3961 if (n == NULL_TREE)
3962 n = TYPE_NAME (TREE_TYPE (t));
3963 return htab_hash_string (IDENTIFIER_POINTER (n));
3964 }
3965
3966 static int
3967 module_htab_decls_eq (const void *x1, const void *x2)
3968 {
3969 const_tree t1 = (const_tree) x1;
3970 const_tree n1 = DECL_NAME (t1);
3971 if (n1 == NULL_TREE)
3972 n1 = TYPE_NAME (TREE_TYPE (t1));
3973 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3974 }
3975
3976 struct module_htab_entry *
3977 gfc_find_module (const char *name)
3978 {
3979 void **slot;
3980
3981 if (! module_htab)
3982 module_htab = htab_create_ggc (10, module_htab_do_hash,
3983 module_htab_eq, NULL);
3984
3985 slot = htab_find_slot_with_hash (module_htab, name,
3986 htab_hash_string (name), INSERT);
3987 if (*slot == NULL)
3988 {
3989 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3990
3991 entry->name = gfc_get_string (name);
3992 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3993 module_htab_decls_eq, NULL);
3994 *slot = (void *) entry;
3995 }
3996 return (struct module_htab_entry *) *slot;
3997 }
3998
3999 void
4000 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
4001 {
4002 void **slot;
4003 const char *name;
4004
4005 if (DECL_NAME (decl))
4006 name = IDENTIFIER_POINTER (DECL_NAME (decl));
4007 else
4008 {
4009 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
4010 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
4011 }
4012 slot = htab_find_slot_with_hash (entry->decls, name,
4013 htab_hash_string (name), INSERT);
4014 if (*slot == NULL)
4015 *slot = (void *) decl;
4016 }
4017
4018 static struct module_htab_entry *cur_module;
4019
4020 /* Output an initialized decl for a module variable. */
4021
4022 static void
4023 gfc_create_module_variable (gfc_symbol * sym)
4024 {
4025 tree decl;
4026
4027 /* Module functions with alternate entries are dealt with later and
4028 would get caught by the next condition. */
4029 if (sym->attr.entry)
4030 return;
4031
4032 /* Make sure we convert the types of the derived types from iso_c_binding
4033 into (void *). */
4034 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4035 && sym->ts.type == BT_DERIVED)
4036 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4037
4038 if (sym->attr.flavor == FL_DERIVED
4039 && sym->backend_decl
4040 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4041 {
4042 decl = sym->backend_decl;
4043 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4044
4045 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
4046 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
4047 {
4048 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4049 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4050 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4051 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4052 == sym->ns->proc_name->backend_decl);
4053 }
4054 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4055 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4056 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4057 }
4058
4059 /* Only output variables, procedure pointers and array valued,
4060 or derived type, parameters. */
4061 if (sym->attr.flavor != FL_VARIABLE
4062 && !(sym->attr.flavor == FL_PARAMETER
4063 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4064 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4065 return;
4066
4067 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4068 {
4069 decl = sym->backend_decl;
4070 gcc_assert (DECL_FILE_SCOPE_P (decl));
4071 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4072 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4073 gfc_module_add_decl (cur_module, decl);
4074 }
4075
4076 /* Don't generate variables from other modules. Variables from
4077 COMMONs will already have been generated. */
4078 if (sym->attr.use_assoc || sym->attr.in_common)
4079 return;
4080
4081 /* Equivalenced variables arrive here after creation. */
4082 if (sym->backend_decl
4083 && (sym->equiv_built || sym->attr.in_equivalence))
4084 return;
4085
4086 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4087 internal_error ("backend decl for module variable %s already exists",
4088 sym->name);
4089
4090 /* We always want module variables to be created. */
4091 sym->attr.referenced = 1;
4092 /* Create the decl. */
4093 decl = gfc_get_symbol_decl (sym);
4094
4095 /* Create the variable. */
4096 pushdecl (decl);
4097 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4098 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4099 rest_of_decl_compilation (decl, 1, 0);
4100 gfc_module_add_decl (cur_module, decl);
4101
4102 /* Also add length of strings. */
4103 if (sym->ts.type == BT_CHARACTER)
4104 {
4105 tree length;
4106
4107 length = sym->ts.u.cl->backend_decl;
4108 gcc_assert (length || sym->attr.proc_pointer);
4109 if (length && !INTEGER_CST_P (length))
4110 {
4111 pushdecl (length);
4112 rest_of_decl_compilation (length, 1, 0);
4113 }
4114 }
4115
4116 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4117 && sym->attr.referenced && !sym->attr.use_assoc)
4118 has_coarray_vars = true;
4119 }
4120
4121 /* Emit debug information for USE statements. */
4122
4123 static void
4124 gfc_trans_use_stmts (gfc_namespace * ns)
4125 {
4126 gfc_use_list *use_stmt;
4127 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4128 {
4129 struct module_htab_entry *entry
4130 = gfc_find_module (use_stmt->module_name);
4131 gfc_use_rename *rent;
4132
4133 if (entry->namespace_decl == NULL)
4134 {
4135 entry->namespace_decl
4136 = build_decl (input_location,
4137 NAMESPACE_DECL,
4138 get_identifier (use_stmt->module_name),
4139 void_type_node);
4140 DECL_EXTERNAL (entry->namespace_decl) = 1;
4141 }
4142 gfc_set_backend_locus (&use_stmt->where);
4143 if (!use_stmt->only_flag)
4144 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4145 NULL_TREE,
4146 ns->proc_name->backend_decl,
4147 false);
4148 for (rent = use_stmt->rename; rent; rent = rent->next)
4149 {
4150 tree decl, local_name;
4151 void **slot;
4152
4153 if (rent->op != INTRINSIC_NONE)
4154 continue;
4155
4156 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4157 htab_hash_string (rent->use_name),
4158 INSERT);
4159 if (*slot == NULL)
4160 {
4161 gfc_symtree *st;
4162
4163 st = gfc_find_symtree (ns->sym_root,
4164 rent->local_name[0]
4165 ? rent->local_name : rent->use_name);
4166
4167 /* The following can happen if a derived type is renamed. */
4168 if (!st)
4169 {
4170 char *name;
4171 name = xstrdup (rent->local_name[0]
4172 ? rent->local_name : rent->use_name);
4173 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4174 st = gfc_find_symtree (ns->sym_root, name);
4175 free (name);
4176 gcc_assert (st);
4177 }
4178
4179 /* Sometimes, generic interfaces wind up being over-ruled by a
4180 local symbol (see PR41062). */
4181 if (!st->n.sym->attr.use_assoc)
4182 continue;
4183
4184 if (st->n.sym->backend_decl
4185 && DECL_P (st->n.sym->backend_decl)
4186 && st->n.sym->module
4187 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4188 {
4189 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4190 || (TREE_CODE (st->n.sym->backend_decl)
4191 != VAR_DECL));
4192 decl = copy_node (st->n.sym->backend_decl);
4193 DECL_CONTEXT (decl) = entry->namespace_decl;
4194 DECL_EXTERNAL (decl) = 1;
4195 DECL_IGNORED_P (decl) = 0;
4196 DECL_INITIAL (decl) = NULL_TREE;
4197 }
4198 else
4199 {
4200 *slot = error_mark_node;
4201 htab_clear_slot (entry->decls, slot);
4202 continue;
4203 }
4204 *slot = decl;
4205 }
4206 decl = (tree) *slot;
4207 if (rent->local_name[0])
4208 local_name = get_identifier (rent->local_name);
4209 else
4210 local_name = NULL_TREE;
4211 gfc_set_backend_locus (&rent->where);
4212 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4213 ns->proc_name->backend_decl,
4214 !use_stmt->only_flag);
4215 }
4216 }
4217 }
4218
4219
4220 /* Return true if expr is a constant initializer that gfc_conv_initializer
4221 will handle. */
4222
4223 static bool
4224 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4225 bool pointer)
4226 {
4227 gfc_constructor *c;
4228 gfc_component *cm;
4229
4230 if (pointer)
4231 return true;
4232 else if (array)
4233 {
4234 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4235 return true;
4236 else if (expr->expr_type == EXPR_STRUCTURE)
4237 return check_constant_initializer (expr, ts, false, false);
4238 else if (expr->expr_type != EXPR_ARRAY)
4239 return false;
4240 for (c = gfc_constructor_first (expr->value.constructor);
4241 c; c = gfc_constructor_next (c))
4242 {
4243 if (c->iterator)
4244 return false;
4245 if (c->expr->expr_type == EXPR_STRUCTURE)
4246 {
4247 if (!check_constant_initializer (c->expr, ts, false, false))
4248 return false;
4249 }
4250 else if (c->expr->expr_type != EXPR_CONSTANT)
4251 return false;
4252 }
4253 return true;
4254 }
4255 else switch (ts->type)
4256 {
4257 case BT_DERIVED:
4258 if (expr->expr_type != EXPR_STRUCTURE)
4259 return false;
4260 cm = expr->ts.u.derived->components;
4261 for (c = gfc_constructor_first (expr->value.constructor);
4262 c; c = gfc_constructor_next (c), cm = cm->next)
4263 {
4264 if (!c->expr || cm->attr.allocatable)
4265 continue;
4266 if (!check_constant_initializer (c->expr, &cm->ts,
4267 cm->attr.dimension,
4268 cm->attr.pointer))
4269 return false;
4270 }
4271 return true;
4272 default:
4273 return expr->expr_type == EXPR_CONSTANT;
4274 }
4275 }
4276
4277 /* Emit debug info for parameters and unreferenced variables with
4278 initializers. */
4279
4280 static void
4281 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4282 {
4283 tree decl;
4284
4285 if (sym->attr.flavor != FL_PARAMETER
4286 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4287 return;
4288
4289 if (sym->backend_decl != NULL
4290 || sym->value == NULL
4291 || sym->attr.use_assoc
4292 || sym->attr.dummy
4293 || sym->attr.result
4294 || sym->attr.function
4295 || sym->attr.intrinsic
4296 || sym->attr.pointer
4297 || sym->attr.allocatable
4298 || sym->attr.cray_pointee
4299 || sym->attr.threadprivate
4300 || sym->attr.is_bind_c
4301 || sym->attr.subref_array_pointer
4302 || sym->attr.assign)
4303 return;
4304
4305 if (sym->ts.type == BT_CHARACTER)
4306 {
4307 gfc_conv_const_charlen (sym->ts.u.cl);
4308 if (sym->ts.u.cl->backend_decl == NULL
4309 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4310 return;
4311 }
4312 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4313 return;
4314
4315 if (sym->as)
4316 {
4317 int n;
4318
4319 if (sym->as->type != AS_EXPLICIT)
4320 return;
4321 for (n = 0; n < sym->as->rank; n++)
4322 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4323 || sym->as->upper[n] == NULL
4324 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4325 return;
4326 }
4327
4328 if (!check_constant_initializer (sym->value, &sym->ts,
4329 sym->attr.dimension, false))
4330 return;
4331
4332 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4333 return;
4334
4335 /* Create the decl for the variable or constant. */
4336 decl = build_decl (input_location,
4337 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4338 gfc_sym_identifier (sym), gfc_sym_type (sym));
4339 if (sym->attr.flavor == FL_PARAMETER)
4340 TREE_READONLY (decl) = 1;
4341 gfc_set_decl_location (decl, &sym->declared_at);
4342 if (sym->attr.dimension)
4343 GFC_DECL_PACKED_ARRAY (decl) = 1;
4344 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4345 TREE_STATIC (decl) = 1;
4346 TREE_USED (decl) = 1;
4347 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4348 TREE_PUBLIC (decl) = 1;
4349 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4350 TREE_TYPE (decl),
4351 sym->attr.dimension,
4352 false, false);
4353 debug_hooks->global_decl (decl);
4354 }
4355
4356
4357 static void
4358 generate_coarray_sym_init (gfc_symbol *sym)
4359 {
4360 tree tmp, size, decl, token;
4361
4362 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4363 || sym->attr.use_assoc || !sym->attr.referenced)
4364 return;
4365
4366 decl = sym->backend_decl;
4367 TREE_USED(decl) = 1;
4368 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4369
4370 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4371 to make sure the variable is not optimized away. */
4372 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4373
4374 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4375
4376 /* Ensure that we do not have size=0 for zero-sized arrays. */
4377 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4378 fold_convert (size_type_node, size),
4379 build_int_cst (size_type_node, 1));
4380
4381 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4382 {
4383 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4384 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4385 fold_convert (size_type_node, tmp), size);
4386 }
4387
4388 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4389 token = gfc_build_addr_expr (ppvoid_type_node,
4390 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4391
4392 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4393 build_int_cst (integer_type_node,
4394 GFC_CAF_COARRAY_STATIC), /* type. */
4395 token, null_pointer_node, /* token, stat. */
4396 null_pointer_node, /* errgmsg, errmsg_len. */
4397 build_int_cst (integer_type_node, 0));
4398
4399 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4400
4401
4402 /* Handle "static" initializer. */
4403 if (sym->value)
4404 {
4405 sym->attr.pointer = 1;
4406 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4407 true, false);
4408 sym->attr.pointer = 0;
4409 gfc_add_expr_to_block (&caf_init_block, tmp);
4410 }
4411 }
4412
4413
4414 /* Generate constructor function to initialize static, nonallocatable
4415 coarrays. */
4416
4417 static void
4418 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4419 {
4420 tree fndecl, tmp, decl, save_fn_decl;
4421
4422 save_fn_decl = current_function_decl;
4423 push_function_context ();
4424
4425 tmp = build_function_type_list (void_type_node, NULL_TREE);
4426 fndecl = build_decl (input_location, FUNCTION_DECL,
4427 create_tmp_var_name ("_caf_init"), tmp);
4428
4429 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4430 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4431
4432 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4433 DECL_ARTIFICIAL (decl) = 1;
4434 DECL_IGNORED_P (decl) = 1;
4435 DECL_CONTEXT (decl) = fndecl;
4436 DECL_RESULT (fndecl) = decl;
4437
4438 pushdecl (fndecl);
4439 current_function_decl = fndecl;
4440 announce_function (fndecl);
4441
4442 rest_of_decl_compilation (fndecl, 0, 0);
4443 make_decl_rtl (fndecl);
4444 allocate_struct_function (fndecl, false);
4445
4446 pushlevel ();
4447 gfc_init_block (&caf_init_block);
4448
4449 gfc_traverse_ns (ns, generate_coarray_sym_init);
4450
4451 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4452 decl = getdecls ();
4453
4454 poplevel (1, 1);
4455 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4456
4457 DECL_SAVED_TREE (fndecl)
4458 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4459 DECL_INITIAL (fndecl));
4460 dump_function (TDI_original, fndecl);
4461
4462 cfun->function_end_locus = input_location;
4463 set_cfun (NULL);
4464
4465 if (decl_function_context (fndecl))
4466 (void) cgraph_create_node (fndecl);
4467 else
4468 cgraph_finalize_function (fndecl, true);
4469
4470 pop_function_context ();
4471 current_function_decl = save_fn_decl;
4472 }
4473
4474
4475 /* Generate all the required code for module variables. */
4476
4477 void
4478 gfc_generate_module_vars (gfc_namespace * ns)
4479 {
4480 module_namespace = ns;
4481 cur_module = gfc_find_module (ns->proc_name->name);
4482
4483 /* Check if the frontend left the namespace in a reasonable state. */
4484 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4485
4486 /* Generate COMMON blocks. */
4487 gfc_trans_common (ns);
4488
4489 has_coarray_vars = false;
4490
4491 /* Create decls for all the module variables. */
4492 gfc_traverse_ns (ns, gfc_create_module_variable);
4493
4494 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4495 generate_coarray_init (ns);
4496
4497 cur_module = NULL;
4498
4499 gfc_trans_use_stmts (ns);
4500 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4501 }
4502
4503
4504 static void
4505 gfc_generate_contained_functions (gfc_namespace * parent)
4506 {
4507 gfc_namespace *ns;
4508
4509 /* We create all the prototypes before generating any code. */
4510 for (ns = parent->contained; ns; ns = ns->sibling)
4511 {
4512 /* Skip namespaces from used modules. */
4513 if (ns->parent != parent)
4514 continue;
4515
4516 gfc_create_function_decl (ns, false);
4517 }
4518
4519 for (ns = parent->contained; ns; ns = ns->sibling)
4520 {
4521 /* Skip namespaces from used modules. */
4522 if (ns->parent != parent)
4523 continue;
4524
4525 gfc_generate_function_code (ns);
4526 }
4527 }
4528
4529
4530 /* Drill down through expressions for the array specification bounds and
4531 character length calling generate_local_decl for all those variables
4532 that have not already been declared. */
4533
4534 static void
4535 generate_local_decl (gfc_symbol *);
4536
4537 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4538
4539 static bool
4540 expr_decls (gfc_expr *e, gfc_symbol *sym,
4541 int *f ATTRIBUTE_UNUSED)
4542 {
4543 if (e->expr_type != EXPR_VARIABLE
4544 || sym == e->symtree->n.sym
4545 || e->symtree->n.sym->mark
4546 || e->symtree->n.sym->ns != sym->ns)
4547 return false;
4548
4549 generate_local_decl (e->symtree->n.sym);
4550 return false;
4551 }
4552
4553 static void
4554 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4555 {
4556 gfc_traverse_expr (e, sym, expr_decls, 0);
4557 }
4558
4559
4560 /* Check for dependencies in the character length and array spec. */
4561
4562 static void
4563 generate_dependency_declarations (gfc_symbol *sym)
4564 {
4565 int i;
4566
4567 if (sym->ts.type == BT_CHARACTER
4568 && sym->ts.u.cl
4569 && sym->ts.u.cl->length
4570 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4571 generate_expr_decls (sym, sym->ts.u.cl->length);
4572
4573 if (sym->as && sym->as->rank)
4574 {
4575 for (i = 0; i < sym->as->rank; i++)
4576 {
4577 generate_expr_decls (sym, sym->as->lower[i]);
4578 generate_expr_decls (sym, sym->as->upper[i]);
4579 }
4580 }
4581 }
4582
4583
4584 /* Generate decls for all local variables. We do this to ensure correct
4585 handling of expressions which only appear in the specification of
4586 other functions. */
4587
4588 static void
4589 generate_local_decl (gfc_symbol * sym)
4590 {
4591 if (sym->attr.flavor == FL_VARIABLE)
4592 {
4593 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4594 && sym->attr.referenced && !sym->attr.use_assoc)
4595 has_coarray_vars = true;
4596
4597 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4598 generate_dependency_declarations (sym);
4599
4600 if (sym->attr.referenced)
4601 gfc_get_symbol_decl (sym);
4602
4603 /* Warnings for unused dummy arguments. */
4604 else if (sym->attr.dummy)
4605 {
4606 /* INTENT(out) dummy arguments are likely meant to be set. */
4607 if (gfc_option.warn_unused_dummy_argument
4608 && sym->attr.intent == INTENT_OUT)
4609 {
4610 if (sym->ts.type != BT_DERIVED)
4611 gfc_warning ("Dummy argument '%s' at %L was declared "
4612 "INTENT(OUT) but was not set", sym->name,
4613 &sym->declared_at);
4614 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4615 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4616 "declared INTENT(OUT) but was not set and "
4617 "does not have a default initializer",
4618 sym->name, &sym->declared_at);
4619 if (sym->backend_decl != NULL_TREE)
4620 TREE_NO_WARNING(sym->backend_decl) = 1;
4621 }
4622 else if (gfc_option.warn_unused_dummy_argument)
4623 {
4624 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4625 &sym->declared_at);
4626 if (sym->backend_decl != NULL_TREE)
4627 TREE_NO_WARNING(sym->backend_decl) = 1;
4628 }
4629 }
4630
4631 /* Warn for unused variables, but not if they're inside a common
4632 block or a namelist. */
4633 else if (warn_unused_variable
4634 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
4635 {
4636 if (sym->attr.use_only)
4637 {
4638 gfc_warning ("Unused module variable '%s' which has been "
4639 "explicitly imported at %L", sym->name,
4640 &sym->declared_at);
4641 if (sym->backend_decl != NULL_TREE)
4642 TREE_NO_WARNING(sym->backend_decl) = 1;
4643 }
4644 else if (!sym->attr.use_assoc)
4645 {
4646 gfc_warning ("Unused variable '%s' declared at %L",
4647 sym->name, &sym->declared_at);
4648 if (sym->backend_decl != NULL_TREE)
4649 TREE_NO_WARNING(sym->backend_decl) = 1;
4650 }
4651 }
4652
4653 /* For variable length CHARACTER parameters, the PARM_DECL already
4654 references the length variable, so force gfc_get_symbol_decl
4655 even when not referenced. If optimize > 0, it will be optimized
4656 away anyway. But do this only after emitting -Wunused-parameter
4657 warning if requested. */
4658 if (sym->attr.dummy && !sym->attr.referenced
4659 && sym->ts.type == BT_CHARACTER
4660 && sym->ts.u.cl->backend_decl != NULL
4661 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4662 {
4663 sym->attr.referenced = 1;
4664 gfc_get_symbol_decl (sym);
4665 }
4666
4667 /* INTENT(out) dummy arguments and result variables with allocatable
4668 components are reset by default and need to be set referenced to
4669 generate the code for nullification and automatic lengths. */
4670 if (!sym->attr.referenced
4671 && sym->ts.type == BT_DERIVED
4672 && sym->ts.u.derived->attr.alloc_comp
4673 && !sym->attr.pointer
4674 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4675 ||
4676 (sym->attr.result && sym != sym->result)))
4677 {
4678 sym->attr.referenced = 1;
4679 gfc_get_symbol_decl (sym);
4680 }
4681
4682 /* Check for dependencies in the array specification and string
4683 length, adding the necessary declarations to the function. We
4684 mark the symbol now, as well as in traverse_ns, to prevent
4685 getting stuck in a circular dependency. */
4686 sym->mark = 1;
4687 }
4688 else if (sym->attr.flavor == FL_PARAMETER)
4689 {
4690 if (warn_unused_parameter
4691 && !sym->attr.referenced)
4692 {
4693 if (!sym->attr.use_assoc)
4694 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4695 &sym->declared_at);
4696 else if (sym->attr.use_only)
4697 gfc_warning ("Unused parameter '%s' which has been explicitly "
4698 "imported at %L", sym->name, &sym->declared_at);
4699 }
4700 }
4701 else if (sym->attr.flavor == FL_PROCEDURE)
4702 {
4703 /* TODO: move to the appropriate place in resolve.c. */
4704 if (warn_return_type
4705 && sym->attr.function
4706 && sym->result
4707 && sym != sym->result
4708 && !sym->result->attr.referenced
4709 && !sym->attr.use_assoc
4710 && sym->attr.if_source != IFSRC_IFBODY)
4711 {
4712 gfc_warning ("Return value '%s' of function '%s' declared at "
4713 "%L not set", sym->result->name, sym->name,
4714 &sym->result->declared_at);
4715
4716 /* Prevents "Unused variable" warning for RESULT variables. */
4717 sym->result->mark = 1;
4718 }
4719 }
4720
4721 if (sym->attr.dummy == 1)
4722 {
4723 /* Modify the tree type for scalar character dummy arguments of bind(c)
4724 procedures if they are passed by value. The tree type for them will
4725 be promoted to INTEGER_TYPE for the middle end, which appears to be
4726 what C would do with characters passed by-value. The value attribute
4727 implies the dummy is a scalar. */
4728 if (sym->attr.value == 1 && sym->backend_decl != NULL
4729 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4730 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4731 gfc_conv_scalar_char_value (sym, NULL, NULL);
4732
4733 /* Unused procedure passed as dummy argument. */
4734 if (sym->attr.flavor == FL_PROCEDURE)
4735 {
4736 if (!sym->attr.referenced)
4737 {
4738 if (gfc_option.warn_unused_dummy_argument)
4739 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4740 &sym->declared_at);
4741 }
4742
4743 /* Silence bogus "unused parameter" warnings from the
4744 middle end. */
4745 if (sym->backend_decl != NULL_TREE)
4746 TREE_NO_WARNING (sym->backend_decl) = 1;
4747 }
4748 }
4749
4750 /* Make sure we convert the types of the derived types from iso_c_binding
4751 into (void *). */
4752 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4753 && sym->ts.type == BT_DERIVED)
4754 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4755 }
4756
4757 static void
4758 generate_local_vars (gfc_namespace * ns)
4759 {
4760 gfc_traverse_ns (ns, generate_local_decl);
4761 }
4762
4763
4764 /* Generate a switch statement to jump to the correct entry point. Also
4765 creates the label decls for the entry points. */
4766
4767 static tree
4768 gfc_trans_entry_master_switch (gfc_entry_list * el)
4769 {
4770 stmtblock_t block;
4771 tree label;
4772 tree tmp;
4773 tree val;
4774
4775 gfc_init_block (&block);
4776 for (; el; el = el->next)
4777 {
4778 /* Add the case label. */
4779 label = gfc_build_label_decl (NULL_TREE);
4780 val = build_int_cst (gfc_array_index_type, el->id);
4781 tmp = build_case_label (val, NULL_TREE, label);
4782 gfc_add_expr_to_block (&block, tmp);
4783
4784 /* And jump to the actual entry point. */
4785 label = gfc_build_label_decl (NULL_TREE);
4786 tmp = build1_v (GOTO_EXPR, label);
4787 gfc_add_expr_to_block (&block, tmp);
4788
4789 /* Save the label decl. */
4790 el->label = label;
4791 }
4792 tmp = gfc_finish_block (&block);
4793 /* The first argument selects the entry point. */
4794 val = DECL_ARGUMENTS (current_function_decl);
4795 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
4796 val, tmp, NULL_TREE);
4797 return tmp;
4798 }
4799
4800
4801 /* Add code to string lengths of actual arguments passed to a function against
4802 the expected lengths of the dummy arguments. */
4803
4804 static void
4805 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4806 {
4807 gfc_formal_arglist *formal;
4808
4809 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
4810 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
4811 && !formal->sym->ts.deferred)
4812 {
4813 enum tree_code comparison;
4814 tree cond;
4815 tree argname;
4816 gfc_symbol *fsym;
4817 gfc_charlen *cl;
4818 const char *message;
4819
4820 fsym = formal->sym;
4821 cl = fsym->ts.u.cl;
4822
4823 gcc_assert (cl);
4824 gcc_assert (cl->passed_length != NULL_TREE);
4825 gcc_assert (cl->backend_decl != NULL_TREE);
4826
4827 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4828 string lengths must match exactly. Otherwise, it is only required
4829 that the actual string length is *at least* the expected one.
4830 Sequence association allows for a mismatch of the string length
4831 if the actual argument is (part of) an array, but only if the
4832 dummy argument is an array. (See "Sequence association" in
4833 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4834 if (fsym->attr.pointer || fsym->attr.allocatable
4835 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
4836 || fsym->as->type == AS_ASSUMED_RANK)))
4837 {
4838 comparison = NE_EXPR;
4839 message = _("Actual string length does not match the declared one"
4840 " for dummy argument '%s' (%ld/%ld)");
4841 }
4842 else if (fsym->as && fsym->as->rank != 0)
4843 continue;
4844 else
4845 {
4846 comparison = LT_EXPR;
4847 message = _("Actual string length is shorter than the declared one"
4848 " for dummy argument '%s' (%ld/%ld)");
4849 }
4850
4851 /* Build the condition. For optional arguments, an actual length
4852 of 0 is also acceptable if the associated string is NULL, which
4853 means the argument was not passed. */
4854 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4855 cl->passed_length, cl->backend_decl);
4856 if (fsym->attr.optional)
4857 {
4858 tree not_absent;
4859 tree not_0length;
4860 tree absent_failed;
4861
4862 not_0length = fold_build2_loc (input_location, NE_EXPR,
4863 boolean_type_node,
4864 cl->passed_length,
4865 build_zero_cst (gfc_charlen_type_node));
4866 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4867 fsym->attr.referenced = 1;
4868 not_absent = gfc_conv_expr_present (fsym);
4869
4870 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4871 boolean_type_node, not_0length,
4872 not_absent);
4873
4874 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4875 boolean_type_node, cond, absent_failed);
4876 }
4877
4878 /* Build the runtime check. */
4879 argname = gfc_build_cstring_const (fsym->name);
4880 argname = gfc_build_addr_expr (pchar_type_node, argname);
4881 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4882 message, argname,
4883 fold_convert (long_integer_type_node,
4884 cl->passed_length),
4885 fold_convert (long_integer_type_node,
4886 cl->backend_decl));
4887 }
4888 }
4889
4890
4891 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4892 global variables for -fcoarray=lib. They are placed into the translation
4893 unit of the main program. Make sure that in one TU (the one of the main
4894 program), the first call to gfc_init_coarray_decl is done with true.
4895 Otherwise, expect link errors. */
4896
4897 void
4898 gfc_init_coarray_decl (bool main_tu)
4899 {
4900 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4901 return;
4902
4903 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4904 return;
4905
4906 push_cfun (cfun);
4907
4908 gfort_gvar_caf_this_image
4909 = build_decl (input_location, VAR_DECL,
4910 get_identifier (PREFIX("caf_this_image")),
4911 integer_type_node);
4912 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4913 TREE_USED (gfort_gvar_caf_this_image) = 1;
4914 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4915 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4916
4917 if (main_tu)
4918 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4919 else
4920 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4921
4922 pushdecl_top_level (gfort_gvar_caf_this_image);
4923
4924 gfort_gvar_caf_num_images
4925 = build_decl (input_location, VAR_DECL,
4926 get_identifier (PREFIX("caf_num_images")),
4927 integer_type_node);
4928 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4929 TREE_USED (gfort_gvar_caf_num_images) = 1;
4930 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4931 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4932
4933 if (main_tu)
4934 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4935 else
4936 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4937
4938 pushdecl_top_level (gfort_gvar_caf_num_images);
4939
4940 pop_cfun ();
4941 }
4942
4943
4944 static void
4945 create_main_function (tree fndecl)
4946 {
4947 tree old_context;
4948 tree ftn_main;
4949 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4950 stmtblock_t body;
4951
4952 old_context = current_function_decl;
4953
4954 if (old_context)
4955 {
4956 push_function_context ();
4957 saved_parent_function_decls = saved_function_decls;
4958 saved_function_decls = NULL_TREE;
4959 }
4960
4961 /* main() function must be declared with global scope. */
4962 gcc_assert (current_function_decl == NULL_TREE);
4963
4964 /* Declare the function. */
4965 tmp = build_function_type_list (integer_type_node, integer_type_node,
4966 build_pointer_type (pchar_type_node),
4967 NULL_TREE);
4968 main_identifier_node = get_identifier ("main");
4969 ftn_main = build_decl (input_location, FUNCTION_DECL,
4970 main_identifier_node, tmp);
4971 DECL_EXTERNAL (ftn_main) = 0;
4972 TREE_PUBLIC (ftn_main) = 1;
4973 TREE_STATIC (ftn_main) = 1;
4974 DECL_ATTRIBUTES (ftn_main)
4975 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4976
4977 /* Setup the result declaration (for "return 0"). */
4978 result_decl = build_decl (input_location,
4979 RESULT_DECL, NULL_TREE, integer_type_node);
4980 DECL_ARTIFICIAL (result_decl) = 1;
4981 DECL_IGNORED_P (result_decl) = 1;
4982 DECL_CONTEXT (result_decl) = ftn_main;
4983 DECL_RESULT (ftn_main) = result_decl;
4984
4985 pushdecl (ftn_main);
4986
4987 /* Get the arguments. */
4988
4989 arglist = NULL_TREE;
4990 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4991
4992 tmp = TREE_VALUE (typelist);
4993 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4994 DECL_CONTEXT (argc) = ftn_main;
4995 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4996 TREE_READONLY (argc) = 1;
4997 gfc_finish_decl (argc);
4998 arglist = chainon (arglist, argc);
4999
5000 typelist = TREE_CHAIN (typelist);
5001 tmp = TREE_VALUE (typelist);
5002 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
5003 DECL_CONTEXT (argv) = ftn_main;
5004 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
5005 TREE_READONLY (argv) = 1;
5006 DECL_BY_REFERENCE (argv) = 1;
5007 gfc_finish_decl (argv);
5008 arglist = chainon (arglist, argv);
5009
5010 DECL_ARGUMENTS (ftn_main) = arglist;
5011 current_function_decl = ftn_main;
5012 announce_function (ftn_main);
5013
5014 rest_of_decl_compilation (ftn_main, 1, 0);
5015 make_decl_rtl (ftn_main);
5016 allocate_struct_function (ftn_main, false);
5017 pushlevel ();
5018
5019 gfc_init_block (&body);
5020
5021 /* Call some libgfortran initialization routines, call then MAIN__(). */
5022
5023 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
5024 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5025 {
5026 tree pint_type, pppchar_type;
5027 pint_type = build_pointer_type (integer_type_node);
5028 pppchar_type
5029 = build_pointer_type (build_pointer_type (pchar_type_node));
5030
5031 gfc_init_coarray_decl (true);
5032 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
5033 gfc_build_addr_expr (pint_type, argc),
5034 gfc_build_addr_expr (pppchar_type, argv),
5035 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
5036 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
5037 gfc_add_expr_to_block (&body, tmp);
5038 }
5039
5040 /* Call _gfortran_set_args (argc, argv). */
5041 TREE_USED (argc) = 1;
5042 TREE_USED (argv) = 1;
5043 tmp = build_call_expr_loc (input_location,
5044 gfor_fndecl_set_args, 2, argc, argv);
5045 gfc_add_expr_to_block (&body, tmp);
5046
5047 /* Add a call to set_options to set up the runtime library Fortran
5048 language standard parameters. */
5049 {
5050 tree array_type, array, var;
5051 vec<constructor_elt, va_gc> *v = NULL;
5052
5053 /* Passing a new option to the library requires four modifications:
5054 + add it to the tree_cons list below
5055 + change the array size in the call to build_array_type
5056 + change the first argument to the library call
5057 gfor_fndecl_set_options
5058 + modify the library (runtime/compile_options.c)! */
5059
5060 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5061 build_int_cst (integer_type_node,
5062 gfc_option.warn_std));
5063 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5064 build_int_cst (integer_type_node,
5065 gfc_option.allow_std));
5066 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5067 build_int_cst (integer_type_node, pedantic));
5068 /* TODO: This is the old -fdump-core option, which is unused but
5069 passed due to ABI compatibility; remove when bumping the
5070 library ABI. */
5071 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5072 build_int_cst (integer_type_node,
5073 0));
5074 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5075 build_int_cst (integer_type_node,
5076 gfc_option.flag_backtrace));
5077 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5078 build_int_cst (integer_type_node,
5079 gfc_option.flag_sign_zero));
5080 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5081 build_int_cst (integer_type_node,
5082 (gfc_option.rtcheck
5083 & GFC_RTCHECK_BOUNDS)));
5084 /* TODO: This is the -frange-check option, which no longer affects
5085 library behavior; when bumping the library ABI this slot can be
5086 reused for something else. As it is the last element in the
5087 array, we can instead leave it out altogether.
5088 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5089 build_int_cst (integer_type_node,
5090 gfc_option.flag_range_check));
5091 */
5092
5093 array_type = build_array_type (integer_type_node,
5094 build_index_type (size_int (6)));
5095 array = build_constructor (array_type, v);
5096 TREE_CONSTANT (array) = 1;
5097 TREE_STATIC (array) = 1;
5098
5099 /* Create a static variable to hold the jump table. */
5100 var = gfc_create_var (array_type, "options");
5101 TREE_CONSTANT (var) = 1;
5102 TREE_STATIC (var) = 1;
5103 TREE_READONLY (var) = 1;
5104 DECL_INITIAL (var) = array;
5105 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5106
5107 tmp = build_call_expr_loc (input_location,
5108 gfor_fndecl_set_options, 2,
5109 build_int_cst (integer_type_node, 7), var);
5110 gfc_add_expr_to_block (&body, tmp);
5111 }
5112
5113 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5114 the library will raise a FPE when needed. */
5115 if (gfc_option.fpe != 0)
5116 {
5117 tmp = build_call_expr_loc (input_location,
5118 gfor_fndecl_set_fpe, 1,
5119 build_int_cst (integer_type_node,
5120 gfc_option.fpe));
5121 gfc_add_expr_to_block (&body, tmp);
5122 }
5123
5124 /* If this is the main program and an -fconvert option was provided,
5125 add a call to set_convert. */
5126
5127 if (gfc_option.convert != GFC_CONVERT_NATIVE)
5128 {
5129 tmp = build_call_expr_loc (input_location,
5130 gfor_fndecl_set_convert, 1,
5131 build_int_cst (integer_type_node,
5132 gfc_option.convert));
5133 gfc_add_expr_to_block (&body, tmp);
5134 }
5135
5136 /* If this is the main program and an -frecord-marker option was provided,
5137 add a call to set_record_marker. */
5138
5139 if (gfc_option.record_marker != 0)
5140 {
5141 tmp = build_call_expr_loc (input_location,
5142 gfor_fndecl_set_record_marker, 1,
5143 build_int_cst (integer_type_node,
5144 gfc_option.record_marker));
5145 gfc_add_expr_to_block (&body, tmp);
5146 }
5147
5148 if (gfc_option.max_subrecord_length != 0)
5149 {
5150 tmp = build_call_expr_loc (input_location,
5151 gfor_fndecl_set_max_subrecord_length, 1,
5152 build_int_cst (integer_type_node,
5153 gfc_option.max_subrecord_length));
5154 gfc_add_expr_to_block (&body, tmp);
5155 }
5156
5157 /* Call MAIN__(). */
5158 tmp = build_call_expr_loc (input_location,
5159 fndecl, 0);
5160 gfc_add_expr_to_block (&body, tmp);
5161
5162 /* Mark MAIN__ as used. */
5163 TREE_USED (fndecl) = 1;
5164
5165 /* Coarray: Call _gfortran_caf_finalize(void). */
5166 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5167 {
5168 /* Per F2008, 8.5.1 END of the main program implies a
5169 SYNC MEMORY. */
5170 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5171 tmp = build_call_expr_loc (input_location, tmp, 0);
5172 gfc_add_expr_to_block (&body, tmp);
5173
5174 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5175 gfc_add_expr_to_block (&body, tmp);
5176 }
5177
5178 /* "return 0". */
5179 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5180 DECL_RESULT (ftn_main),
5181 build_int_cst (integer_type_node, 0));
5182 tmp = build1_v (RETURN_EXPR, tmp);
5183 gfc_add_expr_to_block (&body, tmp);
5184
5185
5186 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5187 decl = getdecls ();
5188
5189 /* Finish off this function and send it for code generation. */
5190 poplevel (1, 1);
5191 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5192
5193 DECL_SAVED_TREE (ftn_main)
5194 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5195 DECL_INITIAL (ftn_main));
5196
5197 /* Output the GENERIC tree. */
5198 dump_function (TDI_original, ftn_main);
5199
5200 cgraph_finalize_function (ftn_main, true);
5201
5202 if (old_context)
5203 {
5204 pop_function_context ();
5205 saved_function_decls = saved_parent_function_decls;
5206 }
5207 current_function_decl = old_context;
5208 }
5209
5210
5211 /* Get the result expression for a procedure. */
5212
5213 static tree
5214 get_proc_result (gfc_symbol* sym)
5215 {
5216 if (sym->attr.subroutine || sym == sym->result)
5217 {
5218 if (current_fake_result_decl != NULL)
5219 return TREE_VALUE (current_fake_result_decl);
5220
5221 return NULL_TREE;
5222 }
5223
5224 return sym->result->backend_decl;
5225 }
5226
5227
5228 /* Generate an appropriate return-statement for a procedure. */
5229
5230 tree
5231 gfc_generate_return (void)
5232 {
5233 gfc_symbol* sym;
5234 tree result;
5235 tree fndecl;
5236
5237 sym = current_procedure_symbol;
5238 fndecl = sym->backend_decl;
5239
5240 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5241 result = NULL_TREE;
5242 else
5243 {
5244 result = get_proc_result (sym);
5245
5246 /* Set the return value to the dummy result variable. The
5247 types may be different for scalar default REAL functions
5248 with -ff2c, therefore we have to convert. */
5249 if (result != NULL_TREE)
5250 {
5251 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5252 result = fold_build2_loc (input_location, MODIFY_EXPR,
5253 TREE_TYPE (result), DECL_RESULT (fndecl),
5254 result);
5255 }
5256 }
5257
5258 return build1_v (RETURN_EXPR, result);
5259 }
5260
5261
5262 /* Generate code for a function. */
5263
5264 void
5265 gfc_generate_function_code (gfc_namespace * ns)
5266 {
5267 tree fndecl;
5268 tree old_context;
5269 tree decl;
5270 tree tmp;
5271 stmtblock_t init, cleanup;
5272 stmtblock_t body;
5273 gfc_wrapped_block try_block;
5274 tree recurcheckvar = NULL_TREE;
5275 gfc_symbol *sym;
5276 gfc_symbol *previous_procedure_symbol;
5277 int rank;
5278 bool is_recursive;
5279
5280 sym = ns->proc_name;
5281 previous_procedure_symbol = current_procedure_symbol;
5282 current_procedure_symbol = sym;
5283
5284 /* Check that the frontend isn't still using this. */
5285 gcc_assert (sym->tlink == NULL);
5286 sym->tlink = sym;
5287
5288 /* Create the declaration for functions with global scope. */
5289 if (!sym->backend_decl)
5290 gfc_create_function_decl (ns, false);
5291
5292 fndecl = sym->backend_decl;
5293 old_context = current_function_decl;
5294
5295 if (old_context)
5296 {
5297 push_function_context ();
5298 saved_parent_function_decls = saved_function_decls;
5299 saved_function_decls = NULL_TREE;
5300 }
5301
5302 trans_function_start (sym);
5303
5304 gfc_init_block (&init);
5305
5306 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5307 {
5308 /* Copy length backend_decls to all entry point result
5309 symbols. */
5310 gfc_entry_list *el;
5311 tree backend_decl;
5312
5313 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5314 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5315 for (el = ns->entries; el; el = el->next)
5316 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5317 }
5318
5319 /* Translate COMMON blocks. */
5320 gfc_trans_common (ns);
5321
5322 /* Null the parent fake result declaration if this namespace is
5323 a module function or an external procedures. */
5324 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5325 || ns->parent == NULL)
5326 parent_fake_result_decl = NULL_TREE;
5327
5328 gfc_generate_contained_functions (ns);
5329
5330 nonlocal_dummy_decls = NULL;
5331 nonlocal_dummy_decl_pset = NULL;
5332
5333 has_coarray_vars = false;
5334 generate_local_vars (ns);
5335
5336 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5337 generate_coarray_init (ns);
5338
5339 /* Keep the parent fake result declaration in module functions
5340 or external procedures. */
5341 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5342 || ns->parent == NULL)
5343 current_fake_result_decl = parent_fake_result_decl;
5344 else
5345 current_fake_result_decl = NULL_TREE;
5346
5347 is_recursive = sym->attr.recursive
5348 || (sym->attr.entry_master
5349 && sym->ns->entries->sym->attr.recursive);
5350 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5351 && !is_recursive
5352 && !gfc_option.flag_recursive)
5353 {
5354 char * msg;
5355
5356 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5357 sym->name);
5358 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5359 TREE_STATIC (recurcheckvar) = 1;
5360 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5361 gfc_add_expr_to_block (&init, recurcheckvar);
5362 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5363 &sym->declared_at, msg);
5364 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5365 free (msg);
5366 }
5367
5368 /* Now generate the code for the body of this function. */
5369 gfc_init_block (&body);
5370
5371 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5372 && sym->attr.subroutine)
5373 {
5374 tree alternate_return;
5375 alternate_return = gfc_get_fake_result_decl (sym, 0);
5376 gfc_add_modify (&body, alternate_return, integer_zero_node);
5377 }
5378
5379 if (ns->entries)
5380 {
5381 /* Jump to the correct entry point. */
5382 tmp = gfc_trans_entry_master_switch (ns->entries);
5383 gfc_add_expr_to_block (&body, tmp);
5384 }
5385
5386 /* If bounds-checking is enabled, generate code to check passed in actual
5387 arguments against the expected dummy argument attributes (e.g. string
5388 lengths). */
5389 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5390 add_argument_checking (&body, sym);
5391
5392 tmp = gfc_trans_code (ns->code);
5393 gfc_add_expr_to_block (&body, tmp);
5394
5395 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5396 {
5397 tree result = get_proc_result (sym);
5398
5399 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5400 {
5401 if (sym->attr.allocatable && sym->attr.dimension == 0
5402 && sym->result == sym)
5403 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5404 null_pointer_node));
5405 else if (sym->ts.type == BT_CLASS
5406 && CLASS_DATA (sym)->attr.allocatable
5407 && CLASS_DATA (sym)->attr.dimension == 0
5408 && sym->result == sym)
5409 {
5410 tmp = CLASS_DATA (sym)->backend_decl;
5411 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5412 TREE_TYPE (tmp), result, tmp, NULL_TREE);
5413 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5414 null_pointer_node));
5415 }
5416 else if (sym->ts.type == BT_DERIVED
5417 && sym->ts.u.derived->attr.alloc_comp
5418 && !sym->attr.allocatable)
5419 {
5420 rank = sym->as ? sym->as->rank : 0;
5421 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5422 gfc_add_expr_to_block (&init, tmp);
5423 }
5424 }
5425
5426 if (result == NULL_TREE)
5427 {
5428 /* TODO: move to the appropriate place in resolve.c. */
5429 if (warn_return_type && sym == sym->result)
5430 gfc_warning ("Return value of function '%s' at %L not set",
5431 sym->name, &sym->declared_at);
5432 if (warn_return_type)
5433 TREE_NO_WARNING(sym->backend_decl) = 1;
5434 }
5435 else
5436 gfc_add_expr_to_block (&body, gfc_generate_return ());
5437 }
5438
5439 gfc_init_block (&cleanup);
5440
5441 /* Reset recursion-check variable. */
5442 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5443 && !is_recursive
5444 && !gfc_option.gfc_flag_openmp
5445 && recurcheckvar != NULL_TREE)
5446 {
5447 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5448 recurcheckvar = NULL;
5449 }
5450
5451 /* Finish the function body and add init and cleanup code. */
5452 tmp = gfc_finish_block (&body);
5453 gfc_start_wrapped_block (&try_block, tmp);
5454 /* Add code to create and cleanup arrays. */
5455 gfc_trans_deferred_vars (sym, &try_block);
5456 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5457 gfc_finish_block (&cleanup));
5458
5459 /* Add all the decls we created during processing. */
5460 decl = saved_function_decls;
5461 while (decl)
5462 {
5463 tree next;
5464
5465 next = DECL_CHAIN (decl);
5466 DECL_CHAIN (decl) = NULL_TREE;
5467 pushdecl (decl);
5468 decl = next;
5469 }
5470 saved_function_decls = NULL_TREE;
5471
5472 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5473 decl = getdecls ();
5474
5475 /* Finish off this function and send it for code generation. */
5476 poplevel (1, 1);
5477 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5478
5479 DECL_SAVED_TREE (fndecl)
5480 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5481 DECL_INITIAL (fndecl));
5482
5483 if (nonlocal_dummy_decls)
5484 {
5485 BLOCK_VARS (DECL_INITIAL (fndecl))
5486 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5487 pointer_set_destroy (nonlocal_dummy_decl_pset);
5488 nonlocal_dummy_decls = NULL;
5489 nonlocal_dummy_decl_pset = NULL;
5490 }
5491
5492 /* Output the GENERIC tree. */
5493 dump_function (TDI_original, fndecl);
5494
5495 /* Store the end of the function, so that we get good line number
5496 info for the epilogue. */
5497 cfun->function_end_locus = input_location;
5498
5499 /* We're leaving the context of this function, so zap cfun.
5500 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5501 tree_rest_of_compilation. */
5502 set_cfun (NULL);
5503
5504 if (old_context)
5505 {
5506 pop_function_context ();
5507 saved_function_decls = saved_parent_function_decls;
5508 }
5509 current_function_decl = old_context;
5510
5511 if (decl_function_context (fndecl) && gfc_option.coarray != GFC_FCOARRAY_LIB
5512 && has_coarray_vars)
5513 /* Register this function with cgraph just far enough to get it
5514 added to our parent's nested function list.
5515 If there are static coarrays in this function, the nested _caf_init
5516 function has already called cgraph_create_node, which also created
5517 the cgraph node for this function. */
5518 (void) cgraph_create_node (fndecl);
5519 else
5520 cgraph_finalize_function (fndecl, true);
5521
5522 gfc_trans_use_stmts (ns);
5523 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5524
5525 if (sym->attr.is_main_program)
5526 create_main_function (fndecl);
5527
5528 current_procedure_symbol = previous_procedure_symbol;
5529 }
5530
5531
5532 void
5533 gfc_generate_constructors (void)
5534 {
5535 gcc_assert (gfc_static_ctors == NULL_TREE);
5536 #if 0
5537 tree fnname;
5538 tree type;
5539 tree fndecl;
5540 tree decl;
5541 tree tmp;
5542
5543 if (gfc_static_ctors == NULL_TREE)
5544 return;
5545
5546 fnname = get_file_function_name ("I");
5547 type = build_function_type_list (void_type_node, NULL_TREE);
5548
5549 fndecl = build_decl (input_location,
5550 FUNCTION_DECL, fnname, type);
5551 TREE_PUBLIC (fndecl) = 1;
5552
5553 decl = build_decl (input_location,
5554 RESULT_DECL, NULL_TREE, void_type_node);
5555 DECL_ARTIFICIAL (decl) = 1;
5556 DECL_IGNORED_P (decl) = 1;
5557 DECL_CONTEXT (decl) = fndecl;
5558 DECL_RESULT (fndecl) = decl;
5559
5560 pushdecl (fndecl);
5561
5562 current_function_decl = fndecl;
5563
5564 rest_of_decl_compilation (fndecl, 1, 0);
5565
5566 make_decl_rtl (fndecl);
5567
5568 allocate_struct_function (fndecl, false);
5569
5570 pushlevel ();
5571
5572 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5573 {
5574 tmp = build_call_expr_loc (input_location,
5575 TREE_VALUE (gfc_static_ctors), 0);
5576 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5577 }
5578
5579 decl = getdecls ();
5580 poplevel (1, 1);
5581
5582 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5583 DECL_SAVED_TREE (fndecl)
5584 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5585 DECL_INITIAL (fndecl));
5586
5587 free_after_parsing (cfun);
5588 free_after_compilation (cfun);
5589
5590 tree_rest_of_compilation (fndecl);
5591
5592 current_function_decl = NULL_TREE;
5593 #endif
5594 }
5595
5596 /* Translates a BLOCK DATA program unit. This means emitting the
5597 commons contained therein plus their initializations. We also emit
5598 a globally visible symbol to make sure that each BLOCK DATA program
5599 unit remains unique. */
5600
5601 void
5602 gfc_generate_block_data (gfc_namespace * ns)
5603 {
5604 tree decl;
5605 tree id;
5606
5607 /* Tell the backend the source location of the block data. */
5608 if (ns->proc_name)
5609 gfc_set_backend_locus (&ns->proc_name->declared_at);
5610 else
5611 gfc_set_backend_locus (&gfc_current_locus);
5612
5613 /* Process the DATA statements. */
5614 gfc_trans_common (ns);
5615
5616 /* Create a global symbol with the mane of the block data. This is to
5617 generate linker errors if the same name is used twice. It is never
5618 really used. */
5619 if (ns->proc_name)
5620 id = gfc_sym_mangled_function_id (ns->proc_name);
5621 else
5622 id = get_identifier ("__BLOCK_DATA__");
5623
5624 decl = build_decl (input_location,
5625 VAR_DECL, id, gfc_array_index_type);
5626 TREE_PUBLIC (decl) = 1;
5627 TREE_STATIC (decl) = 1;
5628 DECL_IGNORED_P (decl) = 1;
5629
5630 pushdecl (decl);
5631 rest_of_decl_compilation (decl, 1, 0);
5632 }
5633
5634
5635 /* Process the local variables of a BLOCK construct. */
5636
5637 void
5638 gfc_process_block_locals (gfc_namespace* ns)
5639 {
5640 tree decl;
5641
5642 gcc_assert (saved_local_decls == NULL_TREE);
5643 has_coarray_vars = false;
5644
5645 generate_local_vars (ns);
5646
5647 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5648 generate_coarray_init (ns);
5649
5650 decl = saved_local_decls;
5651 while (decl)
5652 {
5653 tree next;
5654
5655 next = DECL_CHAIN (decl);
5656 DECL_CHAIN (decl) = NULL_TREE;
5657 pushdecl (decl);
5658 decl = next;
5659 }
5660 saved_local_decls = NULL_TREE;
5661 }
5662
5663
5664 #include "gt-fortran-trans-decl.h"