?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2011-12-11 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-decl.c
blob1f1696feaf2e82ca7ea23d9f80c1d3be814b4728
1 /* Backend function setup
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 2011
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_critical;
125 tree gfor_fndecl_caf_end_critical;
126 tree gfor_fndecl_caf_sync_all;
127 tree gfor_fndecl_caf_sync_images;
128 tree gfor_fndecl_caf_error_stop;
129 tree gfor_fndecl_caf_error_stop_str;
130
131 /* Coarray global variables for num_images/this_image. */
132
133 tree gfort_gvar_caf_num_images;
134 tree gfort_gvar_caf_this_image;
135
136
137 /* Math functions. Many other math functions are handled in
138 trans-intrinsic.c. */
139
140 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
141 tree gfor_fndecl_math_ishftc4;
142 tree gfor_fndecl_math_ishftc8;
143 tree gfor_fndecl_math_ishftc16;
144
145
146 /* String functions. */
147
148 tree gfor_fndecl_compare_string;
149 tree gfor_fndecl_concat_string;
150 tree gfor_fndecl_string_len_trim;
151 tree gfor_fndecl_string_index;
152 tree gfor_fndecl_string_scan;
153 tree gfor_fndecl_string_verify;
154 tree gfor_fndecl_string_trim;
155 tree gfor_fndecl_string_minmax;
156 tree gfor_fndecl_adjustl;
157 tree gfor_fndecl_adjustr;
158 tree gfor_fndecl_select_string;
159 tree gfor_fndecl_compare_string_char4;
160 tree gfor_fndecl_concat_string_char4;
161 tree gfor_fndecl_string_len_trim_char4;
162 tree gfor_fndecl_string_index_char4;
163 tree gfor_fndecl_string_scan_char4;
164 tree gfor_fndecl_string_verify_char4;
165 tree gfor_fndecl_string_trim_char4;
166 tree gfor_fndecl_string_minmax_char4;
167 tree gfor_fndecl_adjustl_char4;
168 tree gfor_fndecl_adjustr_char4;
169 tree gfor_fndecl_select_string_char4;
170
171
172 /* Conversion between character kinds. */
173 tree gfor_fndecl_convert_char1_to_char4;
174 tree gfor_fndecl_convert_char4_to_char1;
175
176
177 /* Other misc. runtime library functions. */
178 tree gfor_fndecl_size0;
179 tree gfor_fndecl_size1;
180 tree gfor_fndecl_iargc;
181
182 /* Intrinsic functions implemented in Fortran. */
183 tree gfor_fndecl_sc_kind;
184 tree gfor_fndecl_si_kind;
185 tree gfor_fndecl_sr_kind;
186
187 /* BLAS gemm functions. */
188 tree gfor_fndecl_sgemm;
189 tree gfor_fndecl_dgemm;
190 tree gfor_fndecl_cgemm;
191 tree gfor_fndecl_zgemm;
192
193
194 static void
195 gfc_add_decl_to_parent_function (tree decl)
196 {
197 gcc_assert (decl);
198 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
199 DECL_NONLOCAL (decl) = 1;
200 DECL_CHAIN (decl) = saved_parent_function_decls;
201 saved_parent_function_decls = decl;
202 }
203
204 void
205 gfc_add_decl_to_function (tree decl)
206 {
207 gcc_assert (decl);
208 TREE_USED (decl) = 1;
209 DECL_CONTEXT (decl) = current_function_decl;
210 DECL_CHAIN (decl) = saved_function_decls;
211 saved_function_decls = decl;
212 }
213
214 static void
215 add_decl_as_local (tree decl)
216 {
217 gcc_assert (decl);
218 TREE_USED (decl) = 1;
219 DECL_CONTEXT (decl) = current_function_decl;
220 DECL_CHAIN (decl) = saved_local_decls;
221 saved_local_decls = decl;
222 }
223
224
225 /* Build a backend label declaration. Set TREE_USED for named labels.
226 The context of the label is always the current_function_decl. All
227 labels are marked artificial. */
228
229 tree
230 gfc_build_label_decl (tree label_id)
231 {
232 /* 2^32 temporaries should be enough. */
233 static unsigned int tmp_num = 1;
234 tree label_decl;
235 char *label_name;
236
237 if (label_id == NULL_TREE)
238 {
239 /* Build an internal label name. */
240 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
241 label_id = get_identifier (label_name);
242 }
243 else
244 label_name = NULL;
245
246 /* Build the LABEL_DECL node. Labels have no type. */
247 label_decl = build_decl (input_location,
248 LABEL_DECL, label_id, void_type_node);
249 DECL_CONTEXT (label_decl) = current_function_decl;
250 DECL_MODE (label_decl) = VOIDmode;
251
252 /* We always define the label as used, even if the original source
253 file never references the label. We don't want all kinds of
254 spurious warnings for old-style Fortran code with too many
255 labels. */
256 TREE_USED (label_decl) = 1;
257
258 DECL_ARTIFICIAL (label_decl) = 1;
259 return label_decl;
260 }
261
262
263 /* Set the backend source location of a decl. */
264
265 void
266 gfc_set_decl_location (tree decl, locus * loc)
267 {
268 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
269 }
270
271
272 /* Return the backend label declaration for a given label structure,
273 or create it if it doesn't exist yet. */
274
275 tree
276 gfc_get_label_decl (gfc_st_label * lp)
277 {
278 if (lp->backend_decl)
279 return lp->backend_decl;
280 else
281 {
282 char label_name[GFC_MAX_SYMBOL_LEN + 1];
283 tree label_decl;
284
285 /* Validate the label declaration from the front end. */
286 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
287
288 /* Build a mangled name for the label. */
289 sprintf (label_name, "__label_%.6d", lp->value);
290
291 /* Build the LABEL_DECL node. */
292 label_decl = gfc_build_label_decl (get_identifier (label_name));
293
294 /* Tell the debugger where the label came from. */
295 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
296 gfc_set_decl_location (label_decl, &lp->where);
297 else
298 DECL_ARTIFICIAL (label_decl) = 1;
299
300 /* Store the label in the label list and return the LABEL_DECL. */
301 lp->backend_decl = label_decl;
302 return label_decl;
303 }
304 }
305
306
307 /* Convert a gfc_symbol to an identifier of the same name. */
308
309 static tree
310 gfc_sym_identifier (gfc_symbol * sym)
311 {
312 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
313 return (get_identifier ("MAIN__"));
314 else
315 return (get_identifier (sym->name));
316 }
317
318
319 /* Construct mangled name from symbol name. */
320
321 static tree
322 gfc_sym_mangled_identifier (gfc_symbol * sym)
323 {
324 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
325
326 /* Prevent the mangling of identifiers that have an assigned
327 binding label (mainly those that are bind(c)). */
328 if (sym->attr.is_bind_c == 1
329 && sym->binding_label[0] != '\0')
330 return get_identifier(sym->binding_label);
331
332 if (sym->module == NULL)
333 return gfc_sym_identifier (sym);
334 else
335 {
336 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
337 return get_identifier (name);
338 }
339 }
340
341
342 /* Construct mangled function name from symbol name. */
343
344 static tree
345 gfc_sym_mangled_function_id (gfc_symbol * sym)
346 {
347 int has_underscore;
348 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
349
350 /* It may be possible to simply use the binding label if it's
351 provided, and remove the other checks. Then we could use it
352 for other things if we wished. */
353 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
354 sym->binding_label[0] != '\0')
355 /* use the binding label rather than the mangled name */
356 return get_identifier (sym->binding_label);
357
358 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
359 || (sym->module != NULL && (sym->attr.external
360 || sym->attr.if_source == IFSRC_IFBODY)))
361 {
362 /* Main program is mangled into MAIN__. */
363 if (sym->attr.is_main_program)
364 return get_identifier ("MAIN__");
365
366 /* Intrinsic procedures are never mangled. */
367 if (sym->attr.proc == PROC_INTRINSIC)
368 return get_identifier (sym->name);
369
370 if (gfc_option.flag_underscoring)
371 {
372 has_underscore = strchr (sym->name, '_') != 0;
373 if (gfc_option.flag_second_underscore && has_underscore)
374 snprintf (name, sizeof name, "%s__", sym->name);
375 else
376 snprintf (name, sizeof name, "%s_", sym->name);
377 return get_identifier (name);
378 }
379 else
380 return get_identifier (sym->name);
381 }
382 else
383 {
384 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
385 return get_identifier (name);
386 }
387 }
388
389
390 void
391 gfc_set_decl_assembler_name (tree decl, tree name)
392 {
393 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
394 SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
395 }
396
397
398 /* Returns true if a variable of specified size should go on the stack. */
399
400 int
401 gfc_can_put_var_on_stack (tree size)
402 {
403 unsigned HOST_WIDE_INT low;
404
405 if (!INTEGER_CST_P (size))
406 return 0;
407
408 if (gfc_option.flag_max_stack_var_size < 0)
409 return 1;
410
411 if (TREE_INT_CST_HIGH (size) != 0)
412 return 0;
413
414 low = TREE_INT_CST_LOW (size);
415 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
416 return 0;
417
418 /* TODO: Set a per-function stack size limit. */
419
420 return 1;
421 }
422
423
424 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
425 an expression involving its corresponding pointer. There are
426 2 cases; one for variable size arrays, and one for everything else,
427 because variable-sized arrays require one fewer level of
428 indirection. */
429
430 static void
431 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
432 {
433 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
434 tree value;
435
436 /* Parameters need to be dereferenced. */
437 if (sym->cp_pointer->attr.dummy)
438 ptr_decl = build_fold_indirect_ref_loc (input_location,
439 ptr_decl);
440
441 /* Check to see if we're dealing with a variable-sized array. */
442 if (sym->attr.dimension
443 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
444 {
445 /* These decls will be dereferenced later, so we don't dereference
446 them here. */
447 value = convert (TREE_TYPE (decl), ptr_decl);
448 }
449 else
450 {
451 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
452 ptr_decl);
453 value = build_fold_indirect_ref_loc (input_location,
454 ptr_decl);
455 }
456
457 SET_DECL_VALUE_EXPR (decl, value);
458 DECL_HAS_VALUE_EXPR_P (decl) = 1;
459 GFC_DECL_CRAY_POINTEE (decl) = 1;
460 /* This is a fake variable just for debugging purposes. */
461 TREE_ASM_WRITTEN (decl) = 1;
462 }
463
464
465 /* Finish processing of a declaration without an initial value. */
466
467 static void
468 gfc_finish_decl (tree decl)
469 {
470 gcc_assert (TREE_CODE (decl) == PARM_DECL
471 || DECL_INITIAL (decl) == NULL_TREE);
472
473 if (TREE_CODE (decl) != VAR_DECL)
474 return;
475
476 if (DECL_SIZE (decl) == NULL_TREE
477 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
478 layout_decl (decl, 0);
479
480 /* A few consistency checks. */
481 /* A static variable with an incomplete type is an error if it is
482 initialized. Also if it is not file scope. Otherwise, let it
483 through, but if it is not `extern' then it may cause an error
484 message later. */
485 /* An automatic variable with an incomplete type is an error. */
486
487 /* We should know the storage size. */
488 gcc_assert (DECL_SIZE (decl) != NULL_TREE
489 || (TREE_STATIC (decl)
490 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
491 : DECL_EXTERNAL (decl)));
492
493 /* The storage size should be constant. */
494 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
495 || !DECL_SIZE (decl)
496 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
497 }
498
499
500 /* Apply symbol attributes to a variable, and add it to the function scope. */
501
502 static void
503 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
504 {
505 tree new_type;
506 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
507 This is the equivalent of the TARGET variables.
508 We also need to set this if the variable is passed by reference in a
509 CALL statement. */
510
511 /* Set DECL_VALUE_EXPR for Cray Pointees. */
512 if (sym->attr.cray_pointee)
513 gfc_finish_cray_pointee (decl, sym);
514
515 if (sym->attr.target)
516 TREE_ADDRESSABLE (decl) = 1;
517 /* If it wasn't used we wouldn't be getting it. */
518 TREE_USED (decl) = 1;
519
520 if (sym->attr.flavor == FL_PARAMETER
521 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
522 TREE_READONLY (decl) = 1;
523
524 /* Chain this decl to the pending declarations. Don't do pushdecl()
525 because this would add them to the current scope rather than the
526 function scope. */
527 if (current_function_decl != NULL_TREE)
528 {
529 if (sym->ns->proc_name->backend_decl == current_function_decl
530 || sym->result == sym)
531 gfc_add_decl_to_function (decl);
532 else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
533 /* This is a BLOCK construct. */
534 add_decl_as_local (decl);
535 else
536 gfc_add_decl_to_parent_function (decl);
537 }
538
539 if (sym->attr.cray_pointee)
540 return;
541
542 if(sym->attr.is_bind_c == 1)
543 {
544 /* We need to put variables that are bind(c) into the common
545 segment of the object file, because this is what C would do.
546 gfortran would typically put them in either the BSS or
547 initialized data segments, and only mark them as common if
548 they were part of common blocks. However, if they are not put
549 into common space, then C cannot initialize global Fortran
550 variables that it interoperates with and the draft says that
551 either Fortran or C should be able to initialize it (but not
552 both, of course.) (J3/04-007, section 15.3). */
553 TREE_PUBLIC(decl) = 1;
554 DECL_COMMON(decl) = 1;
555 }
556
557 /* If a variable is USE associated, it's always external. */
558 if (sym->attr.use_assoc)
559 {
560 DECL_EXTERNAL (decl) = 1;
561 TREE_PUBLIC (decl) = 1;
562 }
563 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
564 {
565 /* TODO: Don't set sym->module for result or dummy variables. */
566 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
567 /* This is the declaration of a module variable. */
568 TREE_PUBLIC (decl) = 1;
569 TREE_STATIC (decl) = 1;
570 }
571
572 /* Derived types are a bit peculiar because of the possibility of
573 a default initializer; this must be applied each time the variable
574 comes into scope it therefore need not be static. These variables
575 are SAVE_NONE but have an initializer. Otherwise explicitly
576 initialized variables are SAVE_IMPLICIT and explicitly saved are
577 SAVE_EXPLICIT. */
578 if (!sym->attr.use_assoc
579 && (sym->attr.save != SAVE_NONE || sym->attr.data
580 || (sym->value && sym->ns->proc_name->attr.is_main_program)
581 || (gfc_option.coarray == GFC_FCOARRAY_LIB
582 && sym->attr.codimension && !sym->attr.allocatable)))
583 TREE_STATIC (decl) = 1;
584
585 if (sym->attr.volatile_)
586 {
587 TREE_THIS_VOLATILE (decl) = 1;
588 TREE_SIDE_EFFECTS (decl) = 1;
589 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
590 TREE_TYPE (decl) = new_type;
591 }
592
593 /* Keep variables larger than max-stack-var-size off stack. */
594 if (!sym->ns->proc_name->attr.recursive
595 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
596 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
597 /* Put variable length auto array pointers always into stack. */
598 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
599 || sym->attr.dimension == 0
600 || sym->as->type != AS_EXPLICIT
601 || sym->attr.pointer
602 || sym->attr.allocatable)
603 && !DECL_ARTIFICIAL (decl))
604 TREE_STATIC (decl) = 1;
605
606 /* Handle threadprivate variables. */
607 if (sym->attr.threadprivate
608 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
609 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
610
611 if (!sym->attr.target
612 && !sym->attr.pointer
613 && !sym->attr.cray_pointee
614 && !sym->attr.proc_pointer)
615 DECL_RESTRICTED_P (decl) = 1;
616 }
617
618
619 /* Allocate the lang-specific part of a decl. */
620
621 void
622 gfc_allocate_lang_decl (tree decl)
623 {
624 DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
625 (struct lang_decl));
626 }
627
628 /* Remember a symbol to generate initialization/cleanup code at function
629 entry/exit. */
630
631 static void
632 gfc_defer_symbol_init (gfc_symbol * sym)
633 {
634 gfc_symbol *p;
635 gfc_symbol *last;
636 gfc_symbol *head;
637
638 /* Don't add a symbol twice. */
639 if (sym->tlink)
640 return;
641
642 last = head = sym->ns->proc_name;
643 p = last->tlink;
644
645 /* Make sure that setup code for dummy variables which are used in the
646 setup of other variables is generated first. */
647 if (sym->attr.dummy)
648 {
649 /* Find the first dummy arg seen after us, or the first non-dummy arg.
650 This is a circular list, so don't go past the head. */
651 while (p != head
652 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
653 {
654 last = p;
655 p = p->tlink;
656 }
657 }
658 /* Insert in between last and p. */
659 last->tlink = sym;
660 sym->tlink = p;
661 }
662
663
664 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
665 backend_decl for a module symbol, if it all ready exists. If the
666 module gsymbol does not exist, it is created. If the symbol does
667 not exist, it is added to the gsymbol namespace. Returns true if
668 an existing backend_decl is found. */
669
670 bool
671 gfc_get_module_backend_decl (gfc_symbol *sym)
672 {
673 gfc_gsymbol *gsym;
674 gfc_symbol *s;
675 gfc_symtree *st;
676
677 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
678
679 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
680 {
681 st = NULL;
682 s = NULL;
683
684 if (gsym)
685 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
686
687 if (!s)
688 {
689 if (!gsym)
690 {
691 gsym = gfc_get_gsymbol (sym->module);
692 gsym->type = GSYM_MODULE;
693 gsym->ns = gfc_get_namespace (NULL, 0);
694 }
695
696 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
697 st->n.sym = sym;
698 sym->refs++;
699 }
700 else if (sym->attr.flavor == FL_DERIVED)
701 {
702 if (s && s->attr.flavor == FL_PROCEDURE)
703 {
704 gfc_interface *intr;
705 gcc_assert (s->attr.generic);
706 for (intr = s->generic; intr; intr = intr->next)
707 if (intr->sym->attr.flavor == FL_DERIVED)
708 {
709 s = intr->sym;
710 break;
711 }
712 }
713
714 if (!s->backend_decl)
715 s->backend_decl = gfc_get_derived_type (s);
716 gfc_copy_dt_decls_ifequal (s, sym, true);
717 return true;
718 }
719 else if (s->backend_decl)
720 {
721 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
722 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
723 true);
724 else if (sym->ts.type == BT_CHARACTER)
725 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
726 sym->backend_decl = s->backend_decl;
727 return true;
728 }
729 }
730 return false;
731 }
732
733
734 /* Create an array index type variable with function scope. */
735
736 static tree
737 create_index_var (const char * pfx, int nest)
738 {
739 tree decl;
740
741 decl = gfc_create_var_np (gfc_array_index_type, pfx);
742 if (nest)
743 gfc_add_decl_to_parent_function (decl);
744 else
745 gfc_add_decl_to_function (decl);
746 return decl;
747 }
748
749
750 /* Create variables to hold all the non-constant bits of info for a
751 descriptorless array. Remember these in the lang-specific part of the
752 type. */
753
754 static void
755 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
756 {
757 tree type;
758 int dim;
759 int nest;
760 gfc_namespace* procns;
761
762 type = TREE_TYPE (decl);
763
764 /* We just use the descriptor, if there is one. */
765 if (GFC_DESCRIPTOR_TYPE_P (type))
766 return;
767
768 gcc_assert (GFC_ARRAY_TYPE_P (type));
769 procns = gfc_find_proc_namespace (sym->ns);
770 nest = (procns->proc_name->backend_decl != current_function_decl)
771 && !sym->attr.contained;
772
773 if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
774 && sym->as->type != AS_ASSUMED_SHAPE
775 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
776 {
777 tree token;
778
779 token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
780 TYPE_QUAL_RESTRICT),
781 "caf_token");
782 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
783 DECL_ARTIFICIAL (token) = 1;
784 TREE_STATIC (token) = 1;
785 gfc_add_decl_to_function (token);
786 }
787
788 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
789 {
790 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
791 {
792 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
793 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
794 }
795 /* Don't try to use the unknown bound for assumed shape arrays. */
796 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
797 && (sym->as->type != AS_ASSUMED_SIZE
798 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
799 {
800 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
801 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
802 }
803
804 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
805 {
806 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
807 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
808 }
809 }
810 for (dim = GFC_TYPE_ARRAY_RANK (type);
811 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
812 {
813 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
814 {
815 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
816 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
817 }
818 /* Don't try to use the unknown ubound for the last coarray dimension. */
819 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
820 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
821 {
822 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
823 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
824 }
825 }
826 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
827 {
828 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
829 "offset");
830 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
831
832 if (nest)
833 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
834 else
835 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
836 }
837
838 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
839 && sym->as->type != AS_ASSUMED_SIZE)
840 {
841 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
842 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
843 }
844
845 if (POINTER_TYPE_P (type))
846 {
847 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
848 gcc_assert (TYPE_LANG_SPECIFIC (type)
849 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
850 type = TREE_TYPE (type);
851 }
852
853 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
854 {
855 tree size, range;
856
857 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
858 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
859 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
860 size);
861 TYPE_DOMAIN (type) = range;
862 layout_type (type);
863 }
864
865 if (TYPE_NAME (type) != NULL_TREE
866 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
867 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
868 {
869 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
870
871 for (dim = 0; dim < sym->as->rank - 1; dim++)
872 {
873 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
874 gtype = TREE_TYPE (gtype);
875 }
876 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
877 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
878 TYPE_NAME (type) = NULL_TREE;
879 }
880
881 if (TYPE_NAME (type) == NULL_TREE)
882 {
883 tree gtype = TREE_TYPE (type), rtype, type_decl;
884
885 for (dim = sym->as->rank - 1; dim >= 0; dim--)
886 {
887 tree lbound, ubound;
888 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
889 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
890 rtype = build_range_type (gfc_array_index_type, lbound, ubound);
891 gtype = build_array_type (gtype, rtype);
892 /* Ensure the bound variables aren't optimized out at -O0.
893 For -O1 and above they often will be optimized out, but
894 can be tracked by VTA. Also set DECL_NAMELESS, so that
895 the artificial lbound.N or ubound.N DECL_NAME doesn't
896 end up in debug info. */
897 if (lbound && TREE_CODE (lbound) == VAR_DECL
898 && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
899 {
900 if (DECL_NAME (lbound)
901 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
902 "lbound") != 0)
903 DECL_NAMELESS (lbound) = 1;
904 DECL_IGNORED_P (lbound) = 0;
905 }
906 if (ubound && TREE_CODE (ubound) == VAR_DECL
907 && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
908 {
909 if (DECL_NAME (ubound)
910 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
911 "ubound") != 0)
912 DECL_NAMELESS (ubound) = 1;
913 DECL_IGNORED_P (ubound) = 0;
914 }
915 }
916 TYPE_NAME (type) = type_decl = build_decl (input_location,
917 TYPE_DECL, NULL, gtype);
918 DECL_ORIGINAL_TYPE (type_decl) = gtype;
919 }
920 }
921
922
923 /* For some dummy arguments we don't use the actual argument directly.
924 Instead we create a local decl and use that. This allows us to perform
925 initialization, and construct full type information. */
926
927 static tree
928 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
929 {
930 tree decl;
931 tree type;
932 gfc_array_spec *as;
933 char *name;
934 gfc_packed packed;
935 int n;
936 bool known_size;
937
938 if (sym->attr.pointer || sym->attr.allocatable)
939 return dummy;
940
941 /* Add to list of variables if not a fake result variable. */
942 if (sym->attr.result || sym->attr.dummy)
943 gfc_defer_symbol_init (sym);
944
945 type = TREE_TYPE (dummy);
946 gcc_assert (TREE_CODE (dummy) == PARM_DECL
947 && POINTER_TYPE_P (type));
948
949 /* Do we know the element size? */
950 known_size = sym->ts.type != BT_CHARACTER
951 || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
952
953 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
954 {
955 /* For descriptorless arrays with known element size the actual
956 argument is sufficient. */
957 gcc_assert (GFC_ARRAY_TYPE_P (type));
958 gfc_build_qualified_array (dummy, sym);
959 return dummy;
960 }
961
962 type = TREE_TYPE (type);
963 if (GFC_DESCRIPTOR_TYPE_P (type))
964 {
965 /* Create a descriptorless array pointer. */
966 as = sym->as;
967 packed = PACKED_NO;
968
969 /* Even when -frepack-arrays is used, symbols with TARGET attribute
970 are not repacked. */
971 if (!gfc_option.flag_repack_arrays || sym->attr.target)
972 {
973 if (as->type == AS_ASSUMED_SIZE)
974 packed = PACKED_FULL;
975 }
976 else
977 {
978 if (as->type == AS_EXPLICIT)
979 {
980 packed = PACKED_FULL;
981 for (n = 0; n < as->rank; n++)
982 {
983 if (!(as->upper[n]
984 && as->lower[n]
985 && as->upper[n]->expr_type == EXPR_CONSTANT
986 && as->lower[n]->expr_type == EXPR_CONSTANT))
987 packed = PACKED_PARTIAL;
988 }
989 }
990 else
991 packed = PACKED_PARTIAL;
992 }
993
994 type = gfc_typenode_for_spec (&sym->ts);
995 type = gfc_get_nodesc_array_type (type, sym->as, packed,
996 !sym->attr.target);
997 }
998 else
999 {
1000 /* We now have an expression for the element size, so create a fully
1001 qualified type. Reset sym->backend decl or this will just return the
1002 old type. */
1003 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1004 sym->backend_decl = NULL_TREE;
1005 type = gfc_sym_type (sym);
1006 packed = PACKED_FULL;
1007 }
1008
1009 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1010 decl = build_decl (input_location,
1011 VAR_DECL, get_identifier (name), type);
1012
1013 DECL_ARTIFICIAL (decl) = 1;
1014 DECL_NAMELESS (decl) = 1;
1015 TREE_PUBLIC (decl) = 0;
1016 TREE_STATIC (decl) = 0;
1017 DECL_EXTERNAL (decl) = 0;
1018
1019 /* We should never get deferred shape arrays here. We used to because of
1020 frontend bugs. */
1021 gcc_assert (sym->as->type != AS_DEFERRED);
1022
1023 if (packed == PACKED_PARTIAL)
1024 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1025 else if (packed == PACKED_FULL)
1026 GFC_DECL_PACKED_ARRAY (decl) = 1;
1027
1028 gfc_build_qualified_array (decl, sym);
1029
1030 if (DECL_LANG_SPECIFIC (dummy))
1031 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1032 else
1033 gfc_allocate_lang_decl (decl);
1034
1035 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1036
1037 if (sym->ns->proc_name->backend_decl == current_function_decl
1038 || sym->attr.contained)
1039 gfc_add_decl_to_function (decl);
1040 else
1041 gfc_add_decl_to_parent_function (decl);
1042
1043 return decl;
1044 }
1045
1046 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1047 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1048 pointing to the artificial variable for debug info purposes. */
1049
1050 static void
1051 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1052 {
1053 tree decl, dummy;
1054
1055 if (! nonlocal_dummy_decl_pset)
1056 nonlocal_dummy_decl_pset = pointer_set_create ();
1057
1058 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1059 return;
1060
1061 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1062 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1063 TREE_TYPE (sym->backend_decl));
1064 DECL_ARTIFICIAL (decl) = 0;
1065 TREE_USED (decl) = 1;
1066 TREE_PUBLIC (decl) = 0;
1067 TREE_STATIC (decl) = 0;
1068 DECL_EXTERNAL (decl) = 0;
1069 if (DECL_BY_REFERENCE (dummy))
1070 DECL_BY_REFERENCE (decl) = 1;
1071 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1072 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1073 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1074 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1075 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1076 nonlocal_dummy_decls = decl;
1077 }
1078
1079 /* Return a constant or a variable to use as a string length. Does not
1080 add the decl to the current scope. */
1081
1082 static tree
1083 gfc_create_string_length (gfc_symbol * sym)
1084 {
1085 gcc_assert (sym->ts.u.cl);
1086 gfc_conv_const_charlen (sym->ts.u.cl);
1087
1088 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1089 {
1090 tree length;
1091 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1092
1093 /* Also prefix the mangled name. */
1094 strcpy (&name[1], sym->name);
1095 name[0] = '.';
1096 length = build_decl (input_location,
1097 VAR_DECL, get_identifier (name),
1098 gfc_charlen_type_node);
1099 DECL_ARTIFICIAL (length) = 1;
1100 TREE_USED (length) = 1;
1101 if (sym->ns->proc_name->tlink != NULL)
1102 gfc_defer_symbol_init (sym);
1103
1104 sym->ts.u.cl->backend_decl = length;
1105 }
1106
1107 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1108 return sym->ts.u.cl->backend_decl;
1109 }
1110
1111 /* If a variable is assigned a label, we add another two auxiliary
1112 variables. */
1113
1114 static void
1115 gfc_add_assign_aux_vars (gfc_symbol * sym)
1116 {
1117 tree addr;
1118 tree length;
1119 tree decl;
1120
1121 gcc_assert (sym->backend_decl);
1122
1123 decl = sym->backend_decl;
1124 gfc_allocate_lang_decl (decl);
1125 GFC_DECL_ASSIGN (decl) = 1;
1126 length = build_decl (input_location,
1127 VAR_DECL, create_tmp_var_name (sym->name),
1128 gfc_charlen_type_node);
1129 addr = build_decl (input_location,
1130 VAR_DECL, create_tmp_var_name (sym->name),
1131 pvoid_type_node);
1132 gfc_finish_var_decl (length, sym);
1133 gfc_finish_var_decl (addr, sym);
1134 /* STRING_LENGTH is also used as flag. Less than -1 means that
1135 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1136 target label's address. Otherwise, value is the length of a format string
1137 and ASSIGN_ADDR is its address. */
1138 if (TREE_STATIC (length))
1139 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1140 else
1141 gfc_defer_symbol_init (sym);
1142
1143 GFC_DECL_STRING_LEN (decl) = length;
1144 GFC_DECL_ASSIGN_ADDR (decl) = addr;
1145 }
1146
1147
1148 static tree
1149 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1150 {
1151 unsigned id;
1152 tree attr;
1153
1154 for (id = 0; id < EXT_ATTR_NUM; id++)
1155 if (sym_attr.ext_attr & (1 << id))
1156 {
1157 attr = build_tree_list (
1158 get_identifier (ext_attr_list[id].middle_end_name),
1159 NULL_TREE);
1160 list = chainon (list, attr);
1161 }
1162
1163 return list;
1164 }
1165
1166
1167 static void build_function_decl (gfc_symbol * sym, bool global);
1168
1169
1170 /* Return the decl for a gfc_symbol, create it if it doesn't already
1171 exist. */
1172
1173 tree
1174 gfc_get_symbol_decl (gfc_symbol * sym)
1175 {
1176 tree decl;
1177 tree length = NULL_TREE;
1178 tree attributes;
1179 int byref;
1180 bool intrinsic_array_parameter = false;
1181
1182 gcc_assert (sym->attr.referenced
1183 || sym->attr.use_assoc
1184 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1185 || (sym->module && sym->attr.if_source != IFSRC_DECL
1186 && sym->backend_decl));
1187
1188 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1189 byref = gfc_return_by_reference (sym->ns->proc_name);
1190 else
1191 byref = 0;
1192
1193 /* Make sure that the vtab for the declared type is completed. */
1194 if (sym->ts.type == BT_CLASS)
1195 {
1196 gfc_component *c = CLASS_DATA (sym);
1197 if (!c->ts.u.derived->backend_decl)
1198 {
1199 gfc_find_derived_vtab (c->ts.u.derived);
1200 gfc_get_derived_type (sym->ts.u.derived);
1201 }
1202 }
1203
1204 /* All deferred character length procedures need to retain the backend
1205 decl, which is a pointer to the character length in the caller's
1206 namespace and to declare a local character length. */
1207 if (!byref && sym->attr.function
1208 && sym->ts.type == BT_CHARACTER
1209 && sym->ts.deferred
1210 && sym->ts.u.cl->passed_length == NULL
1211 && sym->ts.u.cl->backend_decl
1212 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1213 {
1214 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1215 sym->ts.u.cl->backend_decl = NULL_TREE;
1216 length = gfc_create_string_length (sym);
1217 }
1218
1219 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1220 {
1221 /* Return via extra parameter. */
1222 if (sym->attr.result && byref
1223 && !sym->backend_decl)
1224 {
1225 sym->backend_decl =
1226 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1227 /* For entry master function skip over the __entry
1228 argument. */
1229 if (sym->ns->proc_name->attr.entry_master)
1230 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1231 }
1232
1233 /* Dummy variables should already have been created. */
1234 gcc_assert (sym->backend_decl);
1235
1236 /* Create a character length variable. */
1237 if (sym->ts.type == BT_CHARACTER)
1238 {
1239 /* For a deferred dummy, make a new string length variable. */
1240 if (sym->ts.deferred
1241 &&
1242 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1243 sym->ts.u.cl->backend_decl = NULL_TREE;
1244
1245 if (sym->ts.deferred && sym->attr.result
1246 && sym->ts.u.cl->passed_length == NULL
1247 && sym->ts.u.cl->backend_decl)
1248 {
1249 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1250 sym->ts.u.cl->backend_decl = NULL_TREE;
1251 }
1252
1253 if (sym->ts.u.cl->backend_decl == NULL_TREE)
1254 length = gfc_create_string_length (sym);
1255 else
1256 length = sym->ts.u.cl->backend_decl;
1257 if (TREE_CODE (length) == VAR_DECL
1258 && DECL_FILE_SCOPE_P (length))
1259 {
1260 /* Add the string length to the same context as the symbol. */
1261 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1262 gfc_add_decl_to_function (length);
1263 else
1264 gfc_add_decl_to_parent_function (length);
1265
1266 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1267 DECL_CONTEXT (length));
1268
1269 gfc_defer_symbol_init (sym);
1270 }
1271 }
1272
1273 /* Use a copy of the descriptor for dummy arrays. */
1274 if ((sym->attr.dimension || sym->attr.codimension)
1275 && !TREE_USED (sym->backend_decl))
1276 {
1277 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1278 /* Prevent the dummy from being detected as unused if it is copied. */
1279 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1280 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1281 sym->backend_decl = decl;
1282 }
1283
1284 TREE_USED (sym->backend_decl) = 1;
1285 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1286 {
1287 gfc_add_assign_aux_vars (sym);
1288 }
1289
1290 if (sym->attr.dimension
1291 && DECL_LANG_SPECIFIC (sym->backend_decl)
1292 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1293 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1294 gfc_nonlocal_dummy_array_decl (sym);
1295
1296 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1297 GFC_DECL_CLASS(sym->backend_decl) = 1;
1298
1299 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1300 GFC_DECL_CLASS(sym->backend_decl) = 1;
1301 return sym->backend_decl;
1302 }
1303
1304 if (sym->backend_decl)
1305 return sym->backend_decl;
1306
1307 /* Special case for array-valued named constants from intrinsic
1308 procedures; those are inlined. */
1309 if (sym->attr.use_assoc && sym->from_intmod
1310 && sym->attr.flavor == FL_PARAMETER)
1311 intrinsic_array_parameter = true;
1312
1313 /* If use associated and whole file compilation, use the module
1314 declaration. */
1315 if (gfc_option.flag_whole_file
1316 && (sym->attr.flavor == FL_VARIABLE
1317 || sym->attr.flavor == FL_PARAMETER)
1318 && sym->attr.use_assoc
1319 && !intrinsic_array_parameter
1320 && sym->module
1321 && gfc_get_module_backend_decl (sym))
1322 {
1323 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1324 GFC_DECL_CLASS(sym->backend_decl) = 1;
1325 return sym->backend_decl;
1326 }
1327
1328 if (sym->attr.flavor == FL_PROCEDURE)
1329 {
1330 /* Catch function declarations. Only used for actual parameters,
1331 procedure pointers and procptr initialization targets. */
1332 if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1333 {
1334 decl = gfc_get_extern_function_decl (sym);
1335 gfc_set_decl_location (decl, &sym->declared_at);
1336 }
1337 else
1338 {
1339 if (!sym->backend_decl)
1340 build_function_decl (sym, false);
1341 decl = sym->backend_decl;
1342 }
1343 return decl;
1344 }
1345
1346 if (sym->attr.intrinsic)
1347 internal_error ("intrinsic variable which isn't a procedure");
1348
1349 /* Create string length decl first so that they can be used in the
1350 type declaration. */
1351 if (sym->ts.type == BT_CHARACTER)
1352 length = gfc_create_string_length (sym);
1353
1354 /* Create the decl for the variable. */
1355 decl = build_decl (sym->declared_at.lb->location,
1356 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1357
1358 /* Add attributes to variables. Functions are handled elsewhere. */
1359 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1360 decl_attributes (&decl, attributes, 0);
1361
1362 /* Symbols from modules should have their assembler names mangled.
1363 This is done here rather than in gfc_finish_var_decl because it
1364 is different for string length variables. */
1365 if (sym->module)
1366 {
1367 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1368 if (sym->attr.use_assoc && !intrinsic_array_parameter)
1369 DECL_IGNORED_P (decl) = 1;
1370 }
1371
1372 if (sym->attr.dimension || sym->attr.codimension)
1373 {
1374 /* Create variables to hold the non-constant bits of array info. */
1375 gfc_build_qualified_array (decl, sym);
1376
1377 if (sym->attr.contiguous
1378 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1379 GFC_DECL_PACKED_ARRAY (decl) = 1;
1380 }
1381
1382 /* Remember this variable for allocation/cleanup. */
1383 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1384 || (sym->ts.type == BT_CLASS &&
1385 (CLASS_DATA (sym)->attr.dimension
1386 || CLASS_DATA (sym)->attr.allocatable))
1387 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1388 /* This applies a derived type default initializer. */
1389 || (sym->ts.type == BT_DERIVED
1390 && sym->attr.save == SAVE_NONE
1391 && !sym->attr.data
1392 && !sym->attr.allocatable
1393 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1394 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1395 gfc_defer_symbol_init (sym);
1396
1397 gfc_finish_var_decl (decl, sym);
1398
1399 if (sym->ts.type == BT_CHARACTER)
1400 {
1401 /* Character variables need special handling. */
1402 gfc_allocate_lang_decl (decl);
1403
1404 if (TREE_CODE (length) != INTEGER_CST)
1405 {
1406 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1407
1408 if (sym->module)
1409 {
1410 /* Also prefix the mangled name for symbols from modules. */
1411 strcpy (&name[1], sym->name);
1412 name[0] = '.';
1413 strcpy (&name[1],
1414 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1415 gfc_set_decl_assembler_name (decl, get_identifier (name));
1416 }
1417 gfc_finish_var_decl (length, sym);
1418 gcc_assert (!sym->value);
1419 }
1420 }
1421 else if (sym->attr.subref_array_pointer)
1422 {
1423 /* We need the span for these beasts. */
1424 gfc_allocate_lang_decl (decl);
1425 }
1426
1427 if (sym->attr.subref_array_pointer)
1428 {
1429 tree span;
1430 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1431 span = build_decl (input_location,
1432 VAR_DECL, create_tmp_var_name ("span"),
1433 gfc_array_index_type);
1434 gfc_finish_var_decl (span, sym);
1435 TREE_STATIC (span) = TREE_STATIC (decl);
1436 DECL_ARTIFICIAL (span) = 1;
1437 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
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 build_pointer_type (pchar_type_node), integer_type_node);
3168
3169 gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3170 get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3171
3172 gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3173 get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3174
3175 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3176 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3177 3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3178
3179 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3180 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3181 5, integer_type_node, pint_type, pint_type,
3182 build_pointer_type (pchar_type_node), integer_type_node);
3183
3184 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3185 get_identifier (PREFIX("caf_error_stop")),
3186 void_type_node, 1, gfc_int4_type_node);
3187 /* CAF's ERROR STOP doesn't return. */
3188 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3189
3190 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3191 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3192 void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3193 /* CAF's ERROR STOP doesn't return. */
3194 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3195 }
3196
3197 gfc_build_intrinsic_function_decls ();
3198 gfc_build_intrinsic_lib_fndecls ();
3199 gfc_build_io_library_fndecls ();
3200 }
3201
3202
3203 /* Evaluate the length of dummy character variables. */
3204
3205 static void
3206 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3207 gfc_wrapped_block *block)
3208 {
3209 stmtblock_t init;
3210
3211 gfc_finish_decl (cl->backend_decl);
3212
3213 gfc_start_block (&init);
3214
3215 /* Evaluate the string length expression. */
3216 gfc_conv_string_length (cl, NULL, &init);
3217
3218 gfc_trans_vla_type_sizes (sym, &init);
3219
3220 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3221 }
3222
3223
3224 /* Allocate and cleanup an automatic character variable. */
3225
3226 static void
3227 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3228 {
3229 stmtblock_t init;
3230 tree decl;
3231 tree tmp;
3232
3233 gcc_assert (sym->backend_decl);
3234 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3235
3236 gfc_init_block (&init);
3237
3238 /* Evaluate the string length expression. */
3239 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3240
3241 gfc_trans_vla_type_sizes (sym, &init);
3242
3243 decl = sym->backend_decl;
3244
3245 /* Emit a DECL_EXPR for this variable, which will cause the
3246 gimplifier to allocate storage, and all that good stuff. */
3247 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3248 gfc_add_expr_to_block (&init, tmp);
3249
3250 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3251 }
3252
3253 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
3254
3255 static void
3256 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3257 {
3258 stmtblock_t init;
3259
3260 gcc_assert (sym->backend_decl);
3261 gfc_start_block (&init);
3262
3263 /* Set the initial value to length. See the comments in
3264 function gfc_add_assign_aux_vars in this file. */
3265 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3266 build_int_cst (gfc_charlen_type_node, -2));
3267
3268 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3269 }
3270
3271 static void
3272 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3273 {
3274 tree t = *tp, var, val;
3275
3276 if (t == NULL || t == error_mark_node)
3277 return;
3278 if (TREE_CONSTANT (t) || DECL_P (t))
3279 return;
3280
3281 if (TREE_CODE (t) == SAVE_EXPR)
3282 {
3283 if (SAVE_EXPR_RESOLVED_P (t))
3284 {
3285 *tp = TREE_OPERAND (t, 0);
3286 return;
3287 }
3288 val = TREE_OPERAND (t, 0);
3289 }
3290 else
3291 val = t;
3292
3293 var = gfc_create_var_np (TREE_TYPE (t), NULL);
3294 gfc_add_decl_to_function (var);
3295 gfc_add_modify (body, var, val);
3296 if (TREE_CODE (t) == SAVE_EXPR)
3297 TREE_OPERAND (t, 0) = var;
3298 *tp = var;
3299 }
3300
3301 static void
3302 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3303 {
3304 tree t;
3305
3306 if (type == NULL || type == error_mark_node)
3307 return;
3308
3309 type = TYPE_MAIN_VARIANT (type);
3310
3311 if (TREE_CODE (type) == INTEGER_TYPE)
3312 {
3313 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3314 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3315
3316 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3317 {
3318 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3319 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3320 }
3321 }
3322 else if (TREE_CODE (type) == ARRAY_TYPE)
3323 {
3324 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3325 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3326 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3327 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3328
3329 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3330 {
3331 TYPE_SIZE (t) = TYPE_SIZE (type);
3332 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3333 }
3334 }
3335 }
3336
3337 /* Make sure all type sizes and array domains are either constant,
3338 or variable or parameter decls. This is a simplified variant
3339 of gimplify_type_sizes, but we can't use it here, as none of the
3340 variables in the expressions have been gimplified yet.
3341 As type sizes and domains for various variable length arrays
3342 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3343 time, without this routine gimplify_type_sizes in the middle-end
3344 could result in the type sizes being gimplified earlier than where
3345 those variables are initialized. */
3346
3347 void
3348 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3349 {
3350 tree type = TREE_TYPE (sym->backend_decl);
3351
3352 if (TREE_CODE (type) == FUNCTION_TYPE
3353 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3354 {
3355 if (! current_fake_result_decl)
3356 return;
3357
3358 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3359 }
3360
3361 while (POINTER_TYPE_P (type))
3362 type = TREE_TYPE (type);
3363
3364 if (GFC_DESCRIPTOR_TYPE_P (type))
3365 {
3366 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3367
3368 while (POINTER_TYPE_P (etype))
3369 etype = TREE_TYPE (etype);
3370
3371 gfc_trans_vla_type_sizes_1 (etype, body);
3372 }
3373
3374 gfc_trans_vla_type_sizes_1 (type, body);
3375 }
3376
3377
3378 /* Initialize a derived type by building an lvalue from the symbol
3379 and using trans_assignment to do the work. Set dealloc to false
3380 if no deallocation prior the assignment is needed. */
3381 void
3382 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3383 {
3384 gfc_expr *e;
3385 tree tmp;
3386 tree present;
3387
3388 gcc_assert (block);
3389
3390 gcc_assert (!sym->attr.allocatable);
3391 gfc_set_sym_referenced (sym);
3392 e = gfc_lval_expr_from_sym (sym);
3393 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3394 if (sym->attr.dummy && (sym->attr.optional
3395 || sym->ns->proc_name->attr.entry_master))
3396 {
3397 present = gfc_conv_expr_present (sym);
3398 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3399 tmp, build_empty_stmt (input_location));
3400 }
3401 gfc_add_expr_to_block (block, tmp);
3402 gfc_free_expr (e);
3403 }
3404
3405
3406 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3407 them their default initializer, if they do not have allocatable
3408 components, they have their allocatable components deallocated. */
3409
3410 static void
3411 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3412 {
3413 stmtblock_t init;
3414 gfc_formal_arglist *f;
3415 tree tmp;
3416 tree present;
3417
3418 gfc_init_block (&init);
3419 for (f = proc_sym->formal; f; f = f->next)
3420 if (f->sym && f->sym->attr.intent == INTENT_OUT
3421 && !f->sym->attr.pointer
3422 && f->sym->ts.type == BT_DERIVED)
3423 {
3424 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3425 {
3426 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3427 f->sym->backend_decl,
3428 f->sym->as ? f->sym->as->rank : 0);
3429
3430 if (f->sym->attr.optional
3431 || f->sym->ns->proc_name->attr.entry_master)
3432 {
3433 present = gfc_conv_expr_present (f->sym);
3434 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3435 present, tmp,
3436 build_empty_stmt (input_location));
3437 }
3438
3439 gfc_add_expr_to_block (&init, tmp);
3440 }
3441 else if (f->sym->value)
3442 gfc_init_default_dt (f->sym, &init, true);
3443 }
3444 else if (f->sym && f->sym->attr.intent == INTENT_OUT
3445 && f->sym->ts.type == BT_CLASS
3446 && !CLASS_DATA (f->sym)->attr.class_pointer
3447 && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3448 {
3449 tree decl = build_fold_indirect_ref_loc (input_location,
3450 f->sym->backend_decl);
3451 tmp = CLASS_DATA (f->sym)->backend_decl;
3452 tmp = fold_build3_loc (input_location, COMPONENT_REF,
3453 TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3454 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3455 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3456 tmp,
3457 CLASS_DATA (f->sym)->as ?
3458 CLASS_DATA (f->sym)->as->rank : 0);
3459
3460 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3461 {
3462 present = gfc_conv_expr_present (f->sym);
3463 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3464 present, tmp,
3465 build_empty_stmt (input_location));
3466 }
3467
3468 gfc_add_expr_to_block (&init, tmp);
3469 }
3470
3471 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3472 }
3473
3474
3475 /* Generate function entry and exit code, and add it to the function body.
3476 This includes:
3477 Allocation and initialization of array variables.
3478 Allocation of character string variables.
3479 Initialization and possibly repacking of dummy arrays.
3480 Initialization of ASSIGN statement auxiliary variable.
3481 Initialization of ASSOCIATE names.
3482 Automatic deallocation. */
3483
3484 void
3485 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3486 {
3487 locus loc;
3488 gfc_symbol *sym;
3489 gfc_formal_arglist *f;
3490 stmtblock_t tmpblock;
3491 bool seen_trans_deferred_array = false;
3492 tree tmp = NULL;
3493 gfc_expr *e;
3494 gfc_se se;
3495 stmtblock_t init;
3496
3497 /* Deal with implicit return variables. Explicit return variables will
3498 already have been added. */
3499 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3500 {
3501 if (!current_fake_result_decl)
3502 {
3503 gfc_entry_list *el = NULL;
3504 if (proc_sym->attr.entry_master)
3505 {
3506 for (el = proc_sym->ns->entries; el; el = el->next)
3507 if (el->sym != el->sym->result)
3508 break;
3509 }
3510 /* TODO: move to the appropriate place in resolve.c. */
3511 if (warn_return_type && el == NULL)
3512 gfc_warning ("Return value of function '%s' at %L not set",
3513 proc_sym->name, &proc_sym->declared_at);
3514 }
3515 else if (proc_sym->as)
3516 {
3517 tree result = TREE_VALUE (current_fake_result_decl);
3518 gfc_trans_dummy_array_bias (proc_sym, result, block);
3519
3520 /* An automatic character length, pointer array result. */
3521 if (proc_sym->ts.type == BT_CHARACTER
3522 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3523 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3524 }
3525 else if (proc_sym->ts.type == BT_CHARACTER)
3526 {
3527 if (proc_sym->ts.deferred)
3528 {
3529 tmp = NULL;
3530 gfc_save_backend_locus (&loc);
3531 gfc_set_backend_locus (&proc_sym->declared_at);
3532 gfc_start_block (&init);
3533 /* Zero the string length on entry. */
3534 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3535 build_int_cst (gfc_charlen_type_node, 0));
3536 /* Null the pointer. */
3537 e = gfc_lval_expr_from_sym (proc_sym);
3538 gfc_init_se (&se, NULL);
3539 se.want_pointer = 1;
3540 gfc_conv_expr (&se, e);
3541 gfc_free_expr (e);
3542 tmp = se.expr;
3543 gfc_add_modify (&init, tmp,
3544 fold_convert (TREE_TYPE (se.expr),
3545 null_pointer_node));
3546 gfc_restore_backend_locus (&loc);
3547
3548 /* Pass back the string length on exit. */
3549 tmp = proc_sym->ts.u.cl->passed_length;
3550 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3551 tmp = fold_convert (gfc_charlen_type_node, tmp);
3552 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3553 gfc_charlen_type_node, tmp,
3554 proc_sym->ts.u.cl->backend_decl);
3555 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3556 }
3557 else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3558 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3559 }
3560 else
3561 gcc_assert (gfc_option.flag_f2c
3562 && proc_sym->ts.type == BT_COMPLEX);
3563 }
3564
3565 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3566 should be done here so that the offsets and lbounds of arrays
3567 are available. */
3568 gfc_save_backend_locus (&loc);
3569 gfc_set_backend_locus (&proc_sym->declared_at);
3570 init_intent_out_dt (proc_sym, block);
3571 gfc_restore_backend_locus (&loc);
3572
3573 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3574 {
3575 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3576 && sym->ts.u.derived->attr.alloc_comp;
3577 if (sym->assoc)
3578 continue;
3579
3580 if (sym->attr.dimension || sym->attr.codimension)
3581 {
3582 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
3583 array_type tmp = sym->as->type;
3584 if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3585 tmp = AS_EXPLICIT;
3586 switch (tmp)
3587 {
3588 case AS_EXPLICIT:
3589 if (sym->attr.dummy || sym->attr.result)
3590 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3591 else if (sym->attr.pointer || sym->attr.allocatable)
3592 {
3593 if (TREE_STATIC (sym->backend_decl))
3594 {
3595 gfc_save_backend_locus (&loc);
3596 gfc_set_backend_locus (&sym->declared_at);
3597 gfc_trans_static_array_pointer (sym);
3598 gfc_restore_backend_locus (&loc);
3599 }
3600 else
3601 {
3602 seen_trans_deferred_array = true;
3603 gfc_trans_deferred_array (sym, block);
3604 }
3605 }
3606 else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3607 {
3608 gfc_init_block (&tmpblock);
3609 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3610 &tmpblock, sym);
3611 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3612 NULL_TREE);
3613 continue;
3614 }
3615 else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3616 {
3617 gfc_save_backend_locus (&loc);
3618 gfc_set_backend_locus (&sym->declared_at);
3619
3620 if (sym_has_alloc_comp)
3621 {
3622 seen_trans_deferred_array = true;
3623 gfc_trans_deferred_array (sym, block);
3624 }
3625 else if (sym->ts.type == BT_DERIVED
3626 && sym->value
3627 && !sym->attr.data
3628 && sym->attr.save == SAVE_NONE)
3629 {
3630 gfc_start_block (&tmpblock);
3631 gfc_init_default_dt (sym, &tmpblock, false);
3632 gfc_add_init_cleanup (block,
3633 gfc_finish_block (&tmpblock),
3634 NULL_TREE);
3635 }
3636
3637 gfc_trans_auto_array_allocation (sym->backend_decl,
3638 sym, block);
3639 gfc_restore_backend_locus (&loc);
3640 }
3641 break;
3642
3643 case AS_ASSUMED_SIZE:
3644 /* Must be a dummy parameter. */
3645 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3646
3647 /* We should always pass assumed size arrays the g77 way. */
3648 if (sym->attr.dummy)
3649 gfc_trans_g77_array (sym, block);
3650 break;
3651
3652 case AS_ASSUMED_SHAPE:
3653 /* Must be a dummy parameter. */
3654 gcc_assert (sym->attr.dummy);
3655
3656 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3657 break;
3658
3659 case AS_DEFERRED:
3660 seen_trans_deferred_array = true;
3661 gfc_trans_deferred_array (sym, block);
3662 break;
3663
3664 default:
3665 gcc_unreachable ();
3666 }
3667 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3668 gfc_trans_deferred_array (sym, block);
3669 }
3670 else if ((!sym->attr.dummy || sym->ts.deferred)
3671 && (sym->ts.type == BT_CLASS
3672 && CLASS_DATA (sym)->attr.pointer))
3673 break;
3674 else if ((!sym->attr.dummy || sym->ts.deferred)
3675 && (sym->attr.allocatable
3676 || (sym->ts.type == BT_CLASS
3677 && CLASS_DATA (sym)->attr.allocatable)))
3678 {
3679 if (!sym->attr.save)
3680 {
3681 /* Nullify and automatic deallocation of allocatable
3682 scalars. */
3683 e = gfc_lval_expr_from_sym (sym);
3684 if (sym->ts.type == BT_CLASS)
3685 gfc_add_data_component (e);
3686
3687 gfc_init_se (&se, NULL);
3688 if (sym->ts.type != BT_CLASS
3689 || sym->ts.u.derived->attr.dimension
3690 || sym->ts.u.derived->attr.codimension)
3691 {
3692 se.want_pointer = 1;
3693 gfc_conv_expr (&se, e);
3694 }
3695 else if (sym->ts.type == BT_CLASS
3696 && !CLASS_DATA (sym)->attr.dimension
3697 && !CLASS_DATA (sym)->attr.codimension)
3698 {
3699 se.want_pointer = 1;
3700 gfc_conv_expr (&se, e);
3701 }
3702 else
3703 {
3704 gfc_conv_expr (&se, e);
3705 se.expr = gfc_conv_descriptor_data_addr (se.expr);
3706 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3707 }
3708 gfc_free_expr (e);
3709
3710 gfc_save_backend_locus (&loc);
3711 gfc_set_backend_locus (&sym->declared_at);
3712 gfc_start_block (&init);
3713
3714 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3715 {
3716 /* Nullify when entering the scope. */
3717 gfc_add_modify (&init, se.expr,
3718 fold_convert (TREE_TYPE (se.expr),
3719 null_pointer_node));
3720 }
3721
3722 if ((sym->attr.dummy ||sym->attr.result)
3723 && sym->ts.type == BT_CHARACTER
3724 && sym->ts.deferred)
3725 {
3726 /* Character length passed by reference. */
3727 tmp = sym->ts.u.cl->passed_length;
3728 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3729 tmp = fold_convert (gfc_charlen_type_node, tmp);
3730
3731 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3732 /* Zero the string length when entering the scope. */
3733 gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3734 build_int_cst (gfc_charlen_type_node, 0));
3735 else
3736 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3737
3738 gfc_restore_backend_locus (&loc);
3739
3740 /* Pass the final character length back. */
3741 if (sym->attr.intent != INTENT_IN)
3742 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3743 gfc_charlen_type_node, tmp,
3744 sym->ts.u.cl->backend_decl);
3745 else
3746 tmp = NULL_TREE;
3747 }
3748 else
3749 gfc_restore_backend_locus (&loc);
3750
3751 /* Deallocate when leaving the scope. Nullifying is not
3752 needed. */
3753 if (!sym->attr.result && !sym->attr.dummy)
3754 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
3755 NULL, sym->ts);
3756
3757 if (sym->ts.type == BT_CLASS)
3758 {
3759 /* Initialize _vptr to declared type. */
3760 gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3761 tree rhs;
3762
3763 gfc_save_backend_locus (&loc);
3764 gfc_set_backend_locus (&sym->declared_at);
3765 e = gfc_lval_expr_from_sym (sym);
3766 gfc_add_vptr_component (e);
3767 gfc_init_se (&se, NULL);
3768 se.want_pointer = 1;
3769 gfc_conv_expr (&se, e);
3770 gfc_free_expr (e);
3771 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3772 gfc_get_symbol_decl (vtab));
3773 gfc_add_modify (&init, se.expr, rhs);
3774 gfc_restore_backend_locus (&loc);
3775 }
3776
3777 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3778 }
3779 }
3780 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3781 {
3782 tree tmp = NULL;
3783 stmtblock_t init;
3784
3785 /* If we get to here, all that should be left are pointers. */
3786 gcc_assert (sym->attr.pointer);
3787
3788 if (sym->attr.dummy)
3789 {
3790 gfc_start_block (&init);
3791
3792 /* Character length passed by reference. */
3793 tmp = sym->ts.u.cl->passed_length;
3794 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3795 tmp = fold_convert (gfc_charlen_type_node, tmp);
3796 gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3797 /* Pass the final character length back. */
3798 if (sym->attr.intent != INTENT_IN)
3799 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3800 gfc_charlen_type_node, tmp,
3801 sym->ts.u.cl->backend_decl);
3802 else
3803 tmp = NULL_TREE;
3804 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3805 }
3806 }
3807 else if (sym->ts.deferred)
3808 gfc_fatal_error ("Deferred type parameter not yet supported");
3809 else if (sym_has_alloc_comp)
3810 gfc_trans_deferred_array (sym, block);
3811 else if (sym->ts.type == BT_CHARACTER)
3812 {
3813 gfc_save_backend_locus (&loc);
3814 gfc_set_backend_locus (&sym->declared_at);
3815 if (sym->attr.dummy || sym->attr.result)
3816 gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3817 else
3818 gfc_trans_auto_character_variable (sym, block);
3819 gfc_restore_backend_locus (&loc);
3820 }
3821 else if (sym->attr.assign)
3822 {
3823 gfc_save_backend_locus (&loc);
3824 gfc_set_backend_locus (&sym->declared_at);
3825 gfc_trans_assign_aux_var (sym, block);
3826 gfc_restore_backend_locus (&loc);
3827 }
3828 else if (sym->ts.type == BT_DERIVED
3829 && sym->value
3830 && !sym->attr.data
3831 && sym->attr.save == SAVE_NONE)
3832 {
3833 gfc_start_block (&tmpblock);
3834 gfc_init_default_dt (sym, &tmpblock, false);
3835 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3836 NULL_TREE);
3837 }
3838 else
3839 gcc_unreachable ();
3840 }
3841
3842 gfc_init_block (&tmpblock);
3843
3844 for (f = proc_sym->formal; f; f = f->next)
3845 {
3846 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3847 {
3848 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3849 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3850 gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3851 }
3852 }
3853
3854 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3855 && current_fake_result_decl != NULL)
3856 {
3857 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3858 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3859 gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3860 }
3861
3862 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3863 }
3864
3865 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3866
3867 /* Hash and equality functions for module_htab. */
3868
3869 static hashval_t
3870 module_htab_do_hash (const void *x)
3871 {
3872 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3873 }
3874
3875 static int
3876 module_htab_eq (const void *x1, const void *x2)
3877 {
3878 return strcmp ((((const struct module_htab_entry *)x1)->name),
3879 (const char *)x2) == 0;
3880 }
3881
3882 /* Hash and equality functions for module_htab's decls. */
3883
3884 static hashval_t
3885 module_htab_decls_hash (const void *x)
3886 {
3887 const_tree t = (const_tree) x;
3888 const_tree n = DECL_NAME (t);
3889 if (n == NULL_TREE)
3890 n = TYPE_NAME (TREE_TYPE (t));
3891 return htab_hash_string (IDENTIFIER_POINTER (n));
3892 }
3893
3894 static int
3895 module_htab_decls_eq (const void *x1, const void *x2)
3896 {
3897 const_tree t1 = (const_tree) x1;
3898 const_tree n1 = DECL_NAME (t1);
3899 if (n1 == NULL_TREE)
3900 n1 = TYPE_NAME (TREE_TYPE (t1));
3901 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3902 }
3903
3904 struct module_htab_entry *
3905 gfc_find_module (const char *name)
3906 {
3907 void **slot;
3908
3909 if (! module_htab)
3910 module_htab = htab_create_ggc (10, module_htab_do_hash,
3911 module_htab_eq, NULL);
3912
3913 slot = htab_find_slot_with_hash (module_htab, name,
3914 htab_hash_string (name), INSERT);
3915 if (*slot == NULL)
3916 {
3917 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3918
3919 entry->name = gfc_get_string (name);
3920 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3921 module_htab_decls_eq, NULL);
3922 *slot = (void *) entry;
3923 }
3924 return (struct module_htab_entry *) *slot;
3925 }
3926
3927 void
3928 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3929 {
3930 void **slot;
3931 const char *name;
3932
3933 if (DECL_NAME (decl))
3934 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3935 else
3936 {
3937 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3938 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3939 }
3940 slot = htab_find_slot_with_hash (entry->decls, name,
3941 htab_hash_string (name), INSERT);
3942 if (*slot == NULL)
3943 *slot = (void *) decl;
3944 }
3945
3946 static struct module_htab_entry *cur_module;
3947
3948 /* Output an initialized decl for a module variable. */
3949
3950 static void
3951 gfc_create_module_variable (gfc_symbol * sym)
3952 {
3953 tree decl;
3954
3955 /* Module functions with alternate entries are dealt with later and
3956 would get caught by the next condition. */
3957 if (sym->attr.entry)
3958 return;
3959
3960 /* Make sure we convert the types of the derived types from iso_c_binding
3961 into (void *). */
3962 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3963 && sym->ts.type == BT_DERIVED)
3964 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3965
3966 if (sym->attr.flavor == FL_DERIVED
3967 && sym->backend_decl
3968 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3969 {
3970 decl = sym->backend_decl;
3971 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3972
3973 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3974 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3975 {
3976 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3977 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3978 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3979 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3980 == sym->ns->proc_name->backend_decl);
3981 }
3982 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3983 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3984 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3985 }
3986
3987 /* Only output variables, procedure pointers and array valued,
3988 or derived type, parameters. */
3989 if (sym->attr.flavor != FL_VARIABLE
3990 && !(sym->attr.flavor == FL_PARAMETER
3991 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3992 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3993 return;
3994
3995 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3996 {
3997 decl = sym->backend_decl;
3998 gcc_assert (DECL_FILE_SCOPE_P (decl));
3999 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4000 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4001 gfc_module_add_decl (cur_module, decl);
4002 }
4003
4004 /* Don't generate variables from other modules. Variables from
4005 COMMONs will already have been generated. */
4006 if (sym->attr.use_assoc || sym->attr.in_common)
4007 return;
4008
4009 /* Equivalenced variables arrive here after creation. */
4010 if (sym->backend_decl
4011 && (sym->equiv_built || sym->attr.in_equivalence))
4012 return;
4013
4014 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4015 internal_error ("backend decl for module variable %s already exists",
4016 sym->name);
4017
4018 /* We always want module variables to be created. */
4019 sym->attr.referenced = 1;
4020 /* Create the decl. */
4021 decl = gfc_get_symbol_decl (sym);
4022
4023 /* Create the variable. */
4024 pushdecl (decl);
4025 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4026 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4027 rest_of_decl_compilation (decl, 1, 0);
4028 gfc_module_add_decl (cur_module, decl);
4029
4030 /* Also add length of strings. */
4031 if (sym->ts.type == BT_CHARACTER)
4032 {
4033 tree length;
4034
4035 length = sym->ts.u.cl->backend_decl;
4036 gcc_assert (length || sym->attr.proc_pointer);
4037 if (length && !INTEGER_CST_P (length))
4038 {
4039 pushdecl (length);
4040 rest_of_decl_compilation (length, 1, 0);
4041 }
4042 }
4043
4044 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4045 && sym->attr.referenced && !sym->attr.use_assoc)
4046 has_coarray_vars = true;
4047 }
4048
4049 /* Emit debug information for USE statements. */
4050
4051 static void
4052 gfc_trans_use_stmts (gfc_namespace * ns)
4053 {
4054 gfc_use_list *use_stmt;
4055 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4056 {
4057 struct module_htab_entry *entry
4058 = gfc_find_module (use_stmt->module_name);
4059 gfc_use_rename *rent;
4060
4061 if (entry->namespace_decl == NULL)
4062 {
4063 entry->namespace_decl
4064 = build_decl (input_location,
4065 NAMESPACE_DECL,
4066 get_identifier (use_stmt->module_name),
4067 void_type_node);
4068 DECL_EXTERNAL (entry->namespace_decl) = 1;
4069 }
4070 gfc_set_backend_locus (&use_stmt->where);
4071 if (!use_stmt->only_flag)
4072 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4073 NULL_TREE,
4074 ns->proc_name->backend_decl,
4075 false);
4076 for (rent = use_stmt->rename; rent; rent = rent->next)
4077 {
4078 tree decl, local_name;
4079 void **slot;
4080
4081 if (rent->op != INTRINSIC_NONE)
4082 continue;
4083
4084 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4085 htab_hash_string (rent->use_name),
4086 INSERT);
4087 if (*slot == NULL)
4088 {
4089 gfc_symtree *st;
4090
4091 st = gfc_find_symtree (ns->sym_root,
4092 rent->local_name[0]
4093 ? rent->local_name : rent->use_name);
4094
4095 /* The following can happen if a derived type is renamed. */
4096 if (!st)
4097 {
4098 char *name;
4099 name = xstrdup (rent->local_name[0]
4100 ? rent->local_name : rent->use_name);
4101 name[0] = (char) TOUPPER ((unsigned char) name[0]);
4102 st = gfc_find_symtree (ns->sym_root, name);
4103 free (name);
4104 gcc_assert (st);
4105 }
4106
4107 /* Sometimes, generic interfaces wind up being over-ruled by a
4108 local symbol (see PR41062). */
4109 if (!st->n.sym->attr.use_assoc)
4110 continue;
4111
4112 if (st->n.sym->backend_decl
4113 && DECL_P (st->n.sym->backend_decl)
4114 && st->n.sym->module
4115 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4116 {
4117 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4118 || (TREE_CODE (st->n.sym->backend_decl)
4119 != VAR_DECL));
4120 decl = copy_node (st->n.sym->backend_decl);
4121 DECL_CONTEXT (decl) = entry->namespace_decl;
4122 DECL_EXTERNAL (decl) = 1;
4123 DECL_IGNORED_P (decl) = 0;
4124 DECL_INITIAL (decl) = NULL_TREE;
4125 }
4126 else
4127 {
4128 *slot = error_mark_node;
4129 htab_clear_slot (entry->decls, slot);
4130 continue;
4131 }
4132 *slot = decl;
4133 }
4134 decl = (tree) *slot;
4135 if (rent->local_name[0])
4136 local_name = get_identifier (rent->local_name);
4137 else
4138 local_name = NULL_TREE;
4139 gfc_set_backend_locus (&rent->where);
4140 (*debug_hooks->imported_module_or_decl) (decl, local_name,
4141 ns->proc_name->backend_decl,
4142 !use_stmt->only_flag);
4143 }
4144 }
4145 }
4146
4147
4148 /* Return true if expr is a constant initializer that gfc_conv_initializer
4149 will handle. */
4150
4151 static bool
4152 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4153 bool pointer)
4154 {
4155 gfc_constructor *c;
4156 gfc_component *cm;
4157
4158 if (pointer)
4159 return true;
4160 else if (array)
4161 {
4162 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4163 return true;
4164 else if (expr->expr_type == EXPR_STRUCTURE)
4165 return check_constant_initializer (expr, ts, false, false);
4166 else if (expr->expr_type != EXPR_ARRAY)
4167 return false;
4168 for (c = gfc_constructor_first (expr->value.constructor);
4169 c; c = gfc_constructor_next (c))
4170 {
4171 if (c->iterator)
4172 return false;
4173 if (c->expr->expr_type == EXPR_STRUCTURE)
4174 {
4175 if (!check_constant_initializer (c->expr, ts, false, false))
4176 return false;
4177 }
4178 else if (c->expr->expr_type != EXPR_CONSTANT)
4179 return false;
4180 }
4181 return true;
4182 }
4183 else switch (ts->type)
4184 {
4185 case BT_DERIVED:
4186 if (expr->expr_type != EXPR_STRUCTURE)
4187 return false;
4188 cm = expr->ts.u.derived->components;
4189 for (c = gfc_constructor_first (expr->value.constructor);
4190 c; c = gfc_constructor_next (c), cm = cm->next)
4191 {
4192 if (!c->expr || cm->attr.allocatable)
4193 continue;
4194 if (!check_constant_initializer (c->expr, &cm->ts,
4195 cm->attr.dimension,
4196 cm->attr.pointer))
4197 return false;
4198 }
4199 return true;
4200 default:
4201 return expr->expr_type == EXPR_CONSTANT;
4202 }
4203 }
4204
4205 /* Emit debug info for parameters and unreferenced variables with
4206 initializers. */
4207
4208 static void
4209 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4210 {
4211 tree decl;
4212
4213 if (sym->attr.flavor != FL_PARAMETER
4214 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4215 return;
4216
4217 if (sym->backend_decl != NULL
4218 || sym->value == NULL
4219 || sym->attr.use_assoc
4220 || sym->attr.dummy
4221 || sym->attr.result
4222 || sym->attr.function
4223 || sym->attr.intrinsic
4224 || sym->attr.pointer
4225 || sym->attr.allocatable
4226 || sym->attr.cray_pointee
4227 || sym->attr.threadprivate
4228 || sym->attr.is_bind_c
4229 || sym->attr.subref_array_pointer
4230 || sym->attr.assign)
4231 return;
4232
4233 if (sym->ts.type == BT_CHARACTER)
4234 {
4235 gfc_conv_const_charlen (sym->ts.u.cl);
4236 if (sym->ts.u.cl->backend_decl == NULL
4237 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4238 return;
4239 }
4240 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4241 return;
4242
4243 if (sym->as)
4244 {
4245 int n;
4246
4247 if (sym->as->type != AS_EXPLICIT)
4248 return;
4249 for (n = 0; n < sym->as->rank; n++)
4250 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4251 || sym->as->upper[n] == NULL
4252 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4253 return;
4254 }
4255
4256 if (!check_constant_initializer (sym->value, &sym->ts,
4257 sym->attr.dimension, false))
4258 return;
4259
4260 if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4261 return;
4262
4263 /* Create the decl for the variable or constant. */
4264 decl = build_decl (input_location,
4265 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4266 gfc_sym_identifier (sym), gfc_sym_type (sym));
4267 if (sym->attr.flavor == FL_PARAMETER)
4268 TREE_READONLY (decl) = 1;
4269 gfc_set_decl_location (decl, &sym->declared_at);
4270 if (sym->attr.dimension)
4271 GFC_DECL_PACKED_ARRAY (decl) = 1;
4272 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4273 TREE_STATIC (decl) = 1;
4274 TREE_USED (decl) = 1;
4275 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4276 TREE_PUBLIC (decl) = 1;
4277 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4278 TREE_TYPE (decl),
4279 sym->attr.dimension,
4280 false, false);
4281 debug_hooks->global_decl (decl);
4282 }
4283
4284
4285 static void
4286 generate_coarray_sym_init (gfc_symbol *sym)
4287 {
4288 tree tmp, size, decl, token;
4289
4290 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4291 || sym->attr.use_assoc || !sym->attr.referenced)
4292 return;
4293
4294 decl = sym->backend_decl;
4295 TREE_USED(decl) = 1;
4296 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4297
4298 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4299 to make sure the variable is not optimized away. */
4300 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4301
4302 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4303
4304 /* Ensure that we do not have size=0 for zero-sized arrays. */
4305 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4306 fold_convert (size_type_node, size),
4307 build_int_cst (size_type_node, 1));
4308
4309 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4310 {
4311 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4312 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4313 fold_convert (size_type_node, tmp), size);
4314 }
4315
4316 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4317 token = gfc_build_addr_expr (ppvoid_type_node,
4318 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4319
4320 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4321 build_int_cst (integer_type_node,
4322 GFC_CAF_COARRAY_STATIC), /* type. */
4323 token, null_pointer_node, /* token, stat. */
4324 null_pointer_node, /* errgmsg, errmsg_len. */
4325 build_int_cst (integer_type_node, 0));
4326
4327 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4328
4329
4330 /* Handle "static" initializer. */
4331 if (sym->value)
4332 {
4333 sym->attr.pointer = 1;
4334 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4335 true, false);
4336 sym->attr.pointer = 0;
4337 gfc_add_expr_to_block (&caf_init_block, tmp);
4338 }
4339 }
4340
4341
4342 /* Generate constructor function to initialize static, nonallocatable
4343 coarrays. */
4344
4345 static void
4346 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4347 {
4348 tree fndecl, tmp, decl, save_fn_decl;
4349
4350 save_fn_decl = current_function_decl;
4351 push_function_context ();
4352
4353 tmp = build_function_type_list (void_type_node, NULL_TREE);
4354 fndecl = build_decl (input_location, FUNCTION_DECL,
4355 create_tmp_var_name ("_caf_init"), tmp);
4356
4357 DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4358 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4359
4360 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4361 DECL_ARTIFICIAL (decl) = 1;
4362 DECL_IGNORED_P (decl) = 1;
4363 DECL_CONTEXT (decl) = fndecl;
4364 DECL_RESULT (fndecl) = decl;
4365
4366 pushdecl (fndecl);
4367 current_function_decl = fndecl;
4368 announce_function (fndecl);
4369
4370 rest_of_decl_compilation (fndecl, 0, 0);
4371 make_decl_rtl (fndecl);
4372 init_function_start (fndecl);
4373
4374 pushlevel (0);
4375 gfc_init_block (&caf_init_block);
4376
4377 gfc_traverse_ns (ns, generate_coarray_sym_init);
4378
4379 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4380 decl = getdecls ();
4381
4382 poplevel (1, 0, 1);
4383 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4384
4385 DECL_SAVED_TREE (fndecl)
4386 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4387 DECL_INITIAL (fndecl));
4388 dump_function (TDI_original, fndecl);
4389
4390 cfun->function_end_locus = input_location;
4391 set_cfun (NULL);
4392
4393 if (decl_function_context (fndecl))
4394 (void) cgraph_create_node (fndecl);
4395 else
4396 cgraph_finalize_function (fndecl, true);
4397
4398 pop_function_context ();
4399 current_function_decl = save_fn_decl;
4400 }
4401
4402
4403 /* Generate all the required code for module variables. */
4404
4405 void
4406 gfc_generate_module_vars (gfc_namespace * ns)
4407 {
4408 module_namespace = ns;
4409 cur_module = gfc_find_module (ns->proc_name->name);
4410
4411 /* Check if the frontend left the namespace in a reasonable state. */
4412 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4413
4414 /* Generate COMMON blocks. */
4415 gfc_trans_common (ns);
4416
4417 has_coarray_vars = false;
4418
4419 /* Create decls for all the module variables. */
4420 gfc_traverse_ns (ns, gfc_create_module_variable);
4421
4422 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4423 generate_coarray_init (ns);
4424
4425 cur_module = NULL;
4426
4427 gfc_trans_use_stmts (ns);
4428 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4429 }
4430
4431
4432 static void
4433 gfc_generate_contained_functions (gfc_namespace * parent)
4434 {
4435 gfc_namespace *ns;
4436
4437 /* We create all the prototypes before generating any code. */
4438 for (ns = parent->contained; ns; ns = ns->sibling)
4439 {
4440 /* Skip namespaces from used modules. */
4441 if (ns->parent != parent)
4442 continue;
4443
4444 gfc_create_function_decl (ns, false);
4445 }
4446
4447 for (ns = parent->contained; ns; ns = ns->sibling)
4448 {
4449 /* Skip namespaces from used modules. */
4450 if (ns->parent != parent)
4451 continue;
4452
4453 gfc_generate_function_code (ns);
4454 }
4455 }
4456
4457
4458 /* Drill down through expressions for the array specification bounds and
4459 character length calling generate_local_decl for all those variables
4460 that have not already been declared. */
4461
4462 static void
4463 generate_local_decl (gfc_symbol *);
4464
4465 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4466
4467 static bool
4468 expr_decls (gfc_expr *e, gfc_symbol *sym,
4469 int *f ATTRIBUTE_UNUSED)
4470 {
4471 if (e->expr_type != EXPR_VARIABLE
4472 || sym == e->symtree->n.sym
4473 || e->symtree->n.sym->mark
4474 || e->symtree->n.sym->ns != sym->ns)
4475 return false;
4476
4477 generate_local_decl (e->symtree->n.sym);
4478 return false;
4479 }
4480
4481 static void
4482 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4483 {
4484 gfc_traverse_expr (e, sym, expr_decls, 0);
4485 }
4486
4487
4488 /* Check for dependencies in the character length and array spec. */
4489
4490 static void
4491 generate_dependency_declarations (gfc_symbol *sym)
4492 {
4493 int i;
4494
4495 if (sym->ts.type == BT_CHARACTER
4496 && sym->ts.u.cl
4497 && sym->ts.u.cl->length
4498 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4499 generate_expr_decls (sym, sym->ts.u.cl->length);
4500
4501 if (sym->as && sym->as->rank)
4502 {
4503 for (i = 0; i < sym->as->rank; i++)
4504 {
4505 generate_expr_decls (sym, sym->as->lower[i]);
4506 generate_expr_decls (sym, sym->as->upper[i]);
4507 }
4508 }
4509 }
4510
4511
4512 /* Generate decls for all local variables. We do this to ensure correct
4513 handling of expressions which only appear in the specification of
4514 other functions. */
4515
4516 static void
4517 generate_local_decl (gfc_symbol * sym)
4518 {
4519 if (sym->attr.flavor == FL_VARIABLE)
4520 {
4521 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4522 && sym->attr.referenced && !sym->attr.use_assoc)
4523 has_coarray_vars = true;
4524
4525 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4526 generate_dependency_declarations (sym);
4527
4528 if (sym->attr.referenced)
4529 gfc_get_symbol_decl (sym);
4530
4531 /* Warnings for unused dummy arguments. */
4532 else if (sym->attr.dummy)
4533 {
4534 /* INTENT(out) dummy arguments are likely meant to be set. */
4535 if (gfc_option.warn_unused_dummy_argument
4536 && sym->attr.intent == INTENT_OUT)
4537 {
4538 if (sym->ts.type != BT_DERIVED)
4539 gfc_warning ("Dummy argument '%s' at %L was declared "
4540 "INTENT(OUT) but was not set", sym->name,
4541 &sym->declared_at);
4542 else if (!gfc_has_default_initializer (sym->ts.u.derived))
4543 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4544 "declared INTENT(OUT) but was not set and "
4545 "does not have a default initializer",
4546 sym->name, &sym->declared_at);
4547 }
4548 else if (gfc_option.warn_unused_dummy_argument)
4549 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4550 &sym->declared_at);
4551 }
4552
4553 /* Warn for unused variables, but not if they're inside a common
4554 block, a namelist, or are use-associated. */
4555 else if (warn_unused_variable
4556 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
4557 || sym->attr.in_namelist))
4558 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
4559 &sym->declared_at);
4560 else if (warn_unused_variable && sym->attr.use_only)
4561 gfc_warning ("Unused module variable '%s' which has been explicitly "
4562 "imported at %L", sym->name, &sym->declared_at);
4563
4564 /* For variable length CHARACTER parameters, the PARM_DECL already
4565 references the length variable, so force gfc_get_symbol_decl
4566 even when not referenced. If optimize > 0, it will be optimized
4567 away anyway. But do this only after emitting -Wunused-parameter
4568 warning if requested. */
4569 if (sym->attr.dummy && !sym->attr.referenced
4570 && sym->ts.type == BT_CHARACTER
4571 && sym->ts.u.cl->backend_decl != NULL
4572 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4573 {
4574 sym->attr.referenced = 1;
4575 gfc_get_symbol_decl (sym);
4576 }
4577
4578 /* INTENT(out) dummy arguments and result variables with allocatable
4579 components are reset by default and need to be set referenced to
4580 generate the code for nullification and automatic lengths. */
4581 if (!sym->attr.referenced
4582 && sym->ts.type == BT_DERIVED
4583 && sym->ts.u.derived->attr.alloc_comp
4584 && !sym->attr.pointer
4585 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4586 ||
4587 (sym->attr.result && sym != sym->result)))
4588 {
4589 sym->attr.referenced = 1;
4590 gfc_get_symbol_decl (sym);
4591 }
4592
4593 /* Check for dependencies in the array specification and string
4594 length, adding the necessary declarations to the function. We
4595 mark the symbol now, as well as in traverse_ns, to prevent
4596 getting stuck in a circular dependency. */
4597 sym->mark = 1;
4598
4599 /* We do not want the middle-end to warn about unused parameters
4600 as this was already done above. */
4601 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
4602 TREE_NO_WARNING(sym->backend_decl) = 1;
4603 }
4604 else if (sym->attr.flavor == FL_PARAMETER)
4605 {
4606 if (warn_unused_parameter
4607 && !sym->attr.referenced)
4608 {
4609 if (!sym->attr.use_assoc)
4610 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4611 &sym->declared_at);
4612 else if (sym->attr.use_only)
4613 gfc_warning ("Unused parameter '%s' which has been explicitly "
4614 "imported at %L", sym->name, &sym->declared_at);
4615 }
4616 }
4617 else if (sym->attr.flavor == FL_PROCEDURE)
4618 {
4619 /* TODO: move to the appropriate place in resolve.c. */
4620 if (warn_return_type
4621 && sym->attr.function
4622 && sym->result
4623 && sym != sym->result
4624 && !sym->result->attr.referenced
4625 && !sym->attr.use_assoc
4626 && sym->attr.if_source != IFSRC_IFBODY)
4627 {
4628 gfc_warning ("Return value '%s' of function '%s' declared at "
4629 "%L not set", sym->result->name, sym->name,
4630 &sym->result->declared_at);
4631
4632 /* Prevents "Unused variable" warning for RESULT variables. */
4633 sym->result->mark = 1;
4634 }
4635 }
4636
4637 if (sym->attr.dummy == 1)
4638 {
4639 /* Modify the tree type for scalar character dummy arguments of bind(c)
4640 procedures if they are passed by value. The tree type for them will
4641 be promoted to INTEGER_TYPE for the middle end, which appears to be
4642 what C would do with characters passed by-value. The value attribute
4643 implies the dummy is a scalar. */
4644 if (sym->attr.value == 1 && sym->backend_decl != NULL
4645 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4646 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4647 gfc_conv_scalar_char_value (sym, NULL, NULL);
4648 }
4649
4650 /* Make sure we convert the types of the derived types from iso_c_binding
4651 into (void *). */
4652 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4653 && sym->ts.type == BT_DERIVED)
4654 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4655 }
4656
4657 static void
4658 generate_local_vars (gfc_namespace * ns)
4659 {
4660 gfc_traverse_ns (ns, generate_local_decl);
4661 }
4662
4663
4664 /* Generate a switch statement to jump to the correct entry point. Also
4665 creates the label decls for the entry points. */
4666
4667 static tree
4668 gfc_trans_entry_master_switch (gfc_entry_list * el)
4669 {
4670 stmtblock_t block;
4671 tree label;
4672 tree tmp;
4673 tree val;
4674
4675 gfc_init_block (&block);
4676 for (; el; el = el->next)
4677 {
4678 /* Add the case label. */
4679 label = gfc_build_label_decl (NULL_TREE);
4680 val = build_int_cst (gfc_array_index_type, el->id);
4681 tmp = build_case_label (val, NULL_TREE, label);
4682 gfc_add_expr_to_block (&block, tmp);
4683
4684 /* And jump to the actual entry point. */
4685 label = gfc_build_label_decl (NULL_TREE);
4686 tmp = build1_v (GOTO_EXPR, label);
4687 gfc_add_expr_to_block (&block, tmp);
4688
4689 /* Save the label decl. */
4690 el->label = label;
4691 }
4692 tmp = gfc_finish_block (&block);
4693 /* The first argument selects the entry point. */
4694 val = DECL_ARGUMENTS (current_function_decl);
4695 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4696 return tmp;
4697 }
4698
4699
4700 /* Add code to string lengths of actual arguments passed to a function against
4701 the expected lengths of the dummy arguments. */
4702
4703 static void
4704 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4705 {
4706 gfc_formal_arglist *formal;
4707
4708 for (formal = sym->formal; formal; formal = formal->next)
4709 if (formal->sym && formal->sym->ts.type == BT_CHARACTER
4710 && !formal->sym->ts.deferred)
4711 {
4712 enum tree_code comparison;
4713 tree cond;
4714 tree argname;
4715 gfc_symbol *fsym;
4716 gfc_charlen *cl;
4717 const char *message;
4718
4719 fsym = formal->sym;
4720 cl = fsym->ts.u.cl;
4721
4722 gcc_assert (cl);
4723 gcc_assert (cl->passed_length != NULL_TREE);
4724 gcc_assert (cl->backend_decl != NULL_TREE);
4725
4726 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4727 string lengths must match exactly. Otherwise, it is only required
4728 that the actual string length is *at least* the expected one.
4729 Sequence association allows for a mismatch of the string length
4730 if the actual argument is (part of) an array, but only if the
4731 dummy argument is an array. (See "Sequence association" in
4732 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4733 if (fsym->attr.pointer || fsym->attr.allocatable
4734 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4735 {
4736 comparison = NE_EXPR;
4737 message = _("Actual string length does not match the declared one"
4738 " for dummy argument '%s' (%ld/%ld)");
4739 }
4740 else if (fsym->as && fsym->as->rank != 0)
4741 continue;
4742 else
4743 {
4744 comparison = LT_EXPR;
4745 message = _("Actual string length is shorter than the declared one"
4746 " for dummy argument '%s' (%ld/%ld)");
4747 }
4748
4749 /* Build the condition. For optional arguments, an actual length
4750 of 0 is also acceptable if the associated string is NULL, which
4751 means the argument was not passed. */
4752 cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4753 cl->passed_length, cl->backend_decl);
4754 if (fsym->attr.optional)
4755 {
4756 tree not_absent;
4757 tree not_0length;
4758 tree absent_failed;
4759
4760 not_0length = fold_build2_loc (input_location, NE_EXPR,
4761 boolean_type_node,
4762 cl->passed_length,
4763 build_zero_cst (gfc_charlen_type_node));
4764 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4765 fsym->attr.referenced = 1;
4766 not_absent = gfc_conv_expr_present (fsym);
4767
4768 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4769 boolean_type_node, not_0length,
4770 not_absent);
4771
4772 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4773 boolean_type_node, cond, absent_failed);
4774 }
4775
4776 /* Build the runtime check. */
4777 argname = gfc_build_cstring_const (fsym->name);
4778 argname = gfc_build_addr_expr (pchar_type_node, argname);
4779 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4780 message, argname,
4781 fold_convert (long_integer_type_node,
4782 cl->passed_length),
4783 fold_convert (long_integer_type_node,
4784 cl->backend_decl));
4785 }
4786 }
4787
4788
4789 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4790 global variables for -fcoarray=lib. They are placed into the translation
4791 unit of the main program. Make sure that in one TU (the one of the main
4792 program), the first call to gfc_init_coarray_decl is done with true.
4793 Otherwise, expect link errors. */
4794
4795 void
4796 gfc_init_coarray_decl (bool main_tu)
4797 {
4798 tree save_fn_decl;
4799
4800 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4801 return;
4802
4803 if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4804 return;
4805
4806 save_fn_decl = current_function_decl;
4807 current_function_decl = NULL_TREE;
4808 push_cfun (cfun);
4809
4810 gfort_gvar_caf_this_image
4811 = build_decl (input_location, VAR_DECL,
4812 get_identifier (PREFIX("caf_this_image")),
4813 integer_type_node);
4814 DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4815 TREE_USED (gfort_gvar_caf_this_image) = 1;
4816 TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4817 TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4818
4819 if (main_tu)
4820 TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4821 else
4822 DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4823
4824 pushdecl_top_level (gfort_gvar_caf_this_image);
4825
4826 gfort_gvar_caf_num_images
4827 = build_decl (input_location, VAR_DECL,
4828 get_identifier (PREFIX("caf_num_images")),
4829 integer_type_node);
4830 DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4831 TREE_USED (gfort_gvar_caf_num_images) = 1;
4832 TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4833 TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4834
4835 if (main_tu)
4836 TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4837 else
4838 DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4839
4840 pushdecl_top_level (gfort_gvar_caf_num_images);
4841
4842 pop_cfun ();
4843 current_function_decl = save_fn_decl;
4844 }
4845
4846
4847 static void
4848 create_main_function (tree fndecl)
4849 {
4850 tree old_context;
4851 tree ftn_main;
4852 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4853 stmtblock_t body;
4854
4855 old_context = current_function_decl;
4856
4857 if (old_context)
4858 {
4859 push_function_context ();
4860 saved_parent_function_decls = saved_function_decls;
4861 saved_function_decls = NULL_TREE;
4862 }
4863
4864 /* main() function must be declared with global scope. */
4865 gcc_assert (current_function_decl == NULL_TREE);
4866
4867 /* Declare the function. */
4868 tmp = build_function_type_list (integer_type_node, integer_type_node,
4869 build_pointer_type (pchar_type_node),
4870 NULL_TREE);
4871 main_identifier_node = get_identifier ("main");
4872 ftn_main = build_decl (input_location, FUNCTION_DECL,
4873 main_identifier_node, tmp);
4874 DECL_EXTERNAL (ftn_main) = 0;
4875 TREE_PUBLIC (ftn_main) = 1;
4876 TREE_STATIC (ftn_main) = 1;
4877 DECL_ATTRIBUTES (ftn_main)
4878 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4879
4880 /* Setup the result declaration (for "return 0"). */
4881 result_decl = build_decl (input_location,
4882 RESULT_DECL, NULL_TREE, integer_type_node);
4883 DECL_ARTIFICIAL (result_decl) = 1;
4884 DECL_IGNORED_P (result_decl) = 1;
4885 DECL_CONTEXT (result_decl) = ftn_main;
4886 DECL_RESULT (ftn_main) = result_decl;
4887
4888 pushdecl (ftn_main);
4889
4890 /* Get the arguments. */
4891
4892 arglist = NULL_TREE;
4893 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4894
4895 tmp = TREE_VALUE (typelist);
4896 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4897 DECL_CONTEXT (argc) = ftn_main;
4898 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4899 TREE_READONLY (argc) = 1;
4900 gfc_finish_decl (argc);
4901 arglist = chainon (arglist, argc);
4902
4903 typelist = TREE_CHAIN (typelist);
4904 tmp = TREE_VALUE (typelist);
4905 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4906 DECL_CONTEXT (argv) = ftn_main;
4907 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4908 TREE_READONLY (argv) = 1;
4909 DECL_BY_REFERENCE (argv) = 1;
4910 gfc_finish_decl (argv);
4911 arglist = chainon (arglist, argv);
4912
4913 DECL_ARGUMENTS (ftn_main) = arglist;
4914 current_function_decl = ftn_main;
4915 announce_function (ftn_main);
4916
4917 rest_of_decl_compilation (ftn_main, 1, 0);
4918 make_decl_rtl (ftn_main);
4919 init_function_start (ftn_main);
4920 pushlevel (0);
4921
4922 gfc_init_block (&body);
4923
4924 /* Call some libgfortran initialization routines, call then MAIN__(). */
4925
4926 /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images). */
4927 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4928 {
4929 tree pint_type, pppchar_type;
4930 pint_type = build_pointer_type (integer_type_node);
4931 pppchar_type
4932 = build_pointer_type (build_pointer_type (pchar_type_node));
4933
4934 gfc_init_coarray_decl (true);
4935 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
4936 gfc_build_addr_expr (pint_type, argc),
4937 gfc_build_addr_expr (pppchar_type, argv),
4938 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
4939 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
4940 gfc_add_expr_to_block (&body, tmp);
4941 }
4942
4943 /* Call _gfortran_set_args (argc, argv). */
4944 TREE_USED (argc) = 1;
4945 TREE_USED (argv) = 1;
4946 tmp = build_call_expr_loc (input_location,
4947 gfor_fndecl_set_args, 2, argc, argv);
4948 gfc_add_expr_to_block (&body, tmp);
4949
4950 /* Add a call to set_options to set up the runtime library Fortran
4951 language standard parameters. */
4952 {
4953 tree array_type, array, var;
4954 VEC(constructor_elt,gc) *v = NULL;
4955
4956 /* Passing a new option to the library requires four modifications:
4957 + add it to the tree_cons list below
4958 + change the array size in the call to build_array_type
4959 + change the first argument to the library call
4960 gfor_fndecl_set_options
4961 + modify the library (runtime/compile_options.c)! */
4962
4963 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4964 build_int_cst (integer_type_node,
4965 gfc_option.warn_std));
4966 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4967 build_int_cst (integer_type_node,
4968 gfc_option.allow_std));
4969 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4970 build_int_cst (integer_type_node, pedantic));
4971 /* TODO: This is the old -fdump-core option, which is unused but
4972 passed due to ABI compatibility; remove when bumping the
4973 library ABI. */
4974 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4975 build_int_cst (integer_type_node,
4976 0));
4977 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4978 build_int_cst (integer_type_node,
4979 gfc_option.flag_backtrace));
4980 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4981 build_int_cst (integer_type_node,
4982 gfc_option.flag_sign_zero));
4983 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4984 build_int_cst (integer_type_node,
4985 (gfc_option.rtcheck
4986 & GFC_RTCHECK_BOUNDS)));
4987 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4988 build_int_cst (integer_type_node,
4989 gfc_option.flag_range_check));
4990
4991 array_type = build_array_type (integer_type_node,
4992 build_index_type (size_int (7)));
4993 array = build_constructor (array_type, v);
4994 TREE_CONSTANT (array) = 1;
4995 TREE_STATIC (array) = 1;
4996
4997 /* Create a static variable to hold the jump table. */
4998 var = gfc_create_var (array_type, "options");
4999 TREE_CONSTANT (var) = 1;
5000 TREE_STATIC (var) = 1;
5001 TREE_READONLY (var) = 1;
5002 DECL_INITIAL (var) = array;
5003 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5004
5005 tmp = build_call_expr_loc (input_location,
5006 gfor_fndecl_set_options, 2,
5007 build_int_cst (integer_type_node, 8), var);
5008 gfc_add_expr_to_block (&body, tmp);
5009 }
5010
5011 /* If -ffpe-trap option was provided, add a call to set_fpe so that
5012 the library will raise a FPE when needed. */
5013 if (gfc_option.fpe != 0)
5014 {
5015 tmp = build_call_expr_loc (input_location,
5016 gfor_fndecl_set_fpe, 1,
5017 build_int_cst (integer_type_node,
5018 gfc_option.fpe));
5019 gfc_add_expr_to_block (&body, tmp);
5020 }
5021
5022 /* If this is the main program and an -fconvert option was provided,
5023 add a call to set_convert. */
5024
5025 if (gfc_option.convert != GFC_CONVERT_NATIVE)
5026 {
5027 tmp = build_call_expr_loc (input_location,
5028 gfor_fndecl_set_convert, 1,
5029 build_int_cst (integer_type_node,
5030 gfc_option.convert));
5031 gfc_add_expr_to_block (&body, tmp);
5032 }
5033
5034 /* If this is the main program and an -frecord-marker option was provided,
5035 add a call to set_record_marker. */
5036
5037 if (gfc_option.record_marker != 0)
5038 {
5039 tmp = build_call_expr_loc (input_location,
5040 gfor_fndecl_set_record_marker, 1,
5041 build_int_cst (integer_type_node,
5042 gfc_option.record_marker));
5043 gfc_add_expr_to_block (&body, tmp);
5044 }
5045
5046 if (gfc_option.max_subrecord_length != 0)
5047 {
5048 tmp = build_call_expr_loc (input_location,
5049 gfor_fndecl_set_max_subrecord_length, 1,
5050 build_int_cst (integer_type_node,
5051 gfc_option.max_subrecord_length));
5052 gfc_add_expr_to_block (&body, tmp);
5053 }
5054
5055 /* Call MAIN__(). */
5056 tmp = build_call_expr_loc (input_location,
5057 fndecl, 0);
5058 gfc_add_expr_to_block (&body, tmp);
5059
5060 /* Mark MAIN__ as used. */
5061 TREE_USED (fndecl) = 1;
5062
5063 /* Coarray: Call _gfortran_caf_finalize(void). */
5064 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5065 {
5066 /* Per F2008, 8.5.1 END of the main program implies a
5067 SYNC MEMORY. */
5068 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5069 tmp = build_call_expr_loc (input_location, tmp, 0);
5070 gfc_add_expr_to_block (&body, tmp);
5071
5072 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5073 gfc_add_expr_to_block (&body, tmp);
5074 }
5075
5076 /* "return 0". */
5077 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5078 DECL_RESULT (ftn_main),
5079 build_int_cst (integer_type_node, 0));
5080 tmp = build1_v (RETURN_EXPR, tmp);
5081 gfc_add_expr_to_block (&body, tmp);
5082
5083
5084 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5085 decl = getdecls ();
5086
5087 /* Finish off this function and send it for code generation. */
5088 poplevel (1, 0, 1);
5089 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5090
5091 DECL_SAVED_TREE (ftn_main)
5092 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5093 DECL_INITIAL (ftn_main));
5094
5095 /* Output the GENERIC tree. */
5096 dump_function (TDI_original, ftn_main);
5097
5098 cgraph_finalize_function (ftn_main, true);
5099
5100 if (old_context)
5101 {
5102 pop_function_context ();
5103 saved_function_decls = saved_parent_function_decls;
5104 }
5105 current_function_decl = old_context;
5106 }
5107
5108
5109 /* Get the result expression for a procedure. */
5110
5111 static tree
5112 get_proc_result (gfc_symbol* sym)
5113 {
5114 if (sym->attr.subroutine || sym == sym->result)
5115 {
5116 if (current_fake_result_decl != NULL)
5117 return TREE_VALUE (current_fake_result_decl);
5118
5119 return NULL_TREE;
5120 }
5121
5122 return sym->result->backend_decl;
5123 }
5124
5125
5126 /* Generate an appropriate return-statement for a procedure. */
5127
5128 tree
5129 gfc_generate_return (void)
5130 {
5131 gfc_symbol* sym;
5132 tree result;
5133 tree fndecl;
5134
5135 sym = current_procedure_symbol;
5136 fndecl = sym->backend_decl;
5137
5138 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5139 result = NULL_TREE;
5140 else
5141 {
5142 result = get_proc_result (sym);
5143
5144 /* Set the return value to the dummy result variable. The
5145 types may be different for scalar default REAL functions
5146 with -ff2c, therefore we have to convert. */
5147 if (result != NULL_TREE)
5148 {
5149 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5150 result = fold_build2_loc (input_location, MODIFY_EXPR,
5151 TREE_TYPE (result), DECL_RESULT (fndecl),
5152 result);
5153 }
5154 }
5155
5156 return build1_v (RETURN_EXPR, result);
5157 }
5158
5159
5160 /* Generate code for a function. */
5161
5162 void
5163 gfc_generate_function_code (gfc_namespace * ns)
5164 {
5165 tree fndecl;
5166 tree old_context;
5167 tree decl;
5168 tree tmp;
5169 stmtblock_t init, cleanup;
5170 stmtblock_t body;
5171 gfc_wrapped_block try_block;
5172 tree recurcheckvar = NULL_TREE;
5173 gfc_symbol *sym;
5174 gfc_symbol *previous_procedure_symbol;
5175 int rank;
5176 bool is_recursive;
5177
5178 sym = ns->proc_name;
5179 previous_procedure_symbol = current_procedure_symbol;
5180 current_procedure_symbol = sym;
5181
5182 /* Check that the frontend isn't still using this. */
5183 gcc_assert (sym->tlink == NULL);
5184 sym->tlink = sym;
5185
5186 /* Create the declaration for functions with global scope. */
5187 if (!sym->backend_decl)
5188 gfc_create_function_decl (ns, false);
5189
5190 fndecl = sym->backend_decl;
5191 old_context = current_function_decl;
5192
5193 if (old_context)
5194 {
5195 push_function_context ();
5196 saved_parent_function_decls = saved_function_decls;
5197 saved_function_decls = NULL_TREE;
5198 }
5199
5200 trans_function_start (sym);
5201
5202 gfc_init_block (&init);
5203
5204 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5205 {
5206 /* Copy length backend_decls to all entry point result
5207 symbols. */
5208 gfc_entry_list *el;
5209 tree backend_decl;
5210
5211 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5212 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5213 for (el = ns->entries; el; el = el->next)
5214 el->sym->result->ts.u.cl->backend_decl = backend_decl;
5215 }
5216
5217 /* Translate COMMON blocks. */
5218 gfc_trans_common (ns);
5219
5220 /* Null the parent fake result declaration if this namespace is
5221 a module function or an external procedures. */
5222 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5223 || ns->parent == NULL)
5224 parent_fake_result_decl = NULL_TREE;
5225
5226 gfc_generate_contained_functions (ns);
5227
5228 nonlocal_dummy_decls = NULL;
5229 nonlocal_dummy_decl_pset = NULL;
5230
5231 has_coarray_vars = false;
5232 generate_local_vars (ns);
5233
5234 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5235 generate_coarray_init (ns);
5236
5237 /* Keep the parent fake result declaration in module functions
5238 or external procedures. */
5239 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5240 || ns->parent == NULL)
5241 current_fake_result_decl = parent_fake_result_decl;
5242 else
5243 current_fake_result_decl = NULL_TREE;
5244
5245 is_recursive = sym->attr.recursive
5246 || (sym->attr.entry_master
5247 && sym->ns->entries->sym->attr.recursive);
5248 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5249 && !is_recursive
5250 && !gfc_option.flag_recursive)
5251 {
5252 char * msg;
5253
5254 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5255 sym->name);
5256 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5257 TREE_STATIC (recurcheckvar) = 1;
5258 DECL_INITIAL (recurcheckvar) = boolean_false_node;
5259 gfc_add_expr_to_block (&init, recurcheckvar);
5260 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5261 &sym->declared_at, msg);
5262 gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5263 free (msg);
5264 }
5265
5266 /* Now generate the code for the body of this function. */
5267 gfc_init_block (&body);
5268
5269 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5270 && sym->attr.subroutine)
5271 {
5272 tree alternate_return;
5273 alternate_return = gfc_get_fake_result_decl (sym, 0);
5274 gfc_add_modify (&body, alternate_return, integer_zero_node);
5275 }
5276
5277 if (ns->entries)
5278 {
5279 /* Jump to the correct entry point. */
5280 tmp = gfc_trans_entry_master_switch (ns->entries);
5281 gfc_add_expr_to_block (&body, tmp);
5282 }
5283
5284 /* If bounds-checking is enabled, generate code to check passed in actual
5285 arguments against the expected dummy argument attributes (e.g. string
5286 lengths). */
5287 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5288 add_argument_checking (&body, sym);
5289
5290 tmp = gfc_trans_code (ns->code);
5291 gfc_add_expr_to_block (&body, tmp);
5292
5293 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5294 {
5295 tree result = get_proc_result (sym);
5296
5297 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5298 {
5299 if (sym->attr.allocatable && sym->attr.dimension == 0
5300 && sym->result == sym)
5301 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5302 null_pointer_node));
5303 else if (sym->ts.type == BT_CLASS
5304 && CLASS_DATA (sym)->attr.allocatable
5305 && sym->attr.dimension == 0 && sym->result == sym)
5306 {
5307 tmp = CLASS_DATA (sym)->backend_decl;
5308 tmp = fold_build3_loc (input_location, COMPONENT_REF,
5309 TREE_TYPE (tmp), result, tmp, NULL_TREE);
5310 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5311 null_pointer_node));
5312 }
5313 else if (sym->ts.type == BT_DERIVED
5314 && sym->ts.u.derived->attr.alloc_comp
5315 && !sym->attr.allocatable)
5316 {
5317 rank = sym->as ? sym->as->rank : 0;
5318 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5319 gfc_add_expr_to_block (&init, tmp);
5320 }
5321 }
5322
5323 if (result == NULL_TREE)
5324 {
5325 /* TODO: move to the appropriate place in resolve.c. */
5326 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
5327 gfc_warning ("Return value of function '%s' at %L not set",
5328 sym->name, &sym->declared_at);
5329
5330 TREE_NO_WARNING(sym->backend_decl) = 1;
5331 }
5332 else
5333 gfc_add_expr_to_block (&body, gfc_generate_return ());
5334 }
5335
5336 gfc_init_block (&cleanup);
5337
5338 /* Reset recursion-check variable. */
5339 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5340 && !is_recursive
5341 && !gfc_option.gfc_flag_openmp
5342 && recurcheckvar != NULL_TREE)
5343 {
5344 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5345 recurcheckvar = NULL;
5346 }
5347
5348 /* Finish the function body and add init and cleanup code. */
5349 tmp = gfc_finish_block (&body);
5350 gfc_start_wrapped_block (&try_block, tmp);
5351 /* Add code to create and cleanup arrays. */
5352 gfc_trans_deferred_vars (sym, &try_block);
5353 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5354 gfc_finish_block (&cleanup));
5355
5356 /* Add all the decls we created during processing. */
5357 decl = saved_function_decls;
5358 while (decl)
5359 {
5360 tree next;
5361
5362 next = DECL_CHAIN (decl);
5363 DECL_CHAIN (decl) = NULL_TREE;
5364 if (GFC_DECL_PUSH_TOPLEVEL (decl))
5365 pushdecl_top_level (decl);
5366 else
5367 pushdecl (decl);
5368 decl = next;
5369 }
5370 saved_function_decls = NULL_TREE;
5371
5372 DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5373 decl = getdecls ();
5374
5375 /* Finish off this function and send it for code generation. */
5376 poplevel (1, 0, 1);
5377 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5378
5379 DECL_SAVED_TREE (fndecl)
5380 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5381 DECL_INITIAL (fndecl));
5382
5383 if (nonlocal_dummy_decls)
5384 {
5385 BLOCK_VARS (DECL_INITIAL (fndecl))
5386 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5387 pointer_set_destroy (nonlocal_dummy_decl_pset);
5388 nonlocal_dummy_decls = NULL;
5389 nonlocal_dummy_decl_pset = NULL;
5390 }
5391
5392 /* Output the GENERIC tree. */
5393 dump_function (TDI_original, fndecl);
5394
5395 /* Store the end of the function, so that we get good line number
5396 info for the epilogue. */
5397 cfun->function_end_locus = input_location;
5398
5399 /* We're leaving the context of this function, so zap cfun.
5400 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5401 tree_rest_of_compilation. */
5402 set_cfun (NULL);
5403
5404 if (old_context)
5405 {
5406 pop_function_context ();
5407 saved_function_decls = saved_parent_function_decls;
5408 }
5409 current_function_decl = old_context;
5410
5411 if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
5412 && has_coarray_vars)
5413 /* Register this function with cgraph just far enough to get it
5414 added to our parent's nested function list.
5415 If there are static coarrays in this function, the nested _caf_init
5416 function has already called cgraph_create_node, which also created
5417 the cgraph node for this function. */
5418 (void) cgraph_create_node (fndecl);
5419 else
5420 cgraph_finalize_function (fndecl, true);
5421
5422 gfc_trans_use_stmts (ns);
5423 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5424
5425 if (sym->attr.is_main_program)
5426 create_main_function (fndecl);
5427
5428 current_procedure_symbol = previous_procedure_symbol;
5429 }
5430
5431
5432 void
5433 gfc_generate_constructors (void)
5434 {
5435 gcc_assert (gfc_static_ctors == NULL_TREE);
5436 #if 0
5437 tree fnname;
5438 tree type;
5439 tree fndecl;
5440 tree decl;
5441 tree tmp;
5442
5443 if (gfc_static_ctors == NULL_TREE)
5444 return;
5445
5446 fnname = get_file_function_name ("I");
5447 type = build_function_type_list (void_type_node, NULL_TREE);
5448
5449 fndecl = build_decl (input_location,
5450 FUNCTION_DECL, fnname, type);
5451 TREE_PUBLIC (fndecl) = 1;
5452
5453 decl = build_decl (input_location,
5454 RESULT_DECL, NULL_TREE, void_type_node);
5455 DECL_ARTIFICIAL (decl) = 1;
5456 DECL_IGNORED_P (decl) = 1;
5457 DECL_CONTEXT (decl) = fndecl;
5458 DECL_RESULT (fndecl) = decl;
5459
5460 pushdecl (fndecl);
5461
5462 current_function_decl = fndecl;
5463
5464 rest_of_decl_compilation (fndecl, 1, 0);
5465
5466 make_decl_rtl (fndecl);
5467
5468 init_function_start (fndecl);
5469
5470 pushlevel (0);
5471
5472 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5473 {
5474 tmp = build_call_expr_loc (input_location,
5475 TREE_VALUE (gfc_static_ctors), 0);
5476 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5477 }
5478
5479 decl = getdecls ();
5480 poplevel (1, 0, 1);
5481
5482 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5483 DECL_SAVED_TREE (fndecl)
5484 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5485 DECL_INITIAL (fndecl));
5486
5487 free_after_parsing (cfun);
5488 free_after_compilation (cfun);
5489
5490 tree_rest_of_compilation (fndecl);
5491
5492 current_function_decl = NULL_TREE;
5493 #endif
5494 }
5495
5496 /* Translates a BLOCK DATA program unit. This means emitting the
5497 commons contained therein plus their initializations. We also emit
5498 a globally visible symbol to make sure that each BLOCK DATA program
5499 unit remains unique. */
5500
5501 void
5502 gfc_generate_block_data (gfc_namespace * ns)
5503 {
5504 tree decl;
5505 tree id;
5506
5507 /* Tell the backend the source location of the block data. */
5508 if (ns->proc_name)
5509 gfc_set_backend_locus (&ns->proc_name->declared_at);
5510 else
5511 gfc_set_backend_locus (&gfc_current_locus);
5512
5513 /* Process the DATA statements. */
5514 gfc_trans_common (ns);
5515
5516 /* Create a global symbol with the mane of the block data. This is to
5517 generate linker errors if the same name is used twice. It is never
5518 really used. */
5519 if (ns->proc_name)
5520 id = gfc_sym_mangled_function_id (ns->proc_name);
5521 else
5522 id = get_identifier ("__BLOCK_DATA__");
5523
5524 decl = build_decl (input_location,
5525 VAR_DECL, id, gfc_array_index_type);
5526 TREE_PUBLIC (decl) = 1;
5527 TREE_STATIC (decl) = 1;
5528 DECL_IGNORED_P (decl) = 1;
5529
5530 pushdecl (decl);
5531 rest_of_decl_compilation (decl, 1, 0);
5532 }
5533
5534
5535 /* Process the local variables of a BLOCK construct. */
5536
5537 void
5538 gfc_process_block_locals (gfc_namespace* ns)
5539 {
5540 tree decl;
5541
5542 gcc_assert (saved_local_decls == NULL_TREE);
5543 has_coarray_vars = false;
5544
5545 generate_local_vars (ns);
5546
5547 if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5548 generate_coarray_init (ns);
5549
5550 decl = saved_local_decls;
5551 while (decl)
5552 {
5553 tree next;
5554
5555 next = DECL_CHAIN (decl);
5556 DECL_CHAIN (decl) = NULL_TREE;
5557 pushdecl (decl);
5558 decl = next;
5559 }
5560 saved_local_decls = NULL_TREE;
5561 }
5562
5563
5564 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org