Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/interface.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 /* Deal with interfaces. 1 /* Deal with interfaces.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc. 2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught 3 Contributed by Andy Vaught
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
120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */ 120 beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
121 121
122 static gfc_intrinsic_op 122 static gfc_intrinsic_op
123 dtio_op (char* mode) 123 dtio_op (char* mode)
124 { 124 {
125 if (strncmp (mode, "formatted", 9) == 0) 125 if (strcmp (mode, "formatted") == 0)
126 return INTRINSIC_FORMATTED; 126 return INTRINSIC_FORMATTED;
127 if (strncmp (mode, "unformatted", 9) == 0) 127 if (strcmp (mode, "unformatted") == 0)
128 return INTRINSIC_UNFORMATTED; 128 return INTRINSIC_UNFORMATTED;
129 return INTRINSIC_NONE; 129 return INTRINSIC_NONE;
130 } 130 }
131 131
132 132
733 compare_type (gfc_symbol *s1, gfc_symbol *s2) 733 compare_type (gfc_symbol *s1, gfc_symbol *s2)
734 { 734 {
735 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 735 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
736 return true; 736 return true;
737 737
738 return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
739 }
740
741
742 static bool
743 compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2)
744 {
738 /* TYPE and CLASS of the same declared type are type compatible, 745 /* TYPE and CLASS of the same declared type are type compatible,
739 but have different characteristics. */ 746 but have different characteristics. */
740 if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) 747 if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
741 || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) 748 || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
742 return false; 749 return false;
743 750
744 return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; 751 return compare_type (s1, s2);
745 } 752 }
746 753
747 754
748 static bool 755 static bool
749 compare_rank (gfc_symbol *s1, gfc_symbol *s2) 756 compare_rank (gfc_symbol *s1, gfc_symbol *s2)
752 int r1, r2; 759 int r1, r2;
753 760
754 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 761 if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
755 return true; 762 return true;
756 763
757 as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as; 764 as1 = (s1->ts.type == BT_CLASS
758 as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as; 765 && !s1->ts.u.derived->attr.unlimited_polymorphic)
766 ? CLASS_DATA (s1)->as : s1->as;
767 as2 = (s2->ts.type == BT_CLASS
768 && !s2->ts.u.derived->attr.unlimited_polymorphic)
769 ? CLASS_DATA (s2)->as : s2->as;
759 770
760 r1 = as1 ? as1->rank : 0; 771 r1 = as1 ? as1->rank : 0;
761 r2 = as2 ? as2->rank : 0; 772 r2 = as2 ? as2->rank : 0;
762 773
763 if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) 774 if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
1184 1195
1185 return rc; 1196 return rc;
1186 } 1197 }
1187 1198
1188 1199
1200 /* Returns true if two dummy arguments are distinguishable due to their POINTER
1201 and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3).
1202 The function is asymmetric wrt to the arguments s1 and s2 and should always
1203 be called twice (with flipped arguments in the second call). */
1204
1205 static bool
1206 compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2)
1207 {
1208 /* Is s1 allocatable? */
1209 const bool a1 = s1->ts.type == BT_CLASS ?
1210 CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable;
1211 /* Is s2 a pointer? */
1212 const bool p2 = s2->ts.type == BT_CLASS ?
1213 CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer;
1214 return a1 && p2 && (s2->attr.intent != INTENT_IN);
1215 }
1216
1217
1189 /* Perform the correspondence test in rule (3) of F08:C1215. 1218 /* Perform the correspondence test in rule (3) of F08:C1215.
1190 Returns zero if no argument is found that satisfies this rule, 1219 Returns zero if no argument is found that satisfies this rule,
1191 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures 1220 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
1192 (if applicable). 1221 (if applicable).
1193 1222
1227 f2 = f2->next; 1256 f2 = f2->next;
1228 1257
1229 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) 1258 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
1230 || compare_type_rank (f2->sym, f1->sym)) 1259 || compare_type_rank (f2->sym, f1->sym))
1231 && !((gfc_option.allow_std & GFC_STD_F2008) 1260 && !((gfc_option.allow_std & GFC_STD_F2008)
1232 && ((f1->sym->attr.allocatable && f2->sym->attr.pointer) 1261 && (compare_ptr_alloc(f1->sym, f2->sym)
1233 || (f2->sym->attr.allocatable && f1->sym->attr.pointer)))) 1262 || compare_ptr_alloc(f2->sym, f1->sym))))
1234 goto next; 1263 goto next;
1235 1264
1236 /* Now search for a disambiguating keyword argument starting at 1265 /* Now search for a disambiguating keyword argument starting at
1237 the current non-match. */ 1266 the current non-match. */
1238 for (g = f1; g; g = g->next) 1267 for (g = f1; g; g = g->next)
1241 continue; 1270 continue;
1242 1271
1243 sym = find_keyword_arg (g->sym->name, f2_save); 1272 sym = find_keyword_arg (g->sym->name, f2_save);
1244 if (sym == NULL || !compare_type_rank (g->sym, sym) 1273 if (sym == NULL || !compare_type_rank (g->sym, sym)
1245 || ((gfc_option.allow_std & GFC_STD_F2008) 1274 || ((gfc_option.allow_std & GFC_STD_F2008)
1246 && ((sym->attr.allocatable && g->sym->attr.pointer) 1275 && (compare_ptr_alloc(sym, g->sym)
1247 || (sym->attr.pointer && g->sym->attr.allocatable)))) 1276 || compare_ptr_alloc(g->sym, sym))))
1248 return true; 1277 return true;
1249 } 1278 }
1250 1279
1251 next: 1280 next:
1252 if (f1 != NULL) 1281 if (f1 != NULL)
1260 1289
1261 1290
1262 static int 1291 static int
1263 symbol_rank (gfc_symbol *sym) 1292 symbol_rank (gfc_symbol *sym)
1264 { 1293 {
1265 gfc_array_spec *as; 1294 gfc_array_spec *as = NULL;
1266 as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as; 1295
1296 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1297 as = CLASS_DATA (sym)->as;
1298 else
1299 as = sym->as;
1300
1267 return as ? as->rank : 0; 1301 return as ? as->rank : 0;
1268 } 1302 }
1269 1303
1270 1304
1271 /* Check if the characteristics of two dummy arguments match, 1305 /* Check if the characteristics of two dummy arguments match,
1280 return s1 == s2 ? true : false; 1314 return s1 == s2 ? true : false;
1281 1315
1282 /* Check type and rank. */ 1316 /* Check type and rank. */
1283 if (type_must_agree) 1317 if (type_must_agree)
1284 { 1318 {
1285 if (!compare_type (s1, s2) || !compare_type (s2, s1)) 1319 if (!compare_type_characteristics (s1, s2)
1320 || !compare_type_characteristics (s2, s1))
1286 { 1321 {
1287 snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)", 1322 snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
1288 s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts)); 1323 s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
1289 return false; 1324 return false;
1290 } 1325 }
1499 1534
1500 if (r1->ts.type == BT_UNKNOWN) 1535 if (r1->ts.type == BT_UNKNOWN)
1501 return true; 1536 return true;
1502 1537
1503 /* Check type and rank. */ 1538 /* Check type and rank. */
1504 if (!compare_type (r1, r2)) 1539 if (!compare_type_characteristics (r1, r2))
1505 { 1540 {
1506 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)", 1541 snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
1507 gfc_typename (&r1->ts), gfc_typename (&r2->ts)); 1542 gfc_typename (&r1->ts), gfc_typename (&r2->ts));
1508 return false; 1543 return false;
1509 } 1544 }
1747 errmsg, err_len)) 1782 errmsg, err_len))
1748 return false; 1783 return false;
1749 } 1784 }
1750 else 1785 else
1751 { 1786 {
1752 /* Only check type and rank. */ 1787 /* Operators: Only check type and rank of arguments. */
1753 if (!compare_type (f2->sym, f1->sym)) 1788 if (!compare_type (f2->sym, f1->sym))
1754 { 1789 {
1755 if (errmsg != NULL) 1790 if (errmsg != NULL)
1756 snprintf (errmsg, err_len, "Type mismatch in argument '%s' " 1791 snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
1757 "(%s/%s)", f1->sym->name, 1792 "(%s/%s)", f1->sym->name,
1763 { 1798 {
1764 if (errmsg != NULL) 1799 if (errmsg != NULL)
1765 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' " 1800 snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
1766 "(%i/%i)", f1->sym->name, symbol_rank (f1->sym), 1801 "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
1767 symbol_rank (f2->sym)); 1802 symbol_rank (f2->sym));
1803 return false;
1804 }
1805 if ((gfc_option.allow_std & GFC_STD_F2008)
1806 && (compare_ptr_alloc(f1->sym, f2->sym)
1807 || compare_ptr_alloc(f2->sym, f1->sym)))
1808 {
1809 if (errmsg != NULL)
1810 snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE "
1811 "attribute in argument '%s' ", f1->sym->name);
1768 return false; 1812 return false;
1769 } 1813 }
1770 } 1814 }
1771 } 1815 }
1772 1816
2348 } 2392 }
2349 2393
2350 if (formal->attr.codimension) 2394 if (formal->attr.codimension)
2351 { 2395 {
2352 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */ 2396 /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
2353 /* F2015, 12.5.2.8. */ 2397 /* F2018, 12.5.2.8. */
2354 if (formal->attr.dimension 2398 if (formal->attr.dimension
2355 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) 2399 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
2356 && actual_attr.dimension 2400 && actual_attr.dimension
2357 && !gfc_is_simply_contiguous (actual, true, true)) 2401 && !gfc_is_simply_contiguous (actual, true, true))
2358 { 2402 {
2824 errors when things don't match instead of just returning the status 2868 errors when things don't match instead of just returning the status
2825 code. */ 2869 code. */
2826 2870
2827 static bool 2871 static bool
2828 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 2872 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2829 int ranks_must_agree, int is_elemental, locus *where) 2873 int ranks_must_agree, int is_elemental,
2874 bool in_statement_function, locus *where)
2830 { 2875 {
2831 gfc_actual_arglist **new_arg, *a, *actual; 2876 gfc_actual_arglist **new_arg, *a, *actual;
2832 gfc_formal_arglist *f; 2877 gfc_formal_arglist *f;
2833 int i, n, na; 2878 int i, n, na;
2834 unsigned long actual_size, formal_size; 2879 unsigned long actual_size, formal_size;
2853 f = formal; 2898 f = formal;
2854 i = 0; 2899 i = 0;
2855 2900
2856 for (a = actual; a; a = a->next, f = f->next) 2901 for (a = actual; a; a = a->next, f = f->next)
2857 { 2902 {
2903 if (a->name != NULL && in_statement_function)
2904 {
2905 gfc_error ("Keyword argument %qs at %L is invalid in "
2906 "a statement function", a->name, &a->expr->where);
2907 return false;
2908 }
2909
2858 /* Look for keywords but ignore g77 extensions like %VAL. */ 2910 /* Look for keywords but ignore g77 extensions like %VAL. */
2859 if (a->name != NULL && a->name[0] != '%') 2911 if (a->name != NULL && a->name[0] != '%')
2860 { 2912 {
2861 i = 0; 2913 i = 0;
2862 for (f = formal; f; f = f->next, i++) 2914 for (f = formal; f; f = f->next, i++)
3193 f->sym->name, &a->expr->where); 3245 f->sym->name, &a->expr->where);
3194 return false; 3246 return false;
3195 } 3247 }
3196 3248
3197 /* Check intent = OUT/INOUT for definable actual argument. */ 3249 /* Check intent = OUT/INOUT for definable actual argument. */
3198 if ((f->sym->attr.intent == INTENT_OUT 3250 if (!in_statement_function
3199 || f->sym->attr.intent == INTENT_INOUT)) 3251 && (f->sym->attr.intent == INTENT_OUT
3252 || f->sym->attr.intent == INTENT_INOUT))
3200 { 3253 {
3201 const char* context = (where 3254 const char* context = (where
3202 ? _("actual argument to INTENT = OUT/INOUT") 3255 ? _("actual argument to INTENT = OUT/INOUT")
3203 : NULL); 3256 : NULL);
3204 3257
3299 if (where) 3352 if (where)
3300 gfc_error ("Missing alternate return spec in subroutine call " 3353 gfc_error ("Missing alternate return spec in subroutine call "
3301 "at %L", where); 3354 "at %L", where);
3302 return false; 3355 return false;
3303 } 3356 }
3304 if (!f->sym->attr.optional) 3357 if (!f->sym->attr.optional
3358 || (in_statement_function && f->sym->attr.optional))
3305 { 3359 {
3306 if (where) 3360 if (where)
3307 gfc_error ("Missing actual argument for argument %qs at %L", 3361 gfc_error ("Missing actual argument for argument %qs at %L",
3308 f->sym->name, where); 3362 f->sym->name, where);
3309 return false; 3363 return false;
3587 sorted. */ 3641 sorted. */
3588 3642
3589 bool 3643 bool
3590 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) 3644 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3591 { 3645 {
3646 gfc_actual_arglist *a;
3592 gfc_formal_arglist *dummy_args; 3647 gfc_formal_arglist *dummy_args;
3593 3648
3594 /* Warn about calls with an implicit interface. Special case 3649 /* Warn about calls with an implicit interface. Special case
3595 for calling a ISO_C_BINDING because c_loc and c_funloc 3650 for calling a ISO_C_BINDING because c_loc and c_funloc
3596 are pseudo-unknown. Additionally, warn about procedures not 3651 are pseudo-unknown. Additionally, warn about procedures not
3620 sym->name, where); 3675 sym->name, where);
3621 } 3676 }
3622 3677
3623 if (sym->attr.if_source == IFSRC_UNKNOWN) 3678 if (sym->attr.if_source == IFSRC_UNKNOWN)
3624 { 3679 {
3625 gfc_actual_arglist *a;
3626
3627 if (sym->attr.pointer) 3680 if (sym->attr.pointer)
3628 { 3681 {
3629 gfc_error ("The pointer object %qs at %L must have an explicit " 3682 gfc_error ("The pointer object %qs at %L must have an explicit "
3630 "function interface or be declared as array", 3683 "function interface or be declared as array",
3631 sym->name, where); 3684 sym->name, where);
3713 return true; 3766 return true;
3714 } 3767 }
3715 3768
3716 dummy_args = gfc_sym_get_dummy_args (sym); 3769 dummy_args = gfc_sym_get_dummy_args (sym);
3717 3770
3718 if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where)) 3771 /* For a statement function, check that types and type parameters of actual
3772 arguments and dummy arguments match. */
3773 if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,
3774 sym->attr.proc == PROC_ST_FUNCTION, where))
3719 return false; 3775 return false;
3720 3776
3721 if (!check_intents (dummy_args, *ap)) 3777 if (!check_intents (dummy_args, *ap))
3722 return false; 3778 return false;
3723 3779
3724 if (warn_aliasing) 3780 if (warn_aliasing)
3725 check_some_aliasing (dummy_args, *ap); 3781 check_some_aliasing (dummy_args, *ap);
3762 3818
3763 return; 3819 return;
3764 } 3820 }
3765 3821
3766 if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, 3822 if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
3767 comp->attr.elemental, where)) 3823 comp->attr.elemental, false, where))
3768 return; 3824 return;
3769 3825
3770 check_intents (comp->ts.interface->formal, *ap); 3826 check_intents (comp->ts.interface->formal, *ap);
3771 if (warn_aliasing) 3827 if (warn_aliasing)
3772 check_some_aliasing (comp->ts.interface->formal, *ap); 3828 check_some_aliasing (comp->ts.interface->formal, *ap);
3787 return false; 3843 return false;
3788 3844
3789 dummy_args = gfc_sym_get_dummy_args (sym); 3845 dummy_args = gfc_sym_get_dummy_args (sym);
3790 3846
3791 r = !sym->attr.elemental; 3847 r = !sym->attr.elemental;
3792 if (compare_actual_formal (args, dummy_args, r, !r, NULL)) 3848 if (compare_actual_formal (args, dummy_args, r, !r, false, NULL))
3793 { 3849 {
3794 check_intents (dummy_args, *args); 3850 check_intents (dummy_args, *args);
3795 if (warn_aliasing) 3851 if (warn_aliasing)
3796 check_some_aliasing (dummy_args, *args); 3852 check_some_aliasing (dummy_args, *args);
3797 return true; 3853 return true;
4657 } 4713 }
4658 4714
4659 4715
4660 /* The following three functions check that the formal arguments 4716 /* The following three functions check that the formal arguments
4661 of user defined derived type IO procedures are compliant with 4717 of user defined derived type IO procedures are compliant with
4662 the requirements of the standard. */ 4718 the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */
4663 4719
4664 static void 4720 static void
4665 check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, 4721 check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
4666 int kind, int rank, sym_intent intent) 4722 int kind, int rank, sym_intent intent)
4667 { 4723 {
4686 else if (rank == 1 4742 else if (rank == 1
4687 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) 4743 && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
4688 gfc_error ("DTIO dummy argument at %L must be an " 4744 gfc_error ("DTIO dummy argument at %L must be an "
4689 "ASSUMED SHAPE ARRAY", &fsym->declared_at); 4745 "ASSUMED SHAPE ARRAY", &fsym->declared_at);
4690 4746
4747 if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)
4748 gfc_error ("DTIO character argument at %L must have assumed length",
4749 &fsym->declared_at);
4750
4691 if (fsym->attr.intent != intent) 4751 if (fsym->attr.intent != intent)
4692 gfc_error ("DTIO dummy argument at %L must have INTENT %s", 4752 gfc_error ("DTIO dummy argument at %L must have INTENT %s",
4693 &fsym->declared_at, gfc_code2string (intents, (int)intent)); 4753 &fsym->declared_at, gfc_code2string (intents, (int)intent));
4694 return; 4754 return;
4695 } 4755 }
4718 tb_io_proc = tb_io_st->n.tb; 4778 tb_io_proc = tb_io_st->n.tb;
4719 if (tb_io_proc == NULL) 4779 if (tb_io_proc == NULL)
4720 return; 4780 return;
4721 4781
4722 gcc_assert (tb_io_proc->is_generic); 4782 gcc_assert (tb_io_proc->is_generic);
4723 gcc_assert (tb_io_proc->u.generic->next == NULL);
4724 4783
4725 specific_proc = tb_io_proc->u.generic->specific; 4784 specific_proc = tb_io_proc->u.generic->specific;
4726 if (specific_proc == NULL || specific_proc->is_generic) 4785 if (specific_proc == NULL || specific_proc->is_generic)
4727 return; 4786 return;
4728 4787