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