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