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