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