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