diff options
Diffstat (limited to 'gcc/fortran/intrinsic.c')
| -rw-r--r-- | gcc/fortran/intrinsic.c | 91 |
1 files changed, 81 insertions, 10 deletions
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 6096686..17978c1 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -60,17 +60,22 @@ enum klass /* Return a letter based on the passed type. Used to construct the - name of a type-dependent subroutine. */ + name of a type-dependent subroutine. If logical_equals_int is + true, we can treat a logical like an int. */ char -gfc_type_letter (bt type) +gfc_type_letter (bt type, bool logical_equals_int) { char c; switch (type) { case BT_LOGICAL: - c = 'l'; + if (logical_equals_int) + c = 'i'; + else + c = 'l'; + break; case BT_CHARACTER: c = 's'; @@ -683,8 +688,8 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty } -/* MINLOC and MAXLOC get special treatment because their argument - might have to be reordered. */ +/* MINLOC and MAXLOC get special treatment because their + argument might have to be reordered. */ static void add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, @@ -717,6 +722,42 @@ add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt (void *) 0); } +/* Similar for FINDLOC. */ + +static void +add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4, + const char *a5, bt type5, int kind5, int optional5, + const char *a6, bt type6, int kind6, int optional6) + +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f6fl = check; + sf.f6 = simplify; + rf.f6 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + a5, type5, kind5, optional5, INTENT_IN, + a6, type6, kind6, optional6, INTENT_IN, + (void *) 0); +} + /* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because their argument also might have to be reordered. */ @@ -1248,7 +1289,8 @@ add_functions (void) *sta = "string_a", *stb = "string_b", *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", - *vb = "vector_b", *vl = "values", *x = "x", *y = "y", *z = "z"; + *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", + *z = "z"; int di, dr, dd, dl, dc, dz, ii; @@ -2476,6 +2518,15 @@ add_functions (void) make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); + add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc, + ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008); + add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, @@ -4279,7 +4330,7 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, static void resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) { - gfc_expr *a1, *a2, *a3, *a4, *a5; + gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; gfc_actual_arglist *arg; if (specific->resolve.f1 == NULL) @@ -4353,6 +4404,15 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) return; } + a6 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6); + return; + } + gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic"); } @@ -4366,7 +4426,7 @@ resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) static bool do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) { - gfc_expr *result, *a1, *a2, *a3, *a4, *a5; + gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6; gfc_actual_arglist *arg; /* Max and min require special handling due to the variable number @@ -4447,8 +4507,17 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) if (arg == NULL) result = (*specific->simplify.f5) (a1, a2, a3, a4, a5); else - gfc_internal_error - ("do_simplify(): Too many args for intrinsic"); + { + a6 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f6) + (a1, a2, a3, a4, a5, a6); + else + gfc_internal_error + ("do_simplify(): Too many args for intrinsic"); + } } } } @@ -4528,6 +4597,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) if (specific->check.f5ml == gfc_check_minloc_maxloc) /* This is special because we might have to reorder the argument list. */ t = gfc_check_minloc_maxloc (*ap); + else if (specific->check.f6fl == gfc_check_findloc) + t = gfc_check_findloc (*ap); else if (specific->check.f3red == gfc_check_minval_maxval) /* This is also special because we also might have to reorder the argument list. */ |