?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-07-05 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / trans-decl.c
blob1c7226c41e60773ced0ed712d55941e5d7830489
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) = ggc_alloc_cleared_lang_decl(sizeof
616 (struct lang_decl));
617 }
618
619 /* Remember a symbol to generate initialization/cleanup code at function
620 entry/exit. */
621
622 static void
623 gfc_defer_symbol_init (gfc_symbol * sym)
624 {
625 gfc_symbol *p;
626 gfc_symbol *last;
627 gfc_symbol *head;
628
629 /* Don't add a symbol twice. */
630 if (sym->tlink)
631 return;
632
633 last = head = sym->ns->proc_name;
634 p = last->tlink;
635
636 /* Make sure that setup code for dummy variables which are used in the
637 setup of other variables is generated first. */
638 if (sym->attr.dummy)
639 {
640 /* Find the first dummy arg seen after us, or the first non-dummy arg.
641 This is a circular list, so don't go past the head. */
642 while (p != head
643 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
644 {
645 last = p;
646 p = p->tlink;
647 }
648 }
649 /* Insert in between last and p. */
650 last->tlink = sym;
651 sym->tlink = p;
652 }
653
654
655 /* 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.contiguous
1217 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1218 GFC_DECL_PACKED_ARRAY (decl) = 1;
1219 }
1220
1221 /* Remember this variable for allocation/cleanup. */
1222 if (sym->attr.dimension || sym->attr.allocatable
1223 || (sym->ts.type == BT_CLASS &&
1224 (CLASS_DATA (sym)->attr.dimension
1225 || CLASS_DATA (sym)->attr.allocatable))
1226 || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1227 /* This applies a derived type default initializer. */
1228 || (sym->ts.type == BT_DERIVED
1229 && sym->attr.save == SAVE_NONE
1230 && !sym->attr.data
1231 && !sym->attr.allocatable
1232 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1233 && !sym->attr.use_assoc))
1234 gfc_defer_symbol_init (sym);
1235
1236 gfc_finish_var_decl (decl, sym);
1237
1238 if (sym->ts.type == BT_CHARACTER)
1239 {
1240 /* Character variables need special handling. */
1241 gfc_allocate_lang_decl (decl);
1242
1243 if (TREE_CODE (length) != INTEGER_CST)
1244 {
1245 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1246
1247 if (sym->module)
1248 {
1249 /* Also prefix the mangled name for symbols from modules. */
1250 strcpy (&name[1], sym->name);
1251 name[0] = '.';
1252 strcpy (&name[1],
1253 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1254 gfc_set_decl_assembler_name (decl, get_identifier (name));
1255 }
1256 gfc_finish_var_decl (length, sym);
1257 gcc_assert (!sym->value);
1258 }
1259 }
1260 else if (sym->attr.subref_array_pointer)
1261 {
1262 /* We need the span for these beasts. */
1263 gfc_allocate_lang_decl (decl);
1264 }
1265
1266 if (sym->attr.subref_array_pointer)
1267 {
1268 tree span;
1269 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1270 span = build_decl (input_location,
1271 VAR_DECL, create_tmp_var_name ("span"),
1272 gfc_array_index_type);
1273 gfc_finish_var_decl (span, sym);
1274 TREE_STATIC (span) = TREE_STATIC (decl);
1275 DECL_ARTIFICIAL (span) = 1;
1276 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1277
1278 GFC_DECL_SPAN (decl) = span;
1279 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1280 }
1281
1282 sym->backend_decl = decl;
1283
1284 if (sym->attr.assign)
1285 gfc_add_assign_aux_vars (sym);
1286
1287 if (TREE_STATIC (decl) && !sym->attr.use_assoc
1288 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1289 || gfc_option.flag_max_stack_var_size == 0
1290 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
1291 {
1292 /* Add static initializer. For procedures, it is only needed if
1293 SAVE is specified otherwise they need to be reinitialized
1294 every time the procedure is entered. The TREE_STATIC is
1295 in this case due to -fmax-stack-var-size=. */
1296 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1297 TREE_TYPE (decl), sym->attr.dimension,
1298 sym->attr.pointer || sym->attr.allocatable);
1299 }
1300
1301 if (!TREE_STATIC (decl)
1302 && POINTER_TYPE_P (TREE_TYPE (decl))
1303 && !sym->attr.pointer
1304 && !sym->attr.allocatable
1305 && !sym->attr.proc_pointer)
1306 DECL_BY_REFERENCE (decl) = 1;
1307
1308 return decl;
1309 }
1310
1311
1312 /* Substitute a temporary variable in place of the real one. */
1313
1314 void
1315 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1316 {
1317 save->attr = sym->attr;
1318 save->decl = sym->backend_decl;
1319
1320 gfc_clear_attr (&sym->attr);
1321 sym->attr.referenced = 1;
1322 sym->attr.flavor = FL_VARIABLE;
1323
1324 sym->backend_decl = decl;
1325 }
1326
1327
1328 /* Restore the original variable. */
1329
1330 void
1331 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1332 {
1333 sym->attr = save->attr;
1334 sym->backend_decl = save->decl;
1335 }
1336
1337
1338 /* Declare a procedure pointer. */
1339
1340 static tree
1341 get_proc_pointer_decl (gfc_symbol *sym)
1342 {
1343 tree decl;
1344 tree attributes;
1345
1346 decl = sym->backend_decl;
1347 if (decl)
1348 return decl;
1349
1350 decl = build_decl (input_location,
1351 VAR_DECL, get_identifier (sym->name),
1352 build_pointer_type (gfc_get_function_type (sym)));
1353
1354 if ((sym->ns->proc_name
1355 && sym->ns->proc_name->backend_decl == current_function_decl)
1356 || sym->attr.contained)
1357 gfc_add_decl_to_function (decl);
1358 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1359 gfc_add_decl_to_parent_function (decl);
1360
1361 sym->backend_decl = decl;
1362
1363 /* If a variable is USE associated, it's always external. */
1364 if (sym->attr.use_assoc)
1365 {
1366 DECL_EXTERNAL (decl) = 1;
1367 TREE_PUBLIC (decl) = 1;
1368 }
1369 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1370 {
1371 /* This is the declaration of a module variable. */
1372 TREE_PUBLIC (decl) = 1;
1373 TREE_STATIC (decl) = 1;
1374 }
1375
1376 if (!sym->attr.use_assoc
1377 && (sym->attr.save != SAVE_NONE || sym->attr.data
1378 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1379 TREE_STATIC (decl) = 1;
1380
1381 if (TREE_STATIC (decl) && sym->value)
1382 {
1383 /* Add static initializer. */
1384 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1385 TREE_TYPE (decl),
1386 sym->attr.proc_pointer ? false : sym->attr.dimension,
1387 sym->attr.proc_pointer);
1388 }
1389
1390 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1391 decl_attributes (&decl, attributes, 0);
1392
1393 return decl;
1394 }
1395
1396
1397 /* Get a basic decl for an external function. */
1398
1399 tree
1400 gfc_get_extern_function_decl (gfc_symbol * sym)
1401 {
1402 tree type;
1403 tree fndecl;
1404 tree attributes;
1405 gfc_expr e;
1406 gfc_intrinsic_sym *isym;
1407 gfc_expr argexpr;
1408 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
1409 tree name;
1410 tree mangled_name;
1411 gfc_gsymbol *gsym;
1412
1413 if (sym->backend_decl)
1414 return sym->backend_decl;
1415
1416 /* We should never be creating external decls for alternate entry points.
1417 The procedure may be an alternate entry point, but we don't want/need
1418 to know that. */
1419 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1420
1421 if (sym->attr.proc_pointer)
1422 return get_proc_pointer_decl (sym);
1423
1424 /* See if this is an external procedure from the same file. If so,
1425 return the backend_decl. */
1426 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1427
1428 if (gfc_option.flag_whole_file
1429 && !sym->attr.use_assoc
1430 && !sym->backend_decl
1431 && gsym && gsym->ns
1432 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1433 && gsym->ns->proc_name->backend_decl)
1434 {
1435 /* If the namespace has entries, the proc_name is the
1436 entry master. Find the entry and use its backend_decl.
1437 otherwise, use the proc_name backend_decl. */
1438 if (gsym->ns->entries)
1439 {
1440 gfc_entry_list *entry = gsym->ns->entries;
1441
1442 for (; entry; entry = entry->next)
1443 {
1444 if (strcmp (gsym->name, entry->sym->name) == 0)
1445 {
1446 sym->backend_decl = entry->sym->backend_decl;
1447 break;
1448 }
1449 }
1450 }
1451 else
1452 {
1453 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1454 }
1455
1456 if (sym->backend_decl)
1457 return sym->backend_decl;
1458 }
1459
1460 /* See if this is a module procedure from the same file. If so,
1461 return the backend_decl. */
1462 if (sym->module)
1463 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
1464
1465 if (gfc_option.flag_whole_file
1466 && gsym && gsym->ns
1467 && gsym->type == GSYM_MODULE)
1468 {
1469 gfc_symbol *s;
1470
1471 s = NULL;
1472 gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1473 if (s && s->backend_decl)
1474 {
1475 sym->backend_decl = s->backend_decl;
1476 return sym->backend_decl;
1477 }
1478 }
1479
1480 if (sym->attr.intrinsic)
1481 {
1482 /* Call the resolution function to get the actual name. This is
1483 a nasty hack which relies on the resolution functions only looking
1484 at the first argument. We pass NULL for the second argument
1485 otherwise things like AINT get confused. */
1486 isym = gfc_find_function (sym->name);
1487 gcc_assert (isym->resolve.f0 != NULL);
1488
1489 memset (&e, 0, sizeof (e));
1490 e.expr_type = EXPR_FUNCTION;
1491
1492 memset (&argexpr, 0, sizeof (argexpr));
1493 gcc_assert (isym->formal);
1494 argexpr.ts = isym->formal->ts;
1495
1496 if (isym->formal->next == NULL)
1497 isym->resolve.f1 (&e, &argexpr);
1498 else
1499 {
1500 if (isym->formal->next->next == NULL)
1501 isym->resolve.f2 (&e, &argexpr, NULL);
1502 else
1503 {
1504 if (isym->formal->next->next->next == NULL)
1505 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1506 else
1507 {
1508 /* All specific intrinsics take less than 5 arguments. */
1509 gcc_assert (isym->formal->next->next->next->next == NULL);
1510 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1511 }
1512 }
1513 }
1514
1515 if (gfc_option.flag_f2c
1516 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1517 || e.ts.type == BT_COMPLEX))
1518 {
1519 /* Specific which needs a different implementation if f2c
1520 calling conventions are used. */
1521 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1522 }
1523 else
1524 sprintf (s, "_gfortran_specific%s", e.value.function.name);
1525
1526 name = get_identifier (s);
1527 mangled_name = name;
1528 }
1529 else
1530 {
1531 name = gfc_sym_identifier (sym);
1532 mangled_name = gfc_sym_mangled_function_id (sym);
1533 }
1534
1535 type = gfc_get_function_type (sym);
1536 fndecl = build_decl (input_location,
1537 FUNCTION_DECL, name, type);
1538
1539 attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1540 decl_attributes (&fndecl, attributes, 0);
1541
1542 gfc_set_decl_assembler_name (fndecl, mangled_name);
1543
1544 /* Set the context of this decl. */
1545 if (0 && sym->ns && sym->ns->proc_name)
1546 {
1547 /* TODO: Add external decls to the appropriate scope. */
1548 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1549 }
1550 else
1551 {
1552 /* Global declaration, e.g. intrinsic subroutine. */
1553 DECL_CONTEXT (fndecl) = NULL_TREE;
1554 }
1555
1556 DECL_EXTERNAL (fndecl) = 1;
1557
1558 /* This specifies if a function is globally addressable, i.e. it is
1559 the opposite of declaring static in C. */
1560 TREE_PUBLIC (fndecl) = 1;
1561
1562 /* Set attributes for PURE functions. A call to PURE function in the
1563 Fortran 95 sense is both pure and without side effects in the C
1564 sense. */
1565 if (sym->attr.pure || sym->attr.elemental)
1566 {
1567 if (sym->attr.function && !gfc_return_by_reference (sym))
1568 DECL_PURE_P (fndecl) = 1;
1569 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1570 parameters and don't use alternate returns (is this
1571 allowed?). In that case, calls to them are meaningless, and
1572 can be optimized away. See also in build_function_decl(). */
1573 TREE_SIDE_EFFECTS (fndecl) = 0;
1574 }
1575
1576 /* Mark non-returning functions. */
1577 if (sym->attr.noreturn)
1578 TREE_THIS_VOLATILE(fndecl) = 1;
1579
1580 sym->backend_decl = fndecl;
1581
1582 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1583 pushdecl_top_level (fndecl);
1584
1585 return fndecl;
1586 }
1587
1588
1589 /* Create a declaration for a procedure. For external functions (in the C
1590 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1591 a master function with alternate entry points. */
1592
1593 static void
1594 build_function_decl (gfc_symbol * sym)
1595 {
1596 tree fndecl, type, attributes;
1597 symbol_attribute attr;
1598 tree result_decl;
1599 gfc_formal_arglist *f;
1600
1601 gcc_assert (!sym->backend_decl);
1602 gcc_assert (!sym->attr.external);
1603
1604 /* Set the line and filename. sym->declared_at seems to point to the
1605 last statement for subroutines, but it'll do for now. */
1606 gfc_set_backend_locus (&sym->declared_at);
1607
1608 /* Allow only one nesting level. Allow public declarations. */
1609 gcc_assert (current_function_decl == NULL_TREE
1610 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1611 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1612 == NAMESPACE_DECL);
1613
1614 type = gfc_get_function_type (sym);
1615 fndecl = build_decl (input_location,
1616 FUNCTION_DECL, gfc_sym_identifier (sym), type);
1617
1618 attr = sym->attr;
1619
1620 attributes = add_attributes_to_decl (attr, NULL_TREE);
1621 decl_attributes (&fndecl, attributes, 0);
1622
1623 /* Perform name mangling if this is a top level or module procedure. */
1624 if (current_function_decl == NULL_TREE)
1625 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1626
1627 /* Figure out the return type of the declared function, and build a
1628 RESULT_DECL for it. If this is a subroutine with alternate
1629 returns, build a RESULT_DECL for it. */
1630 result_decl = NULL_TREE;
1631 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1632 if (attr.function)
1633 {
1634 if (gfc_return_by_reference (sym))
1635 type = void_type_node;
1636 else
1637 {
1638 if (sym->result != sym)
1639 result_decl = gfc_sym_identifier (sym->result);
1640
1641 type = TREE_TYPE (TREE_TYPE (fndecl));
1642 }
1643 }
1644 else
1645 {
1646 /* Look for alternate return placeholders. */
1647 int has_alternate_returns = 0;
1648 for (f = sym->formal; f; f = f->next)
1649 {
1650 if (f->sym == NULL)
1651 {
1652 has_alternate_returns = 1;
1653 break;
1654 }
1655 }
1656
1657 if (has_alternate_returns)
1658 type = integer_type_node;
1659 else
1660 type = void_type_node;
1661 }
1662
1663 result_decl = build_decl (input_location,
1664 RESULT_DECL, result_decl, type);
1665 DECL_ARTIFICIAL (result_decl) = 1;
1666 DECL_IGNORED_P (result_decl) = 1;
1667 DECL_CONTEXT (result_decl) = fndecl;
1668 DECL_RESULT (fndecl) = result_decl;
1669
1670 /* Don't call layout_decl for a RESULT_DECL.
1671 layout_decl (result_decl, 0); */
1672
1673 /* Set up all attributes for the function. */
1674 DECL_CONTEXT (fndecl) = current_function_decl;
1675 DECL_EXTERNAL (fndecl) = 0;
1676
1677 /* This specifies if a function is globally visible, i.e. it is
1678 the opposite of declaring static in C. */
1679 if (DECL_CONTEXT (fndecl) == NULL_TREE
1680 && !sym->attr.entry_master && !sym->attr.is_main_program)
1681 TREE_PUBLIC (fndecl) = 1;
1682
1683 /* TREE_STATIC means the function body is defined here. */
1684 TREE_STATIC (fndecl) = 1;
1685
1686 /* Set attributes for PURE functions. A call to a PURE function in the
1687 Fortran 95 sense is both pure and without side effects in the C
1688 sense. */
1689 if (attr.pure || attr.elemental)
1690 {
1691 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1692 including an alternate return. In that case it can also be
1693 marked as PURE. See also in gfc_get_extern_function_decl(). */
1694 if (attr.function && !gfc_return_by_reference (sym))
1695 DECL_PURE_P (fndecl) = 1;
1696 TREE_SIDE_EFFECTS (fndecl) = 0;
1697 }
1698
1699
1700 /* Layout the function declaration and put it in the binding level
1701 of the current function. */
1702 pushdecl (fndecl);
1703
1704 sym->backend_decl = fndecl;
1705 }
1706
1707
1708 /* Create the DECL_ARGUMENTS for a procedure. */
1709
1710 static void
1711 create_function_arglist (gfc_symbol * sym)
1712 {
1713 tree fndecl;
1714 gfc_formal_arglist *f;
1715 tree typelist, hidden_typelist;
1716 tree arglist, hidden_arglist;
1717 tree type;
1718 tree parm;
1719
1720 fndecl = sym->backend_decl;
1721
1722 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1723 the new FUNCTION_DECL node. */
1724 arglist = NULL_TREE;
1725 hidden_arglist = NULL_TREE;
1726 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1727
1728 if (sym->attr.entry_master)
1729 {
1730 type = TREE_VALUE (typelist);
1731 parm = build_decl (input_location,
1732 PARM_DECL, get_identifier ("__entry"), type);
1733
1734 DECL_CONTEXT (parm) = fndecl;
1735 DECL_ARG_TYPE (parm) = type;
1736 TREE_READONLY (parm) = 1;
1737 gfc_finish_decl (parm);
1738 DECL_ARTIFICIAL (parm) = 1;
1739
1740 arglist = chainon (arglist, parm);
1741 typelist = TREE_CHAIN (typelist);
1742 }
1743
1744 if (gfc_return_by_reference (sym))
1745 {
1746 tree type = TREE_VALUE (typelist), length = NULL;
1747
1748 if (sym->ts.type == BT_CHARACTER)
1749 {
1750 /* Length of character result. */
1751 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1752 gcc_assert (len_type == gfc_charlen_type_node);
1753
1754 length = build_decl (input_location,
1755 PARM_DECL,
1756 get_identifier (".__result"),
1757 len_type);
1758 if (!sym->ts.u.cl->length)
1759 {
1760 sym->ts.u.cl->backend_decl = length;
1761 TREE_USED (length) = 1;
1762 }
1763 gcc_assert (TREE_CODE (length) == PARM_DECL);
1764 DECL_CONTEXT (length) = fndecl;
1765 DECL_ARG_TYPE (length) = len_type;
1766 TREE_READONLY (length) = 1;
1767 DECL_ARTIFICIAL (length) = 1;
1768 gfc_finish_decl (length);
1769 if (sym->ts.u.cl->backend_decl == NULL
1770 || sym->ts.u.cl->backend_decl == length)
1771 {
1772 gfc_symbol *arg;
1773 tree backend_decl;
1774
1775 if (sym->ts.u.cl->backend_decl == NULL)
1776 {
1777 tree len = build_decl (input_location,
1778 VAR_DECL,
1779 get_identifier ("..__result"),
1780 gfc_charlen_type_node);
1781 DECL_ARTIFICIAL (len) = 1;
1782 TREE_USED (len) = 1;
1783 sym->ts.u.cl->backend_decl = len;
1784 }
1785
1786 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1787 arg = sym->result ? sym->result : sym;
1788 backend_decl = arg->backend_decl;
1789 /* Temporary clear it, so that gfc_sym_type creates complete
1790 type. */
1791 arg->backend_decl = NULL;
1792 type = gfc_sym_type (arg);
1793 arg->backend_decl = backend_decl;
1794 type = build_reference_type (type);
1795 }
1796 }
1797
1798 parm = build_decl (input_location,
1799 PARM_DECL, get_identifier ("__result"), type);
1800
1801 DECL_CONTEXT (parm) = fndecl;
1802 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1803 TREE_READONLY (parm) = 1;
1804 DECL_ARTIFICIAL (parm) = 1;
1805 gfc_finish_decl (parm);
1806
1807 arglist = chainon (arglist, parm);
1808 typelist = TREE_CHAIN (typelist);
1809
1810 if (sym->ts.type == BT_CHARACTER)
1811 {
1812 gfc_allocate_lang_decl (parm);
1813 arglist = chainon (arglist, length);
1814 typelist = TREE_CHAIN (typelist);
1815 }
1816 }
1817
1818 hidden_typelist = typelist;
1819 for (f = sym->formal; f; f = f->next)
1820 if (f->sym != NULL) /* Ignore alternate returns. */
1821 hidden_typelist = TREE_CHAIN (hidden_typelist);
1822
1823 for (f = sym->formal; f; f = f->next)
1824 {
1825 char name[GFC_MAX_SYMBOL_LEN + 2];
1826
1827 /* Ignore alternate returns. */
1828 if (f->sym == NULL)
1829 continue;
1830
1831 type = TREE_VALUE (typelist);
1832
1833 if (f->sym->ts.type == BT_CHARACTER
1834 && (!sym->attr.is_bind_c || sym->attr.entry_master))
1835 {
1836 tree len_type = TREE_VALUE (hidden_typelist);
1837 tree length = NULL_TREE;
1838 gcc_assert (len_type == gfc_charlen_type_node);
1839
1840 strcpy (&name[1], f->sym->name);
1841 name[0] = '_';
1842 length = build_decl (input_location,
1843 PARM_DECL, get_identifier (name), len_type);
1844
1845 hidden_arglist = chainon (hidden_arglist, length);
1846 DECL_CONTEXT (length) = fndecl;
1847 DECL_ARTIFICIAL (length) = 1;
1848 DECL_ARG_TYPE (length) = len_type;
1849 TREE_READONLY (length) = 1;
1850 gfc_finish_decl (length);
1851
1852 /* Remember the passed value. */
1853 if (f->sym->ts.u.cl->passed_length != NULL)
1854 {
1855 /* This can happen if the same type is used for multiple
1856 arguments. We need to copy cl as otherwise
1857 cl->passed_length gets overwritten. */
1858 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
1859 }
1860 f->sym->ts.u.cl->passed_length = length;
1861
1862 /* Use the passed value for assumed length variables. */
1863 if (!f->sym->ts.u.cl->length)
1864 {
1865 TREE_USED (length) = 1;
1866 gcc_assert (!f->sym->ts.u.cl->backend_decl);
1867 f->sym->ts.u.cl->backend_decl = length;
1868 }
1869
1870 hidden_typelist = TREE_CHAIN (hidden_typelist);
1871
1872 if (f->sym->ts.u.cl->backend_decl == NULL
1873 || f->sym->ts.u.cl->backend_decl == length)
1874 {
1875 if (f->sym->ts.u.cl->backend_decl == NULL)
1876 gfc_create_string_length (f->sym);
1877
1878 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1879 if (f->sym->attr.flavor == FL_PROCEDURE)
1880 type = build_pointer_type (gfc_get_function_type (f->sym));
1881 else
1882 type = gfc_sym_type (f->sym);
1883 }
1884 }
1885
1886 /* For non-constant length array arguments, make sure they use
1887 a different type node from TYPE_ARG_TYPES type. */
1888 if (f->sym->attr.dimension
1889 && type == TREE_VALUE (typelist)
1890 && TREE_CODE (type) == POINTER_TYPE
1891 && GFC_ARRAY_TYPE_P (type)
1892 && f->sym->as->type != AS_ASSUMED_SIZE
1893 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1894 {
1895 if (f->sym->attr.flavor == FL_PROCEDURE)
1896 type = build_pointer_type (gfc_get_function_type (f->sym));
1897 else
1898 type = gfc_sym_type (f->sym);
1899 }
1900
1901 if (f->sym->attr.proc_pointer)
1902 type = build_pointer_type (type);
1903
1904 /* Build the argument declaration. */
1905 parm = build_decl (input_location,
1906 PARM_DECL, gfc_sym_identifier (f->sym), type);
1907
1908 /* Fill in arg stuff. */
1909 DECL_CONTEXT (parm) = fndecl;
1910 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1911 /* All implementation args are read-only. */
1912 TREE_READONLY (parm) = 1;
1913 if (POINTER_TYPE_P (type)
1914 && (!f->sym->attr.proc_pointer
1915 && f->sym->attr.flavor != FL_PROCEDURE))
1916 DECL_BY_REFERENCE (parm) = 1;
1917
1918 gfc_finish_decl (parm);
1919
1920 f->sym->backend_decl = parm;
1921
1922 arglist = chainon (arglist, parm);
1923 typelist = TREE_CHAIN (typelist);
1924 }
1925
1926 /* Add the hidden string length parameters, unless the procedure
1927 is bind(C). */
1928 if (!sym->attr.is_bind_c)
1929 arglist = chainon (arglist, hidden_arglist);
1930
1931 gcc_assert (hidden_typelist == NULL_TREE
1932 || TREE_VALUE (hidden_typelist) == void_type_node);
1933 DECL_ARGUMENTS (fndecl) = arglist;
1934 }
1935
1936 /* Do the setup necessary before generating the body of a function. */
1937
1938 static void
1939 trans_function_start (gfc_symbol * sym)
1940 {
1941 tree fndecl;
1942
1943 fndecl = sym->backend_decl;
1944
1945 /* Let GCC know the current scope is this function. */
1946 current_function_decl = fndecl;
1947
1948 /* Let the world know what we're about to do. */
1949 announce_function (fndecl);
1950
1951 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1952 {
1953 /* Create RTL for function declaration. */
1954 rest_of_decl_compilation (fndecl, 1, 0);
1955 }
1956
1957 /* Create RTL for function definition. */
1958 make_decl_rtl (fndecl);
1959
1960 init_function_start (fndecl);
1961
1962 /* Even though we're inside a function body, we still don't want to
1963 call expand_expr to calculate the size of a variable-sized array.
1964 We haven't necessarily assigned RTL to all variables yet, so it's
1965 not safe to try to expand expressions involving them. */
1966 cfun->dont_save_pending_sizes_p = 1;
1967
1968 /* function.c requires a push at the start of the function. */
1969 pushlevel (0);
1970 }
1971
1972 /* Create thunks for alternate entry points. */
1973
1974 static void
1975 build_entry_thunks (gfc_namespace * ns)
1976 {
1977 gfc_formal_arglist *formal;
1978 gfc_formal_arglist *thunk_formal;
1979 gfc_entry_list *el;
1980 gfc_symbol *thunk_sym;
1981 stmtblock_t body;
1982 tree thunk_fndecl;
1983 tree args;
1984 tree string_args;
1985 tree tmp;
1986 locus old_loc;
1987
1988 /* This should always be a toplevel function. */
1989 gcc_assert (current_function_decl == NULL_TREE);
1990
1991 gfc_get_backend_locus (&old_loc);
1992 for (el = ns->entries; el; el = el->next)
1993 {
1994 thunk_sym = el->sym;
1995
1996 build_function_decl (thunk_sym);
1997 create_function_arglist (thunk_sym);
1998
1999 trans_function_start (thunk_sym);
2000
2001 thunk_fndecl = thunk_sym->backend_decl;
2002
2003 gfc_init_block (&body);
2004
2005 /* Pass extra parameter identifying this entry point. */
2006 tmp = build_int_cst (gfc_array_index_type, el->id);
2007 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
2008 string_args = NULL_TREE;
2009
2010 if (thunk_sym->attr.function)
2011 {
2012 if (gfc_return_by_reference (ns->proc_name))
2013 {
2014 tree ref = DECL_ARGUMENTS (current_function_decl);
2015 args = tree_cons (NULL_TREE, ref, args);
2016 if (ns->proc_name->ts.type == BT_CHARACTER)
2017 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
2018 args);
2019 }
2020 }
2021
2022 for (formal = ns->proc_name->formal; formal; formal = formal->next)
2023 {
2024 /* Ignore alternate returns. */
2025 if (formal->sym == NULL)
2026 continue;
2027
2028 /* We don't have a clever way of identifying arguments, so resort to
2029 a brute-force search. */
2030 for (thunk_formal = thunk_sym->formal;
2031 thunk_formal;
2032 thunk_formal = thunk_formal->next)
2033 {
2034 if (thunk_formal->sym == formal->sym)
2035 break;
2036 }
2037
2038 if (thunk_formal)
2039 {
2040 /* Pass the argument. */
2041 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2042 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
2043 args);
2044 if (formal->sym->ts.type == BT_CHARACTER)
2045 {
2046 tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2047 string_args = tree_cons (NULL_TREE, tmp, string_args);
2048 }
2049 }
2050 else
2051 {
2052 /* Pass NULL for a missing argument. */
2053 args = tree_cons (NULL_TREE, null_pointer_node, args);
2054 if (formal->sym->ts.type == BT_CHARACTER)
2055 {
2056 tmp = build_int_cst (gfc_charlen_type_node, 0);
2057 string_args = tree_cons (NULL_TREE, tmp, string_args);
2058 }
2059 }
2060 }
2061
2062 /* Call the master function. */
2063 args = nreverse (args);
2064 args = chainon (args, nreverse (string_args));
2065 tmp = ns->proc_name->backend_decl;
2066 tmp = build_function_call_expr (input_location, tmp, args);
2067 if (ns->proc_name->attr.mixed_entry_master)
2068 {
2069 tree union_decl, field;
2070 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2071
2072 union_decl = build_decl (input_location,
2073 VAR_DECL, get_identifier ("__result"),
2074 TREE_TYPE (master_type));
2075 DECL_ARTIFICIAL (union_decl) = 1;
2076 DECL_EXTERNAL (union_decl) = 0;
2077 TREE_PUBLIC (union_decl) = 0;
2078 TREE_USED (union_decl) = 1;
2079 layout_decl (union_decl, 0);
2080 pushdecl (union_decl);
2081
2082 DECL_CONTEXT (union_decl) = current_function_decl;
2083 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
2084 union_decl, tmp);
2085 gfc_add_expr_to_block (&body, tmp);
2086
2087 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2088 field; field = TREE_CHAIN (field))
2089 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2090 thunk_sym->result->name) == 0)
2091 break;
2092 gcc_assert (field != NULL_TREE);
2093 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2094 union_decl, field, NULL_TREE);
2095 tmp = fold_build2 (MODIFY_EXPR,
2096 TREE_TYPE (DECL_RESULT (current_function_decl)),
2097 DECL_RESULT (current_function_decl), tmp);
2098 tmp = build1_v (RETURN_EXPR, tmp);
2099 }
2100 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2101 != void_type_node)
2102 {
2103 tmp = fold_build2 (MODIFY_EXPR,
2104 TREE_TYPE (DECL_RESULT (current_function_decl)),
2105 DECL_RESULT (current_function_decl), tmp);
2106 tmp = build1_v (RETURN_EXPR, tmp);
2107 }
2108 gfc_add_expr_to_block (&body, tmp);
2109
2110 /* Finish off this function and send it for code generation. */
2111 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2112 tmp = getdecls ();
2113 poplevel (1, 0, 1);
2114 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2115 DECL_SAVED_TREE (thunk_fndecl)
2116 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2117 DECL_INITIAL (thunk_fndecl));
2118
2119 /* Output the GENERIC tree. */
2120 dump_function (TDI_original, thunk_fndecl);
2121
2122 /* Store the end of the function, so that we get good line number
2123 info for the epilogue. */
2124 cfun->function_end_locus = input_location;
2125
2126 /* We're leaving the context of this function, so zap cfun.
2127 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2128 tree_rest_of_compilation. */
2129 set_cfun (NULL);
2130
2131 current_function_decl = NULL_TREE;
2132
2133 cgraph_finalize_function (thunk_fndecl, true);
2134
2135 /* We share the symbols in the formal argument list with other entry
2136 points and the master function. Clear them so that they are
2137 recreated for each function. */
2138 for (formal = thunk_sym->formal; formal; formal = formal->next)
2139 if (formal->sym != NULL) /* Ignore alternate returns. */
2140 {
2141 formal->sym->backend_decl = NULL_TREE;
2142 if (formal->sym->ts.type == BT_CHARACTER)
2143 formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2144 }
2145
2146 if (thunk_sym->attr.function)
2147 {
2148 if (thunk_sym->ts.type == BT_CHARACTER)
2149 thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2150 if (thunk_sym->result->ts.type == BT_CHARACTER)
2151 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2152 }
2153 }
2154
2155 gfc_set_backend_locus (&old_loc);
2156 }
2157
2158
2159 /* Create a decl for a function, and create any thunks for alternate entry
2160 points. */
2161
2162 void
2163 gfc_create_function_decl (gfc_namespace * ns)
2164 {
2165 /* Create a declaration for the master function. */
2166 build_function_decl (ns->proc_name);
2167
2168 /* Compile the entry thunks. */
2169 if (ns->entries)
2170 build_entry_thunks (ns);
2171
2172 /* Now create the read argument list. */
2173 create_function_arglist (ns->proc_name);
2174 }
2175
2176 /* Return the decl used to hold the function return value. If
2177 parent_flag is set, the context is the parent_scope. */
2178
2179 tree
2180 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2181 {
2182 tree decl;
2183 tree length;
2184 tree this_fake_result_decl;
2185 tree this_function_decl;
2186
2187 char name[GFC_MAX_SYMBOL_LEN + 10];
2188
2189 if (parent_flag)
2190 {
2191 this_fake_result_decl = parent_fake_result_decl;
2192 this_function_decl = DECL_CONTEXT (current_function_decl);
2193 }
2194 else
2195 {
2196 this_fake_result_decl = current_fake_result_decl;
2197 this_function_decl = current_function_decl;
2198 }
2199
2200 if (sym
2201 && sym->ns->proc_name->backend_decl == this_function_decl
2202 && sym->ns->proc_name->attr.entry_master
2203 && sym != sym->ns->proc_name)
2204 {
2205 tree t = NULL, var;
2206 if (this_fake_result_decl != NULL)
2207 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2208 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2209 break;
2210 if (t)
2211 return TREE_VALUE (t);
2212 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2213
2214 if (parent_flag)
2215 this_fake_result_decl = parent_fake_result_decl;
2216 else
2217 this_fake_result_decl = current_fake_result_decl;
2218
2219 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2220 {
2221 tree field;
2222
2223 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2224 field; field = TREE_CHAIN (field))
2225 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2226 sym->name) == 0)
2227 break;
2228
2229 gcc_assert (field != NULL_TREE);
2230 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2231 decl, field, NULL_TREE);
2232 }
2233
2234 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2235 if (parent_flag)
2236 gfc_add_decl_to_parent_function (var);
2237 else
2238 gfc_add_decl_to_function (var);
2239
2240 SET_DECL_VALUE_EXPR (var, decl);
2241 DECL_HAS_VALUE_EXPR_P (var) = 1;
2242 GFC_DECL_RESULT (var) = 1;
2243
2244 TREE_CHAIN (this_fake_result_decl)
2245 = tree_cons (get_identifier (sym->name), var,
2246 TREE_CHAIN (this_fake_result_decl));
2247 return var;
2248 }
2249
2250 if (this_fake_result_decl != NULL_TREE)
2251 return TREE_VALUE (this_fake_result_decl);
2252
2253 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2254 sym is NULL. */
2255 if (!sym)
2256 return NULL_TREE;
2257
2258 if (sym->ts.type == BT_CHARACTER)
2259 {
2260 if (sym->ts.u.cl->backend_decl == NULL_TREE)
2261 length = gfc_create_string_length (sym);
2262 else
2263 length = sym->ts.u.cl->backend_decl;
2264 if (TREE_CODE (length) == VAR_DECL
2265 && DECL_CONTEXT (length) == NULL_TREE)
2266 gfc_add_decl_to_function (length);
2267 }
2268
2269 if (gfc_return_by_reference (sym))
2270 {
2271 decl = DECL_ARGUMENTS (this_function_decl);
2272
2273 if (sym->ns->proc_name->backend_decl == this_function_decl
2274 && sym->ns->proc_name->attr.entry_master)
2275 decl = TREE_CHAIN (decl);
2276
2277 TREE_USED (decl) = 1;
2278 if (sym->as)
2279 decl = gfc_build_dummy_array_decl (sym, decl);
2280 }
2281 else
2282 {
2283 sprintf (name, "__result_%.20s",
2284 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2285
2286 if (!sym->attr.mixed_entry_master && sym->attr.function)
2287 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2288 VAR_DECL, get_identifier (name),
2289 gfc_sym_type (sym));
2290 else
2291 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2292 VAR_DECL, get_identifier (name),
2293 TREE_TYPE (TREE_TYPE (this_function_decl)));
2294 DECL_ARTIFICIAL (decl) = 1;
2295 DECL_EXTERNAL (decl) = 0;
2296 TREE_PUBLIC (decl) = 0;
2297 TREE_USED (decl) = 1;
2298 GFC_DECL_RESULT (decl) = 1;
2299 TREE_ADDRESSABLE (decl) = 1;
2300
2301 layout_decl (decl, 0);
2302
2303 if (parent_flag)
2304 gfc_add_decl_to_parent_function (decl);
2305 else
2306 gfc_add_decl_to_function (decl);
2307 }
2308
2309 if (parent_flag)
2310 parent_fake_result_decl = build_tree_list (NULL, decl);
2311 else
2312 current_fake_result_decl = build_tree_list (NULL, decl);
2313
2314 return decl;
2315 }
2316
2317
2318 /* Builds a function decl. The remaining parameters are the types of the
2319 function arguments. Negative nargs indicates a varargs function. */
2320
2321 static tree
2322 build_library_function_decl_1 (tree name, const char *spec,
2323 tree rettype, int nargs, va_list p)
2324 {
2325 tree arglist;
2326 tree argtype;
2327 tree fntype;
2328 tree fndecl;
2329 int n;
2330
2331 /* Library functions must be declared with global scope. */
2332 gcc_assert (current_function_decl == NULL_TREE);
2333
2334 /* Create a list of the argument types. */
2335 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2336 {
2337 argtype = va_arg (p, tree);
2338 arglist = gfc_chainon_list (arglist, argtype);
2339 }
2340
2341 if (nargs >= 0)
2342 {
2343 /* Terminate the list. */
2344 arglist = gfc_chainon_list (arglist, void_type_node);
2345 }
2346
2347 /* Build the function type and decl. */
2348 fntype = build_function_type (rettype, arglist);
2349 if (spec)
2350 {
2351 tree attr_args = build_tree_list (NULL_TREE,
2352 build_string (strlen (spec), spec));
2353 tree attrs = tree_cons (get_identifier ("fn spec"),
2354 attr_args, TYPE_ATTRIBUTES (fntype));
2355 fntype = build_type_attribute_variant (fntype, attrs);
2356 }
2357 fndecl = build_decl (input_location,
2358 FUNCTION_DECL, name, fntype);
2359
2360 /* Mark this decl as external. */
2361 DECL_EXTERNAL (fndecl) = 1;
2362 TREE_PUBLIC (fndecl) = 1;
2363
2364 pushdecl (fndecl);
2365
2366 rest_of_decl_compilation (fndecl, 1, 0);
2367
2368 return fndecl;
2369 }
2370
2371 /* Builds a function decl. The remaining parameters are the types of the
2372 function arguments. Negative nargs indicates a varargs function. */
2373
2374 tree
2375 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2376 {
2377 tree ret;
2378 va_list args;
2379 va_start (args, nargs);
2380 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2381 va_end (args);
2382 return ret;
2383 }
2384
2385 /* Builds a function decl. The remaining parameters are the types of the
2386 function arguments. Negative nargs indicates a varargs function.
2387 The SPEC parameter specifies the function argument and return type
2388 specification according to the fnspec function type attribute. */
2389
2390 static tree
2391 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2392 tree rettype, int nargs, ...)
2393 {
2394 tree ret;
2395 va_list args;
2396 va_start (args, nargs);
2397 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2398 va_end (args);
2399 return ret;
2400 }
2401
2402 static void
2403 gfc_build_intrinsic_function_decls (void)
2404 {
2405 tree gfc_int4_type_node = gfc_get_int_type (4);
2406 tree gfc_int8_type_node = gfc_get_int_type (8);
2407 tree gfc_int16_type_node = gfc_get_int_type (16);
2408 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2409 tree pchar1_type_node = gfc_get_pchar_type (1);
2410 tree pchar4_type_node = gfc_get_pchar_type (4);
2411
2412 /* String functions. */
2413 gfor_fndecl_compare_string =
2414 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2415 integer_type_node, 4,
2416 gfc_charlen_type_node, pchar1_type_node,
2417 gfc_charlen_type_node, pchar1_type_node);
2418
2419 gfor_fndecl_concat_string =
2420 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2421 void_type_node, 6,
2422 gfc_charlen_type_node, pchar1_type_node,
2423 gfc_charlen_type_node, pchar1_type_node,
2424 gfc_charlen_type_node, pchar1_type_node);
2425
2426 gfor_fndecl_string_len_trim =
2427 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2428 gfc_charlen_type_node, 2,
2429 gfc_charlen_type_node, pchar1_type_node);
2430
2431 gfor_fndecl_string_index =
2432 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2433 gfc_charlen_type_node, 5,
2434 gfc_charlen_type_node, pchar1_type_node,
2435 gfc_charlen_type_node, pchar1_type_node,
2436 gfc_logical4_type_node);
2437
2438 gfor_fndecl_string_scan =
2439 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2440 gfc_charlen_type_node, 5,
2441 gfc_charlen_type_node, pchar1_type_node,
2442 gfc_charlen_type_node, pchar1_type_node,
2443 gfc_logical4_type_node);
2444
2445 gfor_fndecl_string_verify =
2446 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2447 gfc_charlen_type_node, 5,
2448 gfc_charlen_type_node, pchar1_type_node,
2449 gfc_charlen_type_node, pchar1_type_node,
2450 gfc_logical4_type_node);
2451
2452 gfor_fndecl_string_trim =
2453 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2454 void_type_node, 4,
2455 build_pointer_type (gfc_charlen_type_node),
2456 build_pointer_type (pchar1_type_node),
2457 gfc_charlen_type_node, pchar1_type_node);
2458
2459 gfor_fndecl_string_minmax =
2460 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2461 void_type_node, -4,
2462 build_pointer_type (gfc_charlen_type_node),
2463 build_pointer_type (pchar1_type_node),
2464 integer_type_node, integer_type_node);
2465
2466 gfor_fndecl_adjustl =
2467 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2468 void_type_node, 3, pchar1_type_node,
2469 gfc_charlen_type_node, pchar1_type_node);
2470
2471 gfor_fndecl_adjustr =
2472 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2473 void_type_node, 3, pchar1_type_node,
2474 gfc_charlen_type_node, pchar1_type_node);
2475
2476 gfor_fndecl_select_string =
2477 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2478 integer_type_node, 4, pvoid_type_node,
2479 integer_type_node, pchar1_type_node,
2480 gfc_charlen_type_node);
2481
2482 gfor_fndecl_compare_string_char4 =
2483 gfc_build_library_function_decl (get_identifier
2484 (PREFIX("compare_string_char4")),
2485 integer_type_node, 4,
2486 gfc_charlen_type_node, pchar4_type_node,
2487 gfc_charlen_type_node, pchar4_type_node);
2488
2489 gfor_fndecl_concat_string_char4 =
2490 gfc_build_library_function_decl (get_identifier
2491 (PREFIX("concat_string_char4")),
2492 void_type_node, 6,
2493 gfc_charlen_type_node, pchar4_type_node,
2494 gfc_charlen_type_node, pchar4_type_node,
2495 gfc_charlen_type_node, pchar4_type_node);
2496
2497 gfor_fndecl_string_len_trim_char4 =
2498 gfc_build_library_function_decl (get_identifier
2499 (PREFIX("string_len_trim_char4")),
2500 gfc_charlen_type_node, 2,
2501 gfc_charlen_type_node, pchar4_type_node);
2502
2503 gfor_fndecl_string_index_char4 =
2504 gfc_build_library_function_decl (get_identifier
2505 (PREFIX("string_index_char4")),
2506 gfc_charlen_type_node, 5,
2507 gfc_charlen_type_node, pchar4_type_node,
2508 gfc_charlen_type_node, pchar4_type_node,
2509 gfc_logical4_type_node);
2510
2511 gfor_fndecl_string_scan_char4 =
2512 gfc_build_library_function_decl (get_identifier
2513 (PREFIX("string_scan_char4")),
2514 gfc_charlen_type_node, 5,
2515 gfc_charlen_type_node, pchar4_type_node,
2516 gfc_charlen_type_node, pchar4_type_node,
2517 gfc_logical4_type_node);
2518
2519 gfor_fndecl_string_verify_char4 =
2520 gfc_build_library_function_decl (get_identifier
2521 (PREFIX("string_verify_char4")),
2522 gfc_charlen_type_node, 5,
2523 gfc_charlen_type_node, pchar4_type_node,
2524 gfc_charlen_type_node, pchar4_type_node,
2525 gfc_logical4_type_node);
2526
2527 gfor_fndecl_string_trim_char4 =
2528 gfc_build_library_function_decl (get_identifier
2529 (PREFIX("string_trim_char4")),
2530 void_type_node, 4,
2531 build_pointer_type (gfc_charlen_type_node),
2532 build_pointer_type (pchar4_type_node),
2533 gfc_charlen_type_node, pchar4_type_node);
2534
2535 gfor_fndecl_string_minmax_char4 =
2536 gfc_build_library_function_decl (get_identifier
2537 (PREFIX("string_minmax_char4")),
2538 void_type_node, -4,
2539 build_pointer_type (gfc_charlen_type_node),
2540 build_pointer_type (pchar4_type_node),
2541 integer_type_node, integer_type_node);
2542
2543 gfor_fndecl_adjustl_char4 =
2544 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2545 void_type_node, 3, pchar4_type_node,
2546 gfc_charlen_type_node, pchar4_type_node);
2547
2548 gfor_fndecl_adjustr_char4 =
2549 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2550 void_type_node, 3, pchar4_type_node,
2551 gfc_charlen_type_node, pchar4_type_node);
2552
2553 gfor_fndecl_select_string_char4 =
2554 gfc_build_library_function_decl (get_identifier
2555 (PREFIX("select_string_char4")),
2556 integer_type_node, 4, pvoid_type_node,
2557 integer_type_node, pvoid_type_node,
2558 gfc_charlen_type_node);
2559
2560
2561 /* Conversion between character kinds. */
2562
2563 gfor_fndecl_convert_char1_to_char4 =
2564 gfc_build_library_function_decl (get_identifier
2565 (PREFIX("convert_char1_to_char4")),
2566 void_type_node, 3,
2567 build_pointer_type (pchar4_type_node),
2568 gfc_charlen_type_node, pchar1_type_node);
2569
2570 gfor_fndecl_convert_char4_to_char1 =
2571 gfc_build_library_function_decl (get_identifier
2572 (PREFIX("convert_char4_to_char1")),
2573 void_type_node, 3,
2574 build_pointer_type (pchar1_type_node),
2575 gfc_charlen_type_node, pchar4_type_node);
2576
2577 /* Misc. functions. */
2578
2579 gfor_fndecl_ttynam =
2580 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2581 void_type_node,
2582 3,
2583 pchar_type_node,
2584 gfc_charlen_type_node,
2585 integer_type_node);
2586
2587 gfor_fndecl_fdate =
2588 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2589 void_type_node,
2590 2,
2591 pchar_type_node,
2592 gfc_charlen_type_node);
2593
2594 gfor_fndecl_ctime =
2595 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2596 void_type_node,
2597 3,
2598 pchar_type_node,
2599 gfc_charlen_type_node,
2600 gfc_int8_type_node);
2601
2602 gfor_fndecl_sc_kind =
2603 gfc_build_library_function_decl (get_identifier
2604 (PREFIX("selected_char_kind")),
2605 gfc_int4_type_node, 2,
2606 gfc_charlen_type_node, pchar_type_node);
2607
2608 gfor_fndecl_si_kind =
2609 gfc_build_library_function_decl (get_identifier
2610 (PREFIX("selected_int_kind")),
2611 gfc_int4_type_node, 1, pvoid_type_node);
2612
2613 gfor_fndecl_sr_kind =
2614 gfc_build_library_function_decl (get_identifier
2615 (PREFIX("selected_real_kind2008")),
2616 gfc_int4_type_node, 3,
2617 pvoid_type_node, pvoid_type_node,
2618 pvoid_type_node);
2619
2620 /* Power functions. */
2621 {
2622 tree ctype, rtype, itype, jtype;
2623 int rkind, ikind, jkind;
2624 #define NIKINDS 3
2625 #define NRKINDS 4
2626 static int ikinds[NIKINDS] = {4, 8, 16};
2627 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2628 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2629
2630 for (ikind=0; ikind < NIKINDS; ikind++)
2631 {
2632 itype = gfc_get_int_type (ikinds[ikind]);
2633
2634 for (jkind=0; jkind < NIKINDS; jkind++)
2635 {
2636 jtype = gfc_get_int_type (ikinds[jkind]);
2637 if (itype && jtype)
2638 {
2639 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2640 ikinds[jkind]);
2641 gfor_fndecl_math_powi[jkind][ikind].integer =
2642 gfc_build_library_function_decl (get_identifier (name),
2643 jtype, 2, jtype, itype);
2644 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2645 }
2646 }
2647
2648 for (rkind = 0; rkind < NRKINDS; rkind ++)
2649 {
2650 rtype = gfc_get_real_type (rkinds[rkind]);
2651 if (rtype && itype)
2652 {
2653 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2654 ikinds[ikind]);
2655 gfor_fndecl_math_powi[rkind][ikind].real =
2656 gfc_build_library_function_decl (get_identifier (name),
2657 rtype, 2, rtype, itype);
2658 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2659 }
2660
2661 ctype = gfc_get_complex_type (rkinds[rkind]);
2662 if (ctype && itype)
2663 {
2664 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2665 ikinds[ikind]);
2666 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2667 gfc_build_library_function_decl (get_identifier (name),
2668 ctype, 2,ctype, itype);
2669 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2670 }
2671 }
2672 }
2673 #undef NIKINDS
2674 #undef NRKINDS
2675 }
2676
2677 gfor_fndecl_math_ishftc4 =
2678 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2679 gfc_int4_type_node,
2680 3, gfc_int4_type_node,
2681 gfc_int4_type_node, gfc_int4_type_node);
2682 gfor_fndecl_math_ishftc8 =
2683 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2684 gfc_int8_type_node,
2685 3, gfc_int8_type_node,
2686 gfc_int4_type_node, gfc_int4_type_node);
2687 if (gfc_int16_type_node)
2688 gfor_fndecl_math_ishftc16 =
2689 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2690 gfc_int16_type_node, 3,
2691 gfc_int16_type_node,
2692 gfc_int4_type_node,
2693 gfc_int4_type_node);
2694
2695 /* BLAS functions. */
2696 {
2697 tree pint = build_pointer_type (integer_type_node);
2698 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2699 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2700 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2701 tree pz = build_pointer_type
2702 (gfc_get_complex_type (gfc_default_double_kind));
2703
2704 gfor_fndecl_sgemm = gfc_build_library_function_decl
2705 (get_identifier
2706 (gfc_option.flag_underscoring ? "sgemm_"
2707 : "sgemm"),
2708 void_type_node, 15, pchar_type_node,
2709 pchar_type_node, pint, pint, pint, ps, ps, pint,
2710 ps, pint, ps, ps, pint, integer_type_node,
2711 integer_type_node);
2712 gfor_fndecl_dgemm = gfc_build_library_function_decl
2713 (get_identifier
2714 (gfc_option.flag_underscoring ? "dgemm_"
2715 : "dgemm"),
2716 void_type_node, 15, pchar_type_node,
2717 pchar_type_node, pint, pint, pint, pd, pd, pint,
2718 pd, pint, pd, pd, pint, integer_type_node,
2719 integer_type_node);
2720 gfor_fndecl_cgemm = gfc_build_library_function_decl
2721 (get_identifier
2722 (gfc_option.flag_underscoring ? "cgemm_"
2723 : "cgemm"),
2724 void_type_node, 15, pchar_type_node,
2725 pchar_type_node, pint, pint, pint, pc, pc, pint,
2726 pc, pint, pc, pc, pint, integer_type_node,
2727 integer_type_node);
2728 gfor_fndecl_zgemm = gfc_build_library_function_decl
2729 (get_identifier
2730 (gfc_option.flag_underscoring ? "zgemm_"
2731 : "zgemm"),
2732 void_type_node, 15, pchar_type_node,
2733 pchar_type_node, pint, pint, pint, pz, pz, pint,
2734 pz, pint, pz, pz, pint, integer_type_node,
2735 integer_type_node);
2736 }
2737
2738 /* Other functions. */
2739 gfor_fndecl_size0 =
2740 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2741 gfc_array_index_type,
2742 1, pvoid_type_node);
2743 gfor_fndecl_size1 =
2744 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2745 gfc_array_index_type,
2746 2, pvoid_type_node,
2747 gfc_array_index_type);
2748
2749 gfor_fndecl_iargc =
2750 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2751 gfc_int4_type_node,
2752 0);
2753
2754 if (gfc_type_for_size (128, true))
2755 {
2756 tree uint128 = gfc_type_for_size (128, true);
2757
2758 gfor_fndecl_clz128 =
2759 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2760 integer_type_node, 1, uint128);
2761
2762 gfor_fndecl_ctz128 =
2763 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2764 integer_type_node, 1, uint128);
2765 }
2766 }
2767
2768
2769 /* Make prototypes for runtime library functions. */
2770
2771 void
2772 gfc_build_builtin_function_decls (void)
2773 {
2774 tree gfc_int4_type_node = gfc_get_int_type (4);
2775
2776 gfor_fndecl_stop_numeric =
2777 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2778 void_type_node, 1, gfc_int4_type_node);
2779 /* STOP doesn't return. */
2780 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2781
2782
2783 gfor_fndecl_stop_string =
2784 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2785 void_type_node, 2, pchar_type_node,
2786 gfc_int4_type_node);
2787 /* STOP doesn't return. */
2788 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2789
2790
2791 gfor_fndecl_error_stop_numeric =
2792 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_numeric")),
2793 void_type_node, 1, gfc_int4_type_node);
2794 /* ERROR STOP doesn't return. */
2795 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
2796
2797
2798 gfor_fndecl_error_stop_string =
2799 gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2800 void_type_node, 2, pchar_type_node,
2801 gfc_int4_type_node);
2802 /* ERROR STOP doesn't return. */
2803 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2804
2805
2806 gfor_fndecl_pause_numeric =
2807 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2808 void_type_node, 1, gfc_int4_type_node);
2809
2810 gfor_fndecl_pause_string =
2811 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2812 void_type_node, 2, pchar_type_node,
2813 gfc_int4_type_node);
2814
2815 gfor_fndecl_runtime_error =
2816 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2817 void_type_node, -1, pchar_type_node);
2818 /* The runtime_error function does not return. */
2819 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2820
2821 gfor_fndecl_runtime_error_at =
2822 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2823 void_type_node, -2, pchar_type_node,
2824 pchar_type_node);
2825 /* The runtime_error_at function does not return. */
2826 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2827
2828 gfor_fndecl_runtime_warning_at =
2829 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2830 void_type_node, -2, pchar_type_node,
2831 pchar_type_node);
2832 gfor_fndecl_generate_error =
2833 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2834 void_type_node, 3, pvoid_type_node,
2835 integer_type_node, pchar_type_node);
2836
2837 gfor_fndecl_os_error =
2838 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2839 void_type_node, 1, pchar_type_node);
2840 /* The runtime_error function does not return. */
2841 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2842
2843 gfor_fndecl_set_args =
2844 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2845 void_type_node, 2, integer_type_node,
2846 build_pointer_type (pchar_type_node));
2847
2848 gfor_fndecl_set_fpe =
2849 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2850 void_type_node, 1, integer_type_node);
2851
2852 /* Keep the array dimension in sync with the call, later in this file. */
2853 gfor_fndecl_set_options =
2854 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2855 void_type_node, 2, integer_type_node,
2856 build_pointer_type (integer_type_node));
2857
2858 gfor_fndecl_set_convert =
2859 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2860 void_type_node, 1, integer_type_node);
2861
2862 gfor_fndecl_set_record_marker =
2863 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2864 void_type_node, 1, integer_type_node);
2865
2866 gfor_fndecl_set_max_subrecord_length =
2867 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2868 void_type_node, 1, integer_type_node);
2869
2870 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
2871 get_identifier (PREFIX("internal_pack")), ".r",
2872 pvoid_type_node, 1, pvoid_type_node);
2873
2874 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
2875 get_identifier (PREFIX("internal_unpack")), ".wR",
2876 void_type_node, 2, pvoid_type_node, pvoid_type_node);
2877
2878 gfor_fndecl_associated =
2879 gfc_build_library_function_decl (
2880 get_identifier (PREFIX("associated")),
2881 integer_type_node, 2, ppvoid_type_node,
2882 ppvoid_type_node);
2883
2884 gfc_build_intrinsic_function_decls ();
2885 gfc_build_intrinsic_lib_fndecls ();
2886 gfc_build_io_library_fndecls ();
2887 }
2888
2889
2890 /* Evaluate the length of dummy character variables. */
2891
2892 static tree
2893 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2894 {
2895 stmtblock_t body;
2896
2897 gfc_finish_decl (cl->backend_decl);
2898
2899 gfc_start_block (&body);
2900
2901 /* Evaluate the string length expression. */
2902 gfc_conv_string_length (cl, NULL, &body);
2903
2904 gfc_trans_vla_type_sizes (sym, &body);
2905
2906 gfc_add_expr_to_block (&body, fnbody);
2907 return gfc_finish_block (&body);
2908 }
2909
2910
2911 /* Allocate and cleanup an automatic character variable. */
2912
2913 static tree
2914 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2915 {
2916 stmtblock_t body;
2917 tree decl;
2918 tree tmp;
2919
2920 gcc_assert (sym->backend_decl);
2921 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2922
2923 gfc_start_block (&body);
2924
2925 /* Evaluate the string length expression. */
2926 gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2927
2928 gfc_trans_vla_type_sizes (sym, &body);
2929
2930 decl = sym->backend_decl;
2931
2932 /* Emit a DECL_EXPR for this variable, which will cause the
2933 gimplifier to allocate storage, and all that good stuff. */
2934 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2935 gfc_add_expr_to_block (&body, tmp);
2936
2937 gfc_add_expr_to_block (&body, fnbody);
2938 return gfc_finish_block (&body);
2939 }
2940
2941 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2942
2943 static tree
2944 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2945 {
2946 stmtblock_t body;
2947
2948 gcc_assert (sym->backend_decl);
2949 gfc_start_block (&body);
2950
2951 /* Set the initial value to length. See the comments in
2952 function gfc_add_assign_aux_vars in this file. */
2953 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2954 build_int_cst (NULL_TREE, -2));
2955
2956 gfc_add_expr_to_block (&body, fnbody);
2957 return gfc_finish_block (&body);
2958 }
2959
2960 static void
2961 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2962 {
2963 tree t = *tp, var, val;
2964
2965 if (t == NULL || t == error_mark_node)
2966 return;
2967 if (TREE_CONSTANT (t) || DECL_P (t))
2968 return;
2969
2970 if (TREE_CODE (t) == SAVE_EXPR)
2971 {
2972 if (SAVE_EXPR_RESOLVED_P (t))
2973 {
2974 *tp = TREE_OPERAND (t, 0);
2975 return;
2976 }
2977 val = TREE_OPERAND (t, 0);
2978 }
2979 else
2980 val = t;
2981
2982 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2983 gfc_add_decl_to_function (var);
2984 gfc_add_modify (body, var, val);
2985 if (TREE_CODE (t) == SAVE_EXPR)
2986 TREE_OPERAND (t, 0) = var;
2987 *tp = var;
2988 }
2989
2990 static void
2991 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2992 {
2993 tree t;
2994
2995 if (type == NULL || type == error_mark_node)
2996 return;
2997
2998 type = TYPE_MAIN_VARIANT (type);
2999
3000 if (TREE_CODE (type) == INTEGER_TYPE)
3001 {
3002 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3003 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3004
3005 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3006 {
3007 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3008 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3009 }
3010 }
3011 else if (TREE_CODE (type) == ARRAY_TYPE)
3012 {
3013 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3014 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3015 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3016 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3017
3018 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3019 {
3020 TYPE_SIZE (t) = TYPE_SIZE (type);
3021 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3022 }
3023 }
3024 }
3025
3026 /* Make sure all type sizes and array domains are either constant,
3027 or variable or parameter decls. This is a simplified variant
3028 of gimplify_type_sizes, but we can't use it here, as none of the
3029 variables in the expressions have been gimplified yet.
3030 As type sizes and domains for various variable length arrays
3031 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3032 time, without this routine gimplify_type_sizes in the middle-end
3033 could result in the type sizes being gimplified earlier than where
3034 those variables are initialized. */
3035
3036 void
3037 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3038 {
3039 tree type = TREE_TYPE (sym->backend_decl);
3040
3041 if (TREE_CODE (type) == FUNCTION_TYPE
3042 && (sym->attr.function || sym->attr.result || sym->attr.entry))
3043 {
3044 if (! current_fake_result_decl)
3045 return;
3046
3047 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3048 }
3049
3050 while (POINTER_TYPE_P (type))
3051 type = TREE_TYPE (type);
3052
3053 if (GFC_DESCRIPTOR_TYPE_P (type))
3054 {
3055 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3056
3057 while (POINTER_TYPE_P (etype))
3058 etype = TREE_TYPE (etype);
3059
3060 gfc_trans_vla_type_sizes_1 (etype, body);
3061 }
3062
3063 gfc_trans_vla_type_sizes_1 (type, body);
3064 }
3065
3066
3067 /* Initialize a derived type by building an lvalue from the symbol
3068 and using trans_assignment to do the work. Set dealloc to false
3069 if no deallocation prior the assignment is needed. */
3070 tree
3071 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3072 {
3073 stmtblock_t fnblock;
3074 gfc_expr *e;
3075 tree tmp;
3076 tree present;
3077
3078 gfc_init_block (&fnblock);
3079 gcc_assert (!sym->attr.allocatable);
3080 gfc_set_sym_referenced (sym);
3081 e = gfc_lval_expr_from_sym (sym);
3082 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3083 if (sym->attr.dummy && (sym->attr.optional
3084 || sym->ns->proc_name->attr.entry_master))
3085 {
3086 present = gfc_conv_expr_present (sym);
3087 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3088 tmp, build_empty_stmt (input_location));
3089 }
3090 gfc_add_expr_to_block (&fnblock, tmp);
3091 gfc_free_expr (e);
3092 if (body)
3093 gfc_add_expr_to_block (&fnblock, body);
3094 return gfc_finish_block (&fnblock);
3095 }
3096
3097
3098 /* Initialize INTENT(OUT) derived type dummies. As well as giving
3099 them their default initializer, if they do not have allocatable
3100 components, they have their allocatable components deallocated. */
3101
3102 static tree
3103 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3104 {
3105 stmtblock_t fnblock;
3106 gfc_formal_arglist *f;
3107 tree tmp;
3108 tree present;
3109
3110 gfc_init_block (&fnblock);
3111 for (f = proc_sym->formal; f; f = f->next)
3112 if (f->sym && f->sym->attr.intent == INTENT_OUT
3113 && !f->sym->attr.pointer
3114 && f->sym->ts.type == BT_DERIVED)
3115 {
3116 if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3117 {
3118 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3119 f->sym->backend_decl,
3120 f->sym->as ? f->sym->as->rank : 0);
3121
3122 if (f->sym->attr.optional
3123 || f->sym->ns->proc_name->attr.entry_master)
3124 {
3125 present = gfc_conv_expr_present (f->sym);
3126 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3127 tmp, build_empty_stmt (input_location));
3128 }
3129
3130 gfc_add_expr_to_block (&fnblock, tmp);
3131 }
3132 else if (f->sym->value)
3133 body = gfc_init_default_dt (f->sym, body, true);
3134 }
3135
3136 gfc_add_expr_to_block (&fnblock, body);
3137 return gfc_finish_block (&fnblock);
3138 }
3139
3140
3141 /* Generate function entry and exit code, and add it to the function body.
3142 This includes:
3143 Allocation and initialization of array variables.
3144 Allocation of character string variables.
3145 Initialization and possibly repacking of dummy arrays.
3146 Initialization of ASSIGN statement auxiliary variable.
3147 Automatic deallocation. */
3148
3149 tree
3150 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3151 {
3152 locus loc;
3153 gfc_symbol *sym;
3154 gfc_formal_arglist *f;
3155 stmtblock_t body;
3156 bool seen_trans_deferred_array = false;
3157
3158 /* Deal with implicit return variables. Explicit return variables will
3159 already have been added. */
3160 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3161 {
3162 if (!current_fake_result_decl)
3163 {
3164 gfc_entry_list *el = NULL;
3165 if (proc_sym->attr.entry_master)
3166 {
3167 for (el = proc_sym->ns->entries; el; el = el->next)
3168 if (el->sym != el->sym->result)
3169 break;
3170 }
3171 /* TODO: move to the appropriate place in resolve.c. */
3172 if (warn_return_type && el == NULL)
3173 gfc_warning ("Return value of function '%s' at %L not set",
3174 proc_sym->name, &proc_sym->declared_at);
3175 }
3176 else if (proc_sym->as)
3177 {
3178 tree result = TREE_VALUE (current_fake_result_decl);
3179 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3180
3181 /* An automatic character length, pointer array result. */
3182 if (proc_sym->ts.type == BT_CHARACTER
3183 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3184 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3185 fnbody);
3186 }
3187 else if (proc_sym->ts.type == BT_CHARACTER)
3188 {
3189 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3190 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3191 fnbody);
3192 }
3193 else
3194 gcc_assert (gfc_option.flag_f2c
3195 && proc_sym->ts.type == BT_COMPLEX);
3196 }
3197
3198 /* Initialize the INTENT(OUT) derived type dummy arguments. This
3199 should be done here so that the offsets and lbounds of arrays
3200 are available. */
3201 fnbody = init_intent_out_dt (proc_sym, fnbody);
3202
3203 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3204 {
3205 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3206 && sym->ts.u.derived->attr.alloc_comp;
3207 if (sym->attr.dimension)
3208 {
3209 switch (sym->as->type)
3210 {
3211 case AS_EXPLICIT:
3212 if (sym->attr.dummy || sym->attr.result)
3213 fnbody =
3214 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3215 else if (sym->attr.pointer || sym->attr.allocatable)
3216 {
3217 if (TREE_STATIC (sym->backend_decl))
3218 gfc_trans_static_array_pointer (sym);
3219 else
3220 {
3221 seen_trans_deferred_array = true;
3222 fnbody = gfc_trans_deferred_array (sym, fnbody);
3223 }
3224 }
3225 else
3226 {
3227 if (sym_has_alloc_comp)
3228 {
3229 seen_trans_deferred_array = true;
3230 fnbody = gfc_trans_deferred_array (sym, fnbody);
3231 }
3232 else if (sym->ts.type == BT_DERIVED
3233 && sym->value
3234 && !sym->attr.data
3235 && sym->attr.save == SAVE_NONE)
3236 fnbody = gfc_init_default_dt (sym, fnbody, false);
3237
3238 gfc_get_backend_locus (&loc);
3239 gfc_set_backend_locus (&sym->declared_at);
3240 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3241 sym, fnbody);
3242 gfc_set_backend_locus (&loc);
3243 }
3244 break;
3245
3246 case AS_ASSUMED_SIZE:
3247 /* Must be a dummy parameter. */
3248 gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3249
3250 /* We should always pass assumed size arrays the g77 way. */
3251 if (sym->attr.dummy)
3252 fnbody = gfc_trans_g77_array (sym, fnbody);
3253 break;
3254
3255 case AS_ASSUMED_SHAPE:
3256 /* Must be a dummy parameter. */
3257 gcc_assert (sym->attr.dummy);
3258
3259 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3260 fnbody);
3261 break;
3262
3263 case AS_DEFERRED:
3264 seen_trans_deferred_array = true;
3265 fnbody = gfc_trans_deferred_array (sym, fnbody);
3266 break;
3267
3268 default:
3269 gcc_unreachable ();
3270 }
3271 if (sym_has_alloc_comp && !seen_trans_deferred_array)
3272 fnbody = gfc_trans_deferred_array (sym, fnbody);
3273 }
3274 else if (sym->attr.allocatable
3275 || (sym->ts.type == BT_CLASS
3276 && CLASS_DATA (sym)->attr.allocatable))
3277 {
3278 if (!sym->attr.save)
3279 {
3280 /* Nullify and automatic deallocation of allocatable
3281 scalars. */
3282 tree tmp;
3283 gfc_expr *e;
3284 gfc_se se;
3285 stmtblock_t block;
3286
3287 e = gfc_lval_expr_from_sym (sym);
3288 if (sym->ts.type == BT_CLASS)
3289 gfc_add_component_ref (e, "$data");
3290
3291 gfc_init_se (&se, NULL);
3292 se.want_pointer = 1;
3293 gfc_conv_expr (&se, e);
3294 gfc_free_expr (e);
3295
3296 /* Nullify when entering the scope. */
3297 gfc_start_block (&block);
3298 gfc_add_modify (&block, se.expr,
3299 fold_convert (TREE_TYPE (se.expr),
3300 null_pointer_node));
3301 gfc_add_expr_to_block (&block, fnbody);
3302
3303 /* Deallocate when leaving the scope. Nullifying is not
3304 needed. */
3305 tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3306 NULL);
3307 gfc_add_expr_to_block (&block, tmp);
3308 fnbody = gfc_finish_block (&block);
3309 }
3310 }
3311 else if (sym_has_alloc_comp)
3312 fnbody = gfc_trans_deferred_array (sym, fnbody);
3313 else if (sym->ts.type == BT_CHARACTER)
3314 {
3315 gfc_get_backend_locus (&loc);
3316 gfc_set_backend_locus (&sym->declared_at);
3317 if (sym->attr.dummy || sym->attr.result)
3318 fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3319 else
3320 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3321 gfc_set_backend_locus (&loc);
3322 }
3323 else if (sym->attr.assign)
3324 {
3325 gfc_get_backend_locus (&loc);
3326 gfc_set_backend_locus (&sym->declared_at);
3327 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3328 gfc_set_backend_locus (&loc);
3329 }
3330 else if (sym->ts.type == BT_DERIVED
3331 && sym->value
3332 && !sym->attr.data
3333 && sym->attr.save == SAVE_NONE)
3334 fnbody = gfc_init_default_dt (sym, fnbody, false);
3335 else
3336 gcc_unreachable ();
3337 }
3338
3339 gfc_init_block (&body);
3340
3341 for (f = proc_sym->formal; f; f = f->next)
3342 {
3343 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3344 {
3345 gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3346 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3347 gfc_trans_vla_type_sizes (f->sym, &body);
3348 }
3349 }
3350
3351 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3352 && current_fake_result_decl != NULL)
3353 {
3354 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3355 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3356 gfc_trans_vla_type_sizes (proc_sym, &body);
3357 }
3358
3359 gfc_add_expr_to_block (&body, fnbody);
3360 return gfc_finish_block (&body);
3361 }
3362
3363 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3364
3365 /* Hash and equality functions for module_htab. */
3366
3367 static hashval_t
3368 module_htab_do_hash (const void *x)
3369 {
3370 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3371 }
3372
3373 static int
3374 module_htab_eq (const void *x1, const void *x2)
3375 {
3376 return strcmp ((((const struct module_htab_entry *)x1)->name),
3377 (const char *)x2) == 0;
3378 }
3379
3380 /* Hash and equality functions for module_htab's decls. */
3381
3382 static hashval_t
3383 module_htab_decls_hash (const void *x)
3384 {
3385 const_tree t = (const_tree) x;
3386 const_tree n = DECL_NAME (t);
3387 if (n == NULL_TREE)
3388 n = TYPE_NAME (TREE_TYPE (t));
3389 return htab_hash_string (IDENTIFIER_POINTER (n));
3390 }
3391
3392 static int
3393 module_htab_decls_eq (const void *x1, const void *x2)
3394 {
3395 const_tree t1 = (const_tree) x1;
3396 const_tree n1 = DECL_NAME (t1);
3397 if (n1 == NULL_TREE)
3398 n1 = TYPE_NAME (TREE_TYPE (t1));
3399 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3400 }
3401
3402 struct module_htab_entry *
3403 gfc_find_module (const char *name)
3404 {
3405 void **slot;
3406
3407 if (! module_htab)
3408 module_htab = htab_create_ggc (10, module_htab_do_hash,
3409 module_htab_eq, NULL);
3410
3411 slot = htab_find_slot_with_hash (module_htab, name,
3412 htab_hash_string (name), INSERT);
3413 if (*slot == NULL)
3414 {
3415 struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3416
3417 entry->name = gfc_get_string (name);
3418 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3419 module_htab_decls_eq, NULL);
3420 *slot = (void *) entry;
3421 }
3422 return (struct module_htab_entry *) *slot;
3423 }
3424
3425 void
3426 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3427 {
3428 void **slot;
3429 const char *name;
3430
3431 if (DECL_NAME (decl))
3432 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3433 else
3434 {
3435 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3436 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3437 }
3438 slot = htab_find_slot_with_hash (entry->decls, name,
3439 htab_hash_string (name), INSERT);
3440 if (*slot == NULL)
3441 *slot = (void *) decl;
3442 }
3443
3444 static struct module_htab_entry *cur_module;
3445
3446 /* Output an initialized decl for a module variable. */
3447
3448 static void
3449 gfc_create_module_variable (gfc_symbol * sym)
3450 {
3451 tree decl;
3452
3453 /* Module functions with alternate entries are dealt with later and
3454 would get caught by the next condition. */
3455 if (sym->attr.entry)
3456 return;
3457
3458 /* Make sure we convert the types of the derived types from iso_c_binding
3459 into (void *). */
3460 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3461 && sym->ts.type == BT_DERIVED)
3462 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3463
3464 if (sym->attr.flavor == FL_DERIVED
3465 && sym->backend_decl
3466 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3467 {
3468 decl = sym->backend_decl;
3469 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3470
3471 /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */
3472 if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3473 {
3474 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3475 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3476 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3477 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3478 == sym->ns->proc_name->backend_decl);
3479 }
3480 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3481 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3482 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3483 }
3484
3485 /* Only output variables, procedure pointers and array valued,
3486 or derived type, parameters. */
3487 if (sym->attr.flavor != FL_VARIABLE
3488 && !(sym->attr.flavor == FL_PARAMETER
3489 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3490 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3491 return;
3492
3493 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3494 {
3495 decl = sym->backend_decl;
3496 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3497 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3498 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3499 gfc_module_add_decl (cur_module, decl);
3500 }
3501
3502 /* Don't generate variables from other modules. Variables from
3503 COMMONs will already have been generated. */
3504 if (sym->attr.use_assoc || sym->attr.in_common)
3505 return;
3506
3507 /* Equivalenced variables arrive here after creation. */
3508 if (sym->backend_decl
3509 && (sym->equiv_built || sym->attr.in_equivalence))
3510 return;
3511
3512 if (sym->backend_decl && !sym->attr.vtab)
3513 internal_error ("backend decl for module variable %s already exists",
3514 sym->name);
3515
3516 /* We always want module variables to be created. */
3517 sym->attr.referenced = 1;
3518 /* Create the decl. */
3519 decl = gfc_get_symbol_decl (sym);
3520
3521 /* Create the variable. */
3522 pushdecl (decl);
3523 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3524 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3525 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3526 rest_of_decl_compilation (decl, 1, 0);
3527 gfc_module_add_decl (cur_module, decl);
3528
3529 /* Also add length of strings. */
3530 if (sym->ts.type == BT_CHARACTER)
3531 {
3532 tree length;
3533
3534 length = sym->ts.u.cl->backend_decl;
3535 gcc_assert (length || sym->attr.proc_pointer);
3536 if (length && !INTEGER_CST_P (length))
3537 {
3538 pushdecl (length);
3539 rest_of_decl_compilation (length, 1, 0);
3540 }
3541 }
3542 }
3543
3544 /* Emit debug information for USE statements. */
3545
3546 static void
3547 gfc_trans_use_stmts (gfc_namespace * ns)
3548 {
3549 gfc_use_list *use_stmt;
3550 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3551 {
3552 struct module_htab_entry *entry
3553 = gfc_find_module (use_stmt->module_name);
3554 gfc_use_rename *rent;
3555
3556 if (entry->namespace_decl == NULL)
3557 {
3558 entry->namespace_decl
3559 = build_decl (input_location,
3560 NAMESPACE_DECL,
3561 get_identifier (use_stmt->module_name),
3562 void_type_node);
3563 DECL_EXTERNAL (entry->namespace_decl) = 1;
3564 }
3565 gfc_set_backend_locus (&use_stmt->where);
3566 if (!use_stmt->only_flag)
3567 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3568 NULL_TREE,
3569 ns->proc_name->backend_decl,
3570 false);
3571 for (rent = use_stmt->rename; rent; rent = rent->next)
3572 {
3573 tree decl, local_name;
3574 void **slot;
3575
3576 if (rent->op != INTRINSIC_NONE)
3577 continue;
3578
3579 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3580 htab_hash_string (rent->use_name),
3581 INSERT);
3582 if (*slot == NULL)
3583 {
3584 gfc_symtree *st;
3585
3586 st = gfc_find_symtree (ns->sym_root,
3587 rent->local_name[0]
3588 ? rent->local_name : rent->use_name);
3589 gcc_assert (st);
3590
3591 /* Sometimes, generic interfaces wind up being over-ruled by a
3592 local symbol (see PR41062). */
3593 if (!st->n.sym->attr.use_assoc)
3594 continue;
3595
3596 if (st->n.sym->backend_decl
3597 && DECL_P (st->n.sym->backend_decl)
3598 && st->n.sym->module
3599 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3600 {
3601 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3602 || (TREE_CODE (st->n.sym->backend_decl)
3603 != VAR_DECL));
3604 decl = copy_node (st->n.sym->backend_decl);
3605 DECL_CONTEXT (decl) = entry->namespace_decl;
3606 DECL_EXTERNAL (decl) = 1;
3607 DECL_IGNORED_P (decl) = 0;
3608 DECL_INITIAL (decl) = NULL_TREE;
3609 }
3610 else
3611 {
3612 *slot = error_mark_node;
3613 htab_clear_slot (entry->decls, slot);
3614 continue;
3615 }
3616 *slot = decl;
3617 }
3618 decl = (tree) *slot;
3619 if (rent->local_name[0])
3620 local_name = get_identifier (rent->local_name);
3621 else
3622 local_name = NULL_TREE;
3623 gfc_set_backend_locus (&rent->where);
3624 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3625 ns->proc_name->backend_decl,
3626 !use_stmt->only_flag);
3627 }
3628 }
3629 }
3630
3631
3632 /* Return true if expr is a constant initializer that gfc_conv_initializer
3633 will handle. */
3634
3635 static bool
3636 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3637 bool pointer)
3638 {
3639 gfc_constructor *c;
3640 gfc_component *cm;
3641
3642 if (pointer)
3643 return true;
3644 else if (array)
3645 {
3646 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3647 return true;
3648 else if (expr->expr_type == EXPR_STRUCTURE)
3649 return check_constant_initializer (expr, ts, false, false);
3650 else if (expr->expr_type != EXPR_ARRAY)
3651 return false;
3652 for (c = gfc_constructor_first (expr->value.constructor);
3653 c; c = gfc_constructor_next (c))
3654 {
3655 if (c->iterator)
3656 return false;
3657 if (c->expr->expr_type == EXPR_STRUCTURE)
3658 {
3659 if (!check_constant_initializer (c->expr, ts, false, false))
3660 return false;
3661 }
3662 else if (c->expr->expr_type != EXPR_CONSTANT)
3663 return false;
3664 }
3665 return true;
3666 }
3667 else switch (ts->type)
3668 {
3669 case BT_DERIVED:
3670 if (expr->expr_type != EXPR_STRUCTURE)
3671 return false;
3672 cm = expr->ts.u.derived->components;
3673 for (c = gfc_constructor_first (expr->value.constructor);
3674 c; c = gfc_constructor_next (c), cm = cm->next)
3675 {
3676 if (!c->expr || cm->attr.allocatable)
3677 continue;
3678 if (!check_constant_initializer (c->expr, &cm->ts,
3679 cm->attr.dimension,
3680 cm->attr.pointer))
3681 return false;
3682 }
3683 return true;
3684 default:
3685 return expr->expr_type == EXPR_CONSTANT;
3686 }
3687 }
3688
3689 /* Emit debug info for parameters and unreferenced variables with
3690 initializers. */
3691
3692 static void
3693 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3694 {
3695 tree decl;
3696
3697 if (sym->attr.flavor != FL_PARAMETER
3698 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3699 return;
3700
3701 if (sym->backend_decl != NULL
3702 || sym->value == NULL
3703 || sym->attr.use_assoc
3704 || sym->attr.dummy
3705 || sym->attr.result
3706 || sym->attr.function
3707 || sym->attr.intrinsic
3708 || sym->attr.pointer
3709 || sym->attr.allocatable
3710 || sym->attr.cray_pointee
3711 || sym->attr.threadprivate
3712 || sym->attr.is_bind_c
3713 || sym->attr.subref_array_pointer
3714 || sym->attr.assign)
3715 return;
3716
3717 if (sym->ts.type == BT_CHARACTER)
3718 {
3719 gfc_conv_const_charlen (sym->ts.u.cl);
3720 if (sym->ts.u.cl->backend_decl == NULL
3721 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3722 return;
3723 }
3724 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3725 return;
3726
3727 if (sym->as)
3728 {
3729 int n;
3730
3731 if (sym->as->type != AS_EXPLICIT)
3732 return;
3733 for (n = 0; n < sym->as->rank; n++)
3734 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3735 || sym->as->upper[n] == NULL
3736 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3737 return;
3738 }
3739
3740 if (!check_constant_initializer (sym->value, &sym->ts,
3741 sym->attr.dimension, false))
3742 return;
3743
3744 /* Create the decl for the variable or constant. */
3745 decl = build_decl (input_location,
3746 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3747 gfc_sym_identifier (sym), gfc_sym_type (sym));
3748 if (sym->attr.flavor == FL_PARAMETER)
3749 TREE_READONLY (decl) = 1;
3750 gfc_set_decl_location (decl, &sym->declared_at);
3751 if (sym->attr.dimension)
3752 GFC_DECL_PACKED_ARRAY (decl) = 1;
3753 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3754 TREE_STATIC (decl) = 1;
3755 TREE_USED (decl) = 1;
3756 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3757 TREE_PUBLIC (decl) = 1;
3758 DECL_INITIAL (decl)
3759 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3760 sym->attr.dimension, 0);
3761 debug_hooks->global_decl (decl);
3762 }
3763
3764 /* Generate all the required code for module variables. */
3765
3766 void
3767 gfc_generate_module_vars (gfc_namespace * ns)
3768 {
3769 module_namespace = ns;
3770 cur_module = gfc_find_module (ns->proc_name->name);
3771
3772 /* Check if the frontend left the namespace in a reasonable state. */
3773 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3774
3775 /* Generate COMMON blocks. */
3776 gfc_trans_common (ns);
3777
3778 /* Create decls for all the module variables. */
3779 gfc_traverse_ns (ns, gfc_create_module_variable);
3780
3781 cur_module = NULL;
3782
3783 gfc_trans_use_stmts (ns);
3784 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3785 }
3786
3787
3788 static void
3789 gfc_generate_contained_functions (gfc_namespace * parent)
3790 {
3791 gfc_namespace *ns;
3792
3793 /* We create all the prototypes before generating any code. */
3794 for (ns = parent->contained; ns; ns = ns->sibling)
3795 {
3796 /* Skip namespaces from used modules. */
3797 if (ns->parent != parent)
3798 continue;
3799
3800 gfc_create_function_decl (ns);
3801 }
3802
3803 for (ns = parent->contained; ns; ns = ns->sibling)
3804 {
3805 /* Skip namespaces from used modules. */
3806 if (ns->parent != parent)
3807 continue;
3808
3809 gfc_generate_function_code (ns);
3810 }
3811 }
3812
3813
3814 /* Drill down through expressions for the array specification bounds and
3815 character length calling generate_local_decl for all those variables
3816 that have not already been declared. */
3817
3818 static void
3819 generate_local_decl (gfc_symbol *);
3820
3821 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3822
3823 static bool
3824 expr_decls (gfc_expr *e, gfc_symbol *sym,
3825 int *f ATTRIBUTE_UNUSED)
3826 {
3827 if (e->expr_type != EXPR_VARIABLE
3828 || sym == e->symtree->n.sym
3829 || e->symtree->n.sym->mark
3830 || e->symtree->n.sym->ns != sym->ns)
3831 return false;
3832
3833 generate_local_decl (e->symtree->n.sym);
3834 return false;
3835 }
3836
3837 static void
3838 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3839 {
3840 gfc_traverse_expr (e, sym, expr_decls, 0);
3841 }
3842
3843
3844 /* Check for dependencies in the character length and array spec. */
3845
3846 static void
3847 generate_dependency_declarations (gfc_symbol *sym)
3848 {
3849 int i;
3850
3851 if (sym->ts.type == BT_CHARACTER
3852 && sym->ts.u.cl
3853 && sym->ts.u.cl->length
3854 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3855 generate_expr_decls (sym, sym->ts.u.cl->length);
3856
3857 if (sym->as && sym->as->rank)
3858 {
3859 for (i = 0; i < sym->as->rank; i++)
3860 {
3861 generate_expr_decls (sym, sym->as->lower[i]);
3862 generate_expr_decls (sym, sym->as->upper[i]);
3863 }
3864 }
3865 }
3866
3867
3868 /* Generate decls for all local variables. We do this to ensure correct
3869 handling of expressions which only appear in the specification of
3870 other functions. */
3871
3872 static void
3873 generate_local_decl (gfc_symbol * sym)
3874 {
3875 if (sym->attr.flavor == FL_VARIABLE)
3876 {
3877 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3878 generate_dependency_declarations (sym);
3879
3880 if (sym->attr.referenced)
3881 gfc_get_symbol_decl (sym);
3882
3883 /* Warnings for unused dummy arguments. */
3884 else if (sym->attr.dummy)
3885 {
3886 /* INTENT(out) dummy arguments are likely meant to be set. */
3887 if (gfc_option.warn_unused_dummy_argument
3888 && sym->attr.intent == INTENT_OUT)
3889 {
3890 if (sym->ts.type != BT_DERIVED)
3891 gfc_warning ("Dummy argument '%s' at %L was declared "
3892 "INTENT(OUT) but was not set", sym->name,
3893 &sym->declared_at);
3894 else if (!gfc_has_default_initializer (sym->ts.u.derived))
3895 gfc_warning ("Derived-type dummy argument '%s' at %L was "
3896 "declared INTENT(OUT) but was not set and "
3897 "does not have a default initializer",
3898 sym->name, &sym->declared_at);
3899 }
3900 else if (gfc_option.warn_unused_dummy_argument)
3901 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3902 &sym->declared_at);
3903 }
3904
3905 /* Warn for unused variables, but not if they're inside a common
3906 block or are use-associated. */
3907 else if (warn_unused_variable
3908 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3909 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3910 &sym->declared_at);
3911
3912 /* For variable length CHARACTER parameters, the PARM_DECL already
3913 references the length variable, so force gfc_get_symbol_decl
3914 even when not referenced. If optimize > 0, it will be optimized
3915 away anyway. But do this only after emitting -Wunused-parameter
3916 warning if requested. */
3917 if (sym->attr.dummy && !sym->attr.referenced
3918 && sym->ts.type == BT_CHARACTER
3919 && sym->ts.u.cl->backend_decl != NULL
3920 && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3921 {
3922 sym->attr.referenced = 1;
3923 gfc_get_symbol_decl (sym);
3924 }
3925
3926 /* INTENT(out) dummy arguments and result variables with allocatable
3927 components are reset by default and need to be set referenced to
3928 generate the code for nullification and automatic lengths. */
3929 if (!sym->attr.referenced
3930 && sym->ts.type == BT_DERIVED
3931 && sym->ts.u.derived->attr.alloc_comp
3932 && !sym->attr.pointer
3933 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3934 ||
3935 (sym->attr.result && sym != sym->result)))
3936 {
3937 sym->attr.referenced = 1;
3938 gfc_get_symbol_decl (sym);
3939 }
3940
3941 /* Check for dependencies in the array specification and string
3942 length, adding the necessary declarations to the function. We
3943 mark the symbol now, as well as in traverse_ns, to prevent
3944 getting stuck in a circular dependency. */
3945 sym->mark = 1;
3946
3947 /* We do not want the middle-end to warn about unused parameters
3948 as this was already done above. */
3949 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3950 TREE_NO_WARNING(sym->backend_decl) = 1;
3951 }
3952 else if (sym->attr.flavor == FL_PARAMETER)
3953 {
3954 if (warn_unused_parameter
3955 && !sym->attr.referenced
3956 && !sym->attr.use_assoc)
3957 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3958 &sym->declared_at);
3959 }
3960 else if (sym->attr.flavor == FL_PROCEDURE)
3961 {
3962 /* TODO: move to the appropriate place in resolve.c. */
3963 if (warn_return_type
3964 && sym->attr.function
3965 && sym->result
3966 && sym != sym->result
3967 && !sym->result->attr.referenced
3968 && !sym->attr.use_assoc
3969 && sym->attr.if_source != IFSRC_IFBODY)
3970 {
3971 gfc_warning ("Return value '%s' of function '%s' declared at "
3972 "%L not set", sym->result->name, sym->name,
3973 &sym->result->declared_at);
3974
3975 /* Prevents "Unused variable" warning for RESULT variables. */
3976 sym->result->mark = 1;
3977 }
3978 }
3979
3980 if (sym->attr.dummy == 1)
3981 {
3982 /* Modify the tree type for scalar character dummy arguments of bind(c)
3983 procedures if they are passed by value. The tree type for them will
3984 be promoted to INTEGER_TYPE for the middle end, which appears to be
3985 what C would do with characters passed by-value. The value attribute
3986 implies the dummy is a scalar. */
3987 if (sym->attr.value == 1 && sym->backend_decl != NULL
3988 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3989 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3990 gfc_conv_scalar_char_value (sym, NULL, NULL);
3991 }
3992
3993 /* Make sure we convert the types of the derived types from iso_c_binding
3994 into (void *). */
3995 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3996 && sym->ts.type == BT_DERIVED)
3997 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3998 }
3999
4000 static void
4001 generate_local_vars (gfc_namespace * ns)
4002 {
4003 gfc_traverse_ns (ns, generate_local_decl);
4004 }
4005
4006
4007 /* Generate a switch statement to jump to the correct entry point. Also
4008 creates the label decls for the entry points. */
4009
4010 static tree
4011 gfc_trans_entry_master_switch (gfc_entry_list * el)
4012 {
4013 stmtblock_t block;
4014 tree label;
4015 tree tmp;
4016 tree val;
4017
4018 gfc_init_block (&block);
4019 for (; el; el = el->next)
4020 {
4021 /* Add the case label. */
4022 label = gfc_build_label_decl (NULL_TREE);
4023 val = build_int_cst (gfc_array_index_type, el->id);
4024 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4025 gfc_add_expr_to_block (&block, tmp);
4026
4027 /* And jump to the actual entry point. */
4028 label = gfc_build_label_decl (NULL_TREE);
4029 tmp = build1_v (GOTO_EXPR, label);
4030 gfc_add_expr_to_block (&block, tmp);
4031
4032 /* Save the label decl. */
4033 el->label = label;
4034 }
4035 tmp = gfc_finish_block (&block);
4036 /* The first argument selects the entry point. */
4037 val = DECL_ARGUMENTS (current_function_decl);
4038 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4039 return tmp;
4040 }
4041
4042
4043 /* Add code to string lengths of actual arguments passed to a function against
4044 the expected lengths of the dummy arguments. */
4045
4046 static void
4047 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4048 {
4049 gfc_formal_arglist *formal;
4050
4051 for (formal = sym->formal; formal; formal = formal->next)
4052 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4053 {
4054 enum tree_code comparison;
4055 tree cond;
4056 tree argname;
4057 gfc_symbol *fsym;
4058 gfc_charlen *cl;
4059 const char *message;
4060
4061 fsym = formal->sym;
4062 cl = fsym->ts.u.cl;
4063
4064 gcc_assert (cl);
4065 gcc_assert (cl->passed_length != NULL_TREE);
4066 gcc_assert (cl->backend_decl != NULL_TREE);
4067
4068 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4069 string lengths must match exactly. Otherwise, it is only required
4070 that the actual string length is *at least* the expected one.
4071 Sequence association allows for a mismatch of the string length
4072 if the actual argument is (part of) an array, but only if the
4073 dummy argument is an array. (See "Sequence association" in
4074 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */
4075 if (fsym->attr.pointer || fsym->attr.allocatable
4076 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4077 {
4078 comparison = NE_EXPR;
4079 message = _("Actual string length does not match the declared one"
4080 " for dummy argument '%s' (%ld/%ld)");
4081 }
4082 else if (fsym->as && fsym->as->rank != 0)
4083 continue;
4084 else
4085 {
4086 comparison = LT_EXPR;
4087 message = _("Actual string length is shorter than the declared one"
4088 " for dummy argument '%s' (%ld/%ld)");
4089 }
4090
4091 /* Build the condition. For optional arguments, an actual length
4092 of 0 is also acceptable if the associated string is NULL, which
4093 means the argument was not passed. */
4094 cond = fold_build2 (comparison, boolean_type_node,
4095 cl->passed_length, cl->backend_decl);
4096 if (fsym->attr.optional)
4097 {
4098 tree not_absent;
4099 tree not_0length;
4100 tree absent_failed;
4101
4102 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4103 cl->passed_length,
4104 fold_convert (gfc_charlen_type_node,
4105 integer_zero_node));
4106 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
4107 fsym->attr.referenced = 1;
4108 not_absent = gfc_conv_expr_present (fsym);
4109
4110 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4111 not_0length, not_absent);
4112
4113 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4114 cond, absent_failed);
4115 }
4116
4117 /* Build the runtime check. */
4118 argname = gfc_build_cstring_const (fsym->name);
4119 argname = gfc_build_addr_expr (pchar_type_node, argname);
4120 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4121 message, argname,
4122 fold_convert (long_integer_type_node,
4123 cl->passed_length),
4124 fold_convert (long_integer_type_node,
4125 cl->backend_decl));
4126 }
4127 }
4128
4129
4130 static void
4131 create_main_function (tree fndecl)
4132 {
4133 tree old_context;
4134 tree ftn_main;
4135 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4136 stmtblock_t body;
4137
4138 old_context = current_function_decl;
4139
4140 if (old_context)
4141 {
4142 push_function_context ();
4143 saved_parent_function_decls = saved_function_decls;
4144 saved_function_decls = NULL_TREE;
4145 }
4146
4147 /* main() function must be declared with global scope. */
4148 gcc_assert (current_function_decl == NULL_TREE);
4149
4150 /* Declare the function. */
4151 tmp = build_function_type_list (integer_type_node, integer_type_node,
4152 build_pointer_type (pchar_type_node),
4153 NULL_TREE);
4154 main_identifier_node = get_identifier ("main");
4155 ftn_main = build_decl (input_location, FUNCTION_DECL,
4156 main_identifier_node, tmp);
4157 DECL_EXTERNAL (ftn_main) = 0;
4158 TREE_PUBLIC (ftn_main) = 1;
4159 TREE_STATIC (ftn_main) = 1;
4160 DECL_ATTRIBUTES (ftn_main)
4161 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4162
4163 /* Setup the result declaration (for "return 0"). */
4164 result_decl = build_decl (input_location,
4165 RESULT_DECL, NULL_TREE, integer_type_node);
4166 DECL_ARTIFICIAL (result_decl) = 1;
4167 DECL_IGNORED_P (result_decl) = 1;
4168 DECL_CONTEXT (result_decl) = ftn_main;
4169 DECL_RESULT (ftn_main) = result_decl;
4170
4171 pushdecl (ftn_main);
4172
4173 /* Get the arguments. */
4174
4175 arglist = NULL_TREE;
4176 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4177
4178 tmp = TREE_VALUE (typelist);
4179 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4180 DECL_CONTEXT (argc) = ftn_main;
4181 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4182 TREE_READONLY (argc) = 1;
4183 gfc_finish_decl (argc);
4184 arglist = chainon (arglist, argc);
4185
4186 typelist = TREE_CHAIN (typelist);
4187 tmp = TREE_VALUE (typelist);
4188 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4189 DECL_CONTEXT (argv) = ftn_main;
4190 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4191 TREE_READONLY (argv) = 1;
4192 DECL_BY_REFERENCE (argv) = 1;
4193 gfc_finish_decl (argv);
4194 arglist = chainon (arglist, argv);
4195
4196 DECL_ARGUMENTS (ftn_main) = arglist;
4197 current_function_decl = ftn_main;
4198 announce_function (ftn_main);
4199
4200 rest_of_decl_compilation (ftn_main, 1, 0);
4201 make_decl_rtl (ftn_main);
4202 init_function_start (ftn_main);
4203 pushlevel (0);
4204
4205 gfc_init_block (&body);
4206
4207 /* Call some libgfortran initialization routines, call then MAIN__(). */
4208
4209 /* Call _gfortran_set_args (argc, argv). */
4210 TREE_USED (argc) = 1;
4211 TREE_USED (argv) = 1;
4212 tmp = build_call_expr_loc (input_location,
4213 gfor_fndecl_set_args, 2, argc, argv);
4214 gfc_add_expr_to_block (&body, tmp);
4215
4216 /* Add a call to set_options to set up the runtime library Fortran
4217 language standard parameters. */
4218 {
4219 tree array_type, array, var;
4220 VEC(constructor_elt,gc) *v = NULL;
4221
4222 /* Passing a new option to the library requires four modifications:
4223 + add it to the tree_cons list below
4224 + change the array size in the call to build_array_type
4225 + change the first argument to the library call
4226 gfor_fndecl_set_options
4227 + modify the library (runtime/compile_options.c)! */
4228
4229 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4230 build_int_cst (integer_type_node,
4231 gfc_option.warn_std));
4232 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4233 build_int_cst (integer_type_node,
4234 gfc_option.allow_std));
4235 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4236 build_int_cst (integer_type_node, pedantic));
4237 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4238 build_int_cst (integer_type_node,
4239 gfc_option.flag_dump_core));
4240 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4241 build_int_cst (integer_type_node,
4242 gfc_option.flag_backtrace));
4243 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4244 build_int_cst (integer_type_node,
4245 gfc_option.flag_sign_zero));
4246 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4247 build_int_cst (integer_type_node,
4248 (gfc_option.rtcheck
4249 & GFC_RTCHECK_BOUNDS)));
4250 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4251 build_int_cst (integer_type_node,
4252 gfc_option.flag_range_check));
4253
4254 array_type = build_array_type (integer_type_node,
4255 build_index_type (build_int_cst (NULL_TREE, 7)));
4256 array = build_constructor (array_type, v);
4257 TREE_CONSTANT (array) = 1;
4258 TREE_STATIC (array) = 1;
4259
4260 /* Create a static variable to hold the jump table. */
4261 var = gfc_create_var (array_type, "options");
4262 TREE_CONSTANT (var) = 1;
4263 TREE_STATIC (var) = 1;
4264 TREE_READONLY (var) = 1;
4265 DECL_INITIAL (var) = array;
4266 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4267
4268 tmp = build_call_expr_loc (input_location,
4269 gfor_fndecl_set_options, 2,
4270 build_int_cst (integer_type_node, 8), var);
4271 gfc_add_expr_to_block (&body, tmp);
4272 }
4273
4274 /* If -ffpe-trap option was provided, add a call to set_fpe so that
4275 the library will raise a FPE when needed. */
4276 if (gfc_option.fpe != 0)
4277 {
4278 tmp = build_call_expr_loc (input_location,
4279 gfor_fndecl_set_fpe, 1,
4280 build_int_cst (integer_type_node,
4281 gfc_option.fpe));
4282 gfc_add_expr_to_block (&body, tmp);
4283 }
4284
4285 /* If this is the main program and an -fconvert option was provided,
4286 add a call to set_convert. */
4287
4288 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4289 {
4290 tmp = build_call_expr_loc (input_location,
4291 gfor_fndecl_set_convert, 1,
4292 build_int_cst (integer_type_node,
4293 gfc_option.convert));
4294 gfc_add_expr_to_block (&body, tmp);
4295 }
4296
4297 /* If this is the main program and an -frecord-marker option was provided,
4298 add a call to set_record_marker. */
4299
4300 if (gfc_option.record_marker != 0)
4301 {
4302 tmp = build_call_expr_loc (input_location,
4303 gfor_fndecl_set_record_marker, 1,
4304 build_int_cst (integer_type_node,
4305 gfc_option.record_marker));
4306 gfc_add_expr_to_block (&body, tmp);
4307 }
4308
4309 if (gfc_option.max_subrecord_length != 0)
4310 {
4311 tmp = build_call_expr_loc (input_location,
4312 gfor_fndecl_set_max_subrecord_length, 1,
4313 build_int_cst (integer_type_node,
4314 gfc_option.max_subrecord_length));
4315 gfc_add_expr_to_block (&body, tmp);
4316 }
4317
4318 /* Call MAIN__(). */
4319 tmp = build_call_expr_loc (input_location,
4320 fndecl, 0);
4321 gfc_add_expr_to_block (&body, tmp);
4322
4323 /* Mark MAIN__ as used. */
4324 TREE_USED (fndecl) = 1;
4325
4326 /* "return 0". */
4327 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4328 build_int_cst (integer_type_node, 0));
4329 tmp = build1_v (RETURN_EXPR, tmp);
4330 gfc_add_expr_to_block (&body, tmp);
4331
4332
4333 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4334 decl = getdecls ();
4335
4336 /* Finish off this function and send it for code generation. */
4337 poplevel (1, 0, 1);
4338 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4339
4340 DECL_SAVED_TREE (ftn_main)
4341 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4342 DECL_INITIAL (ftn_main));
4343
4344 /* Output the GENERIC tree. */
4345 dump_function (TDI_original, ftn_main);
4346
4347 cgraph_finalize_function (ftn_main, true);
4348
4349 if (old_context)
4350 {
4351 pop_function_context ();
4352 saved_function_decls = saved_parent_function_decls;
4353 }
4354 current_function_decl = old_context;
4355 }
4356
4357
4358 /* Generate code for a function. */
4359
4360 void
4361 gfc_generate_function_code (gfc_namespace * ns)
4362 {
4363 tree fndecl;
4364 tree old_context;
4365 tree decl;
4366 tree tmp;
4367 tree tmp2;
4368 stmtblock_t block;
4369 stmtblock_t body;
4370 tree result;
4371 tree recurcheckvar = NULL_TREE;
4372 gfc_symbol *sym;
4373 int rank;
4374 bool is_recursive;
4375
4376 sym = ns->proc_name;
4377
4378 /* Check that the frontend isn't still using this. */
4379 gcc_assert (sym->tlink == NULL);
4380 sym->tlink = sym;
4381
4382 /* Create the declaration for functions with global scope. */
4383 if (!sym->backend_decl)
4384 gfc_create_function_decl (ns);
4385
4386 fndecl = sym->backend_decl;
4387 old_context = current_function_decl;
4388
4389 if (old_context)
4390 {
4391 push_function_context ();
4392 saved_parent_function_decls = saved_function_decls;
4393 saved_function_decls = NULL_TREE;
4394 }
4395
4396 trans_function_start (sym);
4397
4398 gfc_init_block (&block);
4399
4400 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4401 {
4402 /* Copy length backend_decls to all entry point result
4403 symbols. */
4404 gfc_entry_list *el;
4405 tree backend_decl;
4406
4407 gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4408 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4409 for (el = ns->entries; el; el = el->next)
4410 el->sym->result->ts.u.cl->backend_decl = backend_decl;
4411 }
4412
4413 /* Translate COMMON blocks. */
4414 gfc_trans_common (ns);
4415
4416 /* Null the parent fake result declaration if this namespace is
4417 a module function or an external procedures. */
4418 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4419 || ns->parent == NULL)
4420 parent_fake_result_decl = NULL_TREE;
4421
4422 gfc_generate_contained_functions (ns);
4423
4424 nonlocal_dummy_decls = NULL;
4425 nonlocal_dummy_decl_pset = NULL;
4426
4427 generate_local_vars (ns);
4428
4429 /* Keep the parent fake result declaration in module functions
4430 or external procedures. */
4431 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4432 || ns->parent == NULL)
4433 current_fake_result_decl = parent_fake_result_decl;
4434 else
4435 current_fake_result_decl = NULL_TREE;
4436
4437 current_function_return_label = NULL;
4438
4439 /* Now generate the code for the body of this function. */
4440 gfc_init_block (&body);
4441
4442 is_recursive = sym->attr.recursive
4443 || (sym->attr.entry_master
4444 && sym->ns->entries->sym->attr.recursive);
4445 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4446 && !is_recursive
4447 && !gfc_option.flag_recursive)
4448 {
4449 char * msg;
4450
4451 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4452 sym->name);
4453 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4454 TREE_STATIC (recurcheckvar) = 1;
4455 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4456 gfc_add_expr_to_block (&block, recurcheckvar);
4457 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4458 &sym->declared_at, msg);
4459 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4460 gfc_free (msg);
4461 }
4462
4463 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4464 && sym->attr.subroutine)
4465 {
4466 tree alternate_return;
4467 alternate_return = gfc_get_fake_result_decl (sym, 0);
4468 gfc_add_modify (&body, alternate_return, integer_zero_node);
4469 }
4470
4471 if (ns->entries)
4472 {
4473 /* Jump to the correct entry point. */
4474 tmp = gfc_trans_entry_master_switch (ns->entries);
4475 gfc_add_expr_to_block (&body, tmp);
4476 }
4477
4478 /* If bounds-checking is enabled, generate code to check passed in actual
4479 arguments against the expected dummy argument attributes (e.g. string
4480 lengths). */
4481 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4482 add_argument_checking (&body, sym);
4483
4484 tmp = gfc_trans_code (ns->code);
4485 gfc_add_expr_to_block (&body, tmp);
4486
4487 /* Add a return label if needed. */
4488 if (current_function_return_label)
4489 {
4490 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4491 gfc_add_expr_to_block (&body, tmp);
4492 }
4493
4494 tmp = gfc_finish_block (&body);
4495 /* Add code to create and cleanup arrays. */
4496 tmp = gfc_trans_deferred_vars (sym, tmp);
4497
4498 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4499 {
4500 if (sym->attr.subroutine || sym == sym->result)
4501 {
4502 if (current_fake_result_decl != NULL)
4503 result = TREE_VALUE (current_fake_result_decl);
4504 else
4505 result = NULL_TREE;
4506 current_fake_result_decl = NULL_TREE;
4507 }
4508 else
4509 result = sym->result->backend_decl;
4510
4511 if (result != NULL_TREE
4512 && sym->attr.function
4513 && !sym->attr.pointer)
4514 {
4515 if (sym->ts.type == BT_DERIVED
4516 && sym->ts.u.derived->attr.alloc_comp)
4517 {
4518 rank = sym->as ? sym->as->rank : 0;
4519 tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4520 gfc_add_expr_to_block (&block, tmp2);
4521 }
4522 else if (sym->attr.allocatable && sym->attr.dimension == 0)
4523 gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
4524 null_pointer_node));
4525 }
4526
4527 gfc_add_expr_to_block (&block, tmp);
4528
4529 /* Reset recursion-check variable. */
4530 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4531 && !is_recursive
4532 && !gfc_option.flag_openmp
4533 && recurcheckvar != NULL_TREE)
4534 {
4535 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4536 recurcheckvar = NULL;
4537 }
4538
4539 if (result == NULL_TREE)
4540 {
4541 /* TODO: move to the appropriate place in resolve.c. */
4542 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4543 gfc_warning ("Return value of function '%s' at %L not set",
4544 sym->name, &sym->declared_at);
4545
4546 TREE_NO_WARNING(sym->backend_decl) = 1;
4547 }
4548 else
4549 {
4550 /* Set the return value to the dummy result variable. The
4551 types may be different for scalar default REAL functions
4552 with -ff2c, therefore we have to convert. */
4553 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4554 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4555 DECL_RESULT (fndecl), tmp);
4556 tmp = build1_v (RETURN_EXPR, tmp);
4557 gfc_add_expr_to_block (&block, tmp);
4558 }
4559 }
4560 else
4561 {
4562 gfc_add_expr_to_block (&block, tmp);
4563 /* Reset recursion-check variable. */
4564 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4565 && !is_recursive
4566 && !gfc_option.flag_openmp
4567 && recurcheckvar != NULL_TREE)
4568 {
4569 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4570 recurcheckvar = NULL_TREE;
4571 }
4572 }
4573
4574
4575 /* Add all the decls we created during processing. */
4576 decl = saved_function_decls;
4577 while (decl)
4578 {
4579 tree next;
4580
4581 next = TREE_CHAIN (decl);
4582 TREE_CHAIN (decl) = NULL_TREE;
4583 pushdecl (decl);
4584 decl = next;
4585 }
4586 saved_function_decls = NULL_TREE;
4587
4588 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4589 decl = getdecls ();
4590
4591 /* Finish off this function and send it for code generation. */
4592 poplevel (1, 0, 1);
4593 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4594
4595 DECL_SAVED_TREE (fndecl)
4596 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4597 DECL_INITIAL (fndecl));
4598
4599 if (nonlocal_dummy_decls)
4600 {
4601 BLOCK_VARS (DECL_INITIAL (fndecl))
4602 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4603 pointer_set_destroy (nonlocal_dummy_decl_pset);
4604 nonlocal_dummy_decls = NULL;
4605 nonlocal_dummy_decl_pset = NULL;
4606 }
4607
4608 /* Output the GENERIC tree. */
4609 dump_function (TDI_original, fndecl);
4610
4611 /* Store the end of the function, so that we get good line number
4612 info for the epilogue. */
4613 cfun->function_end_locus = input_location;
4614
4615 /* We're leaving the context of this function, so zap cfun.
4616 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4617 tree_rest_of_compilation. */
4618 set_cfun (NULL);
4619
4620 if (old_context)
4621 {
4622 pop_function_context ();
4623 saved_function_decls = saved_parent_function_decls;
4624 }
4625 current_function_decl = old_context;
4626
4627 if (decl_function_context (fndecl))
4628 /* Register this function with cgraph just far enough to get it
4629 added to our parent's nested function list. */
4630 (void) cgraph_node (fndecl);
4631 else
4632 cgraph_finalize_function (fndecl, true);
4633
4634 gfc_trans_use_stmts (ns);
4635 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4636
4637 if (sym->attr.is_main_program)
4638 create_main_function (fndecl);
4639 }
4640
4641
4642 void
4643 gfc_generate_constructors (void)
4644 {
4645 gcc_assert (gfc_static_ctors == NULL_TREE);
4646 #if 0
4647 tree fnname;
4648 tree type;
4649 tree fndecl;
4650 tree decl;
4651 tree tmp;
4652
4653 if (gfc_static_ctors == NULL_TREE)
4654 return;
4655
4656 fnname = get_file_function_name ("I");
4657 type = build_function_type_list (void_type_node, NULL_TREE);
4658
4659 fndecl = build_decl (input_location,
4660 FUNCTION_DECL, fnname, type);
4661 TREE_PUBLIC (fndecl) = 1;
4662
4663 decl = build_decl (input_location,
4664 RESULT_DECL, NULL_TREE, void_type_node);
4665 DECL_ARTIFICIAL (decl) = 1;
4666 DECL_IGNORED_P (decl) = 1;
4667 DECL_CONTEXT (decl) = fndecl;
4668 DECL_RESULT (fndecl) = decl;
4669
4670 pushdecl (fndecl);
4671
4672 current_function_decl = fndecl;
4673
4674 rest_of_decl_compilation (fndecl, 1, 0);
4675
4676 make_decl_rtl (fndecl);
4677
4678 init_function_start (fndecl);
4679
4680 pushlevel (0);
4681
4682 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4683 {
4684 tmp = build_call_expr_loc (input_location,
4685 TREE_VALUE (gfc_static_ctors), 0);
4686 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4687 }
4688
4689 decl = getdecls ();
4690 poplevel (1, 0, 1);
4691
4692 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4693 DECL_SAVED_TREE (fndecl)
4694 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4695 DECL_INITIAL (fndecl));
4696
4697 free_after_parsing (cfun);
4698 free_after_compilation (cfun);
4699
4700 tree_rest_of_compilation (fndecl);
4701
4702 current_function_decl = NULL_TREE;
4703 #endif
4704 }
4705
4706 /* Translates a BLOCK DATA program unit. This means emitting the
4707 commons contained therein plus their initializations. We also emit
4708 a globally visible symbol to make sure that each BLOCK DATA program
4709 unit remains unique. */
4710
4711 void
4712 gfc_generate_block_data (gfc_namespace * ns)
4713 {
4714 tree decl;
4715 tree id;
4716
4717 /* Tell the backend the source location of the block data. */
4718 if (ns->proc_name)
4719 gfc_set_backend_locus (&ns->proc_name->declared_at);
4720 else
4721 gfc_set_backend_locus (&gfc_current_locus);
4722
4723 /* Process the DATA statements. */
4724 gfc_trans_common (ns);
4725
4726 /* Create a global symbol with the mane of the block data. This is to
4727 generate linker errors if the same name is used twice. It is never
4728 really used. */
4729 if (ns->proc_name)
4730 id = gfc_sym_mangled_function_id (ns->proc_name);
4731 else
4732 id = get_identifier ("__BLOCK_DATA__");
4733
4734 decl = build_decl (input_location,
4735 VAR_DECL, id, gfc_array_index_type);
4736 TREE_PUBLIC (decl) = 1;
4737 TREE_STATIC (decl) = 1;
4738 DECL_IGNORED_P (decl) = 1;
4739
4740 pushdecl (decl);
4741 rest_of_decl_compilation (decl, 1, 0);
4742 }
4743
4744
4745 /* Process the local variables of a BLOCK construct. */
4746
4747 void
4748 gfc_process_block_locals (gfc_namespace* ns)
4749 {
4750 tree decl;
4751
4752 gcc_assert (saved_local_decls == NULL_TREE);
4753 generate_local_vars (ns);
4754
4755 decl = saved_local_decls;
4756 while (decl)
4757 {
4758 tree next;
4759
4760 next = TREE_CHAIN (decl);
4761 TREE_CHAIN (decl) = NULL_TREE;
4762 pushdecl (decl);
4763 decl = next;
4764 }
4765 saved_local_decls = NULL_TREE;
4766 }
4767
4768
4769 #include "gt-fortran-trans-decl.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org