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