projects / gcc.git / blob
? search:


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