Skip to content

R
riscv-gcc-1
Commit 01ce9e31 by Thomas Koenig
Options

re PR fortran/54613 ([F08] Add FINDLOC plus support MAXLOC/MINLOC with KIND=/BACK=) 

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_FINDLOC.
	(gfc_check_f): Add f6fl field.
	(gfc_simplify_f): Add f6 field.
	(gfc_resolve_f): Likewise.
	(gfc_type_letter): Add optional logical_equas_int flag.
	* check.c (intrinsic_type_check): New function.
	(gfc_check_findloc): New function.
	* intrinsics.c (gfc_type_letter): If logical_equals_int is
	set, act accordingly.
	(add_sym_5ml):  Reformat comment.
	(add_sym_6fl): New function.
	(add_functions): Add findloc.
	(check_arglist): Add sixth argument, handle it.
	(resolve_intrinsic): Likewise.
	(check_specific): Handle findloc.
	* intrinsic.h (gfc_check_findloc): Add prototype.
	(gfc_simplify_findloc): Likewise.
	(gfc_resolve_findloc): Likewise.
	(MAX_INTRINSIC_ARGS): Adjust.
	* iresolve.c (gfc_resolve_findloc): New function.
	* simplify.c (gfc_simplify_minmaxloc): Make static.
	(simplify_findloc_to_scalar): New function.
	(simplify_findloc_nodim): New function.
	(simplify_findloc_to_array): New function.
	(gfc_simplify_findloc): New function.
	(gfc_conv_intrinsic_findloc): New function.
	(gfc_conv_intrinsic_function): Handle GFC_ISYM_FINDLOC.
	(gfc_is_intrinsic_libcall): Likewise.

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* Makefile.am: Add files for findloc.
	* Makefile.in: Regenerated.
	* libgfortran.h (gfc_array_index_type): Add.
	(gfc_array_s1): Add using GFC_UINTEGER_1.
	(gfc_array_s4): Likewise.
	Replace unnecessary comment.
	(HAVE_GFC_UINTEGER_1): Define.
	(HAVE_GFC_UINTEGER_4): Define.
	* m4/findloc0.m4: New file.
	* m4/findloc0s.m4: New file.
	* m4/findloc1.m4: New file.
	* m4/findloc1s.m4: New file.
	* m4/findloc2s.m4: New file.
	* m4/ifindloc0.m4: New file.
	* m4/ifindloc1.m4: New file.
	* m4/ifindloc2.m4: New file.
	* m4/iparm.m4: Use unsigned integer for characters.
        * generated/findloc0_c16.c: New file.
        * generated/findloc0_c4.c: New file.
        * generated/findloc0_c8.c: New file.
        * generated/findloc0_i1.c: New file.
        * generated/findloc0_i16.c: New file.
        * generated/findloc0_i2.c: New file.
        * generated/findloc0_i4.c: New file.
        * generated/findloc0_i8.c: New file.
        * generated/findloc0_r16.c: New file.
        * generated/findloc0_r4.c: New file.
        * generated/findloc0_r8.c: New file.
        * generated/findloc0_s1.c: New file.
        * generated/findloc0_s4.c: New file.
        * generated/findloc1_c16.c: New file.
        * generated/findloc1_c4.c: New file.
        * generated/findloc1_c8.c: New file.
        * generated/findloc1_i1.c: New file.
        * generated/findloc1_i16.c: New file.
        * generated/findloc1_i2.c: New file.
        * generated/findloc1_i4.c: New file.
        * generated/findloc1_i8.c: New file.
        * generated/findloc1_r16.c: New file.
        * generated/findloc1_r4.c: New file.
        * generated/findloc1_r8.c: New file.
        * generated/findloc1_s1.c: New file.
        * generated/findloc1_s4.c: New file.
        * generated/findloc2_s1.c: New file.
        * generated/findloc2_s4.c: New file.
        * generated/maxloc0_16_s1.c: Regenerated.
        * generated/maxloc0_16_s4.c: Regenerated.
        * generated/maxloc0_4_s1.c: Regenerated.
        * generated/maxloc0_4_s4.c: Regenerated.
        * generated/maxloc0_8_s1.c: Regenerated.
        * generated/maxloc0_8_s4.c: Regenerated.
        * generated/maxloc1_16_s1.c: Regenerated.
        * generated/maxloc1_16_s4.c: Regenerated.
        * generated/maxloc1_4_s1.c: Regenerated.
        * generated/maxloc1_4_s4.c: Regenerated.
        * generated/maxloc1_8_s1.c: Regenerated.
        * generated/maxloc1_8_s4.c: Regenerated.
        * generated/maxloc2_16_s1.c: Regenerated.
        * generated/maxloc2_16_s4.c: Regenerated.
        * generated/maxloc2_4_s1.c: Regenerated.
        * generated/maxloc2_4_s4.c: Regenerated.
        * generated/maxloc2_8_s1.c: Regenerated.
        * generated/maxloc2_8_s4.c: Regenerated.
        * generated/maxval0_s1.c: Regenerated.
        * generated/maxval0_s4.c: Regenerated.
        * generated/maxval1_s1.c: Regenerated.
        * generated/maxval1_s4.c: Regenerated.
        * generated/minloc0_16_s1.c: Regenerated.
        * generated/minloc0_16_s4.c: Regenerated.
        * generated/minloc0_4_s1.c: Regenerated.
        * generated/minloc0_4_s4.c: Regenerated.
        * generated/minloc0_8_s1.c: Regenerated.
        * generated/minloc0_8_s4.c: Regenerated.
        * generated/minloc1_16_s1.c: Regenerated.
        * generated/minloc1_16_s4.c: Regenerated.
        * generated/minloc1_4_s1.c: Regenerated.
        * generated/minloc1_4_s4.c: Regenerated.
        * generated/minloc1_8_s1.c: Regenerated.
        * generated/minloc1_8_s4.c: Regenerated.
        * generated/minloc2_16_s1.c: Regenerated.
        * generated/minloc2_16_s4.c: Regenerated.
        * generated/minloc2_4_s1.c: Regenerated.
        * generated/minloc2_4_s4.c: Regenerated.
        * generated/minloc2_8_s1.c: Regenerated.
        * generated/minloc2_8_s4.c: Regenerated.
        * generated/minval0_s1.c: Regenerated.
        * generated/minval0_s4.c: Regenerated.
        * generated/minval1_s1.c: Regenerated.
        * generated/minval1_s4.c: Regenerated.

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* gfortran.dg/findloc_1.f90: New test.
	* gfortran.dg/findloc_2.f90: New test.
	* gfortran.dg/findloc_3.f90: New test.
	* gfortran.dg/findloc_4.f90: New test.
	* gfortran.dg/findloc_5.f90: New test.
	* gfortran.dg/findloc_6.f90: New test.

From-SVN: r265570
parent b10fb078
Showing with 4837 additions and 18 deletions
gcc/fortran/ChangeLog
2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/54613
* gfortran.h (gfc_isym_id): Add GFC_ISYM_FINDLOC.
(gfc_check_f): Add f6fl field.
(gfc_simplify_f): Add f6 field.
(gfc_resolve_f): Likewise.
(gfc_type_letter): Add optional logical_equas_int flag.
* check.c (intrinsic_type_check): New function.
(gfc_check_findloc): New function.
* intrinsics.c (gfc_type_letter): If logical_equals_int is
set, act accordingly.
(add_sym_5ml): Reformat comment.
(add_sym_6fl): New function.
(add_functions): Add findloc.
(check_arglist): Add sixth argument, handle it.
(resolve_intrinsic): Likewise.
(check_specific): Handle findloc.
* intrinsic.h (gfc_check_findloc): Add prototype.
(gfc_simplify_findloc): Likewise.
(gfc_resolve_findloc): Likewise.
(MAX_INTRINSIC_ARGS): Adjust.
* iresolve.c (gfc_resolve_findloc): New function.
* simplify.c (gfc_simplify_minmaxloc): Make static.
(simplify_findloc_to_scalar): New function.
(simplify_findloc_nodim): New function.
(simplify_findloc_to_array): New function.
(gfc_simplify_findloc): New function.
(gfc_conv_intrinsic_findloc): New function.
(gfc_conv_intrinsic_function): Handle GFC_ISYM_FINDLOC.
(gfc_is_intrinsic_libcall): Likewise.
2018-10-27 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/86907
......
gcc/fortran/check.c
......@@ -148,6 +148,21 @@ int_or_real_or_char_check_f2003 (gfc_expr *e, int n)
return true;
}
/* Check that an expression is an intrinsic type. */
static bool
intrinsic_type_check (gfc_expr *e, int n)
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
&& e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
&& e->ts.type != BT_LOGICAL)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
gfc_current_intrinsic_arg[n]->name,
gfc_current_intrinsic, &e->where);
return false;
}
return true;
}
/* Check that an expression is real or complex. */
......@@ -3345,6 +3360,82 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
return true;
}
/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
above, with the additional "value" argument. */
bool
gfc_check_findloc (gfc_actual_arglist *ap)
{
gfc_expr *a, *v, *m, *d, *k, *b;
a = ap->expr;
if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
return false;
v = ap->next->expr;
if (!scalar_check (v,1))
return false;
/* Check if the type is compatible. */
if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
|| (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
{
gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
"conformance to argument %qs at %L",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic, &a->where,
gfc_current_intrinsic_arg[1]->name, &v->where);
}
d = ap->next->next->expr;
m = ap->next->next->next->expr;
k = ap->next->next->next->next->expr;
b = ap->next->next->next->next->next->expr;
if (b)
{
if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
return false;
}
else
{
b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
ap->next->next->next->next->next->expr = b;
}
if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
&& ap->next->name == NULL)
{
m = d;
d = NULL;
ap->next->next->expr = NULL;
ap->next->next->next->expr = m;
}
if (!dim_check (d, 2, false))
return false;
if (!dim_rank_check (d, a, 0))
return false;
if (m != NULL && !type_check (m, 3, BT_LOGICAL))
return false;
if (m != NULL
&& !gfc_check_conformance (a, m,
"arguments '%s' and '%s' for intrinsic %s",
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic))
return false;
if (!kind_check (k, 1, BT_INTEGER))
return false;
return true;
}
/* Similar to minloc/maxloc, the argument list might need to be
reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
......
gcc/fortran/expr.c
......@@ -2509,6 +2509,13 @@ check_transformational (gfc_expr *e)
"trim", "unpack", NULL
};
static const char * const trans_func_f2008[] = {
"all", "any", "count", "dot_product", "matmul", "null", "pack",
"product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
"selected_real_kind", "spread", "sum", "transfer", "transpose",
"trim", "unpack", "findloc", NULL
};
int i;
const char *name;
const char *const *functions;
......@@ -2519,8 +2526,12 @@ check_transformational (gfc_expr *e)
name = e->symtree->n.sym->name;
functions = (gfc_option.allow_std & GFC_STD_F2003)
? trans_func_f2003 : trans_func_f95;
if (gfc_option.allow_std & GFC_STD_F2008)
functions = trans_func_f2008;
else if (gfc_option.allow_std & GFC_STD_F2003)
functions = trans_func_f2003;
else
functions = trans_func_f95;
/* NULL() is dealt with below. */
if (strcmp ("null", name) == 0)
......
gcc/fortran/gfortran.h
......@@ -437,6 +437,7 @@ enum gfc_isym_id
GFC_ISYM_FE_RUNTIME_ERROR,
GFC_ISYM_FGET,
GFC_ISYM_FGETC,
GFC_ISYM_FINDLOC,
GFC_ISYM_FLOOR,
GFC_ISYM_FLUSH,
GFC_ISYM_FNUM,
......@@ -2001,6 +2002,7 @@ typedef union
bool (*f2)(struct gfc_expr *, struct gfc_expr *);
bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
bool (*f5ml)(gfc_actual_arglist *);
bool (*f6fl)(gfc_actual_arglist *);
bool (*f3red)(gfc_actual_arglist *);
bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
......@@ -2025,6 +2027,9 @@ typedef union
struct gfc_expr *(*f5)(struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
struct gfc_expr *(*f6)(struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *);
struct gfc_expr *(*cc)(struct gfc_expr *, bt, int);
}
gfc_simplify_f;
......@@ -2045,6 +2050,9 @@ typedef union
struct gfc_expr *, struct gfc_expr *);
void (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *, struct gfc_expr *);
void (*f6)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *, struct gfc_expr *, struct gfc_expr *,
struct gfc_expr *);
void (*s1)(struct gfc_code *);
}
gfc_resolve_f;
......@@ -2149,6 +2157,11 @@ typedef struct gfc_expr
unsigned int external_blas : 1;
/* Set this if resolution has already happened. It could be harmful
if done again. */
unsigned int do_not_resolve_again : 1;
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
......@@ -3094,7 +3107,7 @@ extern bool gfc_init_expr_flag;
void gfc_intrinsic_init_1 (void);
void gfc_intrinsic_done_1 (void);
char gfc_type_letter (bt);
char gfc_type_letter (bt, bool logical_equals_int = false);
gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
......
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. */
......
gcc/fortran/intrinsic.h
......@@ -74,6 +74,7 @@ bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_failed_or_stopped_images (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_findloc (gfc_actual_arglist *);
bool gfc_check_float (gfc_expr *);
bool gfc_check_fstat (gfc_expr *, gfc_expr *);
bool gfc_check_ftell (gfc_expr *);
......@@ -299,6 +300,8 @@ gfc_expr *gfc_simplify_exp (gfc_expr *);
gfc_expr *gfc_simplify_exponent (gfc_expr *);
gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_failed_or_stopped_images (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_findloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_float (gfc_expr *);
gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_fraction (gfc_expr *);
......@@ -488,6 +491,8 @@ void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_failed_images (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fdate (gfc_expr *);
void gfc_resolve_findloc (gfc_expr *,gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
void gfc_resolve_fraction (gfc_expr *, gfc_expr *);
......@@ -670,9 +675,9 @@ void gfc_resolve_umask_sub (gfc_code *);
void gfc_resolve_unlink_sub (gfc_code *);
/* The mvbits() subroutine requires the most arguments: five. */
/* The findloc() subroutine requires the most arguments: six. */
#define MAX_INTRINSIC_ARGS 5
#define MAX_INTRINSIC_ARGS 6
extern const char *gfc_current_intrinsic;
extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
......
gcc/fortran/iresolve.c
......@@ -1784,6 +1784,115 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
void
gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value,
gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
gfc_expr *back)
{
const char *name;
int i, j, idim;
int fkind;
int d_num;
/* See at the end of the function for why this is necessary. */
if (f->do_not_resolve_again)
return;
f->ts.type = BT_INTEGER;
/* We have a single library version, which uses index_type. */
if (kind)
fkind = mpz_get_si (kind->value.integer);
else
fkind = gfc_default_integer_kind;
f->ts.kind = gfc_index_integer_kind;
/* Convert value. If array is not LOGICAL and value is, we already
issued an error earlier. */
if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
|| array->ts.kind != value->ts.kind)
gfc_convert_type_warn (value, &array->ts, 2, 0);
if (dim == NULL)
{
f->rank = 1;
f->shape = gfc_get_shape (1);
mpz_init_set_si (f->shape[0], array->rank);
}
else
{
f->rank = array->rank - 1;
gfc_resolve_dim_arg (dim);
if (array->shape && dim->expr_type == EXPR_CONSTANT)
{
idim = (int) mpz_get_si (dim->value.integer);
f->shape = gfc_get_shape (f->rank);
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
}
if (mask)
{
if (mask->rank == 0)
name = "sfindloc";
else
name = "mfindloc";
resolve_mask_arg (mask);
}
else
name = "findloc";
if (dim)
{
if (f->rank > 0)
d_num = 1;
else
d_num = 2;
}
else
d_num = 0;
if (back->ts.kind != gfc_logical_4_kind)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_LOGICAL;
ts.kind = gfc_logical_4_kind;
gfc_convert_type_warn (back, &ts, 2, 0);
}
f->value.function.name
= gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
gfc_type_letter (array->ts.type, true), array->ts.kind);
/* We only have a single library function, so we need to convert
here. If the function is resolved from within a convert
function generated on a previous round of resolution, endless
recursion could occur. Guard against that here. */
if (f->ts.kind != fkind)
{
f->do_not_resolve_again = 1;
gfc_typespec ts;
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
ts.kind = fkind;
gfc_convert_type_warn (f, &ts, 2, 0);
}
}
void
gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask)
{
......
gcc/fortran/simplify.c
......@@ -5372,7 +5372,7 @@ simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
/* Simplify minloc and maxloc for constant arrays. */
gfc_expr *
static gfc_expr *
gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
gfc_expr *kind, gfc_expr *back, int sign)
{
......@@ -5452,6 +5452,358 @@ gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *k
return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
}
/* Simplify findloc to scalar. Similar to
simplify_minmaxloc_to_scalar. */
static gfc_expr *
simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
gfc_expr *mask, int back_val)
{
gfc_expr *a, *m;
gfc_constructor *array_ctor, *mask_ctor;
mpz_t count;
mpz_set_si (result->value.integer, 0);
/* Shortcut for constant .FALSE. MASK. */
if (mask
&& mask->expr_type == EXPR_CONSTANT
&& !mask->value.logical)
return result;
array_ctor = gfc_constructor_first (array->value.constructor);
if (mask && mask->expr_type == EXPR_ARRAY)
mask_ctor = gfc_constructor_first (mask->value.constructor);
else
mask_ctor = NULL;
mpz_init_set_si (count, 0);
while (array_ctor)
{
mpz_add_ui (count, count, 1);
a = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
/* A constant MASK equals .TRUE. here and can be ignored. */
if (mask_ctor)
{
m = mask_ctor->expr;
mask_ctor = gfc_constructor_next (mask_ctor);
if (!m->value.logical)
continue;
}
if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
{
/* We have a match. If BACK is true, continue so we find
the last one. */
mpz_set (result->value.integer, count);
if (!back_val)
break;
}
}
mpz_clear (count);
return result;
}
/* Simplify findloc in the absence of a dim argument. Similar to
simplify_minmaxloc_nodim. */
static gfc_expr *
simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
gfc_expr *mask, bool back_val)
{
ssize_t res[GFC_MAX_DIMENSIONS];
int i, n;
gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
sstride[GFC_MAX_DIMENSIONS];
gfc_expr *a, *m;
bool continue_loop;
bool ma;
for (i = 0; i<array->rank; i++)
res[i] = -1;
/* Shortcut for constant .FALSE. MASK. */
if (mask
&& mask->expr_type == EXPR_CONSTANT
&& !mask->value.logical)
goto finish;
for (i = 0; i < array->rank; i++)
{
count[i] = 0;
sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
extent[i] = mpz_get_si (array->shape[i]);
if (extent[i] <= 0)
goto finish;
}
continue_loop = true;
array_ctor = gfc_constructor_first (array->value.constructor);
if (mask && mask->rank > 0)
mask_ctor = gfc_constructor_first (mask->value.constructor);
else
mask_ctor = NULL;
/* Loop over the array elements (and mask), keeping track of
the indices to return. */
while (continue_loop)
{
do
{
a = array_ctor->expr;
if (mask_ctor)
{
m = mask_ctor->expr;
ma = m->value.logical;
mask_ctor = gfc_constructor_next (mask_ctor);
}
else
ma = true;
if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
{
for (i = 0; i<array->rank; i++)
res[i] = count[i];
if (!back_val)
goto finish;
}
array_ctor = gfc_constructor_next (array_ctor);
count[0] ++;
} while (count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
n++;
if (n >= array->rank)
{
continue_loop = false;
break;
}
else
count[n] ++;
} while (count[n] == extent[n]);
}
finish:
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i<array->rank; i++)
{
gfc_expr *r_expr;
r_expr = result_ctor->expr;
mpz_set_si (r_expr->value.integer, res[i] + 1);
result_ctor = gfc_constructor_next (result_ctor);
}
return result;
}
/* Simplify findloc to an array. Similar to
simplify_minmaxloc_to_array. */
static gfc_expr *
simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
gfc_expr *dim, gfc_expr *mask, bool back_val)
{
mpz_t size;
int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
tmpstride[GFC_MAX_DIMENSIONS];
/* Shortcut for constant .FALSE. MASK. */
if (mask
&& mask->expr_type == EXPR_CONSTANT
&& !mask->value.logical)
return result;
/* Build an indexed table for array element expressions to minimize
linked-list traversal. Masked elements are set to NULL. */
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
mpz_clear (size);
arrayvec = XCNEWVEC (gfc_expr*, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
mask_ctor = gfc_constructor_first (mask->value.constructor);
for (i = 0; i < arraysize; ++i)
{
arrayvec[i] = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
if (mask_ctor)
{
if (!mask_ctor->expr->value.logical)
arrayvec[i] = NULL;
mask_ctor = gfc_constructor_next (mask_ctor);
}
}
/* Same for the result expression. */
gfc_array_size (result, &size);
resultsize = mpz_get_ui (size);
mpz_clear (size);
resultvec = XCNEWVEC (gfc_expr*, resultsize);
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
resultvec[i] = result_ctor->expr;
result_ctor = gfc_constructor_next (result_ctor);
}
gfc_extract_int (dim, &dim_index);
dim_index -= 1; /* Zero-base index. */
dim_extent = 0;
dim_stride = 0;
for (i = 0, n = 0; i < array->rank; ++i)
{
count[i] = 0;
tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
if (i == dim_index)
{
dim_extent = mpz_get_si (array->shape[i]);
dim_stride = tmpstride[i];
continue;
}
extent[n] = mpz_get_si (array->shape[i]);
sstride[n] = tmpstride[i];
dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
n += 1;
}
done = resultsize <= 0;
base = arrayvec;
dest = resultvec;
while (!done)
{
for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
{
if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
{
mpz_set_si ((*dest)->value.integer, n + 1);
if (!back_val)
break;
}
}
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (!done && count[n] == extent[n])
{
count[n] = 0;
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n < result->rank)
{
/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
times, we'd warn for the last iteration, because the
array index will have already been incremented to the
array sizes, and we can't tell that this must make
the test against result->rank false, because ranks
must not exceed GFC_MAX_DIMENSIONS. */
GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
count[n]++;
base += sstride[n];
dest += dstride[n];
GCC_DIAGNOSTIC_POP
}
else
done = true;
}
}
/* Place updated expression in result constructor. */
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor->expr = resultvec[i];
result_ctor = gfc_constructor_next (result_ctor);
}
free (arrayvec);
free (resultvec);
return result;
}
/* Simplify findloc. */
gfc_expr *
gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
{
gfc_expr *result;
int ikind;
bool back_val = false;
if (!is_constant_array_expr (array)
|| !gfc_is_constant_expr (dim))
return NULL;
if (! gfc_is_constant_expr (value))
return 0;
if (mask
&& !is_constant_array_expr (mask)
&& mask->expr_type != EXPR_CONSTANT)
return NULL;
if (kind)
{
if (gfc_extract_int (kind, &ikind, -1))
return NULL;
}
else
ikind = gfc_default_integer_kind;
if (back)
{
if (back->expr_type != EXPR_CONSTANT)
return NULL;
back_val = back->value.logical;
}
if (dim)
{
result = transformational_result (array, dim, BT_INTEGER,
ikind, &array->where);
init_result_expr (result, 0, array);
if (array->rank == 1)
return simplify_findloc_to_scalar (result, array, value, mask,
back_val);
else
return simplify_findloc_to_array (result, array, value, dim, mask,
back_val);
}
else
{
result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
return simplify_findloc_nodim (result, value, array, mask, back_val);
}
return NULL;
}
gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
......
gcc/fortran/trans-intrinsic.c
......@@ -5177,6 +5177,219 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
se->expr = convert (type, pos);
}
/* Emit code for findloc. */
static void
gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
*kind_arg, *back_arg;
gfc_expr *value_expr;
int ikind;
tree resvar;
stmtblock_t block;
stmtblock_t body;
stmtblock_t loopblock;
tree type;
tree tmp;
tree found;
tree forward_branch;
tree back_branch;
gfc_loopinfo loop;
gfc_ss *arrayss;
gfc_ss *maskss;
gfc_se arrayse;
gfc_se valuese;
gfc_se maskse;
gfc_se backse;
tree exit_label;
gfc_expr *maskexpr;
tree offset;
int i;
array_arg = expr->value.function.actual;
value_arg = array_arg->next;
dim_arg = value_arg->next;
mask_arg = dim_arg->next;
kind_arg = mask_arg->next;
back_arg = kind_arg->next;
/* Remove kind and set ikind. */
if (kind_arg->expr)
{
ikind = mpz_get_si (kind_arg->expr->value.integer);
gfc_free_expr (kind_arg->expr);
kind_arg->expr = NULL;
}
else
ikind = gfc_default_integer_kind;
value_expr = value_arg->expr;
/* Unless it's a string, pass VALUE by value. */
if (value_expr->ts.type != BT_CHARACTER)
value_arg->name = "%VAL";
/* Pass BACK argument by value. */
back_arg->name = "%VAL";
/* Call the library if we have a character function or if
rank > 0. */
if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
{
se->ignore_optional = 1;
if (expr->rank == 0)
{
/* Remove dim argument. */
gfc_free_expr (dim_arg->expr);
dim_arg->expr = NULL;
}
gfc_conv_intrinsic_funcall (se, expr);
return;
}
type = gfc_get_int_type (ikind);
/* Initialize the result. */
resvar = gfc_create_var (gfc_array_index_type, "pos");
gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
offset = gfc_create_var (gfc_array_index_type, "offset");
maskexpr = mask_arg->expr;
/* Generate two loops, one for BACK=.true. and one for BACK=.false. */
for (i = 0 ; i < 2; i++)
{
/* Walk the arguments. */
arrayss = gfc_walk_expr (array_arg->expr);
gcc_assert (arrayss != gfc_ss_terminator);
if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
maskss = NULL;
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
exit_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (exit_label) = 1;
gfc_add_ss_to_loop (&loop, arrayss);
if (maskss)
gfc_add_ss_to_loop (&loop, maskss);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
/* Calculate the offset. */
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, loop.from[0]);
gfc_add_modify (&loop.pre, offset, tmp);
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
/* The first loop is for BACK=.true. */
if (i == 0)
loop.reverse[0] = GFC_REVERSE_SET;
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
/* If we have an array mask, only add the element if it is
set. */
if (maskss)
{
gfc_init_se (&maskse, NULL);
gfc_copy_loopinfo_to_se (&maskse, &loop);
maskse.ss = maskss;
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&body, &maskse.pre);
}
/* If the condition matches then set the return value. */
gfc_start_block (&block);
/* Add the offset. */
tmp = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (resvar),
loop.loopvar[0], offset);
gfc_add_modify (&block, resvar, tmp);
/* And break out of the loop. */
tmp = build1_v (GOTO_EXPR, exit_label);
gfc_add_expr_to_block (&block, tmp);
found = gfc_finish_block (&block);
/* Check this element. */
gfc_init_se (&arrayse, NULL);
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, array_arg->expr);
gfc_add_block_to_block (&body, &arrayse.pre);
gfc_init_se (&valuese, NULL);
gfc_conv_expr_val (&valuese, value_arg->expr);
gfc_add_block_to_block (&body, &valuese.pre);
tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
arrayse.expr, valuese.expr);
tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
if (maskss)
tmp = build3_v (COND_EXPR, maskse.expr, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
gfc_add_block_to_block (&body, &arrayse.post);
gfc_trans_scalarizing_loops (&loop, &body);
/* Add the exit label. */
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&loop.pre, tmp);
gfc_start_block (&loopblock);
gfc_add_block_to_block (&loopblock, &loop.pre);
gfc_add_block_to_block (&loopblock, &loop.post);
if (i == 0)
forward_branch = gfc_finish_block (&loopblock);
else
back_branch = gfc_finish_block (&loopblock);
gfc_cleanup_loop (&loop);
}
/* Enclose the two loops in an IF statement. */
gfc_init_se (&backse, NULL);
gfc_conv_expr_val (&backse, back_arg->expr);
gfc_add_block_to_block (&se->pre, &backse.pre);
tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskss == NULL)
{
tree if_stmt;
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_init_block (&block);
gfc_add_expr_to_block (&block, maskse.expr);
if_stmt = build3_v (COND_EXPR, maskse.expr, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, if_stmt);
tmp = gfc_finish_block (&block);
}
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = convert (type, resvar);
}
/* Emit code for minval or maxval intrinsic. There are many different cases
we need to handle. For performance reasons we sometimes create two
loops instead of one, where the second one is much simpler.
......@@ -9015,6 +9228,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
conv_generic_with_optional_char_arg (se, expr, 1, 3);
break;
case GFC_ISYM_FINDLOC:
gfc_conv_intrinsic_findloc (se, expr);
break;
case GFC_ISYM_MINLOC:
gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
break;
......@@ -9454,6 +9671,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
break;
case GFC_ISYM_FINDLOC:
gfc_conv_intrinsic_findloc (se, expr);
break;
case GFC_ISYM_MAXVAL:
gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
break;
......@@ -9933,6 +10154,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
case GFC_ISYM_ALL:
case GFC_ISYM_ANY:
case GFC_ISYM_COUNT:
case GFC_ISYM_FINDLOC:
case GFC_ISYM_JN2:
case GFC_ISYM_IANY:
case GFC_ISYM_IALL:
......
gcc/testsuite/ChangeLog
2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/54613
* gfortran.dg/findloc_1.f90: New test.
* gfortran.dg/findloc_2.f90: New test.
* gfortran.dg/findloc_3.f90: New test.
* gfortran.dg/findloc_4.f90: New test.
* gfortran.dg/findloc_5.f90: New test.
* gfortran.dg/findloc_6.f90: New test.
2018-10-26 Bill Schmidt <wschmidt@linux.ibm.com>
Jinsong Ji <jji@us.ibm.com>
......
libgfortran/ChangeLog
2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/54613
* Makefile.am: Add files for findloc.
* Makefile.in: Regenerated.
* libgfortran.h (gfc_array_index_type): Add.
(gfc_array_s1): Add using GFC_UINTEGER_1.
(gfc_array_s4): Likewise.
Replace unnecessary comment.
(HAVE_GFC_UINTEGER_1): Define.
(HAVE_GFC_UINTEGER_4): Define.
* m4/findloc0.m4: New file.
* m4/findloc0s.m4: New file.
* m4/findloc1.m4: New file.
* m4/findloc1s.m4: New file.
* m4/findloc2s.m4: New file.
* m4/ifindloc0.m4: New file.
* m4/ifindloc1.m4: New file.
* m4/ifindloc2.m4: New file.
* m4/iparm.m4: Use unsigned integer for characters.
* generated/findloc0_c16.c: New file.
* generated/findloc0_c4.c: New file.
* generated/findloc0_c8.c: New file.
* generated/findloc0_i1.c: New file.
* generated/findloc0_i16.c: New file.
* generated/findloc0_i2.c: New file.
* generated/findloc0_i4.c: New file.
* generated/findloc0_i8.c: New file.
* generated/findloc0_r16.c: New file.
* generated/findloc0_r4.c: New file.
* generated/findloc0_r8.c: New file.
* generated/findloc0_s1.c: New file.
* generated/findloc0_s4.c: New file.
* generated/findloc1_c16.c: New file.
* generated/findloc1_c4.c: New file.
* generated/findloc1_c8.c: New file.
* generated/findloc1_i1.c: New file.
* generated/findloc1_i16.c: New file.
* generated/findloc1_i2.c: New file.
* generated/findloc1_i4.c: New file.
* generated/findloc1_i8.c: New file.
* generated/findloc1_r16.c: New file.
* generated/findloc1_r4.c: New file.
* generated/findloc1_r8.c: New file.
* generated/findloc1_s1.c: New file.
* generated/findloc1_s4.c: New file.
* generated/findloc2_s1.c: New file.
* generated/findloc2_s4.c: New file.
* generated/maxloc0_16_s1.c: Regenerated.
* generated/maxloc0_16_s4.c: Regenerated.
* generated/maxloc0_4_s1.c: Regenerated.
* generated/maxloc0_4_s4.c: Regenerated.
* generated/maxloc0_8_s1.c: Regenerated.
* generated/maxloc0_8_s4.c: Regenerated.
* generated/maxloc1_16_s1.c: Regenerated.
* generated/maxloc1_16_s4.c: Regenerated.
* generated/maxloc1_4_s1.c: Regenerated.
* generated/maxloc1_4_s4.c: Regenerated.
* generated/maxloc1_8_s1.c: Regenerated.
* generated/maxloc1_8_s4.c: Regenerated.
* generated/maxloc2_16_s1.c: Regenerated.
* generated/maxloc2_16_s4.c: Regenerated.
* generated/maxloc2_4_s1.c: Regenerated.
* generated/maxloc2_4_s4.c: Regenerated.
* generated/maxloc2_8_s1.c: Regenerated.
* generated/maxloc2_8_s4.c: Regenerated.
* generated/maxval0_s1.c: Regenerated.
* generated/maxval0_s4.c: Regenerated.
* generated/maxval1_s1.c: Regenerated.
* generated/maxval1_s4.c: Regenerated.
* generated/minloc0_16_s1.c: Regenerated.
* generated/minloc0_16_s4.c: Regenerated.
* generated/minloc0_4_s1.c: Regenerated.
* generated/minloc0_4_s4.c: Regenerated.
* generated/minloc0_8_s1.c: Regenerated.
* generated/minloc0_8_s4.c: Regenerated.
* generated/minloc1_16_s1.c: Regenerated.
* generated/minloc1_16_s4.c: Regenerated.
* generated/minloc1_4_s1.c: Regenerated.
* generated/minloc1_4_s4.c: Regenerated.
* generated/minloc1_8_s1.c: Regenerated.
* generated/minloc1_8_s4.c: Regenerated.
* generated/minloc2_16_s1.c: Regenerated.
* generated/minloc2_16_s4.c: Regenerated.
* generated/minloc2_4_s1.c: Regenerated.
* generated/minloc2_4_s4.c: Regenerated.
* generated/minloc2_8_s1.c: Regenerated.
* generated/minloc2_8_s4.c: Regenerated.
* generated/minval0_s1.c: Regenerated.
* generated/minval0_s4.c: Regenerated.
* generated/minval1_s1.c: Regenerated.
* generated/minval1_s4.c: Regenerated.
2018-10-06 Janne Blomqvist <jb@gcc.gnu.org>
* io/unix.c (compare_file_filename): Use gfc_charlen_type instead
......
libgfortran/Makefile.am
......@@ -266,6 +266,44 @@ $(srcdir)/generated/iparity_i4.c \
$(srcdir)/generated/iparity_i8.c \
$(srcdir)/generated/iparity_i16.c
i_findloc0_c= \
$(srcdir)/generated/findloc0_i1.c \
$(srcdir)/generated/findloc0_i2.c \
$(srcdir)/generated/findloc0_i4.c \
$(srcdir)/generated/findloc0_i8.c \
$(srcdir)/generated/findloc0_i16.c \
$(srcdir)/generated/findloc0_r4.c \
$(srcdir)/generated/findloc0_r8.c \
$(srcdir)/generated/findloc0_r16.c \
$(srcdir)/generated/findloc0_c4.c \
$(srcdir)/generated/findloc0_c8.c \
$(srcdir)/generated/findloc0_c16.c
i_findloc0s_c= \
$(srcdir)/generated/findloc0_s1.c \
$(srcdir)/generated/findloc0_s4.c
i_findloc1_c= \
$(srcdir)/generated/findloc1_i1.c \
$(srcdir)/generated/findloc1_i2.c \
$(srcdir)/generated/findloc1_i4.c \
$(srcdir)/generated/findloc1_i8.c \
$(srcdir)/generated/findloc1_i16.c \
$(srcdir)/generated/findloc1_r4.c \
$(srcdir)/generated/findloc1_r8.c \
$(srcdir)/generated/findloc1_r16.c \
$(srcdir)/generated/findloc1_c4.c \
$(srcdir)/generated/findloc1_c8.c \
$(srcdir)/generated/findloc1_c16.c
i_findloc1s_c= \
$(srcdir)/generated/findloc1_s1.c \
$(srcdir)/generated/findloc1_s4.c
i_findloc2s_c= \
$(srcdir)/generated/findloc2_s1.c \
$(srcdir)/generated/findloc2_s4.c
i_maxloc0_c= \
$(srcdir)/generated/maxloc0_4_i1.c \
$(srcdir)/generated/maxloc0_8_i1.c \
......@@ -754,7 +792,9 @@ m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach.m4 m4/all.m4 \
m4/pow.m4 \
m4/misc_specifics.m4 m4/pack.m4 \
m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4
m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4 m4/findloc0.m4 \
m4/findloc0s.m4 m4/ifindloc0.m4 m4/findloc1.m4 m4/ifindloc1.m4 \
m4/findloc2s.m4 m4/ifindloc2.m4
gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
......@@ -767,7 +807,9 @@ gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \
$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \
$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c)
$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
$(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c) \
$(i_findloc2s_c)
# Machine generated specifics
gfor_built_specific_src= \
......@@ -995,6 +1037,9 @@ I_M4_DEPS3=$(I_M4_DEPS) m4/iforeach-s.m4
I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4
I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4
I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4
I_M4_DEPS7=$(I_M4_DEPS) m4/ifindloc0.m4
I_M4_DEPS8=$(I_M4_DEPS) m4/ifindloc1.m4
I_M4_DEPS9=$(I_M4_DEPS) m4/ifindloc2.m4
kinds.h: $(srcdir)/mk-kinds-h.sh
$(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@
......@@ -1034,6 +1079,21 @@ $(i_any_c): m4/any.m4 $(I_M4_DEPS2)
$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS7)
$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
$(i_findloc0s_c): m4/findloc0s.m4 $(I_M4_DEPS7)
$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0s.m4 > $@
$(i_findloc1_c): m4/findloc1.m4 $(I_M4_DEPS8)
$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1.m4 > $@
$(i_findloc1s_c): m4/findloc1s.m4 $(I_M4_DEPS8)
$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1s.m4 > $@
$(i_findloc2s_c): m4/findloc2s.m4 $(I_M4_DEPS9)
$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc2s.m4 > $@
$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
......
libgfortran/generated/findloc0_c16.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_COMPLEX_16)
extern void findloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
GFC_LOGICAL_4);
export_proto(findloc0_c16);
void
findloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_16 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_c16);
void
mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_16 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_c16);
void
sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_c16 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_c4.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_COMPLEX_4)
extern void findloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
GFC_LOGICAL_4);
export_proto(findloc0_c4);
void
findloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_4 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_c4);
void
mfindloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_4 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_c4);
void
sfindloc0_c4 (gfc_array_index_type * const restrict retarray,
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_c4 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_c8.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_COMPLEX_8)
extern void findloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
GFC_LOGICAL_4);
export_proto(findloc0_c8);
void
findloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_8 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_c8);
void
mfindloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_COMPLEX_8 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_c8);
void
sfindloc0_c8 (gfc_array_index_type * const restrict retarray,
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_c8 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_i1.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_INTEGER_1)
extern void findloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
GFC_LOGICAL_4);
export_proto(findloc0_i1);
void
findloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_1 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_i1);
void
mfindloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_1 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_i1);
void
sfindloc0_i1 (gfc_array_index_type * const restrict retarray,
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_i1 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_i16.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_INTEGER_16)
extern void findloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
GFC_LOGICAL_4);
export_proto(findloc0_i16);
void
findloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_16 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_i16);
void
mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_16 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_i16);
void
sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_i16 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_i2.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_INTEGER_2)
extern void findloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
GFC_LOGICAL_4);
export_proto(findloc0_i2);
void
findloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_2 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_i2);
void
mfindloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_2 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_i2);
void
sfindloc0_i2 (gfc_array_index_type * const restrict retarray,
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_i2 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_i4.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_INTEGER_4)
extern void findloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
GFC_LOGICAL_4);
export_proto(findloc0_i4);
void
findloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_4 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_i4);
void
mfindloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_4 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_i4);
void
sfindloc0_i4 (gfc_array_index_type * const restrict retarray,
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_i4 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_i8.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_INTEGER_8)
extern void findloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
GFC_LOGICAL_4);
export_proto(findloc0_i8);
void
findloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_8 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_i8);
void
mfindloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_INTEGER_8 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_i8);
void
sfindloc0_i8 (gfc_array_index_type * const restrict retarray,
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_i8 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_r16.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_REAL_16)
extern void findloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
GFC_LOGICAL_4);
export_proto(findloc0_r16);
void
findloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_REAL_16 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_r16);
void
mfindloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_REAL_16 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_r16);
void
sfindloc0_r16 (gfc_array_index_type * const restrict retarray,
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_r16 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
libgfortran/generated/findloc0_r4.c 0 → 100644
/* Implementation of the FINDLOC intrinsic
Copyright (C) 2018 Free Software Foundation, Inc.
Contributed by Thomas König <tk@tkoenig.net>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
#include "libgfortran.h"
#include <assert.h>
#if defined (HAVE_GFC_REAL_4)
extern void findloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
GFC_LOGICAL_4);
export_proto(findloc0_r4);
void
findloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_REAL_4 *base;
index_type * restrict dest;
index_type rank;
index_type n;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n] * 1;
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void mfindloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_r4);
void
mfindloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
const GFC_REAL_4 *base;
index_type * restrict dest;
GFC_LOGICAL_1 *mbase;
index_type rank;
index_type n;
int mask_kind;
index_type sz;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else
{
if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
bounds_equal_extents ((array_t *) mask, (array_t *) array,
"MASK argument", "FINDLOC");
}
}
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
mbase = mask->base_addr;
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
else
internal_error (NULL, "Funny sized logical array");
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
sz = 1;
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sz *= extent[n];
if (extent[n] <= 0)
return;
}
for (n = 0; n < rank; n++)
count[n] = 0;
if (back)
{
base = array->base_addr + (sz - 1) * 1;
mbase = mbase + (sz - 1) * mask_kind;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = extent[n] - count[n];
return;
}
base -= sstride[0] * 1;
mbase -= mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base += sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base -= sstride[n] * 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
else
{
base = array->base_addr;
while (1)
{
do
{
if (unlikely(*mbase && *base == value))
{
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
return;
}
base += sstride[0] * 1;
mbase += mstride[0];
} while(++count[0] != extent[0]);
n = 0;
do
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
base -= sstride[n] * extent[n] * 1;
mbase -= mstride[n] * extent[n];
n++;
if (n >= rank)
return;
else
{
count[n]++;
base += sstride[n]* 1;
mbase += mstride[n];
}
} while (count[n] == extent[n]);
}
}
return;
}
extern void sfindloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_r4);
void
sfindloc0_r4 (gfc_array_index_type * const restrict retarray,
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
index_type rank;
index_type dstride;
index_type * restrict dest;
index_type n;
if (*mask)
{
findloc0_r4 (retarray, array, value, back);
return;
}
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
internal_error (NULL, "Rank of array needs to be > 0");
if (retarray->base_addr == NULL)
{
GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
retarray->dtype.rank = 1;
retarray->offset = 0;
retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
}
else if (unlikely (compile_options.bounds_check))
{
bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
"FINDLOC");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
dest = retarray->base_addr;
for (n = 0; n<rank; n++)
dest[n * dstride] = 0 ;
}
#endif
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment