Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/trans-decl.c @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
1 /* Backend function setup 1 /* Backend function setup
2 Copyright (C) 2002-2017 Free Software Foundation, Inc. 2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook 3 Contributed by Paul Brook
4 4
5 This file is part of GCC. 5 This file is part of GCC.
6 6
7 GCC is free software; you can redistribute it and/or modify it under 7 GCC is free software; you can redistribute it and/or modify it under
58 58
59 /* Holds the variable DECLs for the current function. */ 59 /* Holds the variable DECLs for the current function. */
60 60
61 static GTY(()) tree saved_function_decls; 61 static GTY(()) tree saved_function_decls;
62 static GTY(()) tree saved_parent_function_decls; 62 static GTY(()) tree saved_parent_function_decls;
63
64 static hash_set<tree> *nonlocal_dummy_decl_pset;
65 static GTY(()) tree nonlocal_dummy_decls;
66 63
67 /* Holds the variable DECLs that are locals. */ 64 /* Holds the variable DECLs that are locals. */
68 65
69 static GTY(()) tree saved_local_decls; 66 static GTY(()) tree saved_local_decls;
70 67
120 tree gfor_fndecl_associated; 117 tree gfor_fndecl_associated;
121 tree gfor_fndecl_system_clock4; 118 tree gfor_fndecl_system_clock4;
122 tree gfor_fndecl_system_clock8; 119 tree gfor_fndecl_system_clock8;
123 tree gfor_fndecl_ieee_procedure_entry; 120 tree gfor_fndecl_ieee_procedure_entry;
124 tree gfor_fndecl_ieee_procedure_exit; 121 tree gfor_fndecl_ieee_procedure_exit;
125
126 122
127 /* Coarray run-time library function decls. */ 123 /* Coarray run-time library function decls. */
128 tree gfor_fndecl_caf_init; 124 tree gfor_fndecl_caf_init;
129 tree gfor_fndecl_caf_finalize; 125 tree gfor_fndecl_caf_finalize;
130 tree gfor_fndecl_caf_this_image; 126 tree gfor_fndecl_caf_this_image;
155 tree gfor_fndecl_caf_event_query; 151 tree gfor_fndecl_caf_event_query;
156 tree gfor_fndecl_caf_fail_image; 152 tree gfor_fndecl_caf_fail_image;
157 tree gfor_fndecl_caf_failed_images; 153 tree gfor_fndecl_caf_failed_images;
158 tree gfor_fndecl_caf_image_status; 154 tree gfor_fndecl_caf_image_status;
159 tree gfor_fndecl_caf_stopped_images; 155 tree gfor_fndecl_caf_stopped_images;
156 tree gfor_fndecl_caf_form_team;
157 tree gfor_fndecl_caf_change_team;
158 tree gfor_fndecl_caf_end_team;
159 tree gfor_fndecl_caf_sync_team;
160 tree gfor_fndecl_caf_get_team;
161 tree gfor_fndecl_caf_team_number;
160 tree gfor_fndecl_co_broadcast; 162 tree gfor_fndecl_co_broadcast;
161 tree gfor_fndecl_co_max; 163 tree gfor_fndecl_co_max;
162 tree gfor_fndecl_co_min; 164 tree gfor_fndecl_co_min;
163 tree gfor_fndecl_co_reduce; 165 tree gfor_fndecl_co_reduce;
164 tree gfor_fndecl_co_sum; 166 tree gfor_fndecl_co_sum;
207 209
208 /* Other misc. runtime library functions. */ 210 /* Other misc. runtime library functions. */
209 tree gfor_fndecl_size0; 211 tree gfor_fndecl_size0;
210 tree gfor_fndecl_size1; 212 tree gfor_fndecl_size1;
211 tree gfor_fndecl_iargc; 213 tree gfor_fndecl_iargc;
214 tree gfor_fndecl_kill;
215 tree gfor_fndecl_kill_sub;
216
212 217
213 /* Intrinsic functions implemented in Fortran. */ 218 /* Intrinsic functions implemented in Fortran. */
214 tree gfor_fndecl_sc_kind; 219 tree gfor_fndecl_sc_kind;
215 tree gfor_fndecl_si_kind; 220 tree gfor_fndecl_si_kind;
216 tree gfor_fndecl_sr_kind; 221 tree gfor_fndecl_sr_kind;
219 tree gfor_fndecl_sgemm; 224 tree gfor_fndecl_sgemm;
220 tree gfor_fndecl_dgemm; 225 tree gfor_fndecl_dgemm;
221 tree gfor_fndecl_cgemm; 226 tree gfor_fndecl_cgemm;
222 tree gfor_fndecl_zgemm; 227 tree gfor_fndecl_zgemm;
223 228
229 /* RANDOM_INIT function. */
230 tree gfor_fndecl_random_init;
224 231
225 static void 232 static void
226 gfc_add_decl_to_parent_function (tree decl) 233 gfc_add_decl_to_parent_function (tree decl)
227 { 234 {
228 gcc_assert (decl); 235 gcc_assert (decl);
601 /* Chain this decl to the pending declarations. Don't do pushdecl() 608 /* Chain this decl to the pending declarations. Don't do pushdecl()
602 because this would add them to the current scope rather than the 609 because this would add them to the current scope rather than the
603 function scope. */ 610 function scope. */
604 if (current_function_decl != NULL_TREE) 611 if (current_function_decl != NULL_TREE)
605 { 612 {
606 if (sym->ns->proc_name->backend_decl == current_function_decl 613 if (sym->ns->proc_name
607 || sym->result == sym) 614 && (sym->ns->proc_name->backend_decl == current_function_decl
615 || sym->result == sym))
608 gfc_add_decl_to_function (decl); 616 gfc_add_decl_to_function (decl);
609 else if (sym->ns->proc_name->attr.flavor == FL_LABEL) 617 else if (sym->ns->proc_name
618 && sym->ns->proc_name->attr.flavor == FL_LABEL)
610 /* This is a BLOCK construct. */ 619 /* This is a BLOCK construct. */
611 add_decl_as_local (decl); 620 add_decl_as_local (decl);
612 else 621 else
613 gfc_add_decl_to_parent_function (decl); 622 gfc_add_decl_to_parent_function (decl);
614 } 623 }
687 && sym->ts.u.derived->attr.has_dtio_procs) 696 && sym->ts.u.derived->attr.has_dtio_procs)
688 || (sym->ts.type == BT_CLASS 697 || (sym->ts.type == BT_CLASS
689 && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs))) 698 && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
690 TREE_STATIC (decl) = 1; 699 TREE_STATIC (decl) = 1;
691 700
692 if (sym->attr.volatile_) 701 /* Treat asynchronous variables the same as volatile, for now. */
702 if (sym->attr.volatile_ || sym->attr.asynchronous)
693 { 703 {
694 TREE_THIS_VOLATILE (decl) = 1; 704 TREE_THIS_VOLATILE (decl) = 1;
695 TREE_SIDE_EFFECTS (decl) = 1; 705 TREE_SIDE_EFFECTS (decl) = 1;
696 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); 706 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
697 TREE_TYPE (decl) = new_type; 707 TREE_TYPE (decl) = new_type;
698 } 708 }
699 709
700 /* Keep variables larger than max-stack-var-size off stack. */ 710 /* Keep variables larger than max-stack-var-size off stack. */
701 if (!sym->ns->proc_name->attr.recursive && !sym->attr.automatic 711 if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive)
712 && !sym->attr.automatic
702 && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) 713 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
703 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) 714 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
704 /* Put variable length auto array pointers always into stack. */ 715 /* Put variable length auto array pointers always into stack. */
705 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE 716 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
706 || sym->attr.dimension == 0 717 || sym->attr.dimension == 0
1269 gfc_add_decl_to_parent_function (decl); 1280 gfc_add_decl_to_parent_function (decl);
1270 1281
1271 return decl; 1282 return decl;
1272 } 1283 }
1273 1284
1274 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1275 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1276 pointing to the artificial variable for debug info purposes. */
1277
1278 static void
1279 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1280 {
1281 tree decl, dummy;
1282
1283 if (! nonlocal_dummy_decl_pset)
1284 nonlocal_dummy_decl_pset = new hash_set<tree>;
1285
1286 if (nonlocal_dummy_decl_pset->add (sym->backend_decl))
1287 return;
1288
1289 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1290 decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1291 TREE_TYPE (sym->backend_decl));
1292 DECL_ARTIFICIAL (decl) = 0;
1293 TREE_USED (decl) = 1;
1294 TREE_PUBLIC (decl) = 0;
1295 TREE_STATIC (decl) = 0;
1296 DECL_EXTERNAL (decl) = 0;
1297 if (DECL_BY_REFERENCE (dummy))
1298 DECL_BY_REFERENCE (decl) = 1;
1299 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1300 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1301 DECL_HAS_VALUE_EXPR_P (decl) = 1;
1302 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1303 DECL_CHAIN (decl) = nonlocal_dummy_decls;
1304 nonlocal_dummy_decls = decl;
1305 }
1306
1307 /* Return a constant or a variable to use as a string length. Does not 1285 /* Return a constant or a variable to use as a string length. Does not
1308 add the decl to the current scope. */ 1286 add the decl to the current scope. */
1309 1287
1310 static tree 1288 static tree
1311 gfc_create_string_length (gfc_symbol * sym) 1289 gfc_create_string_length (gfc_symbol * sym)
1529 sym->backend_decl = DECL_CHAIN (sym->backend_decl); 1507 sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1530 } 1508 }
1531 1509
1532 /* Dummy variables should already have been created. */ 1510 /* Dummy variables should already have been created. */
1533 gcc_assert (sym->backend_decl); 1511 gcc_assert (sym->backend_decl);
1512
1513 /* However, the string length of deferred arrays must be set. */
1514 if (sym->ts.type == BT_CHARACTER
1515 && sym->ts.deferred
1516 && sym->attr.dimension
1517 && sym->attr.allocatable)
1518 gfc_defer_symbol_init (sym);
1534 1519
1535 if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) 1520 if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
1536 GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; 1521 GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
1537 1522
1538 /* Create a character length variable. */ 1523 /* Create a character length variable. */
1628 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) 1613 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1629 { 1614 {
1630 gfc_add_assign_aux_vars (sym); 1615 gfc_add_assign_aux_vars (sym);
1631 } 1616 }
1632 1617
1633 if ((sym->attr.dimension || IS_CLASS_ARRAY (sym))
1634 && DECL_LANG_SPECIFIC (sym->backend_decl)
1635 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1636 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1637 gfc_nonlocal_dummy_array_decl (sym);
1638
1639 if (sym->ts.type == BT_CLASS && sym->backend_decl) 1618 if (sym->ts.type == BT_CLASS && sym->backend_decl)
1640 GFC_DECL_CLASS(sym->backend_decl) = 1; 1619 GFC_DECL_CLASS(sym->backend_decl) = 1;
1641 1620
1642 return sym->backend_decl; 1621 return sym->backend_decl;
1643 } 1622 }
1699 if (sym->attr.associate_var 1678 if (sym->attr.associate_var
1700 && sym->ts.deferred 1679 && sym->ts.deferred
1701 && sym->assoc && sym->assoc->target 1680 && sym->assoc && sym->assoc->target
1702 && ((sym->assoc->target->expr_type == EXPR_VARIABLE 1681 && ((sym->assoc->target->expr_type == EXPR_VARIABLE
1703 && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) 1682 && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
1704 || sym->assoc->target->expr_type == EXPR_FUNCTION)) 1683 || sym->assoc->target->expr_type != EXPR_VARIABLE))
1705 sym->ts.u.cl->backend_decl = NULL_TREE; 1684 sym->ts.u.cl->backend_decl = NULL_TREE;
1706 1685
1707 if (sym->attr.associate_var 1686 if (sym->attr.associate_var
1708 && sym->ts.u.cl->backend_decl 1687 && sym->ts.u.cl->backend_decl
1709 && VAR_P (sym->ts.u.cl->backend_decl)) 1688 && (VAR_P (sym->ts.u.cl->backend_decl)
1689 || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL))
1710 length = gfc_index_zero_node; 1690 length = gfc_index_zero_node;
1711 else 1691 else
1712 length = gfc_create_string_length (sym); 1692 length = gfc_create_string_length (sym);
1713 } 1693 }
1714 1694
1763 && !sym->attr.allocatable 1743 && !sym->attr.allocatable
1764 && (sym->value && !sym->ns->proc_name->attr.is_main_program) 1744 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1765 && !(sym->attr.use_assoc && !intrinsic_array_parameter))) 1745 && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1766 gfc_defer_symbol_init (sym); 1746 gfc_defer_symbol_init (sym);
1767 1747
1748 if (sym->ts.type == BT_CHARACTER
1749 && sym->attr.allocatable
1750 && !sym->attr.dimension
1751 && sym->ts.u.cl && sym->ts.u.cl->length
1752 && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
1753 gfc_defer_symbol_init (sym);
1754
1768 /* Associate names can use the hidden string length variable 1755 /* Associate names can use the hidden string length variable
1769 of their associated target. */ 1756 of their associated target. */
1770 if (sym->ts.type == BT_CHARACTER 1757 if (sym->ts.type == BT_CHARACTER
1771 && TREE_CODE (length) != INTEGER_CST) 1758 && TREE_CODE (length) != INTEGER_CST
1772 { 1759 && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF)
1760 {
1761 length = fold_convert (gfc_charlen_type_node, length);
1773 gfc_finish_var_decl (length, sym); 1762 gfc_finish_var_decl (length, sym);
1774 gcc_assert (!sym->value); 1763 if (!sym->attr.associate_var
1764 && TREE_CODE (length) == VAR_DECL
1765 && sym->value && sym->value->expr_type != EXPR_NULL
1766 && sym->value->ts.u.cl->length)
1767 {
1768 gfc_expr *len = sym->value->ts.u.cl->length;
1769 DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts,
1770 TREE_TYPE (length),
1771 false, false, false);
1772 DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node,
1773 DECL_INITIAL (length));
1774 }
1775 else
1776 gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL);
1775 } 1777 }
1776 1778
1777 gfc_finish_var_decl (decl, sym); 1779 gfc_finish_var_decl (decl, sym);
1778 1780
1779 if (sym->ts.type == BT_CHARACTER) 1781 if (sym->ts.type == BT_CHARACTER)
1807 && !(sym->attr.use_assoc && !intrinsic_array_parameter) 1809 && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1808 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program 1810 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1809 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) 1811 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
1810 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE) 1812 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1811 && (flag_coarray != GFC_FCOARRAY_LIB 1813 && (flag_coarray != GFC_FCOARRAY_LIB
1812 || !sym->attr.codimension || sym->attr.allocatable)) 1814 || !sym->attr.codimension || sym->attr.allocatable)
1815 && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
1816 && !(sym->ts.type == BT_CLASS
1817 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type))
1813 { 1818 {
1814 /* Add static initializer. For procedures, it is only needed if 1819 /* Add static initializer. For procedures, it is only needed if
1815 SAVE is specified otherwise they need to be reinitialized 1820 SAVE is specified otherwise they need to be reinitialized
1816 every time the procedure is entered. The TREE_STATIC is 1821 every time the procedure is entered. The TREE_STATIC is
1817 in this case due to -fmax-stack-var-size=. */ 1822 in this case due to -fmax-stack-var-size=. */
1835 1840
1836 if (sym->attr.associate_var) 1841 if (sym->attr.associate_var)
1837 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1; 1842 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
1838 1843
1839 if (sym->attr.vtab 1844 if (sym->attr.vtab
1840 || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0)) 1845 || (sym->name[0] == '_' && gfc_str_startswith (sym->name, "__def_init")))
1841 TREE_READONLY (decl) = 1; 1846 TREE_READONLY (decl) = 1;
1842 1847
1843 return decl; 1848 return decl;
1844 } 1849 }
1845 1850
3310 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( 3315 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
3311 get_identifier (PREFIX("ctime")), ".W", 3316 get_identifier (PREFIX("ctime")), ".W",
3312 void_type_node, 3, pchar_type_node, gfc_charlen_type_node, 3317 void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
3313 gfc_int8_type_node); 3318 gfc_int8_type_node);
3314 3319
3320 gfor_fndecl_random_init = gfc_build_library_function_decl (
3321 get_identifier (PREFIX("random_init")),
3322 void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node,
3323 gfc_int4_type_node);
3324
3315 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( 3325 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
3316 get_identifier (PREFIX("selected_char_kind")), "..R", 3326 get_identifier (PREFIX("selected_char_kind")), "..R",
3317 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); 3327 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
3318 DECL_PURE_P (gfor_fndecl_sc_kind) = 1; 3328 DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
3319 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1; 3329 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
3358 for (jkind=0; jkind < NIKINDS; jkind++) 3368 for (jkind=0; jkind < NIKINDS; jkind++)
3359 { 3369 {
3360 jtype = gfc_get_int_type (ikinds[jkind]); 3370 jtype = gfc_get_int_type (ikinds[jkind]);
3361 if (itype && jtype) 3371 if (itype && jtype)
3362 { 3372 {
3363 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind], 3373 sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
3364 ikinds[jkind]); 3374 ikinds[jkind]);
3365 gfor_fndecl_math_powi[jkind][ikind].integer = 3375 gfor_fndecl_math_powi[jkind][ikind].integer =
3366 gfc_build_library_function_decl (get_identifier (name), 3376 gfc_build_library_function_decl (get_identifier (name),
3367 jtype, 2, jtype, itype); 3377 jtype, 2, jtype, itype);
3368 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; 3378 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
3373 for (rkind = 0; rkind < NRKINDS; rkind ++) 3383 for (rkind = 0; rkind < NRKINDS; rkind ++)
3374 { 3384 {
3375 rtype = gfc_get_real_type (rkinds[rkind]); 3385 rtype = gfc_get_real_type (rkinds[rkind]);
3376 if (rtype && itype) 3386 if (rtype && itype)
3377 { 3387 {
3378 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind], 3388 sprintf (name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
3379 ikinds[ikind]); 3389 ikinds[ikind]);
3380 gfor_fndecl_math_powi[rkind][ikind].real = 3390 gfor_fndecl_math_powi[rkind][ikind].real =
3381 gfc_build_library_function_decl (get_identifier (name), 3391 gfc_build_library_function_decl (get_identifier (name),
3382 rtype, 2, rtype, itype); 3392 rtype, 2, rtype, itype);
3383 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; 3393 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
3385 } 3395 }
3386 3396
3387 ctype = gfc_get_complex_type (rkinds[rkind]); 3397 ctype = gfc_get_complex_type (rkinds[rkind]);
3388 if (ctype && itype) 3398 if (ctype && itype)
3389 { 3399 {
3390 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind], 3400 sprintf (name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
3391 ikinds[ikind]); 3401 ikinds[ikind]);
3392 gfor_fndecl_math_powi[rkind][ikind].cmplx = 3402 gfor_fndecl_math_powi[rkind][ikind].cmplx =
3393 gfc_build_library_function_decl (get_identifier (name), 3403 gfc_build_library_function_decl (get_identifier (name),
3394 ctype, 2,ctype, itype); 3404 ctype, 2,ctype, itype);
3395 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; 3405 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
3478 TREE_NOTHROW (gfor_fndecl_size1) = 1; 3488 TREE_NOTHROW (gfor_fndecl_size1) = 1;
3479 3489
3480 gfor_fndecl_iargc = gfc_build_library_function_decl ( 3490 gfor_fndecl_iargc = gfc_build_library_function_decl (
3481 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); 3491 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3482 TREE_NOTHROW (gfor_fndecl_iargc) = 1; 3492 TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3493
3494 gfor_fndecl_kill_sub = gfc_build_library_function_decl (
3495 get_identifier (PREFIX ("kill_sub")), void_type_node,
3496 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node);
3497
3498 gfor_fndecl_kill = gfc_build_library_function_decl (
3499 get_identifier (PREFIX ("kill")), gfc_int4_type_node,
3500 2, gfc_int4_type_node, gfc_int4_type_node);
3483 } 3501 }
3484 3502
3485 3503
3486 /* Make prototypes for runtime library functions. */ 3504 /* Make prototypes for runtime library functions. */
3487 3505
3488 void 3506 void
3489 gfc_build_builtin_function_decls (void) 3507 gfc_build_builtin_function_decls (void)
3490 { 3508 {
3491 tree gfc_int4_type_node = gfc_get_int_type (4); 3509 tree gfc_int8_type_node = gfc_get_int_type (8);
3492 3510
3493 gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( 3511 gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3494 get_identifier (PREFIX("stop_numeric")), 3512 get_identifier (PREFIX("stop_numeric")),
3495 void_type_node, 1, gfc_int4_type_node); 3513 void_type_node, 2, integer_type_node, boolean_type_node);
3496 /* STOP doesn't return. */ 3514 /* STOP doesn't return. */
3497 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; 3515 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3498 3516
3499 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( 3517 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3500 get_identifier (PREFIX("stop_string")), ".R.", 3518 get_identifier (PREFIX("stop_string")), ".R.",
3501 void_type_node, 2, pchar_type_node, gfc_int4_type_node); 3519 void_type_node, 3, pchar_type_node, size_type_node,
3520 boolean_type_node);
3502 /* STOP doesn't return. */ 3521 /* STOP doesn't return. */
3503 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; 3522 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3504 3523
3505 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( 3524 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3506 get_identifier (PREFIX("error_stop_numeric")), 3525 get_identifier (PREFIX("error_stop_numeric")),
3507 void_type_node, 1, gfc_int4_type_node); 3526 void_type_node, 2, integer_type_node, boolean_type_node);
3508 /* ERROR STOP doesn't return. */ 3527 /* ERROR STOP doesn't return. */
3509 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; 3528 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3510 3529
3511 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( 3530 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3512 get_identifier (PREFIX("error_stop_string")), ".R.", 3531 get_identifier (PREFIX("error_stop_string")), ".R.",
3513 void_type_node, 2, pchar_type_node, gfc_int4_type_node); 3532 void_type_node, 3, pchar_type_node, size_type_node,
3533 boolean_type_node);
3514 /* ERROR STOP doesn't return. */ 3534 /* ERROR STOP doesn't return. */
3515 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; 3535 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3516 3536
3517 gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( 3537 gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3518 get_identifier (PREFIX("pause_numeric")), 3538 get_identifier (PREFIX("pause_numeric")),
3519 void_type_node, 1, gfc_int4_type_node); 3539 void_type_node, 1, gfc_int8_type_node);
3520 3540
3521 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( 3541 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3522 get_identifier (PREFIX("pause_string")), ".R.", 3542 get_identifier (PREFIX("pause_string")), ".R.",
3523 void_type_node, 2, pchar_type_node, gfc_int4_type_node); 3543 void_type_node, 2, pchar_type_node, size_type_node);
3524 3544
3525 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( 3545 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3526 get_identifier (PREFIX("runtime_error")), ".R", 3546 get_identifier (PREFIX("runtime_error")), ".R",
3527 void_type_node, -1, pchar_type_node); 3547 void_type_node, -1, pchar_type_node);
3528 /* The runtime_error function does not return. */ 3548 /* The runtime_error function does not return. */
3623 2, integer_type_node, integer_type_node); 3643 2, integer_type_node, integer_type_node);
3624 3644
3625 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( 3645 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3626 get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7, 3646 get_identifier (PREFIX("caf_register")), "RRWWWWR", void_type_node, 7,
3627 size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node, 3647 size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node,
3628 pint_type, pchar_type_node, integer_type_node); 3648 pint_type, pchar_type_node, size_type_node);
3629 3649
3630 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( 3650 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3631 get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5, 3651 get_identifier (PREFIX("caf_deregister")), "WRWWR", void_type_node, 5,
3632 ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, 3652 ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
3633 integer_type_node); 3653 size_type_node);
3634 3654
3635 gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( 3655 gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
3636 get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10, 3656 get_identifier (PREFIX("caf_get")), ".R.RRWRRRW", void_type_node, 10,
3637 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, 3657 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3638 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, 3658 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3639 boolean_type_node, pint_type); 3659 boolean_type_node, pint_type);
3640 3660
3641 gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( 3661 gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
3642 get_identifier (PREFIX("caf_send")), ".R.RRRRRRW", void_type_node, 10, 3662 get_identifier (PREFIX("caf_send")), ".R.RRRRRRWR", void_type_node, 11,
3643 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, 3663 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
3644 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, 3664 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
3645 boolean_type_node, pint_type); 3665 boolean_type_node, pint_type, pvoid_type_node);
3646 3666
3647 gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( 3667 gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
3648 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR", 3668 get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRRRRR",
3649 void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node, 3669 void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
3650 pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node, 3670 pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
3651 integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, 3671 integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
3652 integer_type_node, boolean_type_node, integer_type_node); 3672 integer_type_node, boolean_type_node, integer_type_node);
3653 3673
3654 gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( 3674 gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec (
3655 get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRW", void_type_node, 3675 get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node,
3656 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, 3676 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3657 integer_type_node, integer_type_node, boolean_type_node, 3677 pvoid_type_node, integer_type_node, integer_type_node,
3658 boolean_type_node, pint_type); 3678 boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3659 3679
3660 gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( 3680 gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
3661 get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRW", void_type_node, 3681 get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR",
3662 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, 3682 void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node,
3663 integer_type_node, integer_type_node, boolean_type_node, 3683 pvoid_type_node, integer_type_node, integer_type_node,
3664 boolean_type_node, pint_type); 3684 boolean_type_node, boolean_type_node, pint_type, integer_type_node);
3665 3685
3666 gfor_fndecl_caf_sendget_by_ref 3686 gfor_fndecl_caf_sendget_by_ref
3667 = gfc_build_library_function_decl_with_spec ( 3687 = gfc_build_library_function_decl_with_spec (
3668 get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWW", 3688 get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR",
3669 void_type_node, 11, pvoid_type_node, integer_type_node, 3689 void_type_node, 13, pvoid_type_node, integer_type_node,
3670 pvoid_type_node, pvoid_type_node, integer_type_node, 3690 pvoid_type_node, pvoid_type_node, integer_type_node,
3671 pvoid_type_node, integer_type_node, integer_type_node, 3691 pvoid_type_node, integer_type_node, integer_type_node,
3672 boolean_type_node, pint_type, pint_type); 3692 boolean_type_node, pint_type, pint_type, integer_type_node,
3693 integer_type_node);
3673 3694
3674 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( 3695 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3675 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node, 3696 get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3676 3, pint_type, pchar_type_node, integer_type_node); 3697 3, pint_type, pchar_type_node, size_type_node);
3677 3698
3678 gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec ( 3699 gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec (
3679 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node, 3700 get_identifier (PREFIX("caf_sync_memory")), ".WW", void_type_node,
3680 3, pint_type, pchar_type_node, integer_type_node); 3701 3, pint_type, pchar_type_node, size_type_node);
3681 3702
3682 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( 3703 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3683 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node, 3704 get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3684 5, integer_type_node, pint_type, pint_type, 3705 5, integer_type_node, pint_type, pint_type,
3685 pchar_type_node, integer_type_node); 3706 pchar_type_node, size_type_node);
3686 3707
3687 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( 3708 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3688 get_identifier (PREFIX("caf_error_stop")), 3709 get_identifier (PREFIX("caf_error_stop")),
3689 void_type_node, 1, gfc_int4_type_node); 3710 void_type_node, 1, integer_type_node);
3690 /* CAF's ERROR STOP doesn't return. */ 3711 /* CAF's ERROR STOP doesn't return. */
3691 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; 3712 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3692 3713
3693 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( 3714 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3694 get_identifier (PREFIX("caf_error_stop_str")), ".R.", 3715 get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3695 void_type_node, 2, pchar_type_node, gfc_int4_type_node); 3716 void_type_node, 2, pchar_type_node, size_type_node);
3696 /* CAF's ERROR STOP doesn't return. */ 3717 /* CAF's ERROR STOP doesn't return. */
3697 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; 3718 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3698 3719
3699 gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec ( 3720 gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl_with_spec (
3700 get_identifier (PREFIX("caf_stop_numeric")), ".R.", 3721 get_identifier (PREFIX("caf_stop_numeric")), ".R.",
3701 void_type_node, 1, gfc_int4_type_node); 3722 void_type_node, 1, integer_type_node);
3702 /* CAF's STOP doesn't return. */ 3723 /* CAF's STOP doesn't return. */
3703 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1; 3724 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1;
3704 3725
3705 gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec ( 3726 gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec (
3706 get_identifier (PREFIX("caf_stop_str")), ".R.", 3727 get_identifier (PREFIX("caf_stop_str")), ".R.",
3707 void_type_node, 2, pchar_type_node, gfc_int4_type_node); 3728 void_type_node, 2, pchar_type_node, size_type_node);
3708 /* CAF's STOP doesn't return. */ 3729 /* CAF's STOP doesn't return. */
3709 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1; 3730 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1;
3710 3731
3711 gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec ( 3732 gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec (
3712 get_identifier (PREFIX("caf_atomic_define")), "R..RW", 3733 get_identifier (PREFIX("caf_atomic_define")), "R..RW",
3731 integer_type_node, integer_type_node); 3752 integer_type_node, integer_type_node);
3732 3753
3733 gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec ( 3754 gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec (
3734 get_identifier (PREFIX("caf_lock")), "R..WWW", 3755 get_identifier (PREFIX("caf_lock")), "R..WWW",
3735 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, 3756 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node,
3736 pint_type, pint_type, pchar_type_node, integer_type_node); 3757 pint_type, pint_type, pchar_type_node, size_type_node);
3737 3758
3738 gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec ( 3759 gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec (
3739 get_identifier (PREFIX("caf_unlock")), "R..WW", 3760 get_identifier (PREFIX("caf_unlock")), "R..WW",
3740 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3761 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3741 pint_type, pchar_type_node, integer_type_node); 3762 pint_type, pchar_type_node, size_type_node);
3742 3763
3743 gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec ( 3764 gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
3744 get_identifier (PREFIX("caf_event_post")), "R..WW", 3765 get_identifier (PREFIX("caf_event_post")), "R..WW",
3745 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3766 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3746 pint_type, pchar_type_node, integer_type_node); 3767 pint_type, pchar_type_node, size_type_node);
3747 3768
3748 gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec ( 3769 gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
3749 get_identifier (PREFIX("caf_event_wait")), "R..WW", 3770 get_identifier (PREFIX("caf_event_wait")), "R..WW",
3750 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3771 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
3751 pint_type, pchar_type_node, integer_type_node); 3772 pint_type, pchar_type_node, size_type_node);
3752 3773
3753 gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec ( 3774 gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
3754 get_identifier (PREFIX("caf_event_query")), "R..WW", 3775 get_identifier (PREFIX("caf_event_query")), "R..WW",
3755 void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node, 3776 void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
3756 pint_type, pint_type); 3777 pint_type, pint_type);
3764 = gfc_build_library_function_decl_with_spec ( 3785 = gfc_build_library_function_decl_with_spec (
3765 get_identifier (PREFIX("caf_failed_images")), "WRR", 3786 get_identifier (PREFIX("caf_failed_images")), "WRR",
3766 void_type_node, 3, pvoid_type_node, ppvoid_type_node, 3787 void_type_node, 3, pvoid_type_node, ppvoid_type_node,
3767 integer_type_node); 3788 integer_type_node);
3768 3789
3790 gfor_fndecl_caf_form_team
3791 = gfc_build_library_function_decl_with_spec (
3792 get_identifier (PREFIX("caf_form_team")), "RWR",
3793 void_type_node, 3, integer_type_node, ppvoid_type_node,
3794 integer_type_node);
3795
3796 gfor_fndecl_caf_change_team
3797 = gfc_build_library_function_decl_with_spec (
3798 get_identifier (PREFIX("caf_change_team")), "RR",
3799 void_type_node, 2, ppvoid_type_node,
3800 integer_type_node);
3801
3802 gfor_fndecl_caf_end_team
3803 = gfc_build_library_function_decl (
3804 get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
3805
3806 gfor_fndecl_caf_get_team
3807 = gfc_build_library_function_decl_with_spec (
3808 get_identifier (PREFIX("caf_get_team")), "R",
3809 void_type_node, 1, integer_type_node);
3810
3811 gfor_fndecl_caf_sync_team
3812 = gfc_build_library_function_decl_with_spec (
3813 get_identifier (PREFIX("caf_sync_team")), "RR",
3814 void_type_node, 2, ppvoid_type_node,
3815 integer_type_node);
3816
3817 gfor_fndecl_caf_team_number
3818 = gfc_build_library_function_decl_with_spec (
3819 get_identifier (PREFIX("caf_team_number")), "R",
3820 integer_type_node, 1, integer_type_node);
3821
3769 gfor_fndecl_caf_image_status 3822 gfor_fndecl_caf_image_status
3770 = gfc_build_library_function_decl_with_spec ( 3823 = gfc_build_library_function_decl_with_spec (
3771 get_identifier (PREFIX("caf_image_status")), "RR", 3824 get_identifier (PREFIX("caf_image_status")), "RR",
3772 integer_type_node, 2, integer_type_node, ppvoid_type_node); 3825 integer_type_node, 2, integer_type_node, ppvoid_type_node);
3773 3826
3778 integer_type_node); 3831 integer_type_node);
3779 3832
3780 gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( 3833 gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
3781 get_identifier (PREFIX("caf_co_broadcast")), "W.WW", 3834 get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
3782 void_type_node, 5, pvoid_type_node, integer_type_node, 3835 void_type_node, 5, pvoid_type_node, integer_type_node,
3783 pint_type, pchar_type_node, integer_type_node); 3836 pint_type, pchar_type_node, size_type_node);
3784 3837
3785 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( 3838 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
3786 get_identifier (PREFIX("caf_co_max")), "W.WW", 3839 get_identifier (PREFIX("caf_co_max")), "W.WW",
3787 void_type_node, 6, pvoid_type_node, integer_type_node, 3840 void_type_node, 6, pvoid_type_node, integer_type_node,
3788 pint_type, pchar_type_node, integer_type_node, integer_type_node); 3841 pint_type, pchar_type_node, integer_type_node, size_type_node);
3789 3842
3790 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec ( 3843 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
3791 get_identifier (PREFIX("caf_co_min")), "W.WW", 3844 get_identifier (PREFIX("caf_co_min")), "W.WW",
3792 void_type_node, 6, pvoid_type_node, integer_type_node, 3845 void_type_node, 6, pvoid_type_node, integer_type_node,
3793 pint_type, pchar_type_node, integer_type_node, integer_type_node); 3846 pint_type, pchar_type_node, integer_type_node, size_type_node);
3794 3847
3795 gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec ( 3848 gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec (
3796 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW", 3849 get_identifier (PREFIX("caf_co_reduce")), "W.R.WW",
3797 void_type_node, 8, pvoid_type_node, 3850 void_type_node, 8, pvoid_type_node,
3798 build_pointer_type (build_varargs_function_type_list (void_type_node, 3851 build_pointer_type (build_varargs_function_type_list (void_type_node,
3799 NULL_TREE)), 3852 NULL_TREE)),
3800 integer_type_node, integer_type_node, pint_type, pchar_type_node, 3853 integer_type_node, integer_type_node, pint_type, pchar_type_node,
3801 integer_type_node, integer_type_node); 3854 integer_type_node, size_type_node);
3802 3855
3803 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( 3856 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
3804 get_identifier (PREFIX("caf_co_sum")), "W.WW", 3857 get_identifier (PREFIX("caf_co_sum")), "W.WW",
3805 void_type_node, 5, pvoid_type_node, integer_type_node, 3858 void_type_node, 5, pvoid_type_node, integer_type_node,
3806 pint_type, pchar_type_node, integer_type_node); 3859 pint_type, pchar_type_node, size_type_node);
3807 3860
3808 gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( 3861 gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
3809 get_identifier (PREFIX("caf_is_present")), "RRR", 3862 get_identifier (PREFIX("caf_is_present")), "RRR",
3810 integer_type_node, 3, pvoid_type_node, integer_type_node, 3863 integer_type_node, 3, pvoid_type_node, integer_type_node,
3811 pvoid_type_node); 3864 pvoid_type_node);
4001 gfc_expr *e; 4054 gfc_expr *e;
4002 tree tmp; 4055 tree tmp;
4003 tree present; 4056 tree present;
4004 4057
4005 gcc_assert (block); 4058 gcc_assert (block);
4059
4060 /* Initialization of PDTs is done elsewhere. */
4061 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
4062 return;
4006 4063
4007 gcc_assert (!sym->attr.allocatable); 4064 gcc_assert (!sym->attr.allocatable);
4008 gfc_set_sym_referenced (sym); 4065 gfc_set_sym_referenced (sym);
4009 e = gfc_lval_expr_from_sym (sym); 4066 e = gfc_lval_expr_from_sym (sym);
4010 tmp = gfc_trans_assignment (e, sym->value, false, dealloc); 4067 tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
4159 tmp = NULL_TREE; 4216 tmp = NULL_TREE;
4160 4217
4161 return tmp; 4218 return tmp;
4162 } 4219 }
4163 4220
4221
4222 /* Get the result expression for a procedure. */
4223
4224 static tree
4225 get_proc_result (gfc_symbol* sym)
4226 {
4227 if (sym->attr.subroutine || sym == sym->result)
4228 {
4229 if (current_fake_result_decl != NULL)
4230 return TREE_VALUE (current_fake_result_decl);
4231
4232 return NULL_TREE;
4233 }
4234
4235 return sym->result->backend_decl;
4236 }
4237
4238
4164 /* Generate function entry and exit code, and add it to the function body. 4239 /* Generate function entry and exit code, and add it to the function body.
4165 This includes: 4240 This includes:
4166 Allocation and initialization of array variables. 4241 Allocation and initialization of array variables.
4167 Allocation of character string variables. 4242 Allocation of character string variables.
4168 Initialization and possibly repacking of dummy arrays. 4243 Initialization and possibly repacking of dummy arrays.
4196 for (el = proc_sym->ns->entries; el; el = el->next) 4271 for (el = proc_sym->ns->entries; el; el = el->next)
4197 if (el->sym != el->sym->result) 4272 if (el->sym != el->sym->result)
4198 break; 4273 break;
4199 } 4274 }
4200 /* TODO: move to the appropriate place in resolve.c. */ 4275 /* TODO: move to the appropriate place in resolve.c. */
4201 if (warn_return_type && el == NULL) 4276 if (warn_return_type > 0 && el == NULL)
4202 gfc_warning (OPT_Wreturn_type, 4277 gfc_warning (OPT_Wreturn_type,
4203 "Return value of function %qs at %L not set", 4278 "Return value of function %qs at %L not set",
4204 proc_sym->name, &proc_sym->declared_at); 4279 proc_sym->name, &proc_sym->declared_at);
4205 } 4280 }
4206 else if (proc_sym->as) 4281 else if (proc_sym->as)
4253 if (TREE_CODE (tmp) != INDIRECT_REF 4328 if (TREE_CODE (tmp) != INDIRECT_REF
4254 && proc_sym->ts.u.cl->passed_length) 4329 && proc_sym->ts.u.cl->passed_length)
4255 { 4330 {
4256 tmp = proc_sym->ts.u.cl->passed_length; 4331 tmp = proc_sym->ts.u.cl->passed_length;
4257 tmp = build_fold_indirect_ref_loc (input_location, tmp); 4332 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4258 tmp = fold_convert (gfc_charlen_type_node, tmp);
4259 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 4333 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4260 gfc_charlen_type_node, tmp, 4334 TREE_TYPE (tmp), tmp,
4261 proc_sym->ts.u.cl->backend_decl); 4335 fold_convert
4336 (TREE_TYPE (tmp),
4337 proc_sym->ts.u.cl->backend_decl));
4262 } 4338 }
4263 else 4339 else
4264 tmp = NULL_TREE; 4340 tmp = NULL_TREE;
4265 4341
4266 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4342 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4269 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); 4345 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
4270 } 4346 }
4271 else 4347 else
4272 gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX); 4348 gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
4273 } 4349 }
4350 else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
4351 {
4352 /* Nullify explicit return class arrays on entry. */
4353 tree type;
4354 tmp = get_proc_result (proc_sym);
4355 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
4356 {
4357 gfc_start_block (&init);
4358 tmp = gfc_class_data_get (tmp);
4359 type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
4360 gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
4361 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
4362 }
4363 }
4364
4274 4365
4275 /* Initialize the INTENT(OUT) derived type dummy arguments. This 4366 /* Initialize the INTENT(OUT) derived type dummy arguments. This
4276 should be done here so that the offsets and lbounds of arrays 4367 should be done here so that the offsets and lbounds of arrays
4277 are available. */ 4368 are available. */
4278 gfc_save_backend_locus (&loc); 4369 gfc_save_backend_locus (&loc);
4302 tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, 4393 tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
4303 sym->backend_decl, 4394 sym->backend_decl,
4304 sym->as ? sym->as->rank : 0, 4395 sym->as ? sym->as->rank : 0,
4305 sym->param_list); 4396 sym->param_list);
4306 gfc_add_expr_to_block (&tmpblock, tmp); 4397 gfc_add_expr_to_block (&tmpblock, tmp);
4307 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, 4398 if (!sym->attr.result)
4308 sym->backend_decl, 4399 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
4309 sym->as ? sym->as->rank : 0); 4400 sym->backend_decl,
4401 sym->as ? sym->as->rank : 0);
4402 else
4403 tmp = NULL_TREE;
4310 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); 4404 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4311 } 4405 }
4312 else if (sym->attr.dummy) 4406 else if (sym->attr.dummy)
4313 { 4407 {
4314 tmp = gfc_check_pdt_dummy (sym->ts.u.derived, 4408 tmp = gfc_check_pdt_dummy (sym->ts.u.derived,
4334 tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp, 4428 tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp,
4335 data->as ? data->as->rank : 0, 4429 data->as ? data->as->rank : 0,
4336 sym->param_list); 4430 sym->param_list);
4337 gfc_add_expr_to_block (&tmpblock, tmp); 4431 gfc_add_expr_to_block (&tmpblock, tmp);
4338 tmp = gfc_class_data_get (sym->backend_decl); 4432 tmp = gfc_class_data_get (sym->backend_decl);
4339 tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp, 4433 if (!sym->attr.result)
4340 data->as ? data->as->rank : 0); 4434 tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
4435 data->as ? data->as->rank : 0);
4436 else
4437 tmp = NULL_TREE;
4341 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); 4438 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
4342 } 4439 }
4343 else if (sym->attr.dummy) 4440 else if (sym->attr.dummy)
4344 { 4441 {
4345 tmp = gfc_class_data_get (sym->backend_decl); 4442 tmp = gfc_class_data_get (sym->backend_decl);
4525 4622
4526 gfc_save_backend_locus (&loc); 4623 gfc_save_backend_locus (&loc);
4527 gfc_set_backend_locus (&sym->declared_at); 4624 gfc_set_backend_locus (&sym->declared_at);
4528 gfc_start_block (&init); 4625 gfc_start_block (&init);
4529 4626
4627 if (sym->ts.type == BT_CHARACTER
4628 && sym->attr.allocatable
4629 && !sym->attr.dimension
4630 && sym->ts.u.cl && sym->ts.u.cl->length
4631 && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE)
4632 gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
4633
4530 if (!sym->attr.pointer) 4634 if (!sym->attr.pointer)
4531 { 4635 {
4532 /* Nullify and automatic deallocation of allocatable 4636 /* Nullify and automatic deallocation of allocatable
4533 scalars. */ 4637 scalars. */
4534 e = gfc_lval_expr_from_sym (sym); 4638 e = gfc_lval_expr_from_sym (sym);
4582 && sym->ts.type == BT_CHARACTER 4686 && sym->ts.type == BT_CHARACTER
4583 && sym->ts.deferred 4687 && sym->ts.deferred
4584 && sym->ts.u.cl->passed_length) 4688 && sym->ts.u.cl->passed_length)
4585 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); 4689 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
4586 else 4690 else
4587 gfc_restore_backend_locus (&loc); 4691 {
4692 gfc_restore_backend_locus (&loc);
4693 tmp = NULL_TREE;
4694 }
4588 4695
4589 /* Deallocate when leaving the scope. Nullifying is not 4696 /* Deallocate when leaving the scope. Nullifying is not
4590 needed. */ 4697 needed. */
4591 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer 4698 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
4592 && !sym->ns->proc_name->attr.is_main_program) 4699 && !sym->ns->proc_name->attr.is_main_program)
4634 gfc_add_modify (&init, se.expr, rhs); 4741 gfc_add_modify (&init, se.expr, rhs);
4635 gfc_restore_backend_locus (&loc); 4742 gfc_restore_backend_locus (&loc);
4636 } 4743 }
4637 4744
4638 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4745 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
4639 /* TODO find out why this is necessary to stop double calls to
4640 free. Somebody is reusing the expression in 'tmp' because
4641 it is being used unititialized. */
4642 tmp = NULL_TREE;
4643 } 4746 }
4644 } 4747 }
4645 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred) 4748 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
4646 { 4749 {
4647 tree tmp = NULL; 4750 tree tmp = NULL;
5261 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size, 5364 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size,
5262 build_int_cst (integer_type_node, reg_type), 5365 build_int_cst (integer_type_node, reg_type),
5263 token, gfc_build_addr_expr (pvoid_type_node, desc), 5366 token, gfc_build_addr_expr (pvoid_type_node, desc),
5264 null_pointer_node, /* stat. */ 5367 null_pointer_node, /* stat. */
5265 null_pointer_node, /* errgmsg. */ 5368 null_pointer_node, /* errgmsg. */
5266 integer_zero_node); /* errmsg_len. */ 5369 build_zero_cst (size_type_node)); /* errmsg_len. */
5267 gfc_add_expr_to_block (&caf_init_block, tmp); 5370 gfc_add_expr_to_block (&caf_init_block, tmp);
5268 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), 5371 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl),
5269 gfc_conv_descriptor_data_get (desc))); 5372 gfc_conv_descriptor_data_get (desc)));
5270 5373
5271 /* Handle "static" initializer. */ 5374 /* Handle "static" initializer. */
5618 } 5721 }
5619 } 5722 }
5620 else if (sym->attr.flavor == FL_PROCEDURE) 5723 else if (sym->attr.flavor == FL_PROCEDURE)
5621 { 5724 {
5622 /* TODO: move to the appropriate place in resolve.c. */ 5725 /* TODO: move to the appropriate place in resolve.c. */
5623 if (warn_return_type 5726 if (warn_return_type > 0
5624 && sym->attr.function 5727 && sym->attr.function
5625 && sym->result 5728 && sym->result
5626 && sym != sym->result 5729 && sym != sym->result
5627 && !sym->result->attr.referenced 5730 && !sym->result->attr.referenced
5628 && !sym->attr.use_assoc 5731 && !sym->attr.use_assoc
5724 el->label = label; 5827 el->label = label;
5725 } 5828 }
5726 tmp = gfc_finish_block (&block); 5829 tmp = gfc_finish_block (&block);
5727 /* The first argument selects the entry point. */ 5830 /* The first argument selects the entry point. */
5728 val = DECL_ARGUMENTS (current_function_decl); 5831 val = DECL_ARGUMENTS (current_function_decl);
5729 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE, 5832 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp);
5730 val, tmp, NULL_TREE);
5731 return tmp; 5833 return tmp;
5732 } 5834 }
5733 5835
5734 5836
5735 /* Add code to string lengths of actual arguments passed to a function against 5837 /* Add code to string lengths of actual arguments passed to a function against
5783 } 5885 }
5784 5886
5785 /* Build the condition. For optional arguments, an actual length 5887 /* Build the condition. For optional arguments, an actual length
5786 of 0 is also acceptable if the associated string is NULL, which 5888 of 0 is also acceptable if the associated string is NULL, which
5787 means the argument was not passed. */ 5889 means the argument was not passed. */
5788 cond = fold_build2_loc (input_location, comparison, boolean_type_node, 5890 cond = fold_build2_loc (input_location, comparison, logical_type_node,
5789 cl->passed_length, cl->backend_decl); 5891 cl->passed_length, cl->backend_decl);
5790 if (fsym->attr.optional) 5892 if (fsym->attr.optional)
5791 { 5893 {
5792 tree not_absent; 5894 tree not_absent;
5793 tree not_0length; 5895 tree not_0length;
5794 tree absent_failed; 5896 tree absent_failed;
5795 5897
5796 not_0length = fold_build2_loc (input_location, NE_EXPR, 5898 not_0length = fold_build2_loc (input_location, NE_EXPR,
5797 boolean_type_node, 5899 logical_type_node,
5798 cl->passed_length, 5900 cl->passed_length,
5799 build_zero_cst (gfc_charlen_type_node)); 5901 build_zero_cst
5902 (TREE_TYPE (cl->passed_length)));
5800 /* The symbol needs to be referenced for gfc_get_symbol_decl. */ 5903 /* The symbol needs to be referenced for gfc_get_symbol_decl. */
5801 fsym->attr.referenced = 1; 5904 fsym->attr.referenced = 1;
5802 not_absent = gfc_conv_expr_present (fsym); 5905 not_absent = gfc_conv_expr_present (fsym);
5803 5906
5804 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, 5907 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5805 boolean_type_node, not_0length, 5908 logical_type_node, not_0length,
5806 not_absent); 5909 not_absent);
5807 5910
5808 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, 5911 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5809 boolean_type_node, cond, absent_failed); 5912 logical_type_node, cond, absent_failed);
5810 } 5913 }
5811 5914
5812 /* Build the runtime check. */ 5915 /* Build the runtime check. */
5813 argname = gfc_build_cstring_const (fsym->name); 5916 argname = gfc_build_cstring_const (fsym->name);
5814 argname = gfc_build_addr_expr (pchar_type_node, argname); 5917 argname = gfc_build_addr_expr (pchar_type_node, argname);
6066 } 6169 }
6067 current_function_decl = old_context; 6170 current_function_decl = old_context;
6068 } 6171 }
6069 6172
6070 6173
6071 /* Get the result expression for a procedure. */
6072
6073 static tree
6074 get_proc_result (gfc_symbol* sym)
6075 {
6076 if (sym->attr.subroutine || sym == sym->result)
6077 {
6078 if (current_fake_result_decl != NULL)
6079 return TREE_VALUE (current_fake_result_decl);
6080
6081 return NULL_TREE;
6082 }
6083
6084 return sym->result->backend_decl;
6085 }
6086
6087
6088 /* Generate an appropriate return-statement for a procedure. */ 6174 /* Generate an appropriate return-statement for a procedure. */
6089 6175
6090 tree 6176 tree
6091 gfc_generate_return (void) 6177 gfc_generate_return (void)
6092 { 6178 {
6348 || ns->parent == NULL) 6434 || ns->parent == NULL)
6349 parent_fake_result_decl = NULL_TREE; 6435 parent_fake_result_decl = NULL_TREE;
6350 6436
6351 gfc_generate_contained_functions (ns); 6437 gfc_generate_contained_functions (ns);
6352 6438
6353 nonlocal_dummy_decls = NULL;
6354 nonlocal_dummy_decl_pset = NULL;
6355
6356 has_coarray_vars = false; 6439 has_coarray_vars = false;
6357 generate_local_vars (ns); 6440 generate_local_vars (ns);
6358 6441
6359 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) 6442 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
6360 generate_coarray_init (ns); 6443 generate_coarray_init (ns);
6375 { 6458 {
6376 char * msg; 6459 char * msg;
6377 6460
6378 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'", 6461 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'",
6379 sym->name); 6462 sym->name);
6380 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); 6463 recurcheckvar = gfc_create_var (logical_type_node, "is_recursive");
6381 TREE_STATIC (recurcheckvar) = 1; 6464 TREE_STATIC (recurcheckvar) = 1;
6382 DECL_INITIAL (recurcheckvar) = boolean_false_node; 6465 DECL_INITIAL (recurcheckvar) = logical_false_node;
6383 gfc_add_expr_to_block (&init, recurcheckvar); 6466 gfc_add_expr_to_block (&init, recurcheckvar);
6384 gfc_trans_runtime_check (true, false, recurcheckvar, &init, 6467 gfc_trans_runtime_check (true, false, recurcheckvar, &init,
6385 &sym->declared_at, msg); 6468 &sym->declared_at, msg);
6386 gfc_add_modify (&init, recurcheckvar, boolean_true_node); 6469 gfc_add_modify (&init, recurcheckvar, logical_true_node);
6387 free (msg); 6470 free (msg);
6388 } 6471 }
6389 6472
6390 /* Check if an IEEE module is used in the procedure. If so, save 6473 /* Check if an IEEE module is used in the procedure. If so, save
6391 the floating point state. */ 6474 the floating point state. */
6493 } 6576 }
6494 6577
6495 if (result == NULL_TREE || artificial_result_decl) 6578 if (result == NULL_TREE || artificial_result_decl)
6496 { 6579 {
6497 /* TODO: move to the appropriate place in resolve.c. */ 6580 /* TODO: move to the appropriate place in resolve.c. */
6498 if (warn_return_type && sym == sym->result) 6581 if (warn_return_type > 0 && sym == sym->result)
6499 gfc_warning (OPT_Wreturn_type, 6582 gfc_warning (OPT_Wreturn_type,
6500 "Return value of function %qs at %L not set", 6583 "Return value of function %qs at %L not set",
6501 sym->name, &sym->declared_at); 6584 sym->name, &sym->declared_at);
6502 if (warn_return_type) 6585 if (warn_return_type > 0)
6503 TREE_NO_WARNING(sym->backend_decl) = 1; 6586 TREE_NO_WARNING(sym->backend_decl) = 1;
6504 } 6587 }
6505 if (result != NULL_TREE) 6588 if (result != NULL_TREE)
6506 gfc_add_expr_to_block (&body, gfc_generate_return ()); 6589 gfc_add_expr_to_block (&body, gfc_generate_return ());
6507 } 6590 }
6510 6593
6511 /* Reset recursion-check variable. */ 6594 /* Reset recursion-check variable. */
6512 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) 6595 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
6513 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE) 6596 && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE)
6514 { 6597 {
6515 gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node); 6598 gfc_add_modify (&cleanup, recurcheckvar, logical_false_node);
6516 recurcheckvar = NULL; 6599 recurcheckvar = NULL;
6517 } 6600 }
6518 6601
6519 /* If IEEE modules are loaded, restore the floating-point state. */ 6602 /* If IEEE modules are loaded, restore the floating-point state. */
6520 if (ieee) 6603 if (ieee)
6550 6633
6551 DECL_SAVED_TREE (fndecl) 6634 DECL_SAVED_TREE (fndecl)
6552 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl), 6635 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
6553 DECL_INITIAL (fndecl)); 6636 DECL_INITIAL (fndecl));
6554 6637
6555 if (nonlocal_dummy_decls)
6556 {
6557 BLOCK_VARS (DECL_INITIAL (fndecl))
6558 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
6559 delete nonlocal_dummy_decl_pset;
6560 nonlocal_dummy_decls = NULL;
6561 nonlocal_dummy_decl_pset = NULL;
6562 }
6563
6564 /* Output the GENERIC tree. */ 6638 /* Output the GENERIC tree. */
6565 dump_function (TDI_original, fndecl); 6639 dump_function (TDI_original, fndecl);
6566 6640
6567 /* Store the end of the function, so that we get good line number 6641 /* Store the end of the function, so that we get good line number
6568 info for the epilogue. */ 6642 info for the epilogue. */
6711 void 6785 void
6712 gfc_process_block_locals (gfc_namespace* ns) 6786 gfc_process_block_locals (gfc_namespace* ns)
6713 { 6787 {
6714 tree decl; 6788 tree decl;
6715 6789
6716 gcc_assert (saved_local_decls == NULL_TREE); 6790 saved_local_decls = NULL_TREE;
6717 has_coarray_vars = false; 6791 has_coarray_vars = false;
6718 6792
6719 generate_local_vars (ns); 6793 generate_local_vars (ns);
6720 6794
6721 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) 6795 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)