]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/trans-decl.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update FSF address.
[gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
6de9cd9a 1/* Backend function setup
e7dc5b4f 2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Paul Brook
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b 18along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 19Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2002110-1301, USA. */
6de9cd9a
DN		 21
22/* trans-decl.c -- Handling of backend function and variable decls, etc */
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "tree.h"
28#include "tree-dump.h"
eadf906f 29#include "tree-gimple.h"
6de9cd9a
DN		 30#include "ggc.h"
31#include "toplev.h"
32#include "tm.h"
33#include "target.h"
34#include "function.h"
6de9cd9a
DN		 35#include "flags.h"
36#include "cgraph.h"
6de9cd9a
DN		 37#include "gfortran.h"
38#include "trans.h"
39#include "trans-types.h"
40#include "trans-array.h"
41#include "trans-const.h"
42/* Only for gfc_trans_code. Shouldn't need to include this. */
43#include "trans-stmt.h"
44
45#define MAX_LABEL_VALUE 99999
46
47
48/* Holds the result of the function if no result variable specified. */
49
50static GTY(()) tree current_fake_result_decl;
51
52static GTY(()) tree current_function_return_label;
53
54
55/* Holds the variable DECLs for the current function. */
56
57static GTY(()) tree saved_function_decls = NULL_TREE;
58static GTY(()) tree saved_parent_function_decls = NULL_TREE;
59
60
61/* The namespace of the module we're currently generating. Only used while
62 outputting decls for module variables. Do not rely on this being set. */
63
64static gfc_namespace *module_namespace;
65
66
67/* List of static constructor functions. */
68
69tree gfc_static_ctors;
70
71
72/* Function declarations for builtin library functions. */
73
74tree gfor_fndecl_internal_malloc;
75tree gfor_fndecl_internal_malloc64;
76tree gfor_fndecl_internal_free;
77tree gfor_fndecl_allocate;
78tree gfor_fndecl_allocate64;
79tree gfor_fndecl_deallocate;
80tree gfor_fndecl_pause_numeric;
81tree gfor_fndecl_pause_string;
82tree gfor_fndecl_stop_numeric;
83tree gfor_fndecl_stop_string;
84tree gfor_fndecl_select_string;
85tree gfor_fndecl_runtime_error;
86tree gfor_fndecl_in_pack;
87tree gfor_fndecl_in_unpack;
88tree gfor_fndecl_associated;
89
90
91/* Math functions. Many other math functions are handled in
92 trans-intrinsic.c. */
93
5b200ac2 94gfc_powdecl_list gfor_fndecl_math_powi[3][2];
6de9cd9a
DN		 95tree gfor_fndecl_math_cpowf;
96tree gfor_fndecl_math_cpow;
6de9cd9a
DN		 97tree gfor_fndecl_math_ishftc4;
98tree gfor_fndecl_math_ishftc8;
99tree gfor_fndecl_math_exponent4;
100tree gfor_fndecl_math_exponent8;
101
102
103/* String functions. */
104
105tree gfor_fndecl_copy_string;
106tree gfor_fndecl_compare_string;
107tree gfor_fndecl_concat_string;
108tree gfor_fndecl_string_len_trim;
109tree gfor_fndecl_string_index;
110tree gfor_fndecl_string_scan;
111tree gfor_fndecl_string_verify;
112tree gfor_fndecl_string_trim;
113tree gfor_fndecl_string_repeat;
114tree gfor_fndecl_adjustl;
115tree gfor_fndecl_adjustr;
116
117
118/* Other misc. runtime library functions. */
119
120tree gfor_fndecl_size0;
121tree gfor_fndecl_size1;
b41b2534 122tree gfor_fndecl_iargc;
6de9cd9a
DN		 123
124/* Intrinsic functions implemented in FORTRAN. */
125tree gfor_fndecl_si_kind;
126tree gfor_fndecl_sr_kind;
127
128
129static void
130gfc_add_decl_to_parent_function (tree decl)
131{
6e45f57b 132 gcc_assert (decl);
6de9cd9a
DN		 133 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
134 DECL_NONLOCAL (decl) = 1;
135 TREE_CHAIN (decl) = saved_parent_function_decls;
136 saved_parent_function_decls = decl;
137}
138
139void
140gfc_add_decl_to_function (tree decl)
141{
6e45f57b 142 gcc_assert (decl);
6de9cd9a
DN		 143 TREE_USED (decl) = 1;
144 DECL_CONTEXT (decl) = current_function_decl;
145 TREE_CHAIN (decl) = saved_function_decls;
146 saved_function_decls = decl;
147}
148
149
c006df4e
SB		 150/* Build a backend label declaration. Set TREE_USED for named labels.
151 The context of the label is always the current_function_decl. All
152 labels are marked artificial. */
6de9cd9a
DN		 153
154tree
155gfc_build_label_decl (tree label_id)
156{
157 /* 2^32 temporaries should be enough. */
158 static unsigned int tmp_num = 1;
159 tree label_decl;
160 char *label_name;
161
162 if (label_id == NULL_TREE)
163 {
164 /* Build an internal label name. */
165 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
166 label_id = get_identifier (label_name);
167 }
168 else
169 label_name = NULL;
170
171 /* Build the LABEL_DECL node. Labels have no type. */
172 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
173 DECL_CONTEXT (label_decl) = current_function_decl;
174 DECL_MODE (label_decl) = VOIDmode;
175
c006df4e
SB		 176 /* We always define the label as used, even if the original source
177 file never references the label. We don't want all kinds of
178 spurious warnings for old-style Fortran code with too many
179 labels. */
180 TREE_USED (label_decl) = 1;
6de9cd9a 181
c006df4e 182 DECL_ARTIFICIAL (label_decl) = 1;
6de9cd9a
DN		 183 return label_decl;
184}
185
186
187/* Returns the return label for the current function. */
188
189tree
190gfc_get_return_label (void)
191{
192 char name[GFC_MAX_SYMBOL_LEN + 10];
193
194 if (current_function_return_label)
195 return current_function_return_label;
196
197 sprintf (name, "__return_%s",
198 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
199
200 current_function_return_label =
201 gfc_build_label_decl (get_identifier (name));
202
203 DECL_ARTIFICIAL (current_function_return_label) = 1;
204
205 return current_function_return_label;
206}
207
208
c8cc8542
PB		 209/* Set the backend source location of a decl. */
210
211void
212gfc_set_decl_location (tree decl, locus * loc)
213{
214#ifdef USE_MAPPED_LOCATION
215 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
216#else
217 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
218 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
219#endif
220}
221
222
6de9cd9a
DN		 223/* Return the backend label declaration for a given label structure,
224 or create it if it doesn't exist yet. */
225
226tree
227gfc_get_label_decl (gfc_st_label * lp)
228{
6de9cd9a
DN		 229 if (lp->backend_decl)
230 return lp->backend_decl;
231 else
232 {
233 char label_name[GFC_MAX_SYMBOL_LEN + 1];
234 tree label_decl;
235
236 /* Validate the label declaration from the front end. */
6e45f57b 237 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
6de9cd9a
DN		 238
239 /* Build a mangled name for the label. */
240 sprintf (label_name, "__label_%.6d", lp->value);
241
242 /* Build the LABEL_DECL node. */
243 label_decl = gfc_build_label_decl (get_identifier (label_name));
244
245 /* Tell the debugger where the label came from. */
f8d0aee5 246 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
c8cc8542 247 gfc_set_decl_location (label_decl, &lp->where);
6de9cd9a
DN		 248 else
249 DECL_ARTIFICIAL (label_decl) = 1;
250
251 /* Store the label in the label list and return the LABEL_DECL. */
252 lp->backend_decl = label_decl;
253 return label_decl;
254 }
255}
256
257
258/* Convert a gfc_symbol to an identifier of the same name. */
259
260static tree
261gfc_sym_identifier (gfc_symbol * sym)
262{
263 return (get_identifier (sym->name));
264}
265
266
267/* Construct mangled name from symbol name. */
268
269static tree
270gfc_sym_mangled_identifier (gfc_symbol * sym)
271{
272 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
273
cb9e4f55 274 if (sym->module == NULL)
6de9cd9a
DN		 275 return gfc_sym_identifier (sym);
276 else
277 {
278 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
279 return get_identifier (name);
280 }
281}
282
283
284/* Construct mangled function name from symbol name. */
285
286static tree
287gfc_sym_mangled_function_id (gfc_symbol * sym)
288{
289 int has_underscore;
290 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
291
cb9e4f55
TS		 292 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
293 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
6de9cd9a
DN		 294 {
295 if (strcmp (sym->name, "MAIN__") == 0
296 || sym->attr.proc == PROC_INTRINSIC)
297 return get_identifier (sym->name);
298
299 if (gfc_option.flag_underscoring)
300 {
301 has_underscore = strchr (sym->name, '_') != 0;
302 if (gfc_option.flag_second_underscore && has_underscore)
303 snprintf (name, sizeof name, "%s__", sym->name);
304 else
305 snprintf (name, sizeof name, "%s_", sym->name);
306 return get_identifier (name);
307 }
308 else
309 return get_identifier (sym->name);
310 }
311 else
312 {
313 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
314 return get_identifier (name);
315 }
316}
317
318
bae88af6
TS		 319/* Returns true if a variable of specified size should go on the stack. */
320
321int
322gfc_can_put_var_on_stack (tree size)
323{
324 unsigned HOST_WIDE_INT low;
325
326 if (!INTEGER_CST_P (size))
327 return 0;
328
329 if (gfc_option.flag_max_stack_var_size < 0)
330 return 1;
331
332 if (TREE_INT_CST_HIGH (size) != 0)
333 return 0;
334
335 low = TREE_INT_CST_LOW (size);
336 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
337 return 0;
338
339/* TODO: Set a per-function stack size limit. */
340
341 return 1;
342}
343
344
6de9cd9a
DN		 345/* Finish processing of a declaration and install its initial value. */
346
347static void
348gfc_finish_decl (tree decl, tree init)
349{
350 if (TREE_CODE (decl) == PARM_DECL)
6e45f57b 351 gcc_assert (init == NULL_TREE);
6de9cd9a
DN		 352 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
353 -- it overlaps DECL_ARG_TYPE. */
354 else if (init == NULL_TREE)
6e45f57b 355 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
6de9cd9a 356 else
6e45f57b 357 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
6de9cd9a
DN		 358
359 if (init != NULL_TREE)
360 {
361 if (TREE_CODE (decl) != TYPE_DECL)
362 DECL_INITIAL (decl) = init;
363 else
364 {
365 /* typedef foo = bar; store the type of bar as the type of foo. */
366 TREE_TYPE (decl) = TREE_TYPE (init);
367 DECL_INITIAL (decl) = init = 0;
368 }
369 }
370
371 if (TREE_CODE (decl) == VAR_DECL)
372 {
373 if (DECL_SIZE (decl) == NULL_TREE
374 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
375 layout_decl (decl, 0);
376
377 /* A static variable with an incomplete type is an error if it is
378 initialized. Also if it is not file scope. Otherwise, let it
379 through, but if it is not `extern' then it may cause an error
380 message later. */
381 /* An automatic variable with an incomplete type is an error. */
382 if (DECL_SIZE (decl) == NULL_TREE
383 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
384 || DECL_CONTEXT (decl) != 0)
385 : !DECL_EXTERNAL (decl)))
386 {
387 gfc_fatal_error ("storage size not known");
388 }
389
390 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
391 && (DECL_SIZE (decl) != 0)
392 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
393 {
394 gfc_fatal_error ("storage size not constant");
395 }
396 }
397
398}
399
400
401/* Apply symbol attributes to a variable, and add it to the function scope. */
402
403static void
404gfc_finish_var_decl (tree decl, gfc_symbol * sym)
405{
f8d0aee5 406 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
6de9cd9a
DN		 407 This is the equivalent of the TARGET variables.
408 We also need to set this if the variable is passed by reference in a
409 CALL statement. */
410 if (sym->attr.target)
411 TREE_ADDRESSABLE (decl) = 1;
412 /* If it wasn't used we wouldn't be getting it. */
413 TREE_USED (decl) = 1;
414
415 /* Chain this decl to the pending declarations. Don't do pushdecl()
416 because this would add them to the current scope rather than the
417 function scope. */
418 if (current_function_decl != NULL_TREE)
419 {
420 if (sym->ns->proc_name->backend_decl == current_function_decl)
421 gfc_add_decl_to_function (decl);
422 else
423 gfc_add_decl_to_parent_function (decl);
424 }
425
426 /* If a variable is USE associated, it's always external. */
427 if (sym->attr.use_assoc)
428 {
429 DECL_EXTERNAL (decl) = 1;
430 TREE_PUBLIC (decl) = 1;
431 }
cb9e4f55 432 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
6de9cd9a 433 {
adf3ed3f 434 /* TODO: Don't set sym->module for result or dummy variables. */
6e45f57b 435 gcc_assert (current_function_decl == NULL_TREE);
6de9cd9a
DN		 436 /* This is the declaration of a module variable. */
437 TREE_PUBLIC (decl) = 1;
438 TREE_STATIC (decl) = 1;
439 }
440
441 if ((sym->attr.save || sym->attr.data || sym->value)
442 && !sym->attr.use_assoc)
443 TREE_STATIC (decl) = 1;
444
445 /* Keep variables larger than max-stack-var-size off stack. */
446 if (!sym->ns->proc_name->attr.recursive
447 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
448 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
449 TREE_STATIC (decl) = 1;
450}
451
452
453/* Allocate the lang-specific part of a decl. */
454
455void
456gfc_allocate_lang_decl (tree decl)
457{
458 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
459 ggc_alloc_cleared (sizeof (struct lang_decl));
460}
461
462/* Remember a symbol to generate initialization/cleanup code at function
463 entry/exit. */
464
465static void
466gfc_defer_symbol_init (gfc_symbol * sym)
467{
468 gfc_symbol *p;
469 gfc_symbol *last;
470 gfc_symbol *head;
471
472 /* Don't add a symbol twice. */
473 if (sym->tlink)
474 return;
475
476 last = head = sym->ns->proc_name;
477 p = last->tlink;
478
479 /* Make sure that setup code for dummy variables which are used in the
480 setup of other variables is generated first. */
481 if (sym->attr.dummy)
482 {
483 /* Find the first dummy arg seen after us, or the first non-dummy arg.
484 This is a circular list, so don't go past the head. */
485 while (p != head
486 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
487 {
488 last = p;
489 p = p->tlink;
490 }
491 }
492 /* Insert in between last and p. */
493 last->tlink = sym;
494 sym->tlink = p;
495}
496
497
498/* Create an array index type variable with function scope. */
499
500static tree
501create_index_var (const char * pfx, int nest)
502{
503 tree decl;
504
505 decl = gfc_create_var_np (gfc_array_index_type, pfx);
506 if (nest)
507 gfc_add_decl_to_parent_function (decl);
508 else
509 gfc_add_decl_to_function (decl);
510 return decl;
511}
512
513
514/* Create variables to hold all the non-constant bits of info for a
515 descriptorless array. Remember these in the lang-specific part of the
516 type. */
517
518static void
519gfc_build_qualified_array (tree decl, gfc_symbol * sym)
520{
521 tree type;
522 int dim;
523 int nest;
524
525 type = TREE_TYPE (decl);
526
527 /* We just use the descriptor, if there is one. */
528 if (GFC_DESCRIPTOR_TYPE_P (type))
529 return;
530
6e45f57b 531 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 532 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
533 && !sym->attr.contained;
534
535 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
536 {
537 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
538 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
aa9c57ec 539 /* Don't try to use the unknown bound for assumed shape arrays. */
6de9cd9a
DN		 540 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
541 && (sym->as->type != AS_ASSUMED_SIZE
542 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
543 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
544
545 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
546 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
547 }
548 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
549 {
550 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
551 "offset");
552 if (nest)
553 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
554 else
555 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
556 }
557}
558
559
560/* For some dummy arguments we don't use the actual argument directly.
bae88af6 561 Instead we create a local decl and use that. This allows us to perform
6de9cd9a
DN		 562 initialization, and construct full type information. */
563
564static tree
565gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
566{
567 tree decl;
568 tree type;
569 gfc_array_spec *as;
570 char *name;
571 int packed;
572 int n;
573 bool known_size;
574
575 if (sym->attr.pointer || sym->attr.allocatable)
576 return dummy;
577
578 /* Add to list of variables if not a fake result variable. */
579 if (sym->attr.result || sym->attr.dummy)
580 gfc_defer_symbol_init (sym);
581
582 type = TREE_TYPE (dummy);
6e45f57b 583 gcc_assert (TREE_CODE (dummy) == PARM_DECL
6de9cd9a
DN		 584 && POINTER_TYPE_P (type));
585
f8d0aee5 586 /* Do we know the element size? */
6de9cd9a
DN		 587 known_size = sym->ts.type != BT_CHARACTER
588 || INTEGER_CST_P (sym->ts.cl->backend_decl);
589
590 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
591 {
592 /* For descriptorless arrays with known element size the actual
593 argument is sufficient. */
6e45f57b 594 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 595 gfc_build_qualified_array (dummy, sym);
596 return dummy;
597 }
598
599 type = TREE_TYPE (type);
600 if (GFC_DESCRIPTOR_TYPE_P (type))
601 {
602 /* Create a decriptorless array pointer. */
603 as = sym->as;
604 packed = 0;
605 if (!gfc_option.flag_repack_arrays)
606 {
607 if (as->type == AS_ASSUMED_SIZE)
608 packed = 2;
609 }
610 else
611 {
612 if (as->type == AS_EXPLICIT)
613 {
614 packed = 2;
615 for (n = 0; n < as->rank; n++)
616 {
617 if (!(as->upper[n]
618 && as->lower[n]
619 && as->upper[n]->expr_type == EXPR_CONSTANT
620 && as->lower[n]->expr_type == EXPR_CONSTANT))
621 packed = 1;
622 }
623 }
624 else
625 packed = 1;
626 }
627
628 type = gfc_typenode_for_spec (&sym->ts);
629 type = gfc_get_nodesc_array_type (type, sym->as, packed);
630 }
631 else
632 {
633 /* We now have an expression for the element size, so create a fully
634 qualified type. Reset sym->backend decl or this will just return the
635 old type. */
636 sym->backend_decl = NULL_TREE;
637 type = gfc_sym_type (sym);
638 packed = 2;
639 }
640
641 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
642 decl = build_decl (VAR_DECL, get_identifier (name), type);
643
644 DECL_ARTIFICIAL (decl) = 1;
645 TREE_PUBLIC (decl) = 0;
646 TREE_STATIC (decl) = 0;
647 DECL_EXTERNAL (decl) = 0;
648
649 /* We should never get deferred shape arrays here. We used to because of
650 frontend bugs. */
6e45f57b 651 gcc_assert (sym->as->type != AS_DEFERRED);
6de9cd9a
DN		 652
653 switch (packed)
654 {
655 case 1:
656 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
657 break;
658
659 case 2:
660 GFC_DECL_PACKED_ARRAY (decl) = 1;
661 break;
662 }
663
664 gfc_build_qualified_array (decl, sym);
665
666 if (DECL_LANG_SPECIFIC (dummy))
667 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
668 else
669 gfc_allocate_lang_decl (decl);
670
671 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
672
673 if (sym->ns->proc_name->backend_decl == current_function_decl
674 || sym->attr.contained)
675 gfc_add_decl_to_function (decl);
676 else
677 gfc_add_decl_to_parent_function (decl);
678
679 return decl;
680}
681
682
683/* Return a constant or a variable to use as a string length. Does not
684 add the decl to the current scope. */
685
686static tree
687gfc_create_string_length (gfc_symbol * sym)
688{
689 tree length;
690
6e45f57b 691 gcc_assert (sym->ts.cl);
6de9cd9a
DN		 692 gfc_conv_const_charlen (sym->ts.cl);
693
694 if (sym->ts.cl->backend_decl == NULL_TREE)
695 {
696 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
697
698 /* Also prefix the mangled name. */
699 strcpy (&name[1], sym->name);
700 name[0] = '.';
701 length = build_decl (VAR_DECL, get_identifier (name),
d7177ab2 702 gfc_charlen_type_node);
6de9cd9a
DN		 703 DECL_ARTIFICIAL (length) = 1;
704 TREE_USED (length) = 1;
705 gfc_defer_symbol_init (sym);
706 sym->ts.cl->backend_decl = length;
707 }
708
709 return sym->ts.cl->backend_decl;
710}
711
712
713/* Return the decl for a gfc_symbol, create it if it doesn't already
714 exist. */
715
716tree
717gfc_get_symbol_decl (gfc_symbol * sym)
718{
719 tree decl;
720 tree length = NULL_TREE;
6de9cd9a
DN		 721 int byref;
722
6e45f57b 723 gcc_assert (sym->attr.referenced);
6de9cd9a
DN		 724
725 if (sym->ns && sym->ns->proc_name->attr.function)
726 byref = gfc_return_by_reference (sym->ns->proc_name);
727 else
728 byref = 0;
729
730 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
731 {
732 /* Return via extra parameter. */
733 if (sym->attr.result && byref
734 && !sym->backend_decl)
735 {
736 sym->backend_decl =
737 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
d198b59a
JJ		 738 /* For entry master function skip over the __entry
739 argument. */
740 if (sym->ns->proc_name->attr.entry_master)
741 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
6de9cd9a
DN		 742 }
743
744 /* Dummy variables should already have been created. */
6e45f57b 745 gcc_assert (sym->backend_decl);
6de9cd9a
DN		 746
747 /* Create a character length variable. */
748 if (sym->ts.type == BT_CHARACTER)
749 {
750 if (sym->ts.cl->backend_decl == NULL_TREE)
751 {
752 length = gfc_create_string_length (sym);
753 if (TREE_CODE (length) != INTEGER_CST)
754 {
755 gfc_finish_var_decl (length, sym);
756 gfc_defer_symbol_init (sym);
757 }
758 }
759 }
760
761 /* Use a copy of the descriptor for dummy arrays. */
762 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
763 {
764 sym->backend_decl =
765 gfc_build_dummy_array_decl (sym, sym->backend_decl);
766 }
767
768 TREE_USED (sym->backend_decl) = 1;
769 return sym->backend_decl;
770 }
771
772 if (sym->backend_decl)
773 return sym->backend_decl;
774
6de9cd9a
DN		 775 /* Catch function declarations. Only used for actual parameters. */
776 if (sym->attr.flavor == FL_PROCEDURE)
777 {
778 decl = gfc_get_extern_function_decl (sym);
779 return decl;
780 }
781
782 if (sym->attr.intrinsic)
783 internal_error ("intrinsic variable which isn't a procedure");
784
785 /* Create string length decl first so that they can be used in the
786 type declaration. */
787 if (sym->ts.type == BT_CHARACTER)
788 length = gfc_create_string_length (sym);
789
790 /* Create the decl for the variable. */
791 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
792
c8cc8542
PB		 793 gfc_set_decl_location (decl, &sym->declared_at);
794
f8d0aee5 795 /* Symbols from modules should have their assembler names mangled.
6de9cd9a
DN		 796 This is done here rather than in gfc_finish_var_decl because it
797 is different for string length variables. */
cb9e4f55 798 if (sym->module)
6de9cd9a
DN		 799 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
800
801 if (sym->attr.dimension)
802 {
803 /* Create variables to hold the non-constant bits of array info. */
804 gfc_build_qualified_array (decl, sym);
805
806 /* Remember this variable for allocation/cleanup. */
807 gfc_defer_symbol_init (sym);
808
809 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
810 GFC_DECL_PACKED_ARRAY (decl) = 1;
811 }
812
813 gfc_finish_var_decl (decl, sym);
814
815 if (sym->attr.assign)
816 {
817 gfc_allocate_lang_decl (decl);
818 GFC_DECL_ASSIGN (decl) = 1;
d7177ab2 819 length = gfc_create_var (gfc_charlen_type_node, sym->name);
6de9cd9a
DN		 820 GFC_DECL_STRING_LEN (decl) = length;
821 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
822 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
823 TREE_STATIC (length) = TREE_STATIC (decl);
824 /* STRING_LENGTH is also used as flag. Less than -1 means that
825 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
826 target label's address. Other value is the length of format string
827 and ASSIGN_ADDR is the address of format string. */
7d60be94 828 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
6de9cd9a
DN		 829 }
830
597073ac 831 if (sym->ts.type == BT_CHARACTER)
6de9cd9a 832 {
6de9cd9a
DN		 833 /* Character variables need special handling. */
834 gfc_allocate_lang_decl (decl);
835
597073ac 836 if (TREE_CODE (length) != INTEGER_CST)
6de9cd9a
DN		 837 {
838 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
839
cb9e4f55 840 if (sym->module)
6de9cd9a
DN		 841 {
842 /* Also prefix the mangled name for symbols from modules. */
843 strcpy (&name[1], sym->name);
844 name[0] = '.';
845 strcpy (&name[1],
846 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
847 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
848 }
849 gfc_finish_var_decl (length, sym);
6e45f57b 850 gcc_assert (!sym->value);
6de9cd9a 851 }
6de9cd9a
DN		 852 }
853 sym->backend_decl = decl;
854
597073ac
PB		 855 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
856 {
857 /* Add static initializer. */
858 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
859 TREE_TYPE (decl), sym->attr.dimension,
860 sym->attr.pointer || sym->attr.allocatable);
861 }
862
6de9cd9a
DN		 863 return decl;
864}
865
866
7b5b57b7
PB		 867/* Substitute a temporary variable in place of the real one. */
868
869void
870gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
871{
872 save->attr = sym->attr;
873 save->decl = sym->backend_decl;
874
875 gfc_clear_attr (&sym->attr);
876 sym->attr.referenced = 1;
877 sym->attr.flavor = FL_VARIABLE;
878
879 sym->backend_decl = decl;
880}
881
882
883/* Restore the original variable. */
884
885void
886gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
887{
888 sym->attr = save->attr;
889 sym->backend_decl = save->decl;
890}
891
892
6de9cd9a
DN		 893/* Get a basic decl for an external function. */
894
895tree
896gfc_get_extern_function_decl (gfc_symbol * sym)
897{
898 tree type;
899 tree fndecl;
900 gfc_expr e;
901 gfc_intrinsic_sym *isym;
902 gfc_expr argexpr;
973ff4c0 903 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
6de9cd9a
DN		 904 tree name;
905 tree mangled_name;
906
907 if (sym->backend_decl)
908 return sym->backend_decl;
909
3d79abbd
PB		 910 /* We should never be creating external decls for alternate entry points.
911 The procedure may be an alternate entry point, but we don't want/need
912 to know that. */
6e45f57b 913 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
3d79abbd 914
6de9cd9a
DN		 915 if (sym->attr.intrinsic)
916 {
917 /* Call the resolution function to get the actual name. This is
918 a nasty hack which relies on the resolution functions only looking
919 at the first argument. We pass NULL for the second argument
920 otherwise things like AINT get confused. */
921 isym = gfc_find_function (sym->name);
6e45f57b 922 gcc_assert (isym->resolve.f0 != NULL);
6de9cd9a
DN		 923
924 memset (&e, 0, sizeof (e));
925 e.expr_type = EXPR_FUNCTION;
926
927 memset (&argexpr, 0, sizeof (argexpr));
6e45f57b 928 gcc_assert (isym->formal);
6de9cd9a
DN		 929 argexpr.ts = isym->formal->ts;
930
931 if (isym->formal->next == NULL)
932 isym->resolve.f1 (&e, &argexpr);
933 else
934 {
935 /* All specific intrinsics take one or two arguments. */
6e45f57b 936 gcc_assert (isym->formal->next->next == NULL);
6de9cd9a
DN		 937 isym->resolve.f2 (&e, &argexpr, NULL);
938 }
973ff4c0
TS		 939
940 if (gfc_option.flag_f2c
941 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
942 || e.ts.type == BT_COMPLEX))
943 {
944 /* Specific which needs a different implementation if f2c
945 calling conventions are used. */
946 sprintf (s, "f2c_specific%s", e.value.function.name);
947 }
948 else
949 sprintf (s, "specific%s", e.value.function.name);
950
6de9cd9a
DN		 951 name = get_identifier (s);
952 mangled_name = name;
953 }
954 else
955 {
956 name = gfc_sym_identifier (sym);
957 mangled_name = gfc_sym_mangled_function_id (sym);
958 }
959
960 type = gfc_get_function_type (sym);
961 fndecl = build_decl (FUNCTION_DECL, name, type);
962
963 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
964 /* If the return type is a pointer, avoid alias issues by setting
965 DECL_IS_MALLOC to nonzero. This means that the function should be
966 treated as if it were a malloc, meaning it returns a pointer that
967 is not an alias. */
968 if (POINTER_TYPE_P (type))
969 DECL_IS_MALLOC (fndecl) = 1;
970
971 /* Set the context of this decl. */
972 if (0 && sym->ns && sym->ns->proc_name)
973 {
974 /* TODO: Add external decls to the appropriate scope. */
975 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
976 }
977 else
978 {
f8d0aee5 979 /* Global declaration, e.g. intrinsic subroutine. */
6de9cd9a
DN		 980 DECL_CONTEXT (fndecl) = NULL_TREE;
981 }
982
983 DECL_EXTERNAL (fndecl) = 1;
984
f8d0aee5 985 /* This specifies if a function is globally addressable, i.e. it is
6de9cd9a
DN		 986 the opposite of declaring static in C. */
987 TREE_PUBLIC (fndecl) = 1;
988
989 /* Set attributes for PURE functions. A call to PURE function in the
990 Fortran 95 sense is both pure and without side effects in the C
991 sense. */
992 if (sym->attr.pure || sym->attr.elemental)
993 {
b7e6a6b3
TS		 994 if (sym->attr.function)
995 DECL_IS_PURE (fndecl) = 1;
996 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
997 parameters and don't use alternate returns (is this
998 allowed?). In that case, calls to them are meaningless, and
3d79abbd 999 can be optimized away. See also in build_function_decl(). */
b7e6a6b3 1000 TREE_SIDE_EFFECTS (fndecl) = 0;
6de9cd9a
DN		 1001 }
1002
1003 sym->backend_decl = fndecl;
1004
1005 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1006 pushdecl_top_level (fndecl);
1007
1008 return fndecl;
1009}
1010
1011
1012/* Create a declaration for a procedure. For external functions (in the C
3d79abbd
PB		 1013 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1014 a master function with alternate entry points. */
6de9cd9a 1015
3d79abbd
PB		 1016static void
1017build_function_decl (gfc_symbol * sym)
6de9cd9a 1018{
3d79abbd 1019 tree fndecl, type;
6de9cd9a 1020 symbol_attribute attr;
3d79abbd 1021 tree result_decl;
6de9cd9a
DN		 1022 gfc_formal_arglist *f;
1023
6e45f57b
PB		 1024 gcc_assert (!sym->backend_decl);
1025 gcc_assert (!sym->attr.external);
6de9cd9a 1026
c8cc8542
PB		 1027 /* Set the line and filename. sym->declared_at seems to point to the
1028 last statement for subroutines, but it'll do for now. */
1029 gfc_set_backend_locus (&sym->declared_at);
1030
6de9cd9a 1031 /* Allow only one nesting level. Allow public declarations. */
6e45f57b 1032 gcc_assert (current_function_decl == NULL_TREE
6de9cd9a
DN		 1033 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1034
1035 type = gfc_get_function_type (sym);
1036 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1037
1038 /* Perform name mangling if this is a top level or module procedure. */
1039 if (current_function_decl == NULL_TREE)
1040 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1041
1042 /* Figure out the return type of the declared function, and build a
f8d0aee5 1043 RESULT_DECL for it. If this is a subroutine with alternate
6de9cd9a
DN		 1044 returns, build a RESULT_DECL for it. */
1045 attr = sym->attr;
1046
1047 result_decl = NULL_TREE;
1048 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1049 if (attr.function)
1050 {
1051 if (gfc_return_by_reference (sym))
1052 type = void_type_node;
1053 else
1054 {
1055 if (sym->result != sym)
1056 result_decl = gfc_sym_identifier (sym->result);
1057
1058 type = TREE_TYPE (TREE_TYPE (fndecl));
1059 }
1060 }
1061 else
1062 {
1063 /* Look for alternate return placeholders. */
1064 int has_alternate_returns = 0;
1065 for (f = sym->formal; f; f = f->next)
1066 {
1067 if (f->sym == NULL)
1068 {
1069 has_alternate_returns = 1;
1070 break;
1071 }
1072 }
1073
1074 if (has_alternate_returns)
1075 type = integer_type_node;
1076 else
1077 type = void_type_node;
1078 }
1079
1080 result_decl = build_decl (RESULT_DECL, result_decl, type);
b785f485
RH		 1081 DECL_ARTIFICIAL (result_decl) = 1;
1082 DECL_IGNORED_P (result_decl) = 1;
6de9cd9a
DN		 1083 DECL_CONTEXT (result_decl) = fndecl;
1084 DECL_RESULT (fndecl) = result_decl;
1085
1086 /* Don't call layout_decl for a RESULT_DECL.
f8d0aee5 1087 layout_decl (result_decl, 0); */
6de9cd9a
DN		 1088
1089 /* If the return type is a pointer, avoid alias issues by setting
1090 DECL_IS_MALLOC to nonzero. This means that the function should be
1091 treated as if it were a malloc, meaning it returns a pointer that
1092 is not an alias. */
1093 if (POINTER_TYPE_P (type))
1094 DECL_IS_MALLOC (fndecl) = 1;
1095
1096 /* Set up all attributes for the function. */
1097 DECL_CONTEXT (fndecl) = current_function_decl;
1098 DECL_EXTERNAL (fndecl) = 0;
1099
ae51017b 1100 /* This specifies if a function is globally visible, i.e. it is
472ca416 1101 the opposite of declaring static in C. */
3d79abbd
PB		 1102 if (DECL_CONTEXT (fndecl) == NULL_TREE
1103 && !sym->attr.entry_master)
6de9cd9a
DN		 1104 TREE_PUBLIC (fndecl) = 1;
1105
1106 /* TREE_STATIC means the function body is defined here. */
1d754240 1107 TREE_STATIC (fndecl) = 1;
6de9cd9a 1108
f8d0aee5 1109 /* Set attributes for PURE functions. A call to a PURE function in the
6de9cd9a
DN		 1110 Fortran 95 sense is both pure and without side effects in the C
1111 sense. */
1112 if (attr.pure || attr.elemental)
1113 {
b7e6a6b3
TS		 1114 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1115 including a alternate return. In that case it can also be
1f2959f0 1116 marked as PURE. See also in gfc_get_extern_function_decl(). */
b7e6a6b3
TS		 1117 if (attr.function)
1118 DECL_IS_PURE (fndecl) = 1;
6de9cd9a
DN		 1119 TREE_SIDE_EFFECTS (fndecl) = 0;
1120 }
1121
1122 /* Layout the function declaration and put it in the binding level
1123 of the current function. */
1d754240 1124 pushdecl (fndecl);
3d79abbd
PB		 1125
1126 sym->backend_decl = fndecl;
1127}
1128
1129
1130/* Create the DECL_ARGUMENTS for a procedure. */
1131
1132static void
1133create_function_arglist (gfc_symbol * sym)
1134{
1135 tree fndecl;
1136 gfc_formal_arglist *f;
1137 tree typelist;
1138 tree arglist;
1139 tree length;
1140 tree type;
1141 tree parm;
1142
1143 fndecl = sym->backend_decl;
1144
1d754240
PB		 1145 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1146 the new FUNCTION_DECL node. */
1d754240
PB		 1147 arglist = NULL_TREE;
1148 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
3d79abbd
PB		 1149
1150 if (sym->attr.entry_master)
1151 {
1152 type = TREE_VALUE (typelist);
1153 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1154
1155 DECL_CONTEXT (parm) = fndecl;
1156 DECL_ARG_TYPE (parm) = type;
1157 TREE_READONLY (parm) = 1;
1158 gfc_finish_decl (parm, NULL_TREE);
1159
1160 arglist = chainon (arglist, parm);
1161 typelist = TREE_CHAIN (typelist);
1162 }
1163
1d754240 1164 if (gfc_return_by_reference (sym))
6de9cd9a 1165 {
1d754240
PB		 1166 type = TREE_VALUE (typelist);
1167 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
6de9cd9a 1168
1d754240
PB		 1169 DECL_CONTEXT (parm) = fndecl;
1170 DECL_ARG_TYPE (parm) = type;
1171 TREE_READONLY (parm) = 1;
ca0e9281 1172 DECL_ARTIFICIAL (parm) = 1;
1d754240 1173 gfc_finish_decl (parm, NULL_TREE);
6de9cd9a 1174
1d754240
PB		 1175 arglist = chainon (arglist, parm);
1176 typelist = TREE_CHAIN (typelist);
6de9cd9a 1177
1d754240
PB		 1178 if (sym->ts.type == BT_CHARACTER)
1179 {
1180 gfc_allocate_lang_decl (parm);
6de9cd9a 1181
1d754240
PB		 1182 /* Length of character result. */
1183 type = TREE_VALUE (typelist);
6e45f57b 1184 gcc_assert (type == gfc_charlen_type_node);
6de9cd9a 1185
1d754240
PB		 1186 length = build_decl (PARM_DECL,
1187 get_identifier (".__result"),
1188 type);
1189 if (!sym->ts.cl->length)
1190 {
1191 sym->ts.cl->backend_decl = length;
1192 TREE_USED (length) = 1;
6de9cd9a 1193 }
6e45f57b 1194 gcc_assert (TREE_CODE (length) == PARM_DECL);
1d754240
PB		 1195 arglist = chainon (arglist, length);
1196 typelist = TREE_CHAIN (typelist);
1197 DECL_CONTEXT (length) = fndecl;
1198 DECL_ARG_TYPE (length) = type;
1199 TREE_READONLY (length) = 1;
ca0e9281 1200 DECL_ARTIFICIAL (length) = 1;
1d754240 1201 gfc_finish_decl (length, NULL_TREE);
6de9cd9a 1202 }
1d754240 1203 }
6de9cd9a 1204
1d754240
PB		 1205 for (f = sym->formal; f; f = f->next)
1206 {
f8d0aee5 1207 if (f->sym != NULL) /* ignore alternate returns. */
6de9cd9a 1208 {
1d754240 1209 length = NULL_TREE;
6de9cd9a 1210
1d754240 1211 type = TREE_VALUE (typelist);
6de9cd9a 1212
1d754240
PB		 1213 /* Build a the argument declaration. */
1214 parm = build_decl (PARM_DECL,
1215 gfc_sym_identifier (f->sym), type);
6de9cd9a 1216
1d754240
PB		 1217 /* Fill in arg stuff. */
1218 DECL_CONTEXT (parm) = fndecl;
1219 DECL_ARG_TYPE (parm) = type;
1220 DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1221 /* All implementation args are read-only. */
1222 TREE_READONLY (parm) = 1;
6de9cd9a 1223
1d754240 1224 gfc_finish_decl (parm, NULL_TREE);
6de9cd9a 1225
1d754240 1226 f->sym->backend_decl = parm;
6de9cd9a 1227
1d754240
PB		 1228 arglist = chainon (arglist, parm);
1229 typelist = TREE_CHAIN (typelist);
1230 }
1231 }
6de9cd9a 1232
1d754240
PB		 1233 /* Add the hidden string length parameters. */
1234 parm = arglist;
1235 for (f = sym->formal; f; f = f->next)
1236 {
1237 char name[GFC_MAX_SYMBOL_LEN + 2];
1238 /* Ignore alternate returns. */
1239 if (f->sym == NULL)
1240 continue;
6de9cd9a 1241
1d754240
PB		 1242 if (f->sym->ts.type != BT_CHARACTER)
1243 continue;
6de9cd9a 1244
1d754240
PB		 1245 parm = f->sym->backend_decl;
1246 type = TREE_VALUE (typelist);
6e45f57b 1247 gcc_assert (type == gfc_charlen_type_node);
6de9cd9a 1248
1d754240
PB		 1249 strcpy (&name[1], f->sym->name);
1250 name[0] = '_';
1251 length = build_decl (PARM_DECL, get_identifier (name), type);
6de9cd9a 1252
1d754240
PB		 1253 arglist = chainon (arglist, length);
1254 DECL_CONTEXT (length) = fndecl;
ca0e9281 1255 DECL_ARTIFICIAL (length) = 1;
1d754240
PB		 1256 DECL_ARG_TYPE (length) = type;
1257 TREE_READONLY (length) = 1;
1258 gfc_finish_decl (length, NULL_TREE);
6de9cd9a 1259
1d754240 1260 /* TODO: Check string lengths when -fbounds-check. */
6de9cd9a 1261
1d754240
PB		 1262 /* Use the passed value for assumed length variables. */
1263 if (!f->sym->ts.cl->length)
1264 {
1265 TREE_USED (length) = 1;
1266 if (!f->sym->ts.cl->backend_decl)
1267 f->sym->ts.cl->backend_decl = length;
1268 else
6de9cd9a 1269 {
1d754240
PB		 1270 /* there is already another variable using this
1271 gfc_charlen node, build a new one for this variable
1272 and chain it into the list of gfc_charlens.
1273 This happens for e.g. in the case
1274 CHARACTER(*)::c1,c2
1275 since CHARACTER declarations on the same line share
1276 the same gfc_charlen node. */
1277 gfc_charlen *cl;
1278
1279 cl = gfc_get_charlen ();
1280 cl->backend_decl = length;
1281 cl->next = f->sym->ts.cl->next;
1282 f->sym->ts.cl->next = cl;
1283 f->sym->ts.cl = cl;
6de9cd9a 1284 }
6de9cd9a
DN		 1285 }
1286
1d754240
PB		 1287 parm = TREE_CHAIN (parm);
1288 typelist = TREE_CHAIN (typelist);
6de9cd9a 1289 }
1d754240 1290
6e45f57b 1291 gcc_assert (TREE_VALUE (typelist) == void_type_node);
1d754240 1292 DECL_ARGUMENTS (fndecl) = arglist;
3d79abbd 1293}
1d754240 1294
3d79abbd
PB		 1295/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1296
1297static void
1298gfc_gimplify_function (tree fndecl)
1299{
1300 struct cgraph_node *cgn;
1301
1302 gimplify_function_tree (fndecl);
1303 dump_function (TDI_generic, fndecl);
1304
1305 /* Convert all nested functions to GIMPLE now. We do things in this order
1306 so that items like VLA sizes are expanded properly in the context of the
1307 correct function. */
1308 cgn = cgraph_node (fndecl);
1309 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1310 gfc_gimplify_function (cgn->decl);
1311}
1312
1313
1314/* Do the setup necessary before generating the body of a function. */
1315
1316static void
1317trans_function_start (gfc_symbol * sym)
1318{
1319 tree fndecl;
1320
1321 fndecl = sym->backend_decl;
1322
f8d0aee5 1323 /* Let GCC know the current scope is this function. */
3d79abbd
PB		 1324 current_function_decl = fndecl;
1325
f8d0aee5 1326 /* Let the world know what we're about to do. */
3d79abbd
PB		 1327 announce_function (fndecl);
1328
1329 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1330 {
f8d0aee5 1331 /* Create RTL for function declaration. */
3d79abbd
PB		 1332 rest_of_decl_compilation (fndecl, 1, 0);
1333 }
1334
f8d0aee5 1335 /* Create RTL for function definition. */
3d79abbd
PB		 1336 make_decl_rtl (fndecl);
1337
3d79abbd
PB		 1338 init_function_start (fndecl);
1339
1340 /* Even though we're inside a function body, we still don't want to
1341 call expand_expr to calculate the size of a variable-sized array.
1342 We haven't necessarily assigned RTL to all variables yet, so it's
1343 not safe to try to expand expressions involving them. */
1344 cfun->x_dont_save_pending_sizes_p = 1;
1345
f8d0aee5 1346 /* function.c requires a push at the start of the function. */
3d79abbd
PB		 1347 pushlevel (0);
1348}
1349
1350/* Create thunks for alternate entry points. */
1351
1352static void
1353build_entry_thunks (gfc_namespace * ns)
1354{
1355 gfc_formal_arglist *formal;
1356 gfc_formal_arglist *thunk_formal;
1357 gfc_entry_list *el;
1358 gfc_symbol *thunk_sym;
1359 stmtblock_t body;
1360 tree thunk_fndecl;
1361 tree args;
1362 tree string_args;
1363 tree tmp;
c8cc8542 1364 locus old_loc;
3d79abbd
PB		 1365
1366 /* This should always be a toplevel function. */
6e45f57b 1367 gcc_assert (current_function_decl == NULL_TREE);
3d79abbd 1368
c8cc8542 1369 gfc_get_backend_locus (&old_loc);
3d79abbd
PB		 1370 for (el = ns->entries; el; el = el->next)
1371 {
1372 thunk_sym = el->sym;
1373
1374 build_function_decl (thunk_sym);
1375 create_function_arglist (thunk_sym);
1376
1377 trans_function_start (thunk_sym);
1378
1379 thunk_fndecl = thunk_sym->backend_decl;
1380
1381 gfc_start_block (&body);
1382
f8d0aee5 1383 /* Pass extra parameter identifying this entry point. */
7d60be94 1384 tmp = build_int_cst (gfc_array_index_type, el->id);
3d79abbd
PB		 1385 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1386 string_args = NULL_TREE;
1387
d198b59a
JJ		 1388 if (thunk_sym->attr.function)
1389 {
1390 if (gfc_return_by_reference (ns->proc_name))
1391 {
1392 tree ref = DECL_ARGUMENTS (current_function_decl);
1393 args = tree_cons (NULL_TREE, ref, args);
1394 if (ns->proc_name->ts.type == BT_CHARACTER)
1395 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1396 args);
1397 }
1398 }
1399
3d79abbd
PB		 1400 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1401 {
d198b59a
JJ		 1402 /* Ignore alternate returns. */
1403 if (formal->sym == NULL)
1404 continue;
1405
3d79abbd
PB		 1406 /* We don't have a clever way of identifying arguments, so resort to
1407 a brute-force search. */
1408 for (thunk_formal = thunk_sym->formal;
1409 thunk_formal;
1410 thunk_formal = thunk_formal->next)
1411 {
1412 if (thunk_formal->sym == formal->sym)
1413 break;
1414 }
1415
1416 if (thunk_formal)
1417 {
1418 /* Pass the argument. */
1419 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1420 args);
1421 if (formal->sym->ts.type == BT_CHARACTER)
1422 {
1423 tmp = thunk_formal->sym->ts.cl->backend_decl;
1424 string_args = tree_cons (NULL_TREE, tmp, string_args);
1425 }
1426 }
1427 else
1428 {
1429 /* Pass NULL for a missing argument. */
1430 args = tree_cons (NULL_TREE, null_pointer_node, args);
1431 if (formal->sym->ts.type == BT_CHARACTER)
1432 {
d7177ab2 1433 tmp = convert (gfc_charlen_type_node, integer_zero_node);
3d79abbd
PB		 1434 string_args = tree_cons (NULL_TREE, tmp, string_args);
1435 }
1436 }
1437 }
1438
1439 /* Call the master function. */
1440 args = nreverse (args);
1441 args = chainon (args, nreverse (string_args));
1442 tmp = ns->proc_name->backend_decl;
1443 tmp = gfc_build_function_call (tmp, args);
d198b59a
JJ		 1444 if (ns->proc_name->attr.mixed_entry_master)
1445 {
1446 tree union_decl, field;
1447 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1448
1449 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1450 TREE_TYPE (master_type));
1451 DECL_ARTIFICIAL (union_decl) = 1;
1452 DECL_EXTERNAL (union_decl) = 0;
1453 TREE_PUBLIC (union_decl) = 0;
1454 TREE_USED (union_decl) = 1;
1455 layout_decl (union_decl, 0);
1456 pushdecl (union_decl);
1457
1458 DECL_CONTEXT (union_decl) = current_function_decl;
1459 tmp = build2 (MODIFY_EXPR,
1460 TREE_TYPE (union_decl),
1461 union_decl, tmp);
1462 gfc_add_expr_to_block (&body, tmp);
1463
1464 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1465 field; field = TREE_CHAIN (field))
1466 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1467 thunk_sym->result->name) == 0)
1468 break;
1469 gcc_assert (field != NULL_TREE);
1470 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1471 NULL_TREE);
1472 tmp = build2 (MODIFY_EXPR,
1473 TREE_TYPE (DECL_RESULT (current_function_decl)),
1474 DECL_RESULT (current_function_decl), tmp);
1475 tmp = build1_v (RETURN_EXPR, tmp);
1476 }
1477 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1478 != void_type_node)
1479 {
1480 tmp = build2 (MODIFY_EXPR,
1481 TREE_TYPE (DECL_RESULT (current_function_decl)),
1482 DECL_RESULT (current_function_decl), tmp);
1483 tmp = build1_v (RETURN_EXPR, tmp);
1484 }
3d79abbd
PB		 1485 gfc_add_expr_to_block (&body, tmp);
1486
1487 /* Finish off this function and send it for code generation. */
1488 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1489 poplevel (1, 0, 1);
1490 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1491
1492 /* Output the GENERIC tree. */
1493 dump_function (TDI_original, thunk_fndecl);
1494
1495 /* Store the end of the function, so that we get good line number
1496 info for the epilogue. */
1497 cfun->function_end_locus = input_location;
1498
1499 /* We're leaving the context of this function, so zap cfun.
1500 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1501 tree_rest_of_compilation. */
1502 cfun = NULL;
1503
1504 current_function_decl = NULL_TREE;
1505
1506 gfc_gimplify_function (thunk_fndecl);
8f235343 1507 cgraph_finalize_function (thunk_fndecl, false);
3d79abbd
PB		 1508
1509 /* We share the symbols in the formal argument list with other entry
1510 points and the master function. Clear them so that they are
1511 recreated for each function. */
1512 for (formal = thunk_sym->formal; formal; formal = formal->next)
d198b59a
JJ		 1513 if (formal->sym != NULL) /* Ignore alternate returns. */
1514 {
1515 formal->sym->backend_decl = NULL_TREE;
1516 if (formal->sym->ts.type == BT_CHARACTER)
1517 formal->sym->ts.cl->backend_decl = NULL_TREE;
1518 }
1519
1520 if (thunk_sym->attr.function)
3d79abbd 1521 {
d198b59a
JJ		 1522 if (thunk_sym->ts.type == BT_CHARACTER)
1523 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1524 if (thunk_sym->result->ts.type == BT_CHARACTER)
1525 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
3d79abbd
PB		 1526 }
1527 }
c8cc8542
PB		 1528
1529 gfc_set_backend_locus (&old_loc);
3d79abbd
PB		 1530}
1531
1532
1533/* Create a decl for a function, and create any thunks for alternate entry
1534 points. */
1535
1536void
1537gfc_create_function_decl (gfc_namespace * ns)
1538{
1539 /* Create a declaration for the master function. */
1540 build_function_decl (ns->proc_name);
1541
f8d0aee5 1542 /* Compile the entry thunks. */
3d79abbd
PB		 1543 if (ns->entries)
1544 build_entry_thunks (ns);
1545
1546 /* Now create the read argument list. */
1547 create_function_arglist (ns->proc_name);
1548}
1549
6de9cd9a
DN		 1550/* Return the decl used to hold the function return value. */
1551
1552tree
1553gfc_get_fake_result_decl (gfc_symbol * sym)
1554{
1555 tree decl;
1556 tree length;
1557
1558 char name[GFC_MAX_SYMBOL_LEN + 10];
1559
d198b59a
JJ		 1560 if (sym
1561 && sym->ns->proc_name->backend_decl == current_function_decl
1562 && sym->ns->proc_name->attr.mixed_entry_master
1563 && sym != sym->ns->proc_name)
1564 {
1565 decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1566 if (decl)
1567 {
1568 tree field;
1569
1570 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1571 field; field = TREE_CHAIN (field))
1572 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1573 sym->name) == 0)
1574 break;
1575
1576 gcc_assert (field != NULL_TREE);
1577 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1578 NULL_TREE);
1579 }
1580 return decl;
1581 }
1582
6de9cd9a
DN		 1583 if (current_fake_result_decl != NULL_TREE)
1584 return current_fake_result_decl;
1585
1586 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1587 sym is NULL. */
1588 if (!sym)
1589 return NULL_TREE;
1590
1591 if (sym->ts.type == BT_CHARACTER
1592 && !sym->ts.cl->backend_decl)
1593 {
1594 length = gfc_create_string_length (sym);
1595 gfc_finish_var_decl (length, sym);
1596 }
1597
1598 if (gfc_return_by_reference (sym))
1599 {
d198b59a
JJ		 1600 decl = DECL_ARGUMENTS (current_function_decl);
1601
1602 if (sym->ns->proc_name->backend_decl == current_function_decl
1603 && sym->ns->proc_name->attr.entry_master)
1604 decl = TREE_CHAIN (decl);
6de9cd9a
DN		 1605
1606 TREE_USED (decl) = 1;
1607 if (sym->as)
1608 decl = gfc_build_dummy_array_decl (sym, decl);
1609 }
1610 else
1611 {
1612 sprintf (name, "__result_%.20s",
1613 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1614
1615 decl = build_decl (VAR_DECL, get_identifier (name),
1616 TREE_TYPE (TREE_TYPE (current_function_decl)));
1617
1618 DECL_ARTIFICIAL (decl) = 1;
1619 DECL_EXTERNAL (decl) = 0;
1620 TREE_PUBLIC (decl) = 0;
1621 TREE_USED (decl) = 1;
1622
1623 layout_decl (decl, 0);
1624
1625 gfc_add_decl_to_function (decl);
1626 }
1627
1628 current_fake_result_decl = decl;
1629
1630 return decl;
1631}
1632
1633
1634/* Builds a function decl. The remaining parameters are the types of the
1635 function arguments. Negative nargs indicates a varargs function. */
1636
1637tree
1638gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1639{
1640 tree arglist;
1641 tree argtype;
1642 tree fntype;
1643 tree fndecl;
1644 va_list p;
1645 int n;
1646
1647 /* Library functions must be declared with global scope. */
6e45f57b 1648 gcc_assert (current_function_decl == NULL_TREE);
6de9cd9a
DN		 1649
1650 va_start (p, nargs);
1651
1652
1653 /* Create a list of the argument types. */
1654 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1655 {
1656 argtype = va_arg (p, tree);
1657 arglist = gfc_chainon_list (arglist, argtype);
1658 }
1659
1660 if (nargs >= 0)
1661 {
1662 /* Terminate the list. */
1663 arglist = gfc_chainon_list (arglist, void_type_node);
1664 }
1665
1666 /* Build the function type and decl. */
1667 fntype = build_function_type (rettype, arglist);
1668 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1669
1670 /* Mark this decl as external. */
1671 DECL_EXTERNAL (fndecl) = 1;
1672 TREE_PUBLIC (fndecl) = 1;
1673
1674 va_end (p);
1675
1676 pushdecl (fndecl);
1677
0e6df31e 1678 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a
DN		 1679
1680 return fndecl;
1681}
1682
1683static void
1684gfc_build_intrinsic_function_decls (void)
1685{
e2cad04b
RH		 1686 tree gfc_int4_type_node = gfc_get_int_type (4);
1687 tree gfc_int8_type_node = gfc_get_int_type (8);
1688 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1689 tree gfc_real4_type_node = gfc_get_real_type (4);
1690 tree gfc_real8_type_node = gfc_get_real_type (8);
1691 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1692 tree gfc_complex8_type_node = gfc_get_complex_type (8);
1693
6de9cd9a
DN		 1694 /* String functions. */
1695 gfor_fndecl_copy_string =
1696 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1697 void_type_node,
1698 4,
d7177ab2
TS		 1699 gfc_charlen_type_node, pchar_type_node,
1700 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1701
1702 gfor_fndecl_compare_string =
1703 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1704 gfc_int4_type_node,
1705 4,
d7177ab2
TS		 1706 gfc_charlen_type_node, pchar_type_node,
1707 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1708
1709 gfor_fndecl_concat_string =
1710 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1711 void_type_node,
1712 6,
d7177ab2
TS		 1713 gfc_charlen_type_node, pchar_type_node,
1714 gfc_charlen_type_node, pchar_type_node,
1715 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1716
1717 gfor_fndecl_string_len_trim =
1718 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1719 gfc_int4_type_node,
d7177ab2 1720 2, gfc_charlen_type_node,
6de9cd9a
DN		 1721 pchar_type_node);
1722
1723 gfor_fndecl_string_index =
1724 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1725 gfc_int4_type_node,
d7177ab2
TS		 1726 5, gfc_charlen_type_node, pchar_type_node,
1727 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1728 gfc_logical4_type_node);
1729
1730 gfor_fndecl_string_scan =
1731 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1732 gfc_int4_type_node,
d7177ab2
TS		 1733 5, gfc_charlen_type_node, pchar_type_node,
1734 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1735 gfc_logical4_type_node);
1736
1737 gfor_fndecl_string_verify =
1738 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1739 gfc_int4_type_node,
d7177ab2
TS		 1740 5, gfc_charlen_type_node, pchar_type_node,
1741 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1742 gfc_logical4_type_node);
1743
1744 gfor_fndecl_string_trim =
1745 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1746 void_type_node,
1747 4,
d7177ab2 1748 build_pointer_type (gfc_charlen_type_node),
6de9cd9a 1749 ppvoid_type_node,
d7177ab2 1750 gfc_charlen_type_node,
6de9cd9a
DN		 1751 pchar_type_node);
1752
1753 gfor_fndecl_string_repeat =
1754 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1755 void_type_node,
1756 4,
1757 pchar_type_node,
d7177ab2 1758 gfc_charlen_type_node,
6de9cd9a
DN		 1759 pchar_type_node,
1760 gfc_int4_type_node);
1761
1762 gfor_fndecl_adjustl =
1763 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1764 void_type_node,
1765 3,
1766 pchar_type_node,
d7177ab2 1767 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1768
1769 gfor_fndecl_adjustr =
1770 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1771 void_type_node,
1772 3,
1773 pchar_type_node,
d7177ab2 1774 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1775
1776 gfor_fndecl_si_kind =
1777 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1778 gfc_int4_type_node,
1779 1,
1780 pvoid_type_node);
1781
1782 gfor_fndecl_sr_kind =
1783 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1784 gfc_int4_type_node,
1785 2, pvoid_type_node,
1786 pvoid_type_node);
1787
6de9cd9a 1788 /* Power functions. */
5b200ac2
FW		 1789 {
1790 tree type;
1791 tree itype;
1792 int kind;
1793 int ikind;
1794 static int kinds[2] = {4, 8};
1795 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1796
1797 for (ikind=0; ikind < 2; ikind++)
1798 {
1799 itype = gfc_get_int_type (kinds[ikind]);
1800 for (kind = 0; kind < 2; kind ++)
1801 {
1802 type = gfc_get_int_type (kinds[kind]);
1803 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1804 gfor_fndecl_math_powi[kind][ikind].integer =
1805 gfc_build_library_function_decl (get_identifier (name),
1806 type, 2, type, itype);
1807
1808 type = gfc_get_real_type (kinds[kind]);
1809 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1810 gfor_fndecl_math_powi[kind][ikind].real =
1811 gfc_build_library_function_decl (get_identifier (name),
1812 type, 2, type, itype);
1813
1814 type = gfc_get_complex_type (kinds[kind]);
1815 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1816 gfor_fndecl_math_powi[kind][ikind].cmplx =
1817 gfc_build_library_function_decl (get_identifier (name),
1818 type, 2, type, itype);
1819 }
1820 }
1821 }
1822
6de9cd9a
DN		 1823 gfor_fndecl_math_cpowf =
1824 gfc_build_library_function_decl (get_identifier ("cpowf"),
1825 gfc_complex4_type_node,
1826 1, gfc_complex4_type_node);
1827 gfor_fndecl_math_cpow =
1828 gfc_build_library_function_decl (get_identifier ("cpow"),
1829 gfc_complex8_type_node,
1830 1, gfc_complex8_type_node);
6de9cd9a
DN		 1831 gfor_fndecl_math_ishftc4 =
1832 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1833 gfc_int4_type_node,
1834 3, gfc_int4_type_node,
1835 gfc_int4_type_node, gfc_int4_type_node);
1836 gfor_fndecl_math_ishftc8 =
1837 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1838 gfc_int8_type_node,
1839 3, gfc_int8_type_node,
1840 gfc_int8_type_node, gfc_int8_type_node);
1841 gfor_fndecl_math_exponent4 =
1842 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1843 gfc_int4_type_node,
1844 1, gfc_real4_type_node);
1845 gfor_fndecl_math_exponent8 =
1846 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1847 gfc_int4_type_node,
1848 1, gfc_real8_type_node);
1849
1850 /* Other functions. */
1851 gfor_fndecl_size0 =
1852 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1853 gfc_array_index_type,
1854 1, pvoid_type_node);
1855 gfor_fndecl_size1 =
1856 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1857 gfc_array_index_type,
1858 2, pvoid_type_node,
1859 gfc_array_index_type);
b41b2534
JB		 1860
1861 gfor_fndecl_iargc =
1862 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1863 gfc_int4_type_node,
1864 0);
6de9cd9a
DN		 1865}
1866
1867
1868/* Make prototypes for runtime library functions. */
1869
1870void
1871gfc_build_builtin_function_decls (void)
1872{
e2cad04b
RH		 1873 tree gfc_int4_type_node = gfc_get_int_type (4);
1874 tree gfc_int8_type_node = gfc_get_int_type (8);
1875 tree gfc_logical4_type_node = gfc_get_logical_type (4);
364667a1 1876 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
e2cad04b 1877
6de9cd9a
DN		 1878 gfor_fndecl_internal_malloc =
1879 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1880 pvoid_type_node, 1, gfc_int4_type_node);
1881
1882 gfor_fndecl_internal_malloc64 =
1883 gfc_build_library_function_decl (get_identifier
1884 (PREFIX("internal_malloc64")),
1885 pvoid_type_node, 1, gfc_int8_type_node);
1886
1887 gfor_fndecl_internal_free =
1888 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1889 void_type_node, 1, pvoid_type_node);
1890
1891 gfor_fndecl_allocate =
1892 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1893 void_type_node, 2, ppvoid_type_node,
1894 gfc_int4_type_node);
1895
1896 gfor_fndecl_allocate64 =
1897 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1898 void_type_node, 2, ppvoid_type_node,
1899 gfc_int8_type_node);
1900
1901 gfor_fndecl_deallocate =
1902 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
364667a1
SK		 1903 void_type_node, 2, ppvoid_type_node,
1904 gfc_pint4_type_node);
6de9cd9a
DN		 1905
1906 gfor_fndecl_stop_numeric =
1907 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1908 void_type_node, 1, gfc_int4_type_node);
1909
1910 gfor_fndecl_stop_string =
1911 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1912 void_type_node, 2, pchar_type_node,
1913 gfc_int4_type_node);
1914
1915 gfor_fndecl_pause_numeric =
1916 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1917 void_type_node, 1, gfc_int4_type_node);
1918
1919 gfor_fndecl_pause_string =
1920 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1921 void_type_node, 2, pchar_type_node,
1922 gfc_int4_type_node);
1923
1924 gfor_fndecl_select_string =
1925 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1926 pvoid_type_node, 0);
1927
1928 gfor_fndecl_runtime_error =
1929 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1930 void_type_node,
1931 3,
1932 pchar_type_node, pchar_type_node,
1933 gfc_int4_type_node);
1934
1935 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1936 get_identifier (PREFIX("internal_pack")),
1937 pvoid_type_node, 1, pvoid_type_node);
1938
1939 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1940 get_identifier (PREFIX("internal_unpack")),
1941 pvoid_type_node, 1, pvoid_type_node);
1942
1943 gfor_fndecl_associated =
1944 gfc_build_library_function_decl (
1945 get_identifier (PREFIX("associated")),
1946 gfc_logical4_type_node,
1947 2,
1948 ppvoid_type_node,
1949 ppvoid_type_node);
1950
1951 gfc_build_intrinsic_function_decls ();
1952 gfc_build_intrinsic_lib_fndecls ();
1953 gfc_build_io_library_fndecls ();
1954}
1955
1956
1f2959f0 1957/* Evaluate the length of dummy character variables. */
6de9cd9a
DN		 1958
1959static tree
1960gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1961{
1962 stmtblock_t body;
1963
1964 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1965
1966 gfc_start_block (&body);
1967
1968 /* Evaluate the string length expression. */
1969 gfc_trans_init_string_length (cl, &body);
1970
1971 gfc_add_expr_to_block (&body, fnbody);
1972 return gfc_finish_block (&body);
1973}
1974
1975
1976/* Allocate and cleanup an automatic character variable. */
1977
1978static tree
1979gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1980{
1981 stmtblock_t body;
1982 tree decl;
6de9cd9a
DN		 1983 tree tmp;
1984
6e45f57b
PB		 1985 gcc_assert (sym->backend_decl);
1986 gcc_assert (sym->ts.cl && sym->ts.cl->length);
6de9cd9a
DN		 1987
1988 gfc_start_block (&body);
1989
1990 /* Evaluate the string length expression. */
1991 gfc_trans_init_string_length (sym->ts.cl, &body);
1992
1993 decl = sym->backend_decl;
1994
1a186ec5 1995 /* Emit a DECL_EXPR for this variable, which will cause the
4ab2db93 1996 gimplifier to allocate storage, and all that good stuff. */
923ab88c 1997 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
6de9cd9a 1998 gfc_add_expr_to_block (&body, tmp);
1a186ec5 1999
6de9cd9a
DN		 2000 gfc_add_expr_to_block (&body, fnbody);
2001 return gfc_finish_block (&body);
2002}
2003
2004
2005/* Generate function entry and exit code, and add it to the function body.
2006 This includes:
f8d0aee5 2007 Allocation and initialization of array variables.
6de9cd9a
DN		 2008 Allocation of character string variables.
2009 Initialization and possibly repacking of dummy arrays. */
2010
2011static tree
2012gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2013{
2014 locus loc;
2015 gfc_symbol *sym;
2016
2017 /* Deal with implicit return variables. Explicit return variables will
2018 already have been added. */
2019 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2020 {
2021 if (!current_fake_result_decl)
2022 {
d198b59a
JJ		 2023 gfc_entry_list *el = NULL;
2024 if (proc_sym->attr.entry_master)
2025 {
2026 for (el = proc_sym->ns->entries; el; el = el->next)
2027 if (el->sym != el->sym->result)
2028 break;
2029 }
2030 if (el == NULL)
2031 warning (0, "Function does not return a value");
6de9cd9a 2032 }
d198b59a 2033 else if (proc_sym->as)
6de9cd9a
DN		 2034 {
2035 fnbody = gfc_trans_dummy_array_bias (proc_sym,
2036 current_fake_result_decl,
2037 fnbody);
2038 }
2039 else if (proc_sym->ts.type == BT_CHARACTER)
2040 {
2041 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2042 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2043 }
2044 else
973ff4c0
TS		 2045 gcc_assert (gfc_option.flag_f2c
2046 && proc_sym->ts.type == BT_COMPLEX);
6de9cd9a
DN		 2047 }
2048
2049 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2050 {
2051 if (sym->attr.dimension)
2052 {
2053 switch (sym->as->type)
2054 {
2055 case AS_EXPLICIT:
2056 if (sym->attr.dummy || sym->attr.result)
2057 fnbody =
2058 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2059 else if (sym->attr.pointer || sym->attr.allocatable)
2060 {
2061 if (TREE_STATIC (sym->backend_decl))
2062 gfc_trans_static_array_pointer (sym);
2063 else
2064 fnbody = gfc_trans_deferred_array (sym, fnbody);
2065 }
2066 else
2067 {
2068 gfc_get_backend_locus (&loc);
2069 gfc_set_backend_locus (&sym->declared_at);
2070 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2071 sym, fnbody);
2072 gfc_set_backend_locus (&loc);
2073 }
2074 break;
2075
2076 case AS_ASSUMED_SIZE:
2077 /* Must be a dummy parameter. */
6e45f57b 2078 gcc_assert (sym->attr.dummy);
6de9cd9a
DN		 2079
2080 /* We should always pass assumed size arrays the g77 way. */
6de9cd9a
DN		 2081 fnbody = gfc_trans_g77_array (sym, fnbody);
2082 break;
2083
2084 case AS_ASSUMED_SHAPE:
2085 /* Must be a dummy parameter. */
6e45f57b 2086 gcc_assert (sym->attr.dummy);
6de9cd9a
DN		 2087
2088 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2089 fnbody);
2090 break;
2091
2092 case AS_DEFERRED:
2093 fnbody = gfc_trans_deferred_array (sym, fnbody);
2094 break;
2095
2096 default:
6e45f57b 2097 gcc_unreachable ();
6de9cd9a
DN		 2098 }
2099 }
2100 else if (sym->ts.type == BT_CHARACTER)
2101 {
2102 gfc_get_backend_locus (&loc);
2103 gfc_set_backend_locus (&sym->declared_at);
2104 if (sym->attr.dummy || sym->attr.result)
2105 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2106 else
2107 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2108 gfc_set_backend_locus (&loc);
2109 }
2110 else
6e45f57b 2111 gcc_unreachable ();
6de9cd9a
DN		 2112 }
2113
2114 return fnbody;
2115}
2116
2117
2118/* Output an initialized decl for a module variable. */
2119
2120static void
2121gfc_create_module_variable (gfc_symbol * sym)
2122{
2123 tree decl;
6de9cd9a
DN		 2124
2125 /* Only output symbols from this module. */
2126 if (sym->ns != module_namespace)
2127 {
2128 /* I don't think this should ever happen. */
2129 internal_error ("module symbol %s in wrong namespace", sym->name);
2130 }
2131
e7dc5b4f 2132 /* Only output variables and array valued parameters. */
6de9cd9a
DN		 2133 if (sym->attr.flavor != FL_VARIABLE
2134 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2135 return;
2136
9cbf8b41
TS		 2137 /* Don't generate variables from other modules. Variables from
2138 COMMONs will already have been generated. */
2139 if (sym->attr.use_assoc || sym->attr.in_common)
6de9cd9a
DN		 2140 return;
2141
2142 if (sym->backend_decl)
2143 internal_error ("backend decl for module variable %s already exists",
2144 sym->name);
2145
2146 /* We always want module variables to be created. */
2147 sym->attr.referenced = 1;
2148 /* Create the decl. */
2149 decl = gfc_get_symbol_decl (sym);
2150
6de9cd9a
DN		 2151 /* Create the variable. */
2152 pushdecl (decl);
0e6df31e 2153 rest_of_decl_compilation (decl, 1, 0);
6de9cd9a
DN		 2154
2155 /* Also add length of strings. */
2156 if (sym->ts.type == BT_CHARACTER)
2157 {
2158 tree length;
2159
2160 length = sym->ts.cl->backend_decl;
2161 if (!INTEGER_CST_P (length))
2162 {
2163 pushdecl (length);
0e6df31e 2164 rest_of_decl_compilation (length, 1, 0);
6de9cd9a
DN		 2165 }
2166 }
2167}
2168
2169
2170/* Generate all the required code for module variables. */
2171
2172void
2173gfc_generate_module_vars (gfc_namespace * ns)
2174{
2175 module_namespace = ns;
2176
472ca416 2177 /* Check if the frontend left the namespace in a reasonable state. */
6e45f57b 2178 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
6de9cd9a 2179
9cbf8b41
TS		 2180 /* Generate COMMON blocks. */
2181 gfc_trans_common (ns);
2182
472ca416 2183 /* Create decls for all the module variables. */
6de9cd9a
DN		 2184 gfc_traverse_ns (ns, gfc_create_module_variable);
2185}
2186
2187static void
2188gfc_generate_contained_functions (gfc_namespace * parent)
2189{
2190 gfc_namespace *ns;
2191
2192 /* We create all the prototypes before generating any code. */
2193 for (ns = parent->contained; ns; ns = ns->sibling)
2194 {
2195 /* Skip namespaces from used modules. */
2196 if (ns->parent != parent)
2197 continue;
2198
3d79abbd 2199 gfc_create_function_decl (ns);
6de9cd9a
DN		 2200 }
2201
2202 for (ns = parent->contained; ns; ns = ns->sibling)
2203 {
2204 /* Skip namespaces from used modules. */
2205 if (ns->parent != parent)
2206 continue;
2207
2208 gfc_generate_function_code (ns);
2209 }
2210}
2211
2212
2213/* Generate decls for all local variables. We do this to ensure correct
2214 handling of expressions which only appear in the specification of
2215 other functions. */
2216
2217static void
2218generate_local_decl (gfc_symbol * sym)
2219{
2220 if (sym->attr.flavor == FL_VARIABLE)
2221 {
6de9cd9a
DN		 2222 if (sym->attr.referenced)
2223 gfc_get_symbol_decl (sym);
19e4c59d 2224 else if (sym->attr.dummy && warn_unused_parameter)
d4ee4d25 2225 warning (0, "unused parameter %qs", sym->name);
f8d0aee5 2226 /* Warn for unused variables, but not if they're inside a common
19e4c59d 2227 block or are use-associated. */
ce738b86
TS		 2228 else if (warn_unused_variable
2229 && !(sym->attr.in_common || sym->attr.use_assoc))
d4ee4d25 2230 warning (0, "unused variable %qs", sym->name);
6de9cd9a
DN		 2231 }
2232}
2233
2234static void
2235generate_local_vars (gfc_namespace * ns)
2236{
2237 gfc_traverse_ns (ns, generate_local_decl);
2238}
2239
2240
3d79abbd
PB		 2241/* Generate a switch statement to jump to the correct entry point. Also
2242 creates the label decls for the entry points. */
6de9cd9a 2243
3d79abbd
PB		 2244static tree
2245gfc_trans_entry_master_switch (gfc_entry_list * el)
6de9cd9a 2246{
3d79abbd
PB		 2247 stmtblock_t block;
2248 tree label;
2249 tree tmp;
2250 tree val;
6de9cd9a 2251
3d79abbd
PB		 2252 gfc_init_block (&block);
2253 for (; el; el = el->next)
2254 {
2255 /* Add the case label. */
c006df4e 2256 label = gfc_build_label_decl (NULL_TREE);
7d60be94 2257 val = build_int_cst (gfc_array_index_type, el->id);
923ab88c 2258 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3d79abbd
PB		 2259 gfc_add_expr_to_block (&block, tmp);
2260
2261 /* And jump to the actual entry point. */
2262 label = gfc_build_label_decl (NULL_TREE);
3d79abbd
PB		 2263 tmp = build1_v (GOTO_EXPR, label);
2264 gfc_add_expr_to_block (&block, tmp);
2265
2266 /* Save the label decl. */
2267 el->label = label;
2268 }
2269 tmp = gfc_finish_block (&block);
2270 /* The first argument selects the entry point. */
2271 val = DECL_ARGUMENTS (current_function_decl);
923ab88c 2272 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3d79abbd 2273 return tmp;
6de9cd9a
DN		 2274}
2275
44de5aeb 2276
6de9cd9a
DN		 2277/* Generate code for a function. */
2278
2279void
2280gfc_generate_function_code (gfc_namespace * ns)
2281{
2282 tree fndecl;
2283 tree old_context;
2284 tree decl;
2285 tree tmp;
2286 stmtblock_t block;
2287 stmtblock_t body;
2288 tree result;
2289 gfc_symbol *sym;
2290
2291 sym = ns->proc_name;
3d79abbd 2292
6de9cd9a 2293 /* Check that the frontend isn't still using this. */
6e45f57b 2294 gcc_assert (sym->tlink == NULL);
6de9cd9a
DN		 2295 sym->tlink = sym;
2296
2297 /* Create the declaration for functions with global scope. */
2298 if (!sym->backend_decl)
3d79abbd 2299 gfc_create_function_decl (ns);
6de9cd9a
DN		 2300
2301 fndecl = sym->backend_decl;
2302 old_context = current_function_decl;
2303
2304 if (old_context)
2305 {
2306 push_function_context ();
2307 saved_parent_function_decls = saved_function_decls;
2308 saved_function_decls = NULL_TREE;
2309 }
2310
3d79abbd 2311 trans_function_start (sym);
6de9cd9a
DN		 2312
2313 /* Will be created as needed. */
2314 current_fake_result_decl = NULL_TREE;
2315
6de9cd9a
DN		 2316 gfc_start_block (&block);
2317
2318 gfc_generate_contained_functions (ns);
2319
d198b59a
JJ		 2320 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2321 {
2322 /* Copy length backend_decls to all entry point result
2323 symbols. */
2324 gfc_entry_list *el;
2325 tree backend_decl;
2326
2327 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2328 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2329 for (el = ns->entries; el; el = el->next)
2330 el->sym->result->ts.cl->backend_decl = backend_decl;
2331 }
2332
6de9cd9a
DN		 2333 /* Translate COMMON blocks. */
2334 gfc_trans_common (ns);
2335
2336 generate_local_vars (ns);
2337
2338 current_function_return_label = NULL;
2339
2340 /* Now generate the code for the body of this function. */
2341 gfc_init_block (&body);
2342
2343 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2344 && sym->attr.subroutine)
2345 {
2346 tree alternate_return;
2347 alternate_return = gfc_get_fake_result_decl (sym);
2348 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2349 }
2350
3d79abbd
PB		 2351 if (ns->entries)
2352 {
2353 /* Jump to the correct entry point. */
2354 tmp = gfc_trans_entry_master_switch (ns->entries);
2355 gfc_add_expr_to_block (&body, tmp);
2356 }
2357
6de9cd9a
DN		 2358 tmp = gfc_trans_code (ns->code);
2359 gfc_add_expr_to_block (&body, tmp);
2360
2361 /* Add a return label if needed. */
2362 if (current_function_return_label)
2363 {
2364 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2365 gfc_add_expr_to_block (&body, tmp);
2366 }
2367
2368 tmp = gfc_finish_block (&body);
2369 /* Add code to create and cleanup arrays. */
2370 tmp = gfc_trans_deferred_vars (sym, tmp);
2371 gfc_add_expr_to_block (&block, tmp);
2372
2373 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2374 {
19e4c59d 2375 if (sym->attr.subroutine || sym == sym->result)
6de9cd9a
DN		 2376 {
2377 result = current_fake_result_decl;
2378 current_fake_result_decl = NULL_TREE;
2379 }
2380 else
2381 result = sym->result->backend_decl;
2382
2383 if (result == NULL_TREE)
d4ee4d25 2384 warning (0, "Function return value not set");
6de9cd9a
DN		 2385 else
2386 {
f8d0aee5 2387 /* Set the return value to the dummy result variable. */
923ab88c
TS		 2388 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2389 DECL_RESULT (fndecl), result);
2390 tmp = build1_v (RETURN_EXPR, tmp);
6de9cd9a
DN		 2391 gfc_add_expr_to_block (&block, tmp);
2392 }
2393 }
2394
2395 /* Add all the decls we created during processing. */
2396 decl = saved_function_decls;
2397 while (decl)
2398 {
2399 tree next;
2400
2401 next = TREE_CHAIN (decl);
2402 TREE_CHAIN (decl) = NULL_TREE;
2403 pushdecl (decl);
2404 decl = next;
2405 }
2406 saved_function_decls = NULL_TREE;
2407
2408 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2409
2410 /* Finish off this function and send it for code generation. */
2411 poplevel (1, 0, 1);
2412 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2413
2414 /* Output the GENERIC tree. */
2415 dump_function (TDI_original, fndecl);
2416
2417 /* Store the end of the function, so that we get good line number
2418 info for the epilogue. */
2419 cfun->function_end_locus = input_location;
2420
2421 /* We're leaving the context of this function, so zap cfun.
2422 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2423 tree_rest_of_compilation. */
2424 cfun = NULL;
2425
2426 if (old_context)
2427 {
2428 pop_function_context ();
2429 saved_function_decls = saved_parent_function_decls;
2430 }
2431 current_function_decl = old_context;
2432
2433 if (decl_function_context (fndecl))
44de5aeb
RK		 2434 /* Register this function with cgraph just far enough to get it
2435 added to our parent's nested function list. */
2436 (void) cgraph_node (fndecl);
6de9cd9a
DN		 2437 else
2438 {
44de5aeb 2439 gfc_gimplify_function (fndecl);
8f235343 2440 cgraph_finalize_function (fndecl, false);
6de9cd9a
DN		 2441 }
2442}
2443
6de9cd9a
DN		 2444void
2445gfc_generate_constructors (void)
2446{
6e45f57b 2447 gcc_assert (gfc_static_ctors == NULL_TREE);
6de9cd9a
DN		 2448#if 0
2449 tree fnname;
2450 tree type;
2451 tree fndecl;
2452 tree decl;
2453 tree tmp;
2454
2455 if (gfc_static_ctors == NULL_TREE)
2456 return;
2457
2458 fnname = get_file_function_name ('I');
2459 type = build_function_type (void_type_node,
2460 gfc_chainon_list (NULL_TREE, void_type_node));
2461
2462 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2463 TREE_PUBLIC (fndecl) = 1;
2464
2465 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
b785f485
RH		 2466 DECL_ARTIFICIAL (decl) = 1;
2467 DECL_IGNORED_P (decl) = 1;
6de9cd9a
DN		 2468 DECL_CONTEXT (decl) = fndecl;
2469 DECL_RESULT (fndecl) = decl;
2470
2471 pushdecl (fndecl);
2472
2473 current_function_decl = fndecl;
2474
0e6df31e 2475 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a 2476
0e6df31e 2477 make_decl_rtl (fndecl);
6de9cd9a 2478
c8cc8542 2479 init_function_start (fndecl);
6de9cd9a 2480
6de9cd9a
DN		 2481 pushlevel (0);
2482
2483 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2484 {
2485 tmp =
2486 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2487 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2488 }
2489
2490 poplevel (1, 0, 1);
2491
2492 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2493
2494 free_after_parsing (cfun);
2495 free_after_compilation (cfun);
2496
0f0377f6 2497 tree_rest_of_compilation (fndecl);
6de9cd9a
DN		 2498
2499 current_function_decl = NULL_TREE;
2500#endif
2501}
2502
0de4325e
TS		 2503/* Translates a BLOCK DATA program unit. This means emitting the
2504 commons contained therein plus their initializations. We also emit
2505 a globally visible symbol to make sure that each BLOCK DATA program
2506 unit remains unique. */
2507
2508void
2509gfc_generate_block_data (gfc_namespace * ns)
2510{
2511 tree decl;
2512 tree id;
2513
c8cc8542
PB		 2514 /* Tell the backend the source location of the block data. */
2515 if (ns->proc_name)
2516 gfc_set_backend_locus (&ns->proc_name->declared_at);
2517 else
2518 gfc_set_backend_locus (&gfc_current_locus);
2519
2520 /* Process the DATA statements. */
0de4325e
TS		 2521 gfc_trans_common (ns);
2522
c8cc8542
PB		 2523 /* Create a global symbol with the mane of the block data. This is to
2524 generate linker errors if the same name is used twice. It is never
2525 really used. */
0de4325e
TS		 2526 if (ns->proc_name)
2527 id = gfc_sym_mangled_function_id (ns->proc_name);
2528 else
2529 id = get_identifier ("__BLOCK_DATA__");
2530
2531 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2532 TREE_PUBLIC (decl) = 1;
2533 TREE_STATIC (decl) = 1;
2534
2535 pushdecl (decl);
2536 rest_of_decl_compilation (decl, 1, 0);
2537}
2538
6de9cd9a 2539#include "gt-fortran-trans-decl.h"
GNU Compiler Collection
This page took 0.673754 seconds and 5 git commands to generate.