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