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