diff options
Diffstat (limited to 'gcc/fortran/intrinsic.cc')
| -rw-r--r-- | gcc/fortran/intrinsic.cc | 65 |
1 files changed, 60 insertions, 5 deletions
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 30f532b..d2ce74f 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -331,7 +331,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) static bool do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) { - gfc_expr *a1, *a2, *a3, *a4, *a5; + gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; if (arg == NULL) return (*specific->check.f0) (); @@ -361,6 +361,11 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) if (arg == NULL) return (*specific->check.f5) (a1, a2, a3, a4, a5); + a6 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f6) (a1, a2, a3, a4, a5, a6); + gfc_internal_error ("do_check(): too many args"); } @@ -838,6 +843,44 @@ add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, } +/* Add a symbol to the function list where the function takes + 6 arguments. */ + +static void +add_sym_6 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + 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.f6 = 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. */ @@ -1358,13 +1401,13 @@ add_functions (void) *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", *dist = "distance", *dm = "dim", *f = "field", *failed="failed", *fs = "fsource", *han = "handler", *i = "i", - *image = "image", *j = "j", *kind = "kind", + *idy = "identity", *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", - *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2", - *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer", - *r = "r", *rd = "round", + *op = "operation", *ord = "order", *odd = "ordered", *p = "p", + *p1 = "path1", *p2 = "path2", *pad = "pad", *pid = "pid", *pos = "pos", + *pt = "pointer", *r = "r", *rd = "round", *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig", *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b", *stg = "string", @@ -2936,6 +2979,18 @@ add_functions (void) make_generic ("sngl", GFC_ISYM_SNGL, GFC_STD_F77); + add_sym_6 ("reduce", GFC_ISYM_REDUCE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F2018, + gfc_check_reduce, NULL, gfc_resolve_reduce, + ar, BT_REAL, dr, REQUIRED, + op, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, di, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL, + idy, BT_REAL, dr, OPTIONAL, + odd, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("reduce", GFC_ISYM_REDUCE, GFC_STD_F2018); + add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); |