]> 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
PR middle-end/25989
[thirdparty/gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
4ee9c684 1/* Backend function setup
c173930f 2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
3 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
10Software Foundation; either version 2, or (at your option) any later
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
c84b470d 19along with GCC; see the file COPYING. If not, write to the Free
30d4ffea 20Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2102110-1301, USA. */
4ee9c684 22
23/* trans-decl.c -- Handling of backend function and variable decls, etc */
24
25#include "config.h"
26#include "system.h"
27#include "coretypes.h"
28#include "tree.h"
29#include "tree-dump.h"
88bce636 30#include "tree-gimple.h"
4ee9c684 31#include "ggc.h"
32#include "toplev.h"
33#include "tm.h"
0290e11b 34#include "rtl.h"
4ee9c684 35#include "target.h"
36#include "function.h"
4ee9c684 37#include "flags.h"
38#include "cgraph.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
77tree gfor_fndecl_internal_malloc;
78tree gfor_fndecl_internal_malloc64;
9e1839e2 79tree gfor_fndecl_internal_realloc;
80tree gfor_fndecl_internal_realloc64;
4ee9c684 81tree gfor_fndecl_internal_free;
82tree gfor_fndecl_allocate;
83tree gfor_fndecl_allocate64;
8a92488f 84tree gfor_fndecl_allocate_array;
85tree gfor_fndecl_allocate64_array;
4ee9c684 86tree gfor_fndecl_deallocate;
87tree gfor_fndecl_pause_numeric;
88tree gfor_fndecl_pause_string;
89tree gfor_fndecl_stop_numeric;
90tree gfor_fndecl_stop_string;
91tree gfor_fndecl_select_string;
92tree gfor_fndecl_runtime_error;
8c84a5de 93tree gfor_fndecl_set_fpe;
64fc3c4c 94tree gfor_fndecl_set_std;
15774a8b 95tree gfor_fndecl_set_convert;
b902b078 96tree gfor_fndecl_ctime;
97tree gfor_fndecl_fdate;
dbc97b88 98tree gfor_fndecl_ttynam;
4ee9c684 99tree gfor_fndecl_in_pack;
100tree gfor_fndecl_in_unpack;
101tree gfor_fndecl_associated;
102
103
104/* Math functions. Many other math functions are handled in
105 trans-intrinsic.c. */
106
920e54ef 107gfc_powdecl_list gfor_fndecl_math_powi[4][3];
4ee9c684 108tree gfor_fndecl_math_cpowf;
109tree gfor_fndecl_math_cpow;
920e54ef 110tree gfor_fndecl_math_cpowl10;
111tree gfor_fndecl_math_cpowl16;
4ee9c684 112tree gfor_fndecl_math_ishftc4;
113tree gfor_fndecl_math_ishftc8;
920e54ef 114tree gfor_fndecl_math_ishftc16;
4ee9c684 115tree gfor_fndecl_math_exponent4;
116tree gfor_fndecl_math_exponent8;
920e54ef 117tree gfor_fndecl_math_exponent10;
118tree gfor_fndecl_math_exponent16;
4ee9c684 119
120
121/* String functions. */
122
123tree gfor_fndecl_copy_string;
124tree gfor_fndecl_compare_string;
125tree gfor_fndecl_concat_string;
126tree gfor_fndecl_string_len_trim;
127tree gfor_fndecl_string_index;
128tree gfor_fndecl_string_scan;
129tree gfor_fndecl_string_verify;
130tree gfor_fndecl_string_trim;
131tree gfor_fndecl_string_repeat;
132tree gfor_fndecl_adjustl;
133tree gfor_fndecl_adjustr;
134
135
136/* Other misc. runtime library functions. */
137
138tree gfor_fndecl_size0;
139tree gfor_fndecl_size1;
9b057c29 140tree gfor_fndecl_iargc;
4ee9c684 141
142/* Intrinsic functions implemented in FORTRAN. */
143tree gfor_fndecl_si_kind;
144tree gfor_fndecl_sr_kind;
145
146
147static void
148gfc_add_decl_to_parent_function (tree decl)
149{
22d678e8 150 gcc_assert (decl);
4ee9c684 151 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
152 DECL_NONLOCAL (decl) = 1;
153 TREE_CHAIN (decl) = saved_parent_function_decls;
154 saved_parent_function_decls = decl;
155}
156
157void
158gfc_add_decl_to_function (tree decl)
159{
22d678e8 160 gcc_assert (decl);
4ee9c684 161 TREE_USED (decl) = 1;
162 DECL_CONTEXT (decl) = current_function_decl;
163 TREE_CHAIN (decl) = saved_function_decls;
164 saved_function_decls = decl;
165}
166
167
b797d6d3 168/* Build a backend label declaration. Set TREE_USED for named labels.
169 The context of the label is always the current_function_decl. All
170 labels are marked artificial. */
4ee9c684 171
172tree
173gfc_build_label_decl (tree label_id)
174{
175 /* 2^32 temporaries should be enough. */
176 static unsigned int tmp_num = 1;
177 tree label_decl;
178 char *label_name;
179
180 if (label_id == NULL_TREE)
181 {
182 /* Build an internal label name. */
183 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
184 label_id = get_identifier (label_name);
185 }
186 else
187 label_name = NULL;
188
189 /* Build the LABEL_DECL node. Labels have no type. */
190 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
191 DECL_CONTEXT (label_decl) = current_function_decl;
192 DECL_MODE (label_decl) = VOIDmode;
193
b797d6d3 194 /* We always define the label as used, even if the original source
195 file never references the label. We don't want all kinds of
196 spurious warnings for old-style Fortran code with too many
197 labels. */
198 TREE_USED (label_decl) = 1;
4ee9c684 199
b797d6d3 200 DECL_ARTIFICIAL (label_decl) = 1;
4ee9c684 201 return label_decl;
202}
203
204
205/* Returns the return label for the current function. */
206
207tree
208gfc_get_return_label (void)
209{
210 char name[GFC_MAX_SYMBOL_LEN + 10];
211
212 if (current_function_return_label)
213 return current_function_return_label;
214
215 sprintf (name, "__return_%s",
216 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
217
218 current_function_return_label =
219 gfc_build_label_decl (get_identifier (name));
220
221 DECL_ARTIFICIAL (current_function_return_label) = 1;
222
223 return current_function_return_label;
224}
225
226
b31f705b 227/* Set the backend source location of a decl. */
228
229void
230gfc_set_decl_location (tree decl, locus * loc)
231{
232#ifdef USE_MAPPED_LOCATION
233 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
234#else
235 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
236 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
237#endif
238}
239
240
4ee9c684 241/* Return the backend label declaration for a given label structure,
242 or create it if it doesn't exist yet. */
243
244tree
245gfc_get_label_decl (gfc_st_label * lp)
246{
4ee9c684 247 if (lp->backend_decl)
248 return lp->backend_decl;
249 else
250 {
251 char label_name[GFC_MAX_SYMBOL_LEN + 1];
252 tree label_decl;
253
254 /* Validate the label declaration from the front end. */
22d678e8 255 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
4ee9c684 256
257 /* Build a mangled name for the label. */
258 sprintf (label_name, "__label_%.6d", lp->value);
259
260 /* Build the LABEL_DECL node. */
261 label_decl = gfc_build_label_decl (get_identifier (label_name));
262
263 /* Tell the debugger where the label came from. */
f888a3fb 264 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
b31f705b 265 gfc_set_decl_location (label_decl, &lp->where);
4ee9c684 266 else
267 DECL_ARTIFICIAL (label_decl) = 1;
268
269 /* Store the label in the label list and return the LABEL_DECL. */
270 lp->backend_decl = label_decl;
271 return label_decl;
272 }
273}
274
275
276/* Convert a gfc_symbol to an identifier of the same name. */
277
278static tree
279gfc_sym_identifier (gfc_symbol * sym)
280{
281 return (get_identifier (sym->name));
282}
283
284
285/* Construct mangled name from symbol name. */
286
287static tree
288gfc_sym_mangled_identifier (gfc_symbol * sym)
289{
290 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
291
4f0fae8e 292 if (sym->module == NULL)
4ee9c684 293 return gfc_sym_identifier (sym);
294 else
295 {
296 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
297 return get_identifier (name);
298 }
299}
300
301
302/* Construct mangled function name from symbol name. */
303
304static tree
305gfc_sym_mangled_function_id (gfc_symbol * sym)
306{
307 int has_underscore;
308 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
309
4f0fae8e 310 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
311 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
4ee9c684 312 {
313 if (strcmp (sym->name, "MAIN__") == 0
314 || sym->attr.proc == PROC_INTRINSIC)
315 return get_identifier (sym->name);
316
317 if (gfc_option.flag_underscoring)
318 {
319 has_underscore = strchr (sym->name, '_') != 0;
320 if (gfc_option.flag_second_underscore && has_underscore)
321 snprintf (name, sizeof name, "%s__", sym->name);
322 else
323 snprintf (name, sizeof name, "%s_", sym->name);
324 return get_identifier (name);
325 }
326 else
327 return get_identifier (sym->name);
328 }
329 else
330 {
331 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
332 return get_identifier (name);
333 }
334}
335
336
5ed82495 337/* Returns true if a variable of specified size should go on the stack. */
338
339int
340gfc_can_put_var_on_stack (tree size)
341{
342 unsigned HOST_WIDE_INT low;
343
344 if (!INTEGER_CST_P (size))
345 return 0;
346
347 if (gfc_option.flag_max_stack_var_size < 0)
348 return 1;
349
350 if (TREE_INT_CST_HIGH (size) != 0)
351 return 0;
352
353 low = TREE_INT_CST_LOW (size);
354 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
355 return 0;
356
357/* TODO: Set a per-function stack size limit. */
358
359 return 1;
360}
361
362
b7bf3f81 363/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
364 an expression involving its corresponding pointer. There are
365 2 cases; one for variable size arrays, and one for everything else,
366 because variable-sized arrays require one fewer level of
367 indirection. */
368
369static void
370gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
371{
372 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
373 tree value;
374
375 /* Parameters need to be dereferenced. */
376 if (sym->cp_pointer->attr.dummy)
4fa2c167 377 ptr_decl = build_fold_indirect_ref (ptr_decl);
b7bf3f81 378
379 /* Check to see if we're dealing with a variable-sized array. */
380 if (sym->attr.dimension
381 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
382 {
942043f8 383 /* These decls will be dereferenced later, so we don't dereference
b7bf3f81 384 them here. */
385 value = convert (TREE_TYPE (decl), ptr_decl);
386 }
387 else
388 {
389 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
390 ptr_decl);
4fa2c167 391 value = build_fold_indirect_ref (ptr_decl);
b7bf3f81 392 }
393
394 SET_DECL_VALUE_EXPR (decl, value);
395 DECL_HAS_VALUE_EXPR_P (decl) = 1;
764f1175 396 GFC_DECL_CRAY_POINTEE (decl) = 1;
b7bf3f81 397 /* This is a fake variable just for debugging purposes. */
398 TREE_ASM_WRITTEN (decl) = 1;
399}
400
401
4ee9c684 402/* Finish processing of a declaration and install its initial value. */
403
404static void
405gfc_finish_decl (tree decl, tree init)
406{
407 if (TREE_CODE (decl) == PARM_DECL)
22d678e8 408 gcc_assert (init == NULL_TREE);
4ee9c684 409 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
410 -- it overlaps DECL_ARG_TYPE. */
411 else if (init == NULL_TREE)
22d678e8 412 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
4ee9c684 413 else
22d678e8 414 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
4ee9c684 415
416 if (init != NULL_TREE)
417 {
418 if (TREE_CODE (decl) != TYPE_DECL)
419 DECL_INITIAL (decl) = init;
420 else
421 {
422 /* typedef foo = bar; store the type of bar as the type of foo. */
423 TREE_TYPE (decl) = TREE_TYPE (init);
424 DECL_INITIAL (decl) = init = 0;
425 }
426 }
427
428 if (TREE_CODE (decl) == VAR_DECL)
429 {
430 if (DECL_SIZE (decl) == NULL_TREE
431 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
432 layout_decl (decl, 0);
433
434 /* A static variable with an incomplete type is an error if it is
435 initialized. Also if it is not file scope. Otherwise, let it
436 through, but if it is not `extern' then it may cause an error
437 message later. */
438 /* An automatic variable with an incomplete type is an error. */
439 if (DECL_SIZE (decl) == NULL_TREE
440 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
441 || DECL_CONTEXT (decl) != 0)
442 : !DECL_EXTERNAL (decl)))
443 {
444 gfc_fatal_error ("storage size not known");
445 }
446
447 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
448 && (DECL_SIZE (decl) != 0)
449 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
450 {
451 gfc_fatal_error ("storage size not constant");
452 }
453 }
454
455}
456
457
458/* Apply symbol attributes to a variable, and add it to the function scope. */
459
460static void
461gfc_finish_var_decl (tree decl, gfc_symbol * sym)
462{
f888a3fb 463 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
4ee9c684 464 This is the equivalent of the TARGET variables.
465 We also need to set this if the variable is passed by reference in a
466 CALL statement. */
b549d2a5 467
b7bf3f81 468 /* Set DECL_VALUE_EXPR for Cray Pointees. */
b549d2a5 469 if (sym->attr.cray_pointee)
b7bf3f81 470 gfc_finish_cray_pointee (decl, sym);
b549d2a5 471
4ee9c684 472 if (sym->attr.target)
473 TREE_ADDRESSABLE (decl) = 1;
474 /* If it wasn't used we wouldn't be getting it. */
475 TREE_USED (decl) = 1;
476
477 /* Chain this decl to the pending declarations. Don't do pushdecl()
478 because this would add them to the current scope rather than the
479 function scope. */
480 if (current_function_decl != NULL_TREE)
481 {
7af6a4af 482 if (sym->ns->proc_name->backend_decl == current_function_decl
483 || sym->result == sym)
4ee9c684 484 gfc_add_decl_to_function (decl);
485 else
486 gfc_add_decl_to_parent_function (decl);
487 }
488
b7bf3f81 489 if (sym->attr.cray_pointee)
490 return;
491
4ee9c684 492 /* If a variable is USE associated, it's always external. */
493 if (sym->attr.use_assoc)
494 {
495 DECL_EXTERNAL (decl) = 1;
496 TREE_PUBLIC (decl) = 1;
497 }
4f0fae8e 498 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
4ee9c684 499 {
6b20224d 500 /* TODO: Don't set sym->module for result or dummy variables. */
7af6a4af 501 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
4ee9c684 502 /* This is the declaration of a module variable. */
503 TREE_PUBLIC (decl) = 1;
504 TREE_STATIC (decl) = 1;
505 }
506
507 if ((sym->attr.save || sym->attr.data || sym->value)
508 && !sym->attr.use_assoc)
509 TREE_STATIC (decl) = 1;
510
511 /* Keep variables larger than max-stack-var-size off stack. */
512 if (!sym->ns->proc_name->attr.recursive
513 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
514 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
515 TREE_STATIC (decl) = 1;
764f1175 516
517 /* Handle threadprivate variables. */
518 if (sym->attr.threadprivate && targetm.have_tls
519 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
520 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
4ee9c684 521}
522
523
524/* Allocate the lang-specific part of a decl. */
525
526void
527gfc_allocate_lang_decl (tree decl)
528{
529 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
530 ggc_alloc_cleared (sizeof (struct lang_decl));
531}
532
533/* Remember a symbol to generate initialization/cleanup code at function
534 entry/exit. */
535
536static void
537gfc_defer_symbol_init (gfc_symbol * sym)
538{
539 gfc_symbol *p;
540 gfc_symbol *last;
541 gfc_symbol *head;
542
543 /* Don't add a symbol twice. */
544 if (sym->tlink)
545 return;
546
547 last = head = sym->ns->proc_name;
548 p = last->tlink;
549
550 /* Make sure that setup code for dummy variables which are used in the
551 setup of other variables is generated first. */
552 if (sym->attr.dummy)
553 {
554 /* Find the first dummy arg seen after us, or the first non-dummy arg.
555 This is a circular list, so don't go past the head. */
556 while (p != head
557 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
558 {
559 last = p;
560 p = p->tlink;
561 }
562 }
563 /* Insert in between last and p. */
564 last->tlink = sym;
565 sym->tlink = p;
566}
567
568
569/* Create an array index type variable with function scope. */
570
571static tree
572create_index_var (const char * pfx, int nest)
573{
574 tree decl;
575
576 decl = gfc_create_var_np (gfc_array_index_type, pfx);
577 if (nest)
578 gfc_add_decl_to_parent_function (decl);
579 else
580 gfc_add_decl_to_function (decl);
581 return decl;
582}
583
584
585/* Create variables to hold all the non-constant bits of info for a
586 descriptorless array. Remember these in the lang-specific part of the
587 type. */
588
589static void
590gfc_build_qualified_array (tree decl, gfc_symbol * sym)
591{
592 tree type;
593 int dim;
594 int nest;
595
596 type = TREE_TYPE (decl);
597
598 /* We just use the descriptor, if there is one. */
599 if (GFC_DESCRIPTOR_TYPE_P (type))
600 return;
601
22d678e8 602 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 603 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
604 && !sym->attr.contained;
605
606 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
607 {
608 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
609 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
9ca15c9b 610 /* Don't try to use the unknown bound for assumed shape arrays. */
4ee9c684 611 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
612 && (sym->as->type != AS_ASSUMED_SIZE
613 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
614 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
615
616 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
617 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
618 }
619 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
620 {
621 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
622 "offset");
623 if (nest)
624 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
625 else
626 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
627 }
d4163395 628
629 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
630 && sym->as->type != AS_ASSUMED_SIZE)
631 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
632
633 if (POINTER_TYPE_P (type))
634 {
635 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
636 gcc_assert (TYPE_LANG_SPECIFIC (type)
637 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
638 type = TREE_TYPE (type);
639 }
640
641 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
642 {
643 tree size, range;
644
645 size = build2 (MINUS_EXPR, gfc_array_index_type,
646 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
647 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
648 size);
649 TYPE_DOMAIN (type) = range;
650 layout_type (type);
651 }
4ee9c684 652}
653
654
655/* For some dummy arguments we don't use the actual argument directly.
5ed82495 656 Instead we create a local decl and use that. This allows us to perform
4ee9c684 657 initialization, and construct full type information. */
658
659static tree
660gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
661{
662 tree decl;
663 tree type;
664 gfc_array_spec *as;
665 char *name;
666 int packed;
667 int n;
668 bool known_size;
669
670 if (sym->attr.pointer || sym->attr.allocatable)
671 return dummy;
672
673 /* Add to list of variables if not a fake result variable. */
674 if (sym->attr.result || sym->attr.dummy)
675 gfc_defer_symbol_init (sym);
676
677 type = TREE_TYPE (dummy);
22d678e8 678 gcc_assert (TREE_CODE (dummy) == PARM_DECL
4ee9c684 679 && POINTER_TYPE_P (type));
680
f888a3fb 681 /* Do we know the element size? */
4ee9c684 682 known_size = sym->ts.type != BT_CHARACTER
683 || INTEGER_CST_P (sym->ts.cl->backend_decl);
684
685 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
686 {
687 /* For descriptorless arrays with known element size the actual
688 argument is sufficient. */
22d678e8 689 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 690 gfc_build_qualified_array (dummy, sym);
691 return dummy;
692 }
693
694 type = TREE_TYPE (type);
695 if (GFC_DESCRIPTOR_TYPE_P (type))
696 {
697 /* Create a decriptorless array pointer. */
698 as = sym->as;
699 packed = 0;
700 if (!gfc_option.flag_repack_arrays)
701 {
702 if (as->type == AS_ASSUMED_SIZE)
703 packed = 2;
704 }
705 else
706 {
707 if (as->type == AS_EXPLICIT)
708 {
709 packed = 2;
710 for (n = 0; n < as->rank; n++)
711 {
712 if (!(as->upper[n]
713 && as->lower[n]
714 && as->upper[n]->expr_type == EXPR_CONSTANT
715 && as->lower[n]->expr_type == EXPR_CONSTANT))
716 packed = 1;
717 }
718 }
719 else
720 packed = 1;
721 }
722
723 type = gfc_typenode_for_spec (&sym->ts);
724 type = gfc_get_nodesc_array_type (type, sym->as, packed);
725 }
726 else
727 {
728 /* We now have an expression for the element size, so create a fully
729 qualified type. Reset sym->backend decl or this will just return the
730 old type. */
731 sym->backend_decl = NULL_TREE;
732 type = gfc_sym_type (sym);
733 packed = 2;
734 }
735
736 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
737 decl = build_decl (VAR_DECL, get_identifier (name), type);
738
739 DECL_ARTIFICIAL (decl) = 1;
740 TREE_PUBLIC (decl) = 0;
741 TREE_STATIC (decl) = 0;
742 DECL_EXTERNAL (decl) = 0;
743
744 /* We should never get deferred shape arrays here. We used to because of
745 frontend bugs. */
22d678e8 746 gcc_assert (sym->as->type != AS_DEFERRED);
4ee9c684 747
748 switch (packed)
749 {
750 case 1:
751 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
752 break;
753
754 case 2:
755 GFC_DECL_PACKED_ARRAY (decl) = 1;
756 break;
757 }
758
759 gfc_build_qualified_array (decl, sym);
760
761 if (DECL_LANG_SPECIFIC (dummy))
762 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
763 else
764 gfc_allocate_lang_decl (decl);
765
766 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
767
768 if (sym->ns->proc_name->backend_decl == current_function_decl
769 || sym->attr.contained)
770 gfc_add_decl_to_function (decl);
771 else
772 gfc_add_decl_to_parent_function (decl);
773
774 return decl;
775}
776
777
778/* Return a constant or a variable to use as a string length. Does not
779 add the decl to the current scope. */
780
781static tree
782gfc_create_string_length (gfc_symbol * sym)
783{
784 tree length;
785
22d678e8 786 gcc_assert (sym->ts.cl);
4ee9c684 787 gfc_conv_const_charlen (sym->ts.cl);
788
789 if (sym->ts.cl->backend_decl == NULL_TREE)
790 {
791 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
792
793 /* Also prefix the mangled name. */
794 strcpy (&name[1], sym->name);
795 name[0] = '.';
796 length = build_decl (VAR_DECL, get_identifier (name),
9ad09405 797 gfc_charlen_type_node);
4ee9c684 798 DECL_ARTIFICIAL (length) = 1;
799 TREE_USED (length) = 1;
d4163395 800 if (sym->ns->proc_name->tlink != NULL)
801 gfc_defer_symbol_init (sym);
4ee9c684 802 sym->ts.cl->backend_decl = length;
803 }
804
805 return sym->ts.cl->backend_decl;
806}
807
c8f1568f 808/* If a variable is assigned a label, we add another two auxiliary
809 variables. */
810
811static void
812gfc_add_assign_aux_vars (gfc_symbol * sym)
813{
814 tree addr;
815 tree length;
816 tree decl;
817
818 gcc_assert (sym->backend_decl);
819
820 decl = sym->backend_decl;
821 gfc_allocate_lang_decl (decl);
822 GFC_DECL_ASSIGN (decl) = 1;
823 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
824 gfc_charlen_type_node);
825 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
826 pvoid_type_node);
827 gfc_finish_var_decl (length, sym);
828 gfc_finish_var_decl (addr, sym);
829 /* STRING_LENGTH is also used as flag. Less than -1 means that
830 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
831 target label's address. Otherwise, value is the length of a format string
832 and ASSIGN_ADDR is its address. */
833 if (TREE_STATIC (length))
834 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
835 else
836 gfc_defer_symbol_init (sym);
837
838 GFC_DECL_STRING_LEN (decl) = length;
839 GFC_DECL_ASSIGN_ADDR (decl) = addr;
840}
4ee9c684 841
842/* Return the decl for a gfc_symbol, create it if it doesn't already
843 exist. */
844
845tree
846gfc_get_symbol_decl (gfc_symbol * sym)
847{
848 tree decl;
849 tree length = NULL_TREE;
4ee9c684 850 int byref;
851
0b5dc8b5 852 gcc_assert (sym->attr.referenced
853 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
4ee9c684 854
855 if (sym->ns && sym->ns->proc_name->attr.function)
856 byref = gfc_return_by_reference (sym->ns->proc_name);
857 else
858 byref = 0;
859
860 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
861 {
862 /* Return via extra parameter. */
863 if (sym->attr.result && byref
864 && !sym->backend_decl)
865 {
866 sym->backend_decl =
867 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
c6871095 868 /* For entry master function skip over the __entry
869 argument. */
870 if (sym->ns->proc_name->attr.entry_master)
871 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
4ee9c684 872 }
873
874 /* Dummy variables should already have been created. */
22d678e8 875 gcc_assert (sym->backend_decl);
4ee9c684 876
877 /* Create a character length variable. */
878 if (sym->ts.type == BT_CHARACTER)
879 {
880 if (sym->ts.cl->backend_decl == NULL_TREE)
d4163395 881 length = gfc_create_string_length (sym);
882 else
883 length = sym->ts.cl->backend_decl;
884 if (TREE_CODE (length) == VAR_DECL
885 && DECL_CONTEXT (length) == NULL_TREE)
4ee9c684 886 {
99042714 887 gfc_add_decl_to_function (length);
d4163395 888 gfc_defer_symbol_init (sym);
e8ff3944 889 }
4ee9c684 890 }
891
892 /* Use a copy of the descriptor for dummy arrays. */
893 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
894 {
895 sym->backend_decl =
896 gfc_build_dummy_array_decl (sym, sym->backend_decl);
897 }
898
899 TREE_USED (sym->backend_decl) = 1;
c8f1568f 900 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
901 {
902 gfc_add_assign_aux_vars (sym);
903 }
4ee9c684 904 return sym->backend_decl;
905 }
906
907 if (sym->backend_decl)
908 return sym->backend_decl;
909
4ee9c684 910 /* Catch function declarations. Only used for actual parameters. */
911 if (sym->attr.flavor == FL_PROCEDURE)
912 {
913 decl = gfc_get_extern_function_decl (sym);
914 return decl;
915 }
916
917 if (sym->attr.intrinsic)
918 internal_error ("intrinsic variable which isn't a procedure");
919
920 /* Create string length decl first so that they can be used in the
921 type declaration. */
922 if (sym->ts.type == BT_CHARACTER)
923 length = gfc_create_string_length (sym);
924
925 /* Create the decl for the variable. */
926 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
927
b31f705b 928 gfc_set_decl_location (decl, &sym->declared_at);
929
f888a3fb 930 /* Symbols from modules should have their assembler names mangled.
4ee9c684 931 This is done here rather than in gfc_finish_var_decl because it
932 is different for string length variables. */
4f0fae8e 933 if (sym->module)
4ee9c684 934 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
935
936 if (sym->attr.dimension)
937 {
938 /* Create variables to hold the non-constant bits of array info. */
939 gfc_build_qualified_array (decl, sym);
940
941 /* Remember this variable for allocation/cleanup. */
942 gfc_defer_symbol_init (sym);
943
944 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
945 GFC_DECL_PACKED_ARRAY (decl) = 1;
946 }
947
948 gfc_finish_var_decl (decl, sym);
949
bda1f152 950 if (sym->ts.type == BT_CHARACTER)
4ee9c684 951 {
4ee9c684 952 /* Character variables need special handling. */
953 gfc_allocate_lang_decl (decl);
954
bda1f152 955 if (TREE_CODE (length) != INTEGER_CST)
4ee9c684 956 {
957 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
958
4f0fae8e 959 if (sym->module)
4ee9c684 960 {
961 /* Also prefix the mangled name for symbols from modules. */
962 strcpy (&name[1], sym->name);
963 name[0] = '.';
964 strcpy (&name[1],
965 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
966 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
967 }
968 gfc_finish_var_decl (length, sym);
22d678e8 969 gcc_assert (!sym->value);
4ee9c684 970 }
4ee9c684 971 }
972 sym->backend_decl = decl;
973
c8f1568f 974 if (sym->attr.assign)
975 {
976 gfc_add_assign_aux_vars (sym);
977 }
978
bda1f152 979 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
980 {
981 /* Add static initializer. */
982 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
983 TREE_TYPE (decl), sym->attr.dimension,
984 sym->attr.pointer || sym->attr.allocatable);
985 }
986
4ee9c684 987 return decl;
988}
989
990
dbe60343 991/* Substitute a temporary variable in place of the real one. */
992
993void
994gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
995{
996 save->attr = sym->attr;
997 save->decl = sym->backend_decl;
998
999 gfc_clear_attr (&sym->attr);
1000 sym->attr.referenced = 1;
1001 sym->attr.flavor = FL_VARIABLE;
1002
1003 sym->backend_decl = decl;
1004}
1005
1006
1007/* Restore the original variable. */
1008
1009void
1010gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1011{
1012 sym->attr = save->attr;
1013 sym->backend_decl = save->decl;
1014}
1015
1016
4ee9c684 1017/* Get a basic decl for an external function. */
1018
1019tree
1020gfc_get_extern_function_decl (gfc_symbol * sym)
1021{
1022 tree type;
1023 tree fndecl;
1024 gfc_expr e;
1025 gfc_intrinsic_sym *isym;
1026 gfc_expr argexpr;
bdaed7d2 1027 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
4ee9c684 1028 tree name;
1029 tree mangled_name;
1030
1031 if (sym->backend_decl)
1032 return sym->backend_decl;
1033
1b716045 1034 /* We should never be creating external decls for alternate entry points.
1035 The procedure may be an alternate entry point, but we don't want/need
1036 to know that. */
22d678e8 1037 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1b716045 1038
4ee9c684 1039 if (sym->attr.intrinsic)
1040 {
1041 /* Call the resolution function to get the actual name. This is
1042 a nasty hack which relies on the resolution functions only looking
1043 at the first argument. We pass NULL for the second argument
1044 otherwise things like AINT get confused. */
1045 isym = gfc_find_function (sym->name);
22d678e8 1046 gcc_assert (isym->resolve.f0 != NULL);
4ee9c684 1047
1048 memset (&e, 0, sizeof (e));
1049 e.expr_type = EXPR_FUNCTION;
1050
1051 memset (&argexpr, 0, sizeof (argexpr));
22d678e8 1052 gcc_assert (isym->formal);
4ee9c684 1053 argexpr.ts = isym->formal->ts;
1054
1055 if (isym->formal->next == NULL)
1056 isym->resolve.f1 (&e, &argexpr);
1057 else
1058 {
1059 /* All specific intrinsics take one or two arguments. */
22d678e8 1060 gcc_assert (isym->formal->next->next == NULL);
4ee9c684 1061 isym->resolve.f2 (&e, &argexpr, NULL);
1062 }
bdaed7d2 1063
1064 if (gfc_option.flag_f2c
1065 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1066 || e.ts.type == BT_COMPLEX))
1067 {
1068 /* Specific which needs a different implementation if f2c
1069 calling conventions are used. */
1070 sprintf (s, "f2c_specific%s", e.value.function.name);
1071 }
1072 else
1073 sprintf (s, "specific%s", e.value.function.name);
1074
4ee9c684 1075 name = get_identifier (s);
1076 mangled_name = name;
1077 }
1078 else
1079 {
1080 name = gfc_sym_identifier (sym);
1081 mangled_name = gfc_sym_mangled_function_id (sym);
1082 }
1083
1084 type = gfc_get_function_type (sym);
1085 fndecl = build_decl (FUNCTION_DECL, name, type);
1086
1087 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1088 /* If the return type is a pointer, avoid alias issues by setting
1089 DECL_IS_MALLOC to nonzero. This means that the function should be
1090 treated as if it were a malloc, meaning it returns a pointer that
1091 is not an alias. */
1092 if (POINTER_TYPE_P (type))
1093 DECL_IS_MALLOC (fndecl) = 1;
1094
1095 /* Set the context of this decl. */
1096 if (0 && sym->ns && sym->ns->proc_name)
1097 {
1098 /* TODO: Add external decls to the appropriate scope. */
1099 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1100 }
1101 else
1102 {
f888a3fb 1103 /* Global declaration, e.g. intrinsic subroutine. */
4ee9c684 1104 DECL_CONTEXT (fndecl) = NULL_TREE;
1105 }
1106
1107 DECL_EXTERNAL (fndecl) = 1;
1108
f888a3fb 1109 /* This specifies if a function is globally addressable, i.e. it is
4ee9c684 1110 the opposite of declaring static in C. */
1111 TREE_PUBLIC (fndecl) = 1;
1112
1113 /* Set attributes for PURE functions. A call to PURE function in the
1114 Fortran 95 sense is both pure and without side effects in the C
1115 sense. */
1116 if (sym->attr.pure || sym->attr.elemental)
1117 {
4d4b9f0e 1118 if (sym->attr.function && !gfc_return_by_reference (sym))
be393645 1119 DECL_IS_PURE (fndecl) = 1;
1120 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1121 parameters and don't use alternate returns (is this
1122 allowed?). In that case, calls to them are meaningless, and
1b716045 1123 can be optimized away. See also in build_function_decl(). */
be393645 1124 TREE_SIDE_EFFECTS (fndecl) = 0;
4ee9c684 1125 }
1126
6e27d773 1127 /* Mark non-returning functions. */
1128 if (sym->attr.noreturn)
1129 TREE_THIS_VOLATILE(fndecl) = 1;
1130
4ee9c684 1131 sym->backend_decl = fndecl;
1132
1133 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1134 pushdecl_top_level (fndecl);
1135
1136 return fndecl;
1137}
1138
1139
1140/* Create a declaration for a procedure. For external functions (in the C
1b716045 1141 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1142 a master function with alternate entry points. */
4ee9c684 1143
1b716045 1144static void
1145build_function_decl (gfc_symbol * sym)
4ee9c684 1146{
1b716045 1147 tree fndecl, type;
4ee9c684 1148 symbol_attribute attr;
1b716045 1149 tree result_decl;
4ee9c684 1150 gfc_formal_arglist *f;
1151
22d678e8 1152 gcc_assert (!sym->backend_decl);
1153 gcc_assert (!sym->attr.external);
4ee9c684 1154
b31f705b 1155 /* Set the line and filename. sym->declared_at seems to point to the
1156 last statement for subroutines, but it'll do for now. */
1157 gfc_set_backend_locus (&sym->declared_at);
1158
4ee9c684 1159 /* Allow only one nesting level. Allow public declarations. */
22d678e8 1160 gcc_assert (current_function_decl == NULL_TREE
4ee9c684 1161 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1162
1163 type = gfc_get_function_type (sym);
1164 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1165
1166 /* Perform name mangling if this is a top level or module procedure. */
1167 if (current_function_decl == NULL_TREE)
1168 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1169
1170 /* Figure out the return type of the declared function, and build a
f888a3fb 1171 RESULT_DECL for it. If this is a subroutine with alternate
4ee9c684 1172 returns, build a RESULT_DECL for it. */
1173 attr = sym->attr;
1174
1175 result_decl = NULL_TREE;
1176 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1177 if (attr.function)
1178 {
1179 if (gfc_return_by_reference (sym))
1180 type = void_type_node;
1181 else
1182 {
1183 if (sym->result != sym)
1184 result_decl = gfc_sym_identifier (sym->result);
1185
1186 type = TREE_TYPE (TREE_TYPE (fndecl));
1187 }
1188 }
1189 else
1190 {
1191 /* Look for alternate return placeholders. */
1192 int has_alternate_returns = 0;
1193 for (f = sym->formal; f; f = f->next)
1194 {
1195 if (f->sym == NULL)
1196 {
1197 has_alternate_returns = 1;
1198 break;
1199 }
1200 }
1201
1202 if (has_alternate_returns)
1203 type = integer_type_node;
1204 else
1205 type = void_type_node;
1206 }
1207
1208 result_decl = build_decl (RESULT_DECL, result_decl, type);
540edea7 1209 DECL_ARTIFICIAL (result_decl) = 1;
1210 DECL_IGNORED_P (result_decl) = 1;
4ee9c684 1211 DECL_CONTEXT (result_decl) = fndecl;
1212 DECL_RESULT (fndecl) = result_decl;
1213
1214 /* Don't call layout_decl for a RESULT_DECL.
f888a3fb 1215 layout_decl (result_decl, 0); */
4ee9c684 1216
1217 /* If the return type is a pointer, avoid alias issues by setting
1218 DECL_IS_MALLOC to nonzero. This means that the function should be
1219 treated as if it were a malloc, meaning it returns a pointer that
1220 is not an alias. */
1221 if (POINTER_TYPE_P (type))
1222 DECL_IS_MALLOC (fndecl) = 1;
1223
1224 /* Set up all attributes for the function. */
1225 DECL_CONTEXT (fndecl) = current_function_decl;
1226 DECL_EXTERNAL (fndecl) = 0;
1227
9d138f47 1228 /* This specifies if a function is globally visible, i.e. it is
dfc222eb 1229 the opposite of declaring static in C. */
1b716045 1230 if (DECL_CONTEXT (fndecl) == NULL_TREE
1231 && !sym->attr.entry_master)
4ee9c684 1232 TREE_PUBLIC (fndecl) = 1;
1233
1234 /* TREE_STATIC means the function body is defined here. */
e4b2c26c 1235 TREE_STATIC (fndecl) = 1;
4ee9c684 1236
f888a3fb 1237 /* Set attributes for PURE functions. A call to a PURE function in the
4ee9c684 1238 Fortran 95 sense is both pure and without side effects in the C
1239 sense. */
1240 if (attr.pure || attr.elemental)
1241 {
be393645 1242 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1243 including a alternate return. In that case it can also be
231e961a 1244 marked as PURE. See also in gfc_get_extern_function_decl(). */
4c319962 1245 if (attr.function && !gfc_return_by_reference (sym))
be393645 1246 DECL_IS_PURE (fndecl) = 1;
4ee9c684 1247 TREE_SIDE_EFFECTS (fndecl) = 0;
1248 }
1249
1250 /* Layout the function declaration and put it in the binding level
1251 of the current function. */
e4b2c26c 1252 pushdecl (fndecl);
1b716045 1253
1254 sym->backend_decl = fndecl;
1255}
1256
1257
1258/* Create the DECL_ARGUMENTS for a procedure. */
1259
1260static void
1261create_function_arglist (gfc_symbol * sym)
1262{
1263 tree fndecl;
1264 gfc_formal_arglist *f;
d4163395 1265 tree typelist, hidden_typelist;
1266 tree arglist, hidden_arglist;
1b716045 1267 tree type;
1268 tree parm;
1269
1270 fndecl = sym->backend_decl;
1271
e4b2c26c 1272 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1273 the new FUNCTION_DECL node. */
e4b2c26c 1274 arglist = NULL_TREE;
d4163395 1275 hidden_arglist = NULL_TREE;
e4b2c26c 1276 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1b716045 1277
1278 if (sym->attr.entry_master)
1279 {
1280 type = TREE_VALUE (typelist);
1281 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1282
1283 DECL_CONTEXT (parm) = fndecl;
1284 DECL_ARG_TYPE (parm) = type;
1285 TREE_READONLY (parm) = 1;
1286 gfc_finish_decl (parm, NULL_TREE);
1287
1288 arglist = chainon (arglist, parm);
1289 typelist = TREE_CHAIN (typelist);
1290 }
1291
e4b2c26c 1292 if (gfc_return_by_reference (sym))
4ee9c684 1293 {
d4163395 1294 tree type = TREE_VALUE (typelist), length = NULL;
4ee9c684 1295
e4b2c26c 1296 if (sym->ts.type == BT_CHARACTER)
1297 {
e4b2c26c 1298 /* Length of character result. */
d4163395 1299 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1300 gcc_assert (len_type == gfc_charlen_type_node);
4ee9c684 1301
e4b2c26c 1302 length = build_decl (PARM_DECL,
1303 get_identifier (".__result"),
d4163395 1304 len_type);
e4b2c26c 1305 if (!sym->ts.cl->length)
1306 {
1307 sym->ts.cl->backend_decl = length;
1308 TREE_USED (length) = 1;
4ee9c684 1309 }
22d678e8 1310 gcc_assert (TREE_CODE (length) == PARM_DECL);
e4b2c26c 1311 DECL_CONTEXT (length) = fndecl;
d4163395 1312 DECL_ARG_TYPE (length) = len_type;
e4b2c26c 1313 TREE_READONLY (length) = 1;
b5b40b3f 1314 DECL_ARTIFICIAL (length) = 1;
e4b2c26c 1315 gfc_finish_decl (length, NULL_TREE);
d4163395 1316 if (sym->ts.cl->backend_decl == NULL
1317 || sym->ts.cl->backend_decl == length)
1318 {
1319 gfc_symbol *arg;
1320 tree backend_decl;
4ee9c684 1321
d4163395 1322 if (sym->ts.cl->backend_decl == NULL)
1323 {
1324 tree len = build_decl (VAR_DECL,
1325 get_identifier ("..__result"),
1326 gfc_charlen_type_node);
1327 DECL_ARTIFICIAL (len) = 1;
1328 TREE_USED (len) = 1;
1329 sym->ts.cl->backend_decl = len;
1330 }
4ee9c684 1331
d4163395 1332 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1333 arg = sym->result ? sym->result : sym;
1334 backend_decl = arg->backend_decl;
1335 /* Temporary clear it, so that gfc_sym_type creates complete
1336 type. */
1337 arg->backend_decl = NULL;
1338 type = gfc_sym_type (arg);
1339 arg->backend_decl = backend_decl;
1340 type = build_reference_type (type);
1341 }
1342 }
4ee9c684 1343
d4163395 1344 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
4ee9c684 1345
d4163395 1346 DECL_CONTEXT (parm) = fndecl;
1347 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1348 TREE_READONLY (parm) = 1;
1349 DECL_ARTIFICIAL (parm) = 1;
1350 gfc_finish_decl (parm, NULL_TREE);
4ee9c684 1351
d4163395 1352 arglist = chainon (arglist, parm);
1353 typelist = TREE_CHAIN (typelist);
4ee9c684 1354
d4163395 1355 if (sym->ts.type == BT_CHARACTER)
1356 {
1357 gfc_allocate_lang_decl (parm);
1358 arglist = chainon (arglist, length);
e4b2c26c 1359 typelist = TREE_CHAIN (typelist);
1360 }
1361 }
4ee9c684 1362
d4163395 1363 hidden_typelist = typelist;
1364 for (f = sym->formal; f; f = f->next)
1365 if (f->sym != NULL) /* Ignore alternate returns. */
1366 hidden_typelist = TREE_CHAIN (hidden_typelist);
1367
e4b2c26c 1368 for (f = sym->formal; f; f = f->next)
1369 {
1370 char name[GFC_MAX_SYMBOL_LEN + 2];
d4163395 1371
e4b2c26c 1372 /* Ignore alternate returns. */
1373 if (f->sym == NULL)
1374 continue;
4ee9c684 1375
e4b2c26c 1376 type = TREE_VALUE (typelist);
4ee9c684 1377
d4163395 1378 if (f->sym->ts.type == BT_CHARACTER)
1379 {
1380 tree len_type = TREE_VALUE (hidden_typelist);
1381 tree length = NULL_TREE;
1382 gcc_assert (len_type == gfc_charlen_type_node);
1383
1384 strcpy (&name[1], f->sym->name);
1385 name[0] = '_';
1386 length = build_decl (PARM_DECL, get_identifier (name), len_type);
4ee9c684 1387
d4163395 1388 hidden_arglist = chainon (hidden_arglist, length);
1389 DECL_CONTEXT (length) = fndecl;
1390 DECL_ARTIFICIAL (length) = 1;
1391 DECL_ARG_TYPE (length) = len_type;
1392 TREE_READONLY (length) = 1;
1393 gfc_finish_decl (length, NULL_TREE);
4ee9c684 1394
d4163395 1395 /* TODO: Check string lengths when -fbounds-check. */
4ee9c684 1396
d4163395 1397 /* Use the passed value for assumed length variables. */
1398 if (!f->sym->ts.cl->length)
4ee9c684 1399 {
d4163395 1400 TREE_USED (length) = 1;
1401 if (!f->sym->ts.cl->backend_decl)
1402 f->sym->ts.cl->backend_decl = length;
1403 else
1404 {
1405 /* there is already another variable using this
1406 gfc_charlen node, build a new one for this variable
1407 and chain it into the list of gfc_charlens.
1408 This happens for e.g. in the case
1409 CHARACTER(*)::c1,c2
1410 since CHARACTER declarations on the same line share
1411 the same gfc_charlen node. */
1412 gfc_charlen *cl;
e4b2c26c 1413
d4163395 1414 cl = gfc_get_charlen ();
1415 cl->backend_decl = length;
1416 cl->next = f->sym->ts.cl->next;
1417 f->sym->ts.cl->next = cl;
1418 f->sym->ts.cl = cl;
1419 }
1420 }
1421
1422 hidden_typelist = TREE_CHAIN (hidden_typelist);
1423
1424 if (f->sym->ts.cl->backend_decl == NULL
1425 || f->sym->ts.cl->backend_decl == length)
1426 {
1427 if (f->sym->ts.cl->backend_decl == NULL)
1428 gfc_create_string_length (f->sym);
1429
1430 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1431 if (f->sym->attr.flavor == FL_PROCEDURE)
1432 type = build_pointer_type (gfc_get_function_type (f->sym));
1433 else
1434 type = gfc_sym_type (f->sym);
4ee9c684 1435 }
4ee9c684 1436 }
1437
d4163395 1438 /* For non-constant length array arguments, make sure they use
1439 a different type node from TYPE_ARG_TYPES type. */
1440 if (f->sym->attr.dimension
1441 && type == TREE_VALUE (typelist)
1442 && TREE_CODE (type) == POINTER_TYPE
1443 && GFC_ARRAY_TYPE_P (type)
1444 && f->sym->as->type != AS_ASSUMED_SIZE
1445 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1446 {
1447 if (f->sym->attr.flavor == FL_PROCEDURE)
1448 type = build_pointer_type (gfc_get_function_type (f->sym));
1449 else
1450 type = gfc_sym_type (f->sym);
1451 }
1452
1453 /* Build a the argument declaration. */
1454 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1455
1456 /* Fill in arg stuff. */
1457 DECL_CONTEXT (parm) = fndecl;
1458 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1459 /* All implementation args are read-only. */
1460 TREE_READONLY (parm) = 1;
1461
1462 gfc_finish_decl (parm, NULL_TREE);
1463
1464 f->sym->backend_decl = parm;
1465
1466 arglist = chainon (arglist, parm);
e4b2c26c 1467 typelist = TREE_CHAIN (typelist);
4ee9c684 1468 }
e4b2c26c 1469
d4163395 1470 /* Add the hidden string length parameters. */
1471 arglist = chainon (arglist, hidden_arglist);
1472
1473 gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
e4b2c26c 1474 DECL_ARGUMENTS (fndecl) = arglist;
1b716045 1475}
e4b2c26c 1476
1b716045 1477/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1478
1479static void
1480gfc_gimplify_function (tree fndecl)
1481{
1482 struct cgraph_node *cgn;
1483
1484 gimplify_function_tree (fndecl);
1485 dump_function (TDI_generic, fndecl);
1486
764f1175 1487 /* Generate errors for structured block violations. */
1488 /* ??? Could be done as part of resolve_labels. */
1489 if (flag_openmp)
1490 diagnose_omp_structured_block_errors (fndecl);
1491
1b716045 1492 /* Convert all nested functions to GIMPLE now. We do things in this order
1493 so that items like VLA sizes are expanded properly in the context of the
1494 correct function. */
1495 cgn = cgraph_node (fndecl);
1496 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1497 gfc_gimplify_function (cgn->decl);
1498}
1499
1500
1501/* Do the setup necessary before generating the body of a function. */
1502
1503static void
1504trans_function_start (gfc_symbol * sym)
1505{
1506 tree fndecl;
1507
1508 fndecl = sym->backend_decl;
1509
f888a3fb 1510 /* Let GCC know the current scope is this function. */
1b716045 1511 current_function_decl = fndecl;
1512
f888a3fb 1513 /* Let the world know what we're about to do. */
1b716045 1514 announce_function (fndecl);
1515
1516 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1517 {
f888a3fb 1518 /* Create RTL for function declaration. */
1b716045 1519 rest_of_decl_compilation (fndecl, 1, 0);
1520 }
1521
f888a3fb 1522 /* Create RTL for function definition. */
1b716045 1523 make_decl_rtl (fndecl);
1524
1b716045 1525 init_function_start (fndecl);
1526
1527 /* Even though we're inside a function body, we still don't want to
1528 call expand_expr to calculate the size of a variable-sized array.
1529 We haven't necessarily assigned RTL to all variables yet, so it's
1530 not safe to try to expand expressions involving them. */
1531 cfun->x_dont_save_pending_sizes_p = 1;
1532
f888a3fb 1533 /* function.c requires a push at the start of the function. */
1b716045 1534 pushlevel (0);
1535}
1536
1537/* Create thunks for alternate entry points. */
1538
1539static void
1540build_entry_thunks (gfc_namespace * ns)
1541{
1542 gfc_formal_arglist *formal;
1543 gfc_formal_arglist *thunk_formal;
1544 gfc_entry_list *el;
1545 gfc_symbol *thunk_sym;
1546 stmtblock_t body;
1547 tree thunk_fndecl;
1548 tree args;
1549 tree string_args;
1550 tree tmp;
b31f705b 1551 locus old_loc;
1b716045 1552
1553 /* This should always be a toplevel function. */
22d678e8 1554 gcc_assert (current_function_decl == NULL_TREE);
1b716045 1555
b31f705b 1556 gfc_get_backend_locus (&old_loc);
1b716045 1557 for (el = ns->entries; el; el = el->next)
1558 {
1559 thunk_sym = el->sym;
1560
1561 build_function_decl (thunk_sym);
1562 create_function_arglist (thunk_sym);
1563
1564 trans_function_start (thunk_sym);
1565
1566 thunk_fndecl = thunk_sym->backend_decl;
1567
1568 gfc_start_block (&body);
1569
f888a3fb 1570 /* Pass extra parameter identifying this entry point. */
7016c612 1571 tmp = build_int_cst (gfc_array_index_type, el->id);
1b716045 1572 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1573 string_args = NULL_TREE;
1574
c6871095 1575 if (thunk_sym->attr.function)
1576 {
1577 if (gfc_return_by_reference (ns->proc_name))
1578 {
1579 tree ref = DECL_ARGUMENTS (current_function_decl);
1580 args = tree_cons (NULL_TREE, ref, args);
1581 if (ns->proc_name->ts.type == BT_CHARACTER)
1582 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1583 args);
1584 }
1585 }
1586
1b716045 1587 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1588 {
c6871095 1589 /* Ignore alternate returns. */
1590 if (formal->sym == NULL)
1591 continue;
1592
1b716045 1593 /* We don't have a clever way of identifying arguments, so resort to
1594 a brute-force search. */
1595 for (thunk_formal = thunk_sym->formal;
1596 thunk_formal;
1597 thunk_formal = thunk_formal->next)
1598 {
1599 if (thunk_formal->sym == formal->sym)
1600 break;
1601 }
1602
1603 if (thunk_formal)
1604 {
1605 /* Pass the argument. */
1606 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1607 args);
1608 if (formal->sym->ts.type == BT_CHARACTER)
1609 {
1610 tmp = thunk_formal->sym->ts.cl->backend_decl;
1611 string_args = tree_cons (NULL_TREE, tmp, string_args);
1612 }
1613 }
1614 else
1615 {
1616 /* Pass NULL for a missing argument. */
1617 args = tree_cons (NULL_TREE, null_pointer_node, args);
1618 if (formal->sym->ts.type == BT_CHARACTER)
1619 {
9ad09405 1620 tmp = convert (gfc_charlen_type_node, integer_zero_node);
1b716045 1621 string_args = tree_cons (NULL_TREE, tmp, string_args);
1622 }
1623 }
1624 }
1625
1626 /* Call the master function. */
1627 args = nreverse (args);
1628 args = chainon (args, nreverse (string_args));
1629 tmp = ns->proc_name->backend_decl;
ac47d547 1630 tmp = build_function_call_expr (tmp, args);
c6871095 1631 if (ns->proc_name->attr.mixed_entry_master)
1632 {
1633 tree union_decl, field;
1634 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1635
1636 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1637 TREE_TYPE (master_type));
1638 DECL_ARTIFICIAL (union_decl) = 1;
1639 DECL_EXTERNAL (union_decl) = 0;
1640 TREE_PUBLIC (union_decl) = 0;
1641 TREE_USED (union_decl) = 1;
1642 layout_decl (union_decl, 0);
1643 pushdecl (union_decl);
1644
1645 DECL_CONTEXT (union_decl) = current_function_decl;
1646 tmp = build2 (MODIFY_EXPR,
1647 TREE_TYPE (union_decl),
1648 union_decl, tmp);
1649 gfc_add_expr_to_block (&body, tmp);
1650
1651 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1652 field; field = TREE_CHAIN (field))
1653 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1654 thunk_sym->result->name) == 0)
1655 break;
1656 gcc_assert (field != NULL_TREE);
1657 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1658 NULL_TREE);
1659 tmp = build2 (MODIFY_EXPR,
1660 TREE_TYPE (DECL_RESULT (current_function_decl)),
1661 DECL_RESULT (current_function_decl), tmp);
1662 tmp = build1_v (RETURN_EXPR, tmp);
1663 }
1664 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1665 != void_type_node)
1666 {
1667 tmp = build2 (MODIFY_EXPR,
1668 TREE_TYPE (DECL_RESULT (current_function_decl)),
1669 DECL_RESULT (current_function_decl), tmp);
1670 tmp = build1_v (RETURN_EXPR, tmp);
1671 }
1b716045 1672 gfc_add_expr_to_block (&body, tmp);
1673
1674 /* Finish off this function and send it for code generation. */
1675 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1676 poplevel (1, 0, 1);
1677 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1678
1679 /* Output the GENERIC tree. */
1680 dump_function (TDI_original, thunk_fndecl);
1681
1682 /* Store the end of the function, so that we get good line number
1683 info for the epilogue. */
1684 cfun->function_end_locus = input_location;
1685
1686 /* We're leaving the context of this function, so zap cfun.
1687 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1688 tree_rest_of_compilation. */
1689 cfun = NULL;
1690
1691 current_function_decl = NULL_TREE;
1692
1693 gfc_gimplify_function (thunk_fndecl);
9d95b2b0 1694 cgraph_finalize_function (thunk_fndecl, false);
1b716045 1695
1696 /* We share the symbols in the formal argument list with other entry
1697 points and the master function. Clear them so that they are
1698 recreated for each function. */
1699 for (formal = thunk_sym->formal; formal; formal = formal->next)
c6871095 1700 if (formal->sym != NULL) /* Ignore alternate returns. */
1701 {
1702 formal->sym->backend_decl = NULL_TREE;
1703 if (formal->sym->ts.type == BT_CHARACTER)
1704 formal->sym->ts.cl->backend_decl = NULL_TREE;
1705 }
1706
1707 if (thunk_sym->attr.function)
1b716045 1708 {
c6871095 1709 if (thunk_sym->ts.type == BT_CHARACTER)
1710 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1711 if (thunk_sym->result->ts.type == BT_CHARACTER)
1712 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1b716045 1713 }
1714 }
b31f705b 1715
1716 gfc_set_backend_locus (&old_loc);
1b716045 1717}
1718
1719
1720/* Create a decl for a function, and create any thunks for alternate entry
1721 points. */
1722
1723void
1724gfc_create_function_decl (gfc_namespace * ns)
1725{
1726 /* Create a declaration for the master function. */
1727 build_function_decl (ns->proc_name);
1728
f888a3fb 1729 /* Compile the entry thunks. */
1b716045 1730 if (ns->entries)
1731 build_entry_thunks (ns);
1732
1733 /* Now create the read argument list. */
1734 create_function_arglist (ns->proc_name);
1735}
1736
c750cc52 1737/* Return the decl used to hold the function return value. If
1738 parent_flag is set, the context is the parent_scope*/
4ee9c684 1739
1740tree
c750cc52 1741gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
4ee9c684 1742{
c750cc52 1743 tree decl;
1744 tree length;
1745 tree this_fake_result_decl;
1746 tree this_function_decl;
4ee9c684 1747
1748 char name[GFC_MAX_SYMBOL_LEN + 10];
1749
c750cc52 1750 if (parent_flag)
1751 {
1752 this_fake_result_decl = parent_fake_result_decl;
1753 this_function_decl = DECL_CONTEXT (current_function_decl);
1754 }
1755 else
1756 {
1757 this_fake_result_decl = current_fake_result_decl;
1758 this_function_decl = current_function_decl;
1759 }
1760
c6871095 1761 if (sym
c750cc52 1762 && sym->ns->proc_name->backend_decl == this_function_decl
d4163395 1763 && sym->ns->proc_name->attr.entry_master
c6871095 1764 && sym != sym->ns->proc_name)
1765 {
d4163395 1766 tree t = NULL, var;
c750cc52 1767 if (this_fake_result_decl != NULL)
1768 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
d4163395 1769 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1770 break;
1771 if (t)
1772 return TREE_VALUE (t);
c750cc52 1773 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1774
1775 if (parent_flag)
1776 this_fake_result_decl = parent_fake_result_decl;
1777 else
1778 this_fake_result_decl = current_fake_result_decl;
1779
d4163395 1780 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
c6871095 1781 {
1782 tree field;
1783
1784 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1785 field; field = TREE_CHAIN (field))
1786 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1787 sym->name) == 0)
1788 break;
1789
1790 gcc_assert (field != NULL_TREE);
1791 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1792 NULL_TREE);
1793 }
c750cc52 1794
1795 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1796 if (parent_flag)
1797 gfc_add_decl_to_parent_function (var);
1798 else
1799 gfc_add_decl_to_function (var);
1800
d4163395 1801 SET_DECL_VALUE_EXPR (var, decl);
1802 DECL_HAS_VALUE_EXPR_P (var) = 1;
c750cc52 1803
1804 TREE_CHAIN (this_fake_result_decl)
1805 = tree_cons (get_identifier (sym->name), var,
1806 TREE_CHAIN (this_fake_result_decl));
d4163395 1807 return var;
c6871095 1808 }
1809
c750cc52 1810 if (this_fake_result_decl != NULL_TREE)
1811 return TREE_VALUE (this_fake_result_decl);
4ee9c684 1812
1813 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1814 sym is NULL. */
1815 if (!sym)
1816 return NULL_TREE;
1817
d4163395 1818 if (sym->ts.type == BT_CHARACTER)
4ee9c684 1819 {
d4163395 1820 if (sym->ts.cl->backend_decl == NULL_TREE)
1821 length = gfc_create_string_length (sym);
1822 else
1823 length = sym->ts.cl->backend_decl;
1824 if (TREE_CODE (length) == VAR_DECL
1825 && DECL_CONTEXT (length) == NULL_TREE)
99042714 1826 gfc_add_decl_to_function (length);
4ee9c684 1827 }
1828
1829 if (gfc_return_by_reference (sym))
1830 {
c750cc52 1831 decl = DECL_ARGUMENTS (this_function_decl);
c6871095 1832
c750cc52 1833 if (sym->ns->proc_name->backend_decl == this_function_decl
c6871095 1834 && sym->ns->proc_name->attr.entry_master)
1835 decl = TREE_CHAIN (decl);
4ee9c684 1836
1837 TREE_USED (decl) = 1;
1838 if (sym->as)
1839 decl = gfc_build_dummy_array_decl (sym, decl);
1840 }
1841 else
1842 {
1843 sprintf (name, "__result_%.20s",
c750cc52 1844 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
4ee9c684 1845
1846 decl = build_decl (VAR_DECL, get_identifier (name),
c750cc52 1847 TREE_TYPE (TREE_TYPE (this_function_decl)));
4ee9c684 1848
1849 DECL_ARTIFICIAL (decl) = 1;
1850 DECL_EXTERNAL (decl) = 0;
1851 TREE_PUBLIC (decl) = 0;
1852 TREE_USED (decl) = 1;
764f1175 1853 GFC_DECL_RESULT (decl) = 1;
4ee9c684 1854
1855 layout_decl (decl, 0);
1856
c750cc52 1857 if (parent_flag)
1858 gfc_add_decl_to_parent_function (decl);
1859 else
1860 gfc_add_decl_to_function (decl);
4ee9c684 1861 }
1862
c750cc52 1863 if (parent_flag)
1864 parent_fake_result_decl = build_tree_list (NULL, decl);
1865 else
1866 current_fake_result_decl = build_tree_list (NULL, decl);
4ee9c684 1867
1868 return decl;
1869}
1870
1871
1872/* Builds a function decl. The remaining parameters are the types of the
1873 function arguments. Negative nargs indicates a varargs function. */
1874
1875tree
1876gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1877{
1878 tree arglist;
1879 tree argtype;
1880 tree fntype;
1881 tree fndecl;
1882 va_list p;
1883 int n;
1884
1885 /* Library functions must be declared with global scope. */
22d678e8 1886 gcc_assert (current_function_decl == NULL_TREE);
4ee9c684 1887
1888 va_start (p, nargs);
1889
1890
1891 /* Create a list of the argument types. */
1892 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1893 {
1894 argtype = va_arg (p, tree);
1895 arglist = gfc_chainon_list (arglist, argtype);
1896 }
1897
1898 if (nargs >= 0)
1899 {
1900 /* Terminate the list. */
1901 arglist = gfc_chainon_list (arglist, void_type_node);
1902 }
1903
1904 /* Build the function type and decl. */
1905 fntype = build_function_type (rettype, arglist);
1906 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1907
1908 /* Mark this decl as external. */
1909 DECL_EXTERNAL (fndecl) = 1;
1910 TREE_PUBLIC (fndecl) = 1;
1911
1912 va_end (p);
1913
1914 pushdecl (fndecl);
1915
b2c4af5e 1916 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 1917
1918 return fndecl;
1919}
1920
1921static void
1922gfc_build_intrinsic_function_decls (void)
1923{
90ba9145 1924 tree gfc_int4_type_node = gfc_get_int_type (4);
1925 tree gfc_int8_type_node = gfc_get_int_type (8);
920e54ef 1926 tree gfc_int16_type_node = gfc_get_int_type (16);
90ba9145 1927 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1928 tree gfc_real4_type_node = gfc_get_real_type (4);
1929 tree gfc_real8_type_node = gfc_get_real_type (8);
920e54ef 1930 tree gfc_real10_type_node = gfc_get_real_type (10);
1931 tree gfc_real16_type_node = gfc_get_real_type (16);
90ba9145 1932 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1933 tree gfc_complex8_type_node = gfc_get_complex_type (8);
920e54ef 1934 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1935 tree gfc_complex16_type_node = gfc_get_complex_type (16);
dbc97b88 1936 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
90ba9145 1937
4ee9c684 1938 /* String functions. */
1939 gfor_fndecl_copy_string =
1940 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1941 void_type_node,
1942 4,
9ad09405 1943 gfc_charlen_type_node, pchar_type_node,
1944 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1945
1946 gfor_fndecl_compare_string =
1947 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1948 gfc_int4_type_node,
1949 4,
9ad09405 1950 gfc_charlen_type_node, pchar_type_node,
1951 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1952
1953 gfor_fndecl_concat_string =
1954 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1955 void_type_node,
1956 6,
9ad09405 1957 gfc_charlen_type_node, pchar_type_node,
1958 gfc_charlen_type_node, pchar_type_node,
1959 gfc_charlen_type_node, pchar_type_node);
4ee9c684 1960
1961 gfor_fndecl_string_len_trim =
1962 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1963 gfc_int4_type_node,
9ad09405 1964 2, gfc_charlen_type_node,
4ee9c684 1965 pchar_type_node);
1966
1967 gfor_fndecl_string_index =
1968 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1969 gfc_int4_type_node,
9ad09405 1970 5, gfc_charlen_type_node, pchar_type_node,
1971 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1972 gfc_logical4_type_node);
1973
1974 gfor_fndecl_string_scan =
1975 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1976 gfc_int4_type_node,
9ad09405 1977 5, gfc_charlen_type_node, pchar_type_node,
1978 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1979 gfc_logical4_type_node);
1980
1981 gfor_fndecl_string_verify =
1982 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1983 gfc_int4_type_node,
9ad09405 1984 5, gfc_charlen_type_node, pchar_type_node,
1985 gfc_charlen_type_node, pchar_type_node,
4ee9c684 1986 gfc_logical4_type_node);
1987
1988 gfor_fndecl_string_trim =
1989 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1990 void_type_node,
1991 4,
9ad09405 1992 build_pointer_type (gfc_charlen_type_node),
4ee9c684 1993 ppvoid_type_node,
9ad09405 1994 gfc_charlen_type_node,
4ee9c684 1995 pchar_type_node);
1996
1997 gfor_fndecl_string_repeat =
1998 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1999 void_type_node,
2000 4,
2001 pchar_type_node,
9ad09405 2002 gfc_charlen_type_node,
4ee9c684 2003 pchar_type_node,
2004 gfc_int4_type_node);
2005
dbc97b88 2006 gfor_fndecl_ttynam =
2007 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2008 void_type_node,
2009 3,
2010 pchar_type_node,
2011 gfc_charlen_type_node,
2012 gfc_c_int_type_node);
2013
b902b078 2014 gfor_fndecl_fdate =
2015 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2016 void_type_node,
2017 2,
2018 pchar_type_node,
2019 gfc_charlen_type_node);
2020
2021 gfor_fndecl_ctime =
2022 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2023 void_type_node,
2024 3,
2025 pchar_type_node,
2026 gfc_charlen_type_node,
2027 gfc_int8_type_node);
2028
4ee9c684 2029 gfor_fndecl_adjustl =
2030 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2031 void_type_node,
2032 3,
2033 pchar_type_node,
9ad09405 2034 gfc_charlen_type_node, pchar_type_node);
4ee9c684 2035
2036 gfor_fndecl_adjustr =
2037 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2038 void_type_node,
2039 3,
2040 pchar_type_node,
9ad09405 2041 gfc_charlen_type_node, pchar_type_node);
4ee9c684 2042
2043 gfor_fndecl_si_kind =
2044 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2045 gfc_int4_type_node,
2046 1,
2047 pvoid_type_node);
2048
2049 gfor_fndecl_sr_kind =
2050 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
2051 gfc_int4_type_node,
2052 2, pvoid_type_node,
2053 pvoid_type_node);
2054
4ee9c684 2055 /* Power functions. */
76834664 2056 {
920e54ef 2057 tree ctype, rtype, itype, jtype;
2058 int rkind, ikind, jkind;
2059#define NIKINDS 3
2060#define NRKINDS 4
2061 static int ikinds[NIKINDS] = {4, 8, 16};
2062 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2063 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2064
2065 for (ikind=0; ikind < NIKINDS; ikind++)
76834664 2066 {
920e54ef 2067 itype = gfc_get_int_type (ikinds[ikind]);
2068
2069 for (jkind=0; jkind < NIKINDS; jkind++)
2070 {
2071 jtype = gfc_get_int_type (ikinds[jkind]);
2072 if (itype && jtype)
2073 {
2074 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2075 ikinds[jkind]);
2076 gfor_fndecl_math_powi[jkind][ikind].integer =
2077 gfc_build_library_function_decl (get_identifier (name),
2078 jtype, 2, jtype, itype);
2079 }
2080 }
2081
2082 for (rkind = 0; rkind < NRKINDS; rkind ++)
76834664 2083 {
920e54ef 2084 rtype = gfc_get_real_type (rkinds[rkind]);
2085 if (rtype && itype)
2086 {
2087 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2088 ikinds[ikind]);
2089 gfor_fndecl_math_powi[rkind][ikind].real =
2090 gfc_build_library_function_decl (get_identifier (name),
2091 rtype, 2, rtype, itype);
2092 }
2093
2094 ctype = gfc_get_complex_type (rkinds[rkind]);
2095 if (ctype && itype)
2096 {
2097 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2098 ikinds[ikind]);
2099 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2100 gfc_build_library_function_decl (get_identifier (name),
2101 ctype, 2,ctype, itype);
2102 }
76834664 2103 }
2104 }
920e54ef 2105#undef NIKINDS
2106#undef NRKINDS
76834664 2107 }
2108
4ee9c684 2109 gfor_fndecl_math_cpowf =
2110 gfc_build_library_function_decl (get_identifier ("cpowf"),
2111 gfc_complex4_type_node,
2112 1, gfc_complex4_type_node);
2113 gfor_fndecl_math_cpow =
2114 gfc_build_library_function_decl (get_identifier ("cpow"),
2115 gfc_complex8_type_node,
2116 1, gfc_complex8_type_node);
920e54ef 2117 if (gfc_complex10_type_node)
2118 gfor_fndecl_math_cpowl10 =
2119 gfc_build_library_function_decl (get_identifier ("cpowl"),
2120 gfc_complex10_type_node, 1,
2121 gfc_complex10_type_node);
2122 if (gfc_complex16_type_node)
2123 gfor_fndecl_math_cpowl16 =
2124 gfc_build_library_function_decl (get_identifier ("cpowl"),
2125 gfc_complex16_type_node, 1,
2126 gfc_complex16_type_node);
2127
4ee9c684 2128 gfor_fndecl_math_ishftc4 =
2129 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2130 gfc_int4_type_node,
2131 3, gfc_int4_type_node,
2132 gfc_int4_type_node, gfc_int4_type_node);
2133 gfor_fndecl_math_ishftc8 =
2134 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2135 gfc_int8_type_node,
2136 3, gfc_int8_type_node,
920e54ef 2137 gfc_int4_type_node, gfc_int4_type_node);
2138 if (gfc_int16_type_node)
2139 gfor_fndecl_math_ishftc16 =
2140 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2141 gfc_int16_type_node, 3,
2142 gfc_int16_type_node,
2143 gfc_int4_type_node,
2144 gfc_int4_type_node);
2145
4ee9c684 2146 gfor_fndecl_math_exponent4 =
2147 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2148 gfc_int4_type_node,
2149 1, gfc_real4_type_node);
2150 gfor_fndecl_math_exponent8 =
2151 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2152 gfc_int4_type_node,
2153 1, gfc_real8_type_node);
920e54ef 2154 if (gfc_real10_type_node)
2155 gfor_fndecl_math_exponent10 =
2156 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2157 gfc_int4_type_node, 1,
2158 gfc_real10_type_node);
2159 if (gfc_real16_type_node)
2160 gfor_fndecl_math_exponent16 =
2161 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2162 gfc_int4_type_node, 1,
2163 gfc_real16_type_node);
4ee9c684 2164
2165 /* Other functions. */
2166 gfor_fndecl_size0 =
2167 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2168 gfc_array_index_type,
2169 1, pvoid_type_node);
2170 gfor_fndecl_size1 =
2171 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2172 gfc_array_index_type,
2173 2, pvoid_type_node,
2174 gfc_array_index_type);
9b057c29 2175
2176 gfor_fndecl_iargc =
2177 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2178 gfc_int4_type_node,
2179 0);
4ee9c684 2180}
2181
2182
2183/* Make prototypes for runtime library functions. */
2184
2185void
2186gfc_build_builtin_function_decls (void)
2187{
8c84a5de 2188 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
90ba9145 2189 tree gfc_int4_type_node = gfc_get_int_type (4);
2190 tree gfc_int8_type_node = gfc_get_int_type (8);
2191 tree gfc_logical4_type_node = gfc_get_logical_type (4);
8302a4a2 2192 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
90ba9145 2193
9c0f3811 2194 /* Treat these two internal malloc wrappers as malloc. */
4ee9c684 2195 gfor_fndecl_internal_malloc =
2196 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2197 pvoid_type_node, 1, gfc_int4_type_node);
9c0f3811 2198 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
4ee9c684 2199
2200 gfor_fndecl_internal_malloc64 =
2201 gfc_build_library_function_decl (get_identifier
2202 (PREFIX("internal_malloc64")),
2203 pvoid_type_node, 1, gfc_int8_type_node);
9c0f3811 2204 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
4ee9c684 2205
9e1839e2 2206 gfor_fndecl_internal_realloc =
2207 gfc_build_library_function_decl (get_identifier
2208 (PREFIX("internal_realloc")),
2209 pvoid_type_node, 2, pvoid_type_node,
2210 gfc_int4_type_node);
2211
2212 gfor_fndecl_internal_realloc64 =
2213 gfc_build_library_function_decl (get_identifier
2214 (PREFIX("internal_realloc64")),
2215 pvoid_type_node, 2, pvoid_type_node,
2216 gfc_int8_type_node);
2217
4ee9c684 2218 gfor_fndecl_internal_free =
2219 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2220 void_type_node, 1, pvoid_type_node);
2221
2222 gfor_fndecl_allocate =
2223 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2224 void_type_node, 2, ppvoid_type_node,
2225 gfc_int4_type_node);
2226
2227 gfor_fndecl_allocate64 =
2228 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2229 void_type_node, 2, ppvoid_type_node,
2230 gfc_int8_type_node);
2231
8a92488f 2232 gfor_fndecl_allocate_array =
2233 gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2234 void_type_node, 2, ppvoid_type_node,
2235 gfc_int4_type_node);
2236
2237 gfor_fndecl_allocate64_array =
2238 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
2239 void_type_node, 2, ppvoid_type_node,
2240 gfc_int8_type_node);
2241
4ee9c684 2242 gfor_fndecl_deallocate =
2243 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
8302a4a2 2244 void_type_node, 2, ppvoid_type_node,
2245 gfc_pint4_type_node);
4ee9c684 2246
2247 gfor_fndecl_stop_numeric =
2248 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2249 void_type_node, 1, gfc_int4_type_node);
2250
98ccec97 2251 /* Stop doesn't return. */
2252 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2253
4ee9c684 2254 gfor_fndecl_stop_string =
2255 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2256 void_type_node, 2, pchar_type_node,
2257 gfc_int4_type_node);
98ccec97 2258 /* Stop doesn't return. */
2259 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
4ee9c684 2260
2261 gfor_fndecl_pause_numeric =
2262 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2263 void_type_node, 1, gfc_int4_type_node);
2264
2265 gfor_fndecl_pause_string =
2266 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2267 void_type_node, 2, pchar_type_node,
2268 gfc_int4_type_node);
2269
2270 gfor_fndecl_select_string =
2271 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2272 pvoid_type_node, 0);
2273
2274 gfor_fndecl_runtime_error =
2275 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2276 void_type_node,
2277 3,
2278 pchar_type_node, pchar_type_node,
2279 gfc_int4_type_node);
9c0f3811 2280 /* The runtime_error function does not return. */
2281 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
4ee9c684 2282
8c84a5de 2283 gfor_fndecl_set_fpe =
2284 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2285 void_type_node, 1, gfc_c_int_type_node);
2286
64fc3c4c 2287 gfor_fndecl_set_std =
2288 gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2289 void_type_node,
7833ddd7 2290 3,
2291 gfc_int4_type_node,
64fc3c4c 2292 gfc_int4_type_node,
2293 gfc_int4_type_node);
2294
15774a8b 2295 gfor_fndecl_set_convert =
2296 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2297 void_type_node, 1, gfc_c_int_type_node);
2298
4ee9c684 2299 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2300 get_identifier (PREFIX("internal_pack")),
2301 pvoid_type_node, 1, pvoid_type_node);
2302
2303 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2304 get_identifier (PREFIX("internal_unpack")),
2305 pvoid_type_node, 1, pvoid_type_node);
2306
2307 gfor_fndecl_associated =
2308 gfc_build_library_function_decl (
2309 get_identifier (PREFIX("associated")),
2310 gfc_logical4_type_node,
2311 2,
2312 ppvoid_type_node,
2313 ppvoid_type_node);
2314
2315 gfc_build_intrinsic_function_decls ();
2316 gfc_build_intrinsic_lib_fndecls ();
2317 gfc_build_io_library_fndecls ();
2318}
2319
2320
231e961a 2321/* Evaluate the length of dummy character variables. */
4ee9c684 2322
2323static tree
d4163395 2324gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
4ee9c684 2325{
2326 stmtblock_t body;
2327
2328 gfc_finish_decl (cl->backend_decl, NULL_TREE);
2329
2330 gfc_start_block (&body);
2331
2332 /* Evaluate the string length expression. */
2333 gfc_trans_init_string_length (cl, &body);
d4163395 2334
2335 gfc_trans_vla_type_sizes (sym, &body);
2336
4ee9c684 2337 gfc_add_expr_to_block (&body, fnbody);
2338 return gfc_finish_block (&body);
2339}
2340
2341
2342/* Allocate and cleanup an automatic character variable. */
2343
2344static tree
2345gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2346{
2347 stmtblock_t body;
2348 tree decl;
4ee9c684 2349 tree tmp;
2350
22d678e8 2351 gcc_assert (sym->backend_decl);
2352 gcc_assert (sym->ts.cl && sym->ts.cl->length);
4ee9c684 2353
2354 gfc_start_block (&body);
2355
2356 /* Evaluate the string length expression. */
2357 gfc_trans_init_string_length (sym->ts.cl, &body);
2358
d4163395 2359 gfc_trans_vla_type_sizes (sym, &body);
2360
4ee9c684 2361 decl = sym->backend_decl;
2362
afcf285e 2363 /* Emit a DECL_EXPR for this variable, which will cause the
4b3a701c 2364 gimplifier to allocate storage, and all that good stuff. */
ed52ef8b 2365 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4ee9c684 2366 gfc_add_expr_to_block (&body, tmp);
afcf285e 2367
4ee9c684 2368 gfc_add_expr_to_block (&body, fnbody);
2369 return gfc_finish_block (&body);
2370}
2371
c8f1568f 2372/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2373
2374static tree
2375gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2376{
2377 stmtblock_t body;
2378
2379 gcc_assert (sym->backend_decl);
2380 gfc_start_block (&body);
2381
2382 /* Set the initial value to length. See the comments in
2383 function gfc_add_assign_aux_vars in this file. */
2384 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2385 build_int_cst (NULL_TREE, -2));
2386
2387 gfc_add_expr_to_block (&body, fnbody);
2388 return gfc_finish_block (&body);
2389}
2390
d4163395 2391static void
2392gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2393{
2394 tree t = *tp, var, val;
2395
2396 if (t == NULL || t == error_mark_node)
2397 return;
2398 if (TREE_CONSTANT (t) || DECL_P (t))
2399 return;
2400
2401 if (TREE_CODE (t) == SAVE_EXPR)
2402 {
2403 if (SAVE_EXPR_RESOLVED_P (t))
2404 {
2405 *tp = TREE_OPERAND (t, 0);
2406 return;
2407 }
2408 val = TREE_OPERAND (t, 0);
2409 }
2410 else
2411 val = t;
2412
2413 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2414 gfc_add_decl_to_function (var);
2415 gfc_add_modify_expr (body, var, val);
2416 if (TREE_CODE (t) == SAVE_EXPR)
2417 TREE_OPERAND (t, 0) = var;
2418 *tp = var;
2419}
2420
2421static void
2422gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2423{
2424 tree t;
2425
2426 if (type == NULL || type == error_mark_node)
2427 return;
2428
2429 type = TYPE_MAIN_VARIANT (type);
2430
2431 if (TREE_CODE (type) == INTEGER_TYPE)
2432 {
2433 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2434 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2435
2436 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2437 {
2438 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2439 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2440 }
2441 }
2442 else if (TREE_CODE (type) == ARRAY_TYPE)
2443 {
2444 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2445 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2446 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2447 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2448
2449 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2450 {
2451 TYPE_SIZE (t) = TYPE_SIZE (type);
2452 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2453 }
2454 }
2455}
2456
2457/* Make sure all type sizes and array domains are either constant,
2458 or variable or parameter decls. This is a simplified variant
2459 of gimplify_type_sizes, but we can't use it here, as none of the
2460 variables in the expressions have been gimplified yet.
2461 As type sizes and domains for various variable length arrays
2462 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2463 time, without this routine gimplify_type_sizes in the middle-end
2464 could result in the type sizes being gimplified earlier than where
2465 those variables are initialized. */
2466
2467void
2468gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2469{
2470 tree type = TREE_TYPE (sym->backend_decl);
2471
2472 if (TREE_CODE (type) == FUNCTION_TYPE
2473 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2474 {
2475 if (! current_fake_result_decl)
2476 return;
2477
2478 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2479 }
2480
2481 while (POINTER_TYPE_P (type))
2482 type = TREE_TYPE (type);
2483
2484 if (GFC_DESCRIPTOR_TYPE_P (type))
2485 {
2486 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2487
2488 while (POINTER_TYPE_P (etype))
2489 etype = TREE_TYPE (etype);
2490
2491 gfc_trans_vla_type_sizes_1 (etype, body);
2492 }
2493
2494 gfc_trans_vla_type_sizes_1 (type, body);
2495}
2496
4ee9c684 2497
2498/* Generate function entry and exit code, and add it to the function body.
2499 This includes:
f888a3fb 2500 Allocation and initialization of array variables.
4ee9c684 2501 Allocation of character string variables.
c8f1568f 2502 Initialization and possibly repacking of dummy arrays.
2503 Initialization of ASSIGN statement auxiliary variable. */
4ee9c684 2504
2505static tree
2506gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2507{
2508 locus loc;
2509 gfc_symbol *sym;
d4163395 2510 gfc_formal_arglist *f;
2511 stmtblock_t body;
4ee9c684 2512
2513 /* Deal with implicit return variables. Explicit return variables will
2514 already have been added. */
2515 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2516 {
2517 if (!current_fake_result_decl)
2518 {
c6871095 2519 gfc_entry_list *el = NULL;
2520 if (proc_sym->attr.entry_master)
2521 {
2522 for (el = proc_sym->ns->entries; el; el = el->next)
2523 if (el->sym != el->sym->result)
2524 break;
2525 }
2526 if (el == NULL)
2527 warning (0, "Function does not return a value");
4ee9c684 2528 }
c6871095 2529 else if (proc_sym->as)
4ee9c684 2530 {
d4163395 2531 tree result = TREE_VALUE (current_fake_result_decl);
2532 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
4ee9c684 2533 }
2534 else if (proc_sym->ts.type == BT_CHARACTER)
2535 {
2536 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
d4163395 2537 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2538 fnbody);
4ee9c684 2539 }
2540 else
bdaed7d2 2541 gcc_assert (gfc_option.flag_f2c
2542 && proc_sym->ts.type == BT_COMPLEX);
4ee9c684 2543 }
2544
2545 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2546 {
2547 if (sym->attr.dimension)
2548 {
2549 switch (sym->as->type)
2550 {
2551 case AS_EXPLICIT:
2552 if (sym->attr.dummy || sym->attr.result)
2553 fnbody =
2554 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2555 else if (sym->attr.pointer || sym->attr.allocatable)
2556 {
2557 if (TREE_STATIC (sym->backend_decl))
2558 gfc_trans_static_array_pointer (sym);
2559 else
2560 fnbody = gfc_trans_deferred_array (sym, fnbody);
2561 }
2562 else
2563 {
2564 gfc_get_backend_locus (&loc);
2565 gfc_set_backend_locus (&sym->declared_at);
2566 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2567 sym, fnbody);
2568 gfc_set_backend_locus (&loc);
2569 }
2570 break;
2571
2572 case AS_ASSUMED_SIZE:
2573 /* Must be a dummy parameter. */
22d678e8 2574 gcc_assert (sym->attr.dummy);
4ee9c684 2575
2576 /* We should always pass assumed size arrays the g77 way. */
4ee9c684 2577 fnbody = gfc_trans_g77_array (sym, fnbody);
2578 break;
2579
2580 case AS_ASSUMED_SHAPE:
2581 /* Must be a dummy parameter. */
22d678e8 2582 gcc_assert (sym->attr.dummy);
4ee9c684 2583
2584 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2585 fnbody);
2586 break;
2587
2588 case AS_DEFERRED:
2589 fnbody = gfc_trans_deferred_array (sym, fnbody);
2590 break;
2591
2592 default:
22d678e8 2593 gcc_unreachable ();
4ee9c684 2594 }
2595 }
2596 else if (sym->ts.type == BT_CHARACTER)
2597 {
2598 gfc_get_backend_locus (&loc);
2599 gfc_set_backend_locus (&sym->declared_at);
2600 if (sym->attr.dummy || sym->attr.result)
d4163395 2601 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
4ee9c684 2602 else
2603 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2604 gfc_set_backend_locus (&loc);
2605 }
c8f1568f 2606 else if (sym->attr.assign)
2607 {
2608 gfc_get_backend_locus (&loc);
2609 gfc_set_backend_locus (&sym->declared_at);
2610 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2611 gfc_set_backend_locus (&loc);
2612 }
4ee9c684 2613 else
22d678e8 2614 gcc_unreachable ();
4ee9c684 2615 }
2616
d4163395 2617 gfc_init_block (&body);
2618
2619 for (f = proc_sym->formal; f; f = f->next)
2620 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2621 {
2622 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2623 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2624 gfc_trans_vla_type_sizes (f->sym, &body);
2625 }
2626
2627 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2628 && current_fake_result_decl != NULL)
2629 {
2630 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2631 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2632 gfc_trans_vla_type_sizes (proc_sym, &body);
2633 }
2634
2635 gfc_add_expr_to_block (&body, fnbody);
2636 return gfc_finish_block (&body);
4ee9c684 2637}
2638
2639
2640/* Output an initialized decl for a module variable. */
2641
2642static void
2643gfc_create_module_variable (gfc_symbol * sym)
2644{
2645 tree decl;
4ee9c684 2646
2647 /* Only output symbols from this module. */
2648 if (sym->ns != module_namespace)
2649 {
2650 /* I don't think this should ever happen. */
2651 internal_error ("module symbol %s in wrong namespace", sym->name);
2652 }
2653
7b3423b9 2654 /* Only output variables and array valued parameters. */
4ee9c684 2655 if (sym->attr.flavor != FL_VARIABLE
2656 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2657 return;
2658
d43a7f7f 2659 /* Don't generate variables from other modules. Variables from
2660 COMMONs will already have been generated. */
2661 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 2662 return;
2663
2b685f8e 2664 /* Equivalenced variables arrive here after creation. */
976d903a 2665 if (sym->backend_decl
2666 && (sym->equiv_built || sym->attr.in_equivalence))
2b685f8e 2667 return;
2668
4ee9c684 2669 if (sym->backend_decl)
2670 internal_error ("backend decl for module variable %s already exists",
2671 sym->name);
2672
2673 /* We always want module variables to be created. */
2674 sym->attr.referenced = 1;
2675 /* Create the decl. */
2676 decl = gfc_get_symbol_decl (sym);
2677
4ee9c684 2678 /* Create the variable. */
2679 pushdecl (decl);
b2c4af5e 2680 rest_of_decl_compilation (decl, 1, 0);
4ee9c684 2681
2682 /* Also add length of strings. */
2683 if (sym->ts.type == BT_CHARACTER)
2684 {
2685 tree length;
2686
2687 length = sym->ts.cl->backend_decl;
2688 if (!INTEGER_CST_P (length))
2689 {
2690 pushdecl (length);
b2c4af5e 2691 rest_of_decl_compilation (length, 1, 0);
4ee9c684 2692 }
2693 }
2694}
2695
2696
2697/* Generate all the required code for module variables. */
2698
2699void
2700gfc_generate_module_vars (gfc_namespace * ns)
2701{
2702 module_namespace = ns;
2703
dfc222eb 2704 /* Check if the frontend left the namespace in a reasonable state. */
22d678e8 2705 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4ee9c684 2706
d43a7f7f 2707 /* Generate COMMON blocks. */
2708 gfc_trans_common (ns);
2709
dfc222eb 2710 /* Create decls for all the module variables. */
4ee9c684 2711 gfc_traverse_ns (ns, gfc_create_module_variable);
2712}
2713
2714static void
2715gfc_generate_contained_functions (gfc_namespace * parent)
2716{
2717 gfc_namespace *ns;
2718
2719 /* We create all the prototypes before generating any code. */
2720 for (ns = parent->contained; ns; ns = ns->sibling)
2721 {
2722 /* Skip namespaces from used modules. */
2723 if (ns->parent != parent)
2724 continue;
2725
1b716045 2726 gfc_create_function_decl (ns);
4ee9c684 2727 }
2728
2729 for (ns = parent->contained; ns; ns = ns->sibling)
2730 {
2731 /* Skip namespaces from used modules. */
2732 if (ns->parent != parent)
2733 continue;
2734
2735 gfc_generate_function_code (ns);
2736 }
2737}
2738
2739
2740/* Generate decls for all local variables. We do this to ensure correct
2741 handling of expressions which only appear in the specification of
2742 other functions. */
2743
2744static void
2745generate_local_decl (gfc_symbol * sym)
2746{
2747 if (sym->attr.flavor == FL_VARIABLE)
2748 {
4ee9c684 2749 if (sym->attr.referenced)
2750 gfc_get_symbol_decl (sym);
14a3addc 2751 else if (sym->attr.dummy && warn_unused_parameter)
c3ceba8e 2752 warning (0, "unused parameter %qs", sym->name);
f888a3fb 2753 /* Warn for unused variables, but not if they're inside a common
14a3addc 2754 block or are use-associated. */
36609028 2755 else if (warn_unused_variable
2756 && !(sym->attr.in_common || sym->attr.use_assoc))
c3ceba8e 2757 warning (0, "unused variable %qs", sym->name);
d4163395 2758 /* For variable length CHARACTER parameters, the PARM_DECL already
2759 references the length variable, so force gfc_get_symbol_decl
2760 even when not referenced. If optimize > 0, it will be optimized
2761 away anyway. But do this only after emitting -Wunused-parameter
2762 warning if requested. */
2763 if (sym->attr.dummy && ! sym->attr.referenced
2764 && sym->ts.type == BT_CHARACTER
2765 && sym->ts.cl->backend_decl != NULL
2766 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2767 {
2768 sym->attr.referenced = 1;
2769 gfc_get_symbol_decl (sym);
2770 }
4ee9c684 2771 }
2772}
2773
2774static void
2775generate_local_vars (gfc_namespace * ns)
2776{
2777 gfc_traverse_ns (ns, generate_local_decl);
2778}
2779
2780
1b716045 2781/* Generate a switch statement to jump to the correct entry point. Also
2782 creates the label decls for the entry points. */
4ee9c684 2783
1b716045 2784static tree
2785gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 2786{
1b716045 2787 stmtblock_t block;
2788 tree label;
2789 tree tmp;
2790 tree val;
4ee9c684 2791
1b716045 2792 gfc_init_block (&block);
2793 for (; el; el = el->next)
2794 {
2795 /* Add the case label. */
b797d6d3 2796 label = gfc_build_label_decl (NULL_TREE);
7016c612 2797 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 2798 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 2799 gfc_add_expr_to_block (&block, tmp);
2800
2801 /* And jump to the actual entry point. */
2802 label = gfc_build_label_decl (NULL_TREE);
1b716045 2803 tmp = build1_v (GOTO_EXPR, label);
2804 gfc_add_expr_to_block (&block, tmp);
2805
2806 /* Save the label decl. */
2807 el->label = label;
2808 }
2809 tmp = gfc_finish_block (&block);
2810 /* The first argument selects the entry point. */
2811 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 2812 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 2813 return tmp;
4ee9c684 2814}
2815
6374121b 2816
4ee9c684 2817/* Generate code for a function. */
2818
2819void
2820gfc_generate_function_code (gfc_namespace * ns)
2821{
2822 tree fndecl;
2823 tree old_context;
2824 tree decl;
2825 tree tmp;
2826 stmtblock_t block;
2827 stmtblock_t body;
2828 tree result;
2829 gfc_symbol *sym;
2830
2831 sym = ns->proc_name;
1b716045 2832
4ee9c684 2833 /* Check that the frontend isn't still using this. */
22d678e8 2834 gcc_assert (sym->tlink == NULL);
4ee9c684 2835 sym->tlink = sym;
2836
2837 /* Create the declaration for functions with global scope. */
2838 if (!sym->backend_decl)
1b716045 2839 gfc_create_function_decl (ns);
4ee9c684 2840
2841 fndecl = sym->backend_decl;
2842 old_context = current_function_decl;
2843
2844 if (old_context)
2845 {
2846 push_function_context ();
2847 saved_parent_function_decls = saved_function_decls;
2848 saved_function_decls = NULL_TREE;
2849 }
2850
1b716045 2851 trans_function_start (sym);
4ee9c684 2852
4ee9c684 2853 gfc_start_block (&block);
2854
c6871095 2855 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2856 {
2857 /* Copy length backend_decls to all entry point result
2858 symbols. */
2859 gfc_entry_list *el;
2860 tree backend_decl;
2861
2862 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2863 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2864 for (el = ns->entries; el; el = el->next)
2865 el->sym->result->ts.cl->backend_decl = backend_decl;
2866 }
2867
4ee9c684 2868 /* Translate COMMON blocks. */
2869 gfc_trans_common (ns);
2870
c750cc52 2871 /* Null the parent fake result declaration if this namespace is
2872 a module function or an external procedures. */
2873 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
2874 || ns->parent == NULL)
2875 parent_fake_result_decl = NULL_TREE;
2876
2b685f8e 2877 gfc_generate_contained_functions (ns);
2878
4ee9c684 2879 generate_local_vars (ns);
669122e7 2880
c750cc52 2881 /* Keep the parent fake result declaration in module functions
2882 or external procedures. */
2883 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
2884 || ns->parent == NULL)
2885 current_fake_result_decl = parent_fake_result_decl;
2886 else
2887 current_fake_result_decl = NULL_TREE;
2888
4ee9c684 2889 current_function_return_label = NULL;
2890
2891 /* Now generate the code for the body of this function. */
2892 gfc_init_block (&body);
2893
7833ddd7 2894 /* If this is the main program, add a call to set_std to set up the
2895 runtime library Fortran language standard parameters. */
2896
2897 if (sym->attr.is_main_program)
64fc3c4c 2898 {
2899 tree arglist, gfc_int4_type_node;
2900
2901 gfc_int4_type_node = gfc_get_int_type (4);
2902 arglist = gfc_chainon_list (NULL_TREE,
2903 build_int_cst (gfc_int4_type_node,
2904 gfc_option.warn_std));
2905 arglist = gfc_chainon_list (arglist,
2906 build_int_cst (gfc_int4_type_node,
2907 gfc_option.allow_std));
7833ddd7 2908 arglist = gfc_chainon_list (arglist,
2909 build_int_cst (gfc_int4_type_node,
2910 pedantic));
ac47d547 2911 tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
64fc3c4c 2912 gfc_add_expr_to_block (&body, tmp);
2913 }
2914
8c84a5de 2915 /* If this is the main program and a -ffpe-trap option was provided,
2916 add a call to set_fpe so that the library will raise a FPE when
2917 needed. */
2918 if (sym->attr.is_main_program && gfc_option.fpe != 0)
2919 {
2920 tree arglist, gfc_c_int_type_node;
2921
2922 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2923 arglist = gfc_chainon_list (NULL_TREE,
2924 build_int_cst (gfc_c_int_type_node,
2925 gfc_option.fpe));
ac47d547 2926 tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
8c84a5de 2927 gfc_add_expr_to_block (&body, tmp);
2928 }
2929
15774a8b 2930 /* If this is the main program and an -fconvert option was provided,
2931 add a call to set_convert. */
2932
2933 if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
2934 {
2935 tree arglist, gfc_c_int_type_node;
2936
2937 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2938 arglist = gfc_chainon_list (NULL_TREE,
2939 build_int_cst (gfc_c_int_type_node,
2940 gfc_option.convert));
2941 tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
2942 gfc_add_expr_to_block (&body, tmp);
2943 }
2944
2945
4ee9c684 2946 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2947 && sym->attr.subroutine)
2948 {
2949 tree alternate_return;
c750cc52 2950 alternate_return = gfc_get_fake_result_decl (sym, 0);
4ee9c684 2951 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2952 }
2953
1b716045 2954 if (ns->entries)
2955 {
2956 /* Jump to the correct entry point. */
2957 tmp = gfc_trans_entry_master_switch (ns->entries);
2958 gfc_add_expr_to_block (&body, tmp);
2959 }
2960
4ee9c684 2961 tmp = gfc_trans_code (ns->code);
2962 gfc_add_expr_to_block (&body, tmp);
2963
2964 /* Add a return label if needed. */
2965 if (current_function_return_label)
2966 {
2967 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2968 gfc_add_expr_to_block (&body, tmp);
2969 }
2970
2971 tmp = gfc_finish_block (&body);
2972 /* Add code to create and cleanup arrays. */
2973 tmp = gfc_trans_deferred_vars (sym, tmp);
2974 gfc_add_expr_to_block (&block, tmp);
2975
2976 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2977 {
14a3addc 2978 if (sym->attr.subroutine || sym == sym->result)
4ee9c684 2979 {
d4163395 2980 if (current_fake_result_decl != NULL)
2981 result = TREE_VALUE (current_fake_result_decl);
2982 else
2983 result = NULL_TREE;
4ee9c684 2984 current_fake_result_decl = NULL_TREE;
2985 }
2986 else
2987 result = sym->result->backend_decl;
2988
2989 if (result == NULL_TREE)
c3ceba8e 2990 warning (0, "Function return value not set");
4ee9c684 2991 else
2992 {
f888a3fb 2993 /* Set the return value to the dummy result variable. */
ed52ef8b 2994 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2995 DECL_RESULT (fndecl), result);
2996 tmp = build1_v (RETURN_EXPR, tmp);
4ee9c684 2997 gfc_add_expr_to_block (&block, tmp);
2998 }
2999 }
3000
3001 /* Add all the decls we created during processing. */
3002 decl = saved_function_decls;
3003 while (decl)
3004 {
3005 tree next;
3006
3007 next = TREE_CHAIN (decl);
3008 TREE_CHAIN (decl) = NULL_TREE;
3009 pushdecl (decl);
3010 decl = next;
3011 }
3012 saved_function_decls = NULL_TREE;
3013
3014 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3015
3016 /* Finish off this function and send it for code generation. */
3017 poplevel (1, 0, 1);
3018 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3019
3020 /* Output the GENERIC tree. */
3021 dump_function (TDI_original, fndecl);
3022
3023 /* Store the end of the function, so that we get good line number
3024 info for the epilogue. */
3025 cfun->function_end_locus = input_location;
3026
3027 /* We're leaving the context of this function, so zap cfun.
3028 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3029 tree_rest_of_compilation. */
3030 cfun = NULL;
3031
3032 if (old_context)
3033 {
3034 pop_function_context ();
3035 saved_function_decls = saved_parent_function_decls;
3036 }
3037 current_function_decl = old_context;
3038
3039 if (decl_function_context (fndecl))
6374121b 3040 /* Register this function with cgraph just far enough to get it
3041 added to our parent's nested function list. */
3042 (void) cgraph_node (fndecl);
4ee9c684 3043 else
3044 {
6374121b 3045 gfc_gimplify_function (fndecl);
9d95b2b0 3046 cgraph_finalize_function (fndecl, false);
4ee9c684 3047 }
3048}
3049
4ee9c684 3050void
3051gfc_generate_constructors (void)
3052{
22d678e8 3053 gcc_assert (gfc_static_ctors == NULL_TREE);
4ee9c684 3054#if 0
3055 tree fnname;
3056 tree type;
3057 tree fndecl;
3058 tree decl;
3059 tree tmp;
3060
3061 if (gfc_static_ctors == NULL_TREE)
3062 return;
3063
3064 fnname = get_file_function_name ('I');
3065 type = build_function_type (void_type_node,
3066 gfc_chainon_list (NULL_TREE, void_type_node));
3067
3068 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3069 TREE_PUBLIC (fndecl) = 1;
3070
3071 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
540edea7 3072 DECL_ARTIFICIAL (decl) = 1;
3073 DECL_IGNORED_P (decl) = 1;
4ee9c684 3074 DECL_CONTEXT (decl) = fndecl;
3075 DECL_RESULT (fndecl) = decl;
3076
3077 pushdecl (fndecl);
3078
3079 current_function_decl = fndecl;
3080
b2c4af5e 3081 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 3082
b2c4af5e 3083 make_decl_rtl (fndecl);
4ee9c684 3084
b31f705b 3085 init_function_start (fndecl);
4ee9c684 3086
4ee9c684 3087 pushlevel (0);
3088
3089 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3090 {
3091 tmp =
ac47d547 3092 build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
4ee9c684 3093 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3094 }
3095
3096 poplevel (1, 0, 1);
3097
3098 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3099
3100 free_after_parsing (cfun);
3101 free_after_compilation (cfun);
3102
6148a911 3103 tree_rest_of_compilation (fndecl);
4ee9c684 3104
3105 current_function_decl = NULL_TREE;
3106#endif
3107}
3108
9ec7c303 3109/* Translates a BLOCK DATA program unit. This means emitting the
3110 commons contained therein plus their initializations. We also emit
3111 a globally visible symbol to make sure that each BLOCK DATA program
3112 unit remains unique. */
3113
3114void
3115gfc_generate_block_data (gfc_namespace * ns)
3116{
3117 tree decl;
3118 tree id;
3119
b31f705b 3120 /* Tell the backend the source location of the block data. */
3121 if (ns->proc_name)
3122 gfc_set_backend_locus (&ns->proc_name->declared_at);
3123 else
3124 gfc_set_backend_locus (&gfc_current_locus);
3125
3126 /* Process the DATA statements. */
9ec7c303 3127 gfc_trans_common (ns);
3128
b31f705b 3129 /* Create a global symbol with the mane of the block data. This is to
3130 generate linker errors if the same name is used twice. It is never
3131 really used. */
9ec7c303 3132 if (ns->proc_name)
3133 id = gfc_sym_mangled_function_id (ns->proc_name);
3134 else
3135 id = get_identifier ("__BLOCK_DATA__");
3136
3137 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3138 TREE_PUBLIC (decl) = 1;
3139 TREE_STATIC (decl) = 1;
3140
3141 pushdecl (decl);
3142 rest_of_decl_compilation (decl, 1, 0);
3143}
3144
b549d2a5 3145
4ee9c684 3146#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git