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