X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fintrinsic.c;h=494b8165584bb03d91baca431aba8fefa5790924;hp=6088a8d80fa30bba6f7c45688eac3b50695b394b;hb=6ff06d363f15102bf83a04bd7228a7fc13230995;hpb=2702253ad9c6e726ee9776a53a1ffbcc7d7ff89b diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 6088a8d80fa..494b8165584 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1,6 +1,7 @@ /* Build up a list of intrinsic subroutines and functions for the name-resolution stage. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb @@ -1008,8 +1009,6 @@ make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED) while (g->name != NULL) { - gcc_assert (g->id == id); - g->next = g + 1; g->specific = 1; g++; @@ -1082,7 +1081,8 @@ add_functions (void) *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b", *z = "z", *ln = "len", *ut = "unit", *han = "handler", *num = "number", *tm = "time", *nm = "name", *md = "mode", - *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command"; + *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command", + *ca = "coarray", *sub = "sub"; int di, dr, dd, dl, dc, dz, ii; @@ -1134,7 +1134,7 @@ add_functions (void) make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos, + gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -1144,7 +1144,7 @@ add_functions (void) make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77); add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_acosh, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh, gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, @@ -1189,7 +1189,7 @@ add_functions (void) make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77); add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, NULL, gfc_resolve_all, + gfc_check_all_any, gfc_simplify_all, gfc_resolve_all, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95); @@ -1211,13 +1211,13 @@ add_functions (void) make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77); add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, NULL, gfc_resolve_any, + gfc_check_all_any, gfc_simplify_any, gfc_resolve_any, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95); add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin, + gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -1227,7 +1227,7 @@ add_functions (void) make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77); add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_asinh, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh, gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, @@ -1243,17 +1243,22 @@ add_functions (void) make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95); add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan, + gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan, x, BT_REAL, dr, REQUIRED); add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan, x, BT_REAL, dd, REQUIRED); + /* Two-argument version of atan, equivalent to atan2. */ + add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, + gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); + make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77); add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_atanh, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh, gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, @@ -1440,7 +1445,7 @@ add_functions (void) make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77); add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh, + gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -1451,7 +1456,7 @@ add_functions (void) add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_count, NULL, gfc_resolve_count, + gfc_check_count, gfc_simplify_count, gfc_resolve_count, msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); @@ -1596,6 +1601,12 @@ add_functions (void) make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95); + add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, + ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of, + a, BT_UNKNOWN, 0, REQUIRED, + mo, BT_UNKNOWN, 0, REQUIRED); + add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); @@ -1656,15 +1667,15 @@ add_functions (void) make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU); - add_sym_1 ("gamma", GFC_ISYM_GAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma, gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED); - add_sym_1 ("dgamma", GFC_ISYM_GAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED); - make_generic ("gamma", GFC_ISYM_GAMMA, GFC_STD_F2008); + make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008); /* Unix IDs (g77 compatibility) */ add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, @@ -1774,6 +1785,10 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); + add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_image_index, gfc_simplify_image_index, NULL, + ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, @@ -1845,18 +1860,21 @@ add_functions (void) add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_i, NULL, NULL, i, BT_INTEGER, 0, REQUIRED); + gfc_check_i, gfc_simplify_is_iostat_end, NULL, + i, BT_INTEGER, 0, REQUIRED); make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003); add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_i, NULL, NULL, i, BT_INTEGER, 0, REQUIRED); + gfc_check_i, gfc_simplify_is_iostat_eor, NULL, + i, BT_INTEGER, 0, REQUIRED); make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003); - add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, - dl, GFC_STD_GNU, gfc_check_isnan, NULL, NULL, + add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_GNU, + gfc_check_isnan, gfc_simplify_isnan, NULL, x, BT_REAL, 0, REQUIRED); make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU); @@ -1906,6 +1924,14 @@ add_functions (void) make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); + add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_lcobound, gfc_simplify_lcobound, NULL, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F95); + add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_i, gfc_simplify_leadz, NULL, @@ -2208,6 +2234,9 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); + add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + NULL, gfc_simplify_num_images, NULL); + add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, @@ -2228,7 +2257,7 @@ add_functions (void) make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95); add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, NULL, gfc_resolve_product, + gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); @@ -2301,6 +2330,12 @@ add_functions (void) make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); + add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, NULL, NULL, + a, BT_UNKNOWN, 0, REQUIRED, + b, BT_UNKNOWN, 0, REQUIRED); + add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); @@ -2402,7 +2437,7 @@ add_functions (void) make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77); add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh, + gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2433,7 +2468,7 @@ add_functions (void) make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95); add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_spread, NULL, gfc_resolve_spread, + gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread, src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED); @@ -2466,7 +2501,7 @@ add_functions (void) make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, NULL, gfc_resolve_sum, + gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL); @@ -2485,7 +2520,7 @@ add_functions (void) make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU); add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan, + gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2495,7 +2530,7 @@ add_functions (void) make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77); add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh, + gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, @@ -2504,6 +2539,10 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); + add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_this_image, gfc_simplify_this_image, NULL, + ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); + add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); @@ -2560,6 +2599,14 @@ add_functions (void) make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); + add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_ucobound, gfc_simplify_ucobound, NULL, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F95); + /* g77 compatibility for UMASK. */ add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, @@ -2575,7 +2622,7 @@ add_functions (void) make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU); add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_unpack, NULL, gfc_resolve_unpack, + gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack, v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, f, BT_REAL, dr, REQUIRED); @@ -3245,7 +3292,7 @@ keywords: if (f->actual != NULL) { - gfc_error ("Argument '%s' is appears twice in call to '%s' at %L", + gfc_error ("Argument '%s' appears twice in call to '%s' at %L", f->name, name, where); return FAILURE; } @@ -3617,14 +3664,13 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) first_expr = arg->expr; for ( ; arg && arg->expr; arg = arg->next, n++) - { - char buffer[80]; - snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'", - gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n], - gfc_current_intrinsic); - if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE) - return FAILURE; - } + if (gfc_check_conformance (first_expr, arg->expr, + "arguments '%s' and '%s' for " + "intrinsic '%s'", + gfc_current_intrinsic_arg[0], + gfc_current_intrinsic_arg[n], + gfc_current_intrinsic) == FAILURE) + return FAILURE; } if (t == FAILURE) @@ -3992,6 +4038,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag) new_expr->shape = gfc_copy_shape (shape, rank); gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); + new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; new_expr->symtree->n.sym->ts = *ts; new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; new_expr->symtree->n.sym->attr.function = 1; @@ -4036,14 +4083,12 @@ gfc_try gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) { gfc_intrinsic_sym *sym; - gfc_typespec from_ts; locus old_where; gfc_expr *new_expr; int rank; mpz_t *shape; gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); - from_ts = expr->ts; /* expr->ts gets clobbered */ sym = find_char_conv (&expr->ts, ts); gcc_assert (sym);