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