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
This commit is contained in:
Thomas Koenig
parent
b10fb07830
commit
01ce9e31a0
|
|
@ -1,3 +1,35 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
|
|
|||
|
|
@ -1783,6 +1783,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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
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>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,96 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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 > $@
|
||||
|
||||
|
|
|
|||
|
|
@ -334,7 +334,16 @@ am__objects_43 = maxval0_s1.lo maxval0_s4.lo
|
|||
am__objects_44 = minval0_s1.lo minval0_s4.lo
|
||||
am__objects_45 = maxval1_s1.lo maxval1_s4.lo
|
||||
am__objects_46 = minval1_s1.lo minval1_s4.lo
|
||||
am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
||||
am__objects_47 = findloc0_i1.lo findloc0_i2.lo findloc0_i4.lo \
|
||||
findloc0_i8.lo findloc0_i16.lo findloc0_r4.lo findloc0_r8.lo \
|
||||
findloc0_r16.lo findloc0_c4.lo findloc0_c8.lo findloc0_c16.lo
|
||||
am__objects_48 = findloc0_s1.lo findloc0_s4.lo
|
||||
am__objects_49 = findloc1_i1.lo findloc1_i2.lo findloc1_i4.lo \
|
||||
findloc1_i8.lo findloc1_i16.lo findloc1_r4.lo findloc1_r8.lo \
|
||||
findloc1_r16.lo findloc1_c4.lo findloc1_c8.lo findloc1_c16.lo
|
||||
am__objects_50 = findloc1_s1.lo findloc1_s4.lo
|
||||
am__objects_51 = findloc2_s1.lo findloc2_s4.lo
|
||||
am__objects_52 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
||||
$(am__objects_7) $(am__objects_8) $(am__objects_9) \
|
||||
$(am__objects_10) $(am__objects_11) $(am__objects_12) \
|
||||
$(am__objects_13) $(am__objects_14) $(am__objects_15) \
|
||||
|
|
@ -348,14 +357,15 @@ am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
|
|||
$(am__objects_37) $(am__objects_38) $(am__objects_39) \
|
||||
$(am__objects_40) $(am__objects_41) $(am__objects_42) \
|
||||
$(am__objects_43) $(am__objects_44) $(am__objects_45) \
|
||||
$(am__objects_46)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \
|
||||
$(am__objects_46) $(am__objects_47) $(am__objects_48) \
|
||||
$(am__objects_49) $(am__objects_50) $(am__objects_51)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_53 = close.lo file_pos.lo format.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
|
||||
am__objects_49 = size_from_kind.lo $(am__objects_48)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
|
||||
am__objects_54 = size_from_kind.lo $(am__objects_53)
|
||||
@LIBGFOR_MINIMAL_FALSE@am__objects_55 = access.lo c99_functions.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \
|
||||
|
|
@ -365,19 +375,19 @@ am__objects_49 = size_from_kind.lo $(am__objects_48)
|
|||
@LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \
|
||||
@LIBGFOR_MINIMAL_FALSE@ unlink.lo
|
||||
@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo
|
||||
am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
|
||||
@IEEE_SUPPORT_TRUE@am__objects_56 = ieee_helper.lo
|
||||
am__objects_57 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
|
||||
eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
|
||||
ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
|
||||
selected_char_kind.lo size.lo spread_generic.lo \
|
||||
string_intrinsics.lo rand.lo random.lo reshape_generic.lo \
|
||||
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
|
||||
unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
|
||||
$(am__objects_50) $(am__objects_51)
|
||||
@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \
|
||||
$(am__objects_55) $(am__objects_56)
|
||||
@IEEE_SUPPORT_TRUE@am__objects_58 = ieee_arithmetic.lo \
|
||||
@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
|
||||
am__objects_54 =
|
||||
am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
am__objects_59 =
|
||||
am__objects_60 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
|
||||
_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
|
||||
_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
|
||||
|
|
@ -401,19 +411,19 @@ am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
|||
_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
|
||||
_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
|
||||
_anint_r8.lo _anint_r10.lo _anint_r16.lo
|
||||
am__objects_56 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
|
||||
am__objects_61 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
|
||||
_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
|
||||
_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
|
||||
_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
|
||||
_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
|
||||
_mod_r10.lo _mod_r16.lo
|
||||
am__objects_57 = misc_specifics.lo
|
||||
am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \
|
||||
am__objects_62 = misc_specifics.lo
|
||||
am__objects_63 = $(am__objects_60) $(am__objects_61) $(am__objects_62) \
|
||||
dprod_r8.lo f2c_specifics.lo random_init.lo
|
||||
am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \
|
||||
$(am__objects_52) $(am__objects_53) $(am__objects_54) \
|
||||
$(am__objects_58)
|
||||
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59)
|
||||
am__objects_64 = $(am__objects_3) $(am__objects_52) $(am__objects_54) \
|
||||
$(am__objects_57) $(am__objects_58) $(am__objects_59) \
|
||||
$(am__objects_63)
|
||||
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_64)
|
||||
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
|
||||
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
|
||||
DEFAULT_INCLUDES = -I.@am__isrc@
|
||||
|
|
@ -725,6 +735,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 \
|
||||
|
|
@ -1213,7 +1261,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) \
|
||||
|
|
@ -1226,7 +1276,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
|
||||
|
|
@ -1407,6 +1459,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
|
||||
EXTRA_DIST = $(m4_files)
|
||||
all: $(BUILT_SOURCES) config.h
|
||||
$(MAKE) $(AM_MAKEFLAGS) all-am
|
||||
|
|
@ -1650,6 +1705,34 @@ distclean-compile:
|
|||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i1.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i2.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_s1.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_s4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i1.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i2.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r16.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r8.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_s1.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_s4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc2_s1.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc2_s4.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnum.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/format.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fpu.Plo@am__quote@
|
||||
|
|
@ -5705,6 +5788,202 @@ minval1_s4.lo: $(srcdir)/generated/minval1_s4.c
|
|||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o minval1_s4.lo `test -f '$(srcdir)/generated/minval1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/minval1_s4.c
|
||||
|
||||
findloc0_i1.lo: $(srcdir)/generated/findloc0_i1.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_i1.lo -MD -MP -MF $(DEPDIR)/findloc0_i1.Tpo -c -o findloc0_i1.lo `test -f '$(srcdir)/generated/findloc0_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i1.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i1.Tpo $(DEPDIR)/findloc0_i1.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i1.c' object='findloc0_i1.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_i1.lo `test -f '$(srcdir)/generated/findloc0_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i1.c
|
||||
|
||||
findloc0_i2.lo: $(srcdir)/generated/findloc0_i2.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_i2.lo -MD -MP -MF $(DEPDIR)/findloc0_i2.Tpo -c -o findloc0_i2.lo `test -f '$(srcdir)/generated/findloc0_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i2.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i2.Tpo $(DEPDIR)/findloc0_i2.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i2.c' object='findloc0_i2.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_i2.lo `test -f '$(srcdir)/generated/findloc0_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i2.c
|
||||
|
||||
findloc0_i4.lo: $(srcdir)/generated/findloc0_i4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_i4.lo -MD -MP -MF $(DEPDIR)/findloc0_i4.Tpo -c -o findloc0_i4.lo `test -f '$(srcdir)/generated/findloc0_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i4.Tpo $(DEPDIR)/findloc0_i4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i4.c' object='findloc0_i4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_i4.lo `test -f '$(srcdir)/generated/findloc0_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i4.c
|
||||
|
||||
findloc0_i8.lo: $(srcdir)/generated/findloc0_i8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_i8.lo -MD -MP -MF $(DEPDIR)/findloc0_i8.Tpo -c -o findloc0_i8.lo `test -f '$(srcdir)/generated/findloc0_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i8.Tpo $(DEPDIR)/findloc0_i8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i8.c' object='findloc0_i8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_i8.lo `test -f '$(srcdir)/generated/findloc0_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i8.c
|
||||
|
||||
findloc0_i16.lo: $(srcdir)/generated/findloc0_i16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_i16.lo -MD -MP -MF $(DEPDIR)/findloc0_i16.Tpo -c -o findloc0_i16.lo `test -f '$(srcdir)/generated/findloc0_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i16.Tpo $(DEPDIR)/findloc0_i16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i16.c' object='findloc0_i16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_i16.lo `test -f '$(srcdir)/generated/findloc0_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_i16.c
|
||||
|
||||
findloc0_r4.lo: $(srcdir)/generated/findloc0_r4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_r4.lo -MD -MP -MF $(DEPDIR)/findloc0_r4.Tpo -c -o findloc0_r4.lo `test -f '$(srcdir)/generated/findloc0_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r4.Tpo $(DEPDIR)/findloc0_r4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r4.c' object='findloc0_r4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_r4.lo `test -f '$(srcdir)/generated/findloc0_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r4.c
|
||||
|
||||
findloc0_r8.lo: $(srcdir)/generated/findloc0_r8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_r8.lo -MD -MP -MF $(DEPDIR)/findloc0_r8.Tpo -c -o findloc0_r8.lo `test -f '$(srcdir)/generated/findloc0_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r8.Tpo $(DEPDIR)/findloc0_r8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r8.c' object='findloc0_r8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_r8.lo `test -f '$(srcdir)/generated/findloc0_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r8.c
|
||||
|
||||
findloc0_r16.lo: $(srcdir)/generated/findloc0_r16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_r16.lo -MD -MP -MF $(DEPDIR)/findloc0_r16.Tpo -c -o findloc0_r16.lo `test -f '$(srcdir)/generated/findloc0_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r16.Tpo $(DEPDIR)/findloc0_r16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r16.c' object='findloc0_r16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_r16.lo `test -f '$(srcdir)/generated/findloc0_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_r16.c
|
||||
|
||||
findloc0_c4.lo: $(srcdir)/generated/findloc0_c4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_c4.lo -MD -MP -MF $(DEPDIR)/findloc0_c4.Tpo -c -o findloc0_c4.lo `test -f '$(srcdir)/generated/findloc0_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c4.Tpo $(DEPDIR)/findloc0_c4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c4.c' object='findloc0_c4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_c4.lo `test -f '$(srcdir)/generated/findloc0_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c4.c
|
||||
|
||||
findloc0_c8.lo: $(srcdir)/generated/findloc0_c8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_c8.lo -MD -MP -MF $(DEPDIR)/findloc0_c8.Tpo -c -o findloc0_c8.lo `test -f '$(srcdir)/generated/findloc0_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c8.Tpo $(DEPDIR)/findloc0_c8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c8.c' object='findloc0_c8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_c8.lo `test -f '$(srcdir)/generated/findloc0_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c8.c
|
||||
|
||||
findloc0_c16.lo: $(srcdir)/generated/findloc0_c16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_c16.lo -MD -MP -MF $(DEPDIR)/findloc0_c16.Tpo -c -o findloc0_c16.lo `test -f '$(srcdir)/generated/findloc0_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c16.Tpo $(DEPDIR)/findloc0_c16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c16.c' object='findloc0_c16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_c16.lo `test -f '$(srcdir)/generated/findloc0_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_c16.c
|
||||
|
||||
findloc0_s1.lo: $(srcdir)/generated/findloc0_s1.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_s1.lo -MD -MP -MF $(DEPDIR)/findloc0_s1.Tpo -c -o findloc0_s1.lo `test -f '$(srcdir)/generated/findloc0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_s1.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_s1.Tpo $(DEPDIR)/findloc0_s1.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_s1.c' object='findloc0_s1.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_s1.lo `test -f '$(srcdir)/generated/findloc0_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_s1.c
|
||||
|
||||
findloc0_s4.lo: $(srcdir)/generated/findloc0_s4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc0_s4.lo -MD -MP -MF $(DEPDIR)/findloc0_s4.Tpo -c -o findloc0_s4.lo `test -f '$(srcdir)/generated/findloc0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_s4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_s4.Tpo $(DEPDIR)/findloc0_s4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_s4.c' object='findloc0_s4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc0_s4.lo `test -f '$(srcdir)/generated/findloc0_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc0_s4.c
|
||||
|
||||
findloc1_i1.lo: $(srcdir)/generated/findloc1_i1.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_i1.lo -MD -MP -MF $(DEPDIR)/findloc1_i1.Tpo -c -o findloc1_i1.lo `test -f '$(srcdir)/generated/findloc1_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i1.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_i1.Tpo $(DEPDIR)/findloc1_i1.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_i1.c' object='findloc1_i1.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_i1.lo `test -f '$(srcdir)/generated/findloc1_i1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i1.c
|
||||
|
||||
findloc1_i2.lo: $(srcdir)/generated/findloc1_i2.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_i2.lo -MD -MP -MF $(DEPDIR)/findloc1_i2.Tpo -c -o findloc1_i2.lo `test -f '$(srcdir)/generated/findloc1_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i2.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_i2.Tpo $(DEPDIR)/findloc1_i2.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_i2.c' object='findloc1_i2.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_i2.lo `test -f '$(srcdir)/generated/findloc1_i2.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i2.c
|
||||
|
||||
findloc1_i4.lo: $(srcdir)/generated/findloc1_i4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_i4.lo -MD -MP -MF $(DEPDIR)/findloc1_i4.Tpo -c -o findloc1_i4.lo `test -f '$(srcdir)/generated/findloc1_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_i4.Tpo $(DEPDIR)/findloc1_i4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_i4.c' object='findloc1_i4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_i4.lo `test -f '$(srcdir)/generated/findloc1_i4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i4.c
|
||||
|
||||
findloc1_i8.lo: $(srcdir)/generated/findloc1_i8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_i8.lo -MD -MP -MF $(DEPDIR)/findloc1_i8.Tpo -c -o findloc1_i8.lo `test -f '$(srcdir)/generated/findloc1_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_i8.Tpo $(DEPDIR)/findloc1_i8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_i8.c' object='findloc1_i8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_i8.lo `test -f '$(srcdir)/generated/findloc1_i8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i8.c
|
||||
|
||||
findloc1_i16.lo: $(srcdir)/generated/findloc1_i16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_i16.lo -MD -MP -MF $(DEPDIR)/findloc1_i16.Tpo -c -o findloc1_i16.lo `test -f '$(srcdir)/generated/findloc1_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_i16.Tpo $(DEPDIR)/findloc1_i16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_i16.c' object='findloc1_i16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_i16.lo `test -f '$(srcdir)/generated/findloc1_i16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_i16.c
|
||||
|
||||
findloc1_r4.lo: $(srcdir)/generated/findloc1_r4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_r4.lo -MD -MP -MF $(DEPDIR)/findloc1_r4.Tpo -c -o findloc1_r4.lo `test -f '$(srcdir)/generated/findloc1_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_r4.Tpo $(DEPDIR)/findloc1_r4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_r4.c' object='findloc1_r4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_r4.lo `test -f '$(srcdir)/generated/findloc1_r4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r4.c
|
||||
|
||||
findloc1_r8.lo: $(srcdir)/generated/findloc1_r8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_r8.lo -MD -MP -MF $(DEPDIR)/findloc1_r8.Tpo -c -o findloc1_r8.lo `test -f '$(srcdir)/generated/findloc1_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_r8.Tpo $(DEPDIR)/findloc1_r8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_r8.c' object='findloc1_r8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_r8.lo `test -f '$(srcdir)/generated/findloc1_r8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r8.c
|
||||
|
||||
findloc1_r16.lo: $(srcdir)/generated/findloc1_r16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_r16.lo -MD -MP -MF $(DEPDIR)/findloc1_r16.Tpo -c -o findloc1_r16.lo `test -f '$(srcdir)/generated/findloc1_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_r16.Tpo $(DEPDIR)/findloc1_r16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_r16.c' object='findloc1_r16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_r16.lo `test -f '$(srcdir)/generated/findloc1_r16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_r16.c
|
||||
|
||||
findloc1_c4.lo: $(srcdir)/generated/findloc1_c4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_c4.lo -MD -MP -MF $(DEPDIR)/findloc1_c4.Tpo -c -o findloc1_c4.lo `test -f '$(srcdir)/generated/findloc1_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_c4.Tpo $(DEPDIR)/findloc1_c4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_c4.c' object='findloc1_c4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_c4.lo `test -f '$(srcdir)/generated/findloc1_c4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c4.c
|
||||
|
||||
findloc1_c8.lo: $(srcdir)/generated/findloc1_c8.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_c8.lo -MD -MP -MF $(DEPDIR)/findloc1_c8.Tpo -c -o findloc1_c8.lo `test -f '$(srcdir)/generated/findloc1_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c8.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_c8.Tpo $(DEPDIR)/findloc1_c8.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_c8.c' object='findloc1_c8.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_c8.lo `test -f '$(srcdir)/generated/findloc1_c8.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c8.c
|
||||
|
||||
findloc1_c16.lo: $(srcdir)/generated/findloc1_c16.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_c16.lo -MD -MP -MF $(DEPDIR)/findloc1_c16.Tpo -c -o findloc1_c16.lo `test -f '$(srcdir)/generated/findloc1_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c16.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_c16.Tpo $(DEPDIR)/findloc1_c16.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_c16.c' object='findloc1_c16.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_c16.lo `test -f '$(srcdir)/generated/findloc1_c16.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_c16.c
|
||||
|
||||
findloc1_s1.lo: $(srcdir)/generated/findloc1_s1.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_s1.lo -MD -MP -MF $(DEPDIR)/findloc1_s1.Tpo -c -o findloc1_s1.lo `test -f '$(srcdir)/generated/findloc1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_s1.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_s1.Tpo $(DEPDIR)/findloc1_s1.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_s1.c' object='findloc1_s1.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_s1.lo `test -f '$(srcdir)/generated/findloc1_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_s1.c
|
||||
|
||||
findloc1_s4.lo: $(srcdir)/generated/findloc1_s4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc1_s4.lo -MD -MP -MF $(DEPDIR)/findloc1_s4.Tpo -c -o findloc1_s4.lo `test -f '$(srcdir)/generated/findloc1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_s4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc1_s4.Tpo $(DEPDIR)/findloc1_s4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc1_s4.c' object='findloc1_s4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc1_s4.lo `test -f '$(srcdir)/generated/findloc1_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc1_s4.c
|
||||
|
||||
findloc2_s1.lo: $(srcdir)/generated/findloc2_s1.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc2_s1.lo -MD -MP -MF $(DEPDIR)/findloc2_s1.Tpo -c -o findloc2_s1.lo `test -f '$(srcdir)/generated/findloc2_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc2_s1.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc2_s1.Tpo $(DEPDIR)/findloc2_s1.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc2_s1.c' object='findloc2_s1.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc2_s1.lo `test -f '$(srcdir)/generated/findloc2_s1.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc2_s1.c
|
||||
|
||||
findloc2_s4.lo: $(srcdir)/generated/findloc2_s4.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT findloc2_s4.lo -MD -MP -MF $(DEPDIR)/findloc2_s4.Tpo -c -o findloc2_s4.lo `test -f '$(srcdir)/generated/findloc2_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc2_s4.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc2_s4.Tpo $(DEPDIR)/findloc2_s4.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc2_s4.c' object='findloc2_s4.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o findloc2_s4.lo `test -f '$(srcdir)/generated/findloc2_s4.c' || echo '$(srcdir)/'`$(srcdir)/generated/findloc2_s4.c
|
||||
|
||||
size_from_kind.lo: io/size_from_kind.c
|
||||
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT size_from_kind.lo -MD -MP -MF $(DEPDIR)/size_from_kind.Tpo -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c
|
||||
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo
|
||||
|
|
@ -6583,6 +6862,21 @@ fpu-target.inc: fpu-target.h $(srcdir)/libgfortran.h
|
|||
@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS7)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_findloc0s_c): m4/findloc0s.m4 $(I_M4_DEPS7)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0s.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_findloc1_c): m4/findloc1.m4 $(I_M4_DEPS8)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_findloc1s_c): m4/findloc1s.m4 $(I_M4_DEPS8)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1s.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_findloc2s_c): m4/findloc2s.m4 $(I_M4_DEPS9)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc2s.m4 > $@
|
||||
|
||||
@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
|
||||
@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
|
||||
/* 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_8)
|
||||
extern void findloc0_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
GFC_LOGICAL_4);
|
||||
export_proto(findloc0_r8);
|
||||
|
||||
void
|
||||
findloc0_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_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_REAL_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_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
|
||||
export_proto(mfindloc0_r8);
|
||||
|
||||
void
|
||||
mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_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_REAL_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_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
|
||||
export_proto(sfindloc0_r8);
|
||||
|
||||
void
|
||||
sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_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_r8 (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
|
||||
|
|
@ -0,0 +1,383 @@
|
|||
|
||||
/* 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_UINTEGER_1)
|
||||
extern void findloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
|
||||
export_proto(findloc0_s1);
|
||||
|
||||
void
|
||||
findloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_UINTEGER_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) * len_array;
|
||||
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * len_array;
|
||||
} 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] * len_array;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * len_array;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * len_array;
|
||||
} 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] * len_array;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
extern void mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(mfindloc0_s1);
|
||||
|
||||
void
|
||||
mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
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_UINTEGER_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) * len_array;
|
||||
mbase = mbase + (sz - 1) * mask_kind;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * len_array;
|
||||
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] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * len_array;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * len_array;
|
||||
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] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n]* len_array;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
extern void sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(sfindloc0_s1);
|
||||
|
||||
void
|
||||
sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
|
||||
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
index_type rank;
|
||||
index_type dstride;
|
||||
index_type * restrict dest;
|
||||
index_type n;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc0_s1 (retarray, array, value, back, len_array, len_value);
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,383 @@
|
|||
|
||||
/* 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_UINTEGER_4)
|
||||
extern void findloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
|
||||
export_proto(findloc0_s4);
|
||||
|
||||
void
|
||||
findloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_UINTEGER_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) * len_array;
|
||||
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(compare_string_char4 (len_array, base, len_value, value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * len_array;
|
||||
} 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] * len_array;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * len_array;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(compare_string_char4 (len_array, base, len_value, value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * len_array;
|
||||
} 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] * len_array;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
extern void mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(mfindloc0_s4);
|
||||
|
||||
void
|
||||
mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
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_UINTEGER_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) * len_array;
|
||||
mbase = mbase + (sz - 1) * mask_kind;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * len_array;
|
||||
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] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * len_array;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * len_array;
|
||||
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] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n]* len_array;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
extern void sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(sfindloc0_s4);
|
||||
|
||||
void
|
||||
sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
|
||||
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
index_type rank;
|
||||
index_type dstride;
|
||||
index_type * restrict dest;
|
||||
index_type n;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc0_s4 (retarray, array, value, back, len_array, len_value);
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_c16);
|
||||
|
||||
extern void
|
||||
findloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_16 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_16 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_c16);
|
||||
|
||||
extern void
|
||||
mfindloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_16 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_16 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_c16);
|
||||
|
||||
extern void
|
||||
sfindloc1_c16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_c16 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_c4);
|
||||
|
||||
extern void
|
||||
findloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_4 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_4 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_c4);
|
||||
|
||||
extern void
|
||||
mfindloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_c4);
|
||||
|
||||
extern void
|
||||
sfindloc1_c4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_c4 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_c8);
|
||||
|
||||
extern void
|
||||
findloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_8 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_8 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_c8);
|
||||
|
||||
extern void
|
||||
mfindloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_COMPLEX_8 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_COMPLEX_8 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_c8);
|
||||
|
||||
extern void
|
||||
sfindloc1_c8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_c8 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_i1);
|
||||
|
||||
extern void
|
||||
findloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_i1);
|
||||
|
||||
extern void
|
||||
mfindloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_i1);
|
||||
|
||||
extern void
|
||||
sfindloc1_i1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_i1 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_i16);
|
||||
|
||||
extern void
|
||||
findloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_16 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_16 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_i16);
|
||||
|
||||
extern void
|
||||
mfindloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_16 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_16 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_i16);
|
||||
|
||||
extern void
|
||||
sfindloc1_i16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_i16 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_i2);
|
||||
|
||||
extern void
|
||||
findloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_2 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_2 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_i2);
|
||||
|
||||
extern void
|
||||
mfindloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_2 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_2 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_i2);
|
||||
|
||||
extern void
|
||||
sfindloc1_i2 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_i2 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_i4);
|
||||
|
||||
extern void
|
||||
findloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_i4);
|
||||
|
||||
extern void
|
||||
mfindloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_i4);
|
||||
|
||||
extern void
|
||||
sfindloc1_i4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_i4 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_i8);
|
||||
|
||||
extern void
|
||||
findloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_8 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_8 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_i8);
|
||||
|
||||
extern void
|
||||
mfindloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_8 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_8 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_i8);
|
||||
|
||||
extern void
|
||||
sfindloc1_i8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_i8 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_r16);
|
||||
|
||||
extern void
|
||||
findloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_16 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_16 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_r16);
|
||||
|
||||
extern void
|
||||
mfindloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_16 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_16 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_r16);
|
||||
|
||||
extern void
|
||||
sfindloc1_r16 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r16 * const restrict array, GFC_REAL_16 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_r16 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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 findloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_r4);
|
||||
|
||||
extern void
|
||||
findloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_4 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_4 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_r4);
|
||||
|
||||
extern void
|
||||
mfindloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_r4);
|
||||
|
||||
extern void
|
||||
sfindloc1_r4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r4 * const restrict array, GFC_REAL_4 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_r4 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
/* 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_8)
|
||||
extern void findloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_r8);
|
||||
|
||||
extern void
|
||||
findloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_8 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_8 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
for (n = len; n > 0; n--, src -= delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 1)
|
||||
{
|
||||
if (*src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_r8);
|
||||
|
||||
extern void
|
||||
mfindloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, 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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_REAL_8 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_REAL_8 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 1;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && *src == value)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 1;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 1;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 1;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_r8);
|
||||
|
||||
extern void
|
||||
sfindloc1_r8 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_r8 * const restrict array, GFC_REAL_8 value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_r8 (retarray, array, value, pdim, back);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,525 @@
|
|||
/* 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_UINTEGER_1)
|
||||
extern void findloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc1_s1);
|
||||
|
||||
extern void
|
||||
findloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * len_array;
|
||||
for (n = len; n > 0; n--, src -= delta * len_array)
|
||||
{
|
||||
if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * len_array)
|
||||
{
|
||||
if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * len_array;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * len_array;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc1_s1);
|
||||
|
||||
extern void
|
||||
mfindloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * len_array;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * len_array;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc1_s1);
|
||||
|
||||
extern void
|
||||
sfindloc1_s1 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_s1 (retarray, array, value, pdim, back, len_array, len_value);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,525 @@
|
|||
/* 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_UINTEGER_4)
|
||||
extern void findloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc1_s4);
|
||||
|
||||
extern void
|
||||
findloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * len_array;
|
||||
for (n = len; n > 0; n--, src -= delta * len_array)
|
||||
{
|
||||
if (compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * len_array)
|
||||
{
|
||||
if (compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * len_array;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * len_array;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc1_s4);
|
||||
|
||||
extern void
|
||||
mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
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[GFC_MAX_DIMENSIONS];
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * len_array;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * len_array;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * len_array;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * len_array;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
extern void sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc1_s4);
|
||||
|
||||
extern void
|
||||
sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
|
||||
gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
|
||||
const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_s4 (retarray, array, value, pdim, back, len_array, len_value);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
/* 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"
|
||||
|
||||
#ifdef HAVE_GFC_UINTEGER_1
|
||||
index_type findloc2_s1 (gfc_array_s1 * const restrict array,
|
||||
const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc2_s1);
|
||||
|
||||
index_type
|
||||
findloc2_s1 (gfc_array_s1 * const restrict array, const GFC_UINTEGER_1 * restrict value,
|
||||
GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
return i;
|
||||
src -= sstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
|
||||
return i;
|
||||
src += sstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
index_type mfindloc2_s1 (gfc_array_s1 * const restrict array,
|
||||
const GFC_UINTEGER_1 * restrict value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc2_s1);
|
||||
|
||||
index_type
|
||||
mfindloc2_s1 (gfc_array_s1 * const restrict array,
|
||||
const GFC_UINTEGER_1 * restrict value, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
int mask_kind;
|
||||
index_type mstride;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
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");
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
|
||||
mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
|
||||
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
mbase += (extent - 1) * mstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0))
|
||||
return i;
|
||||
src -= sstride;
|
||||
mbase -= mstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0))
|
||||
return i;
|
||||
src += sstride;
|
||||
mbase += mstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
index_type sfindloc2_s1 (gfc_array_s1 * const restrict array,
|
||||
const GFC_UINTEGER_1 * restrict value,
|
||||
GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc2_s1);
|
||||
|
||||
index_type
|
||||
sfindloc2_s1 (gfc_array_s1 * const restrict array,
|
||||
const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
if (*mask)
|
||||
{
|
||||
return findloc2_s1 (array, value, back, len_array, len_value);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
#endif
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
/* 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"
|
||||
|
||||
#ifdef HAVE_GFC_UINTEGER_4
|
||||
index_type findloc2_s4 (gfc_array_s4 * const restrict array,
|
||||
const GFC_UINTEGER_4 * restrict value, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc2_s4);
|
||||
|
||||
index_type
|
||||
findloc2_s4 (gfc_array_s4 * const restrict array, const GFC_UINTEGER_4 * restrict value,
|
||||
GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if (compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
return i;
|
||||
src -= sstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if (compare_string_char4 (len_array, src, len_value, value) == 0)
|
||||
return i;
|
||||
src += sstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
index_type mfindloc2_s4 (gfc_array_s4 * const restrict array,
|
||||
const GFC_UINTEGER_4 * restrict value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc2_s4);
|
||||
|
||||
index_type
|
||||
mfindloc2_s4 (gfc_array_s4 * const restrict array,
|
||||
const GFC_UINTEGER_4 * restrict value, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
int mask_kind;
|
||||
index_type mstride;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
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");
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
|
||||
mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
|
||||
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
mbase += (extent - 1) * mstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if (*mbase && (compare_string_char4 (len_array, src, len_value, value) == 0))
|
||||
return i;
|
||||
src -= sstride;
|
||||
mbase -= mstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if (*mbase && (compare_string_char4 (len_array, src, len_value, value) == 0))
|
||||
return i;
|
||||
src += sstride;
|
||||
mbase += mstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
index_type sfindloc2_s4 (gfc_array_s4 * const restrict array,
|
||||
const GFC_UINTEGER_4 * restrict value,
|
||||
GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc2_s4);
|
||||
|
||||
index_type
|
||||
sfindloc2_s4 (gfc_array_s4 * const restrict array,
|
||||
const GFC_UINTEGER_4 * restrict value, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)
|
||||
{
|
||||
if (*mask)
|
||||
{
|
||||
return findloc2_s4 (array, value, back, len_array, len_value);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
#endif
|
||||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_16 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_16 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_4 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_4 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_8 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ maxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ maxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mmaxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_8 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mmaxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
|
||||
maxval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ maxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ maxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mmaxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mmaxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
maxval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_16_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_char
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_16_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_16_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back, gfc_char
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_16_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_4_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charl
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_4_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_4_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back, gfc_charl
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_4_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_8_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charl
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_8_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -49,8 +49,8 @@ maxloc2_8_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back, gfc_charl
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -88,8 +88,8 @@ mmaxloc2_8_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -30,12 +30,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -44,20 +44,20 @@ compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
|||
|
||||
#define INITVAL 0
|
||||
|
||||
extern void maxval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void maxval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s1 * const restrict array, gfc_charlen_type);
|
||||
export_proto(maxval0_s1);
|
||||
|
||||
void
|
||||
maxval0_s1 (GFC_INTEGER_1 * restrict ret,
|
||||
maxval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
||||
gfc_charlen_type xlen,
|
||||
gfc_array_s1 * const restrict array, gfc_charlen_type len)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
||||
|
|
@ -83,7 +83,7 @@ maxval0_s1 (GFC_INTEGER_1 * restrict ret,
|
|||
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
retval = ret;
|
||||
|
||||
while (base)
|
||||
|
|
@ -130,13 +130,13 @@ maxval0_s1 (GFC_INTEGER_1 * restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void mmaxval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void mmaxval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type, gfc_array_s1 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
|
||||
export_proto(mmaxval0_s1);
|
||||
|
||||
void
|
||||
mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
||||
mmaxval0_s1 (GFC_UINTEGER_1 * const restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
|
||||
{
|
||||
|
|
@ -144,7 +144,7 @@ mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -185,7 +185,7 @@ mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
base = array->base_addr;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
|
||||
retval = ret;
|
||||
|
||||
|
|
@ -236,13 +236,13 @@ mmaxval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void smaxval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void smaxval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
||||
export_proto(smaxval0_s1);
|
||||
|
||||
void
|
||||
smaxval0_s1 (GFC_INTEGER_1 * restrict ret,
|
||||
smaxval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
|
||||
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
||||
|
||||
|
|
|
|||
|
|
@ -30,12 +30,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -44,20 +44,20 @@ compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
|||
|
||||
#define INITVAL 0
|
||||
|
||||
extern void maxval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void maxval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s4 * const restrict array, gfc_charlen_type);
|
||||
export_proto(maxval0_s4);
|
||||
|
||||
void
|
||||
maxval0_s4 (GFC_INTEGER_4 * restrict ret,
|
||||
maxval0_s4 (GFC_UINTEGER_4 * restrict ret,
|
||||
gfc_charlen_type xlen,
|
||||
gfc_array_s4 * const restrict array, gfc_charlen_type len)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
||||
|
|
@ -83,7 +83,7 @@ maxval0_s4 (GFC_INTEGER_4 * restrict ret,
|
|||
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
retval = ret;
|
||||
|
||||
while (base)
|
||||
|
|
@ -130,13 +130,13 @@ maxval0_s4 (GFC_INTEGER_4 * restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void mmaxval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void mmaxval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type, gfc_array_s4 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
|
||||
export_proto(mmaxval0_s4);
|
||||
|
||||
void
|
||||
mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
||||
mmaxval0_s4 (GFC_UINTEGER_4 * const restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
|
||||
{
|
||||
|
|
@ -144,7 +144,7 @@ mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -185,7 +185,7 @@ mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
base = array->base_addr;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
|
||||
retval = ret;
|
||||
|
||||
|
|
@ -236,13 +236,13 @@ mmaxval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void smaxval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void smaxval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
||||
export_proto(smaxval0_s4);
|
||||
|
||||
void
|
||||
smaxval0_s4 (GFC_INTEGER_4 * restrict ret,
|
||||
smaxval0_s4 (GFC_UINTEGER_4 * restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
|
||||
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
||||
|
||||
|
|
|
|||
|
|
@ -26,15 +26,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
|
||||
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -54,8 +54,8 @@ maxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
|
|
@ -119,7 +119,7 @@ maxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
|
||||
* string_len;
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
|
|
@ -155,11 +155,11 @@ maxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
retval = base;
|
||||
if (len <= 0)
|
||||
memset (dest, 0, sizeof (*dest) * string_len);
|
||||
|
|
@ -228,8 +228,8 @@ mmaxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -319,7 +319,7 @@ mmaxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
|
||||
}
|
||||
else
|
||||
|
|
@ -349,14 +349,14 @@ mmaxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
memset (dest, 0, sizeof (*dest) * string_len);
|
||||
retval = dest;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
@ -430,7 +430,7 @@ smaxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type dim;
|
||||
|
|
@ -497,7 +497,7 @@ smaxval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
|
|||
|
|
@ -26,15 +26,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
|
||||
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -54,8 +54,8 @@ maxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
|
|
@ -119,7 +119,7 @@ maxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
|
||||
* string_len;
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
|
|
@ -155,11 +155,11 @@ maxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
retval = base;
|
||||
if (len <= 0)
|
||||
memset (dest, 0, sizeof (*dest) * string_len);
|
||||
|
|
@ -228,8 +228,8 @@ mmaxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -319,7 +319,7 @@ mmaxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
|
||||
}
|
||||
else
|
||||
|
|
@ -349,14 +349,14 @@ mmaxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
memset (dest, 0, sizeof (*dest) * string_len);
|
||||
retval = dest;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
@ -430,7 +430,7 @@ smaxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type dim;
|
||||
|
|
@ -497,7 +497,7 @@ smaxval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_16 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_16 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_4 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_4 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_8 *dest;
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,14 +30,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -56,7 +56,7 @@ minloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -102,7 +102,7 @@ minloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 1;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
|
||||
while (base)
|
||||
|
|
@ -168,7 +168,7 @@ mminloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
GFC_INTEGER_8 *dest;
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -234,7 +234,7 @@ mminloc0_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
dest[n * dstride] = 0;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
|
||||
minval = NULL;
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_16 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_16_s4 (gfc_array_i16 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_16 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_4 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_8_s1 (gfc_array_i8 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
#define HAVE_BACK_ARG 1
|
||||
|
||||
|
|
@ -34,9 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -57,7 +57,7 @@ minloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
|
@ -155,12 +155,12 @@ minloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = NULL;
|
||||
result = 0;
|
||||
if (len <= 0)
|
||||
|
|
@ -231,7 +231,7 @@ mminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_8 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -349,14 +349,14 @@ mminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
GFC_INTEGER_8 result;
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
minval = base;
|
||||
result = 0;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_16_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_16_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_16_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_16_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_4_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_4_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_4_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_4_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_8_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *minval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_8_s1 (gfc_array_s1 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_1 *src;
|
||||
const GFC_INTEGER_1 *maxval;
|
||||
const GFC_UINTEGER_1 *src;
|
||||
const GFC_UINTEGER_1 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -28,12 +28,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -50,8 +50,8 @@ minloc2_8_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *minval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *minval;
|
||||
index_type i;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
|
|
@ -89,8 +89,8 @@ mminloc2_8_s4 (gfc_array_s4 * const restrict array,
|
|||
index_type ret;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const GFC_INTEGER_4 *src;
|
||||
const GFC_INTEGER_4 *maxval;
|
||||
const GFC_UINTEGER_4 *src;
|
||||
const GFC_UINTEGER_4 *maxval;
|
||||
index_type i, j;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int mask_kind;
|
||||
|
|
|
|||
|
|
@ -30,12 +30,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -44,20 +44,20 @@ compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
|||
|
||||
#define INITVAL 255
|
||||
|
||||
extern void minval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void minval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s1 * const restrict array, gfc_charlen_type);
|
||||
export_proto(minval0_s1);
|
||||
|
||||
void
|
||||
minval0_s1 (GFC_INTEGER_1 * restrict ret,
|
||||
minval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
||||
gfc_charlen_type xlen,
|
||||
gfc_array_s1 * const restrict array, gfc_charlen_type len)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
||||
|
|
@ -83,7 +83,7 @@ minval0_s1 (GFC_INTEGER_1 * restrict ret,
|
|||
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
retval = ret;
|
||||
|
||||
while (base)
|
||||
|
|
@ -130,13 +130,13 @@ minval0_s1 (GFC_INTEGER_1 * restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void mminval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void mminval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type, gfc_array_s1 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
|
||||
export_proto(mminval0_s1);
|
||||
|
||||
void
|
||||
mminval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
||||
mminval0_s1 (GFC_UINTEGER_1 * const restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
|
||||
{
|
||||
|
|
@ -144,7 +144,7 @@ mminval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 *base;
|
||||
const GFC_UINTEGER_1 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -185,7 +185,7 @@ mminval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
base = array->base_addr;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
|
||||
retval = ret;
|
||||
|
||||
|
|
@ -236,13 +236,13 @@ mminval0_s1 (GFC_INTEGER_1 * const restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void sminval0_s1 (GFC_INTEGER_1 * restrict,
|
||||
extern void sminval0_s1 (GFC_UINTEGER_1 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s1 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
||||
export_proto(sminval0_s1);
|
||||
|
||||
void
|
||||
sminval0_s1 (GFC_INTEGER_1 * restrict ret,
|
||||
sminval0_s1 (GFC_UINTEGER_1 * restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s1 * const restrict array,
|
||||
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
||||
|
||||
|
|
|
|||
|
|
@ -30,12 +30,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include <limits.h>
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -44,20 +44,20 @@ compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
|||
|
||||
#define INITVAL 255
|
||||
|
||||
extern void minval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void minval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s4 * const restrict array, gfc_charlen_type);
|
||||
export_proto(minval0_s4);
|
||||
|
||||
void
|
||||
minval0_s4 (GFC_INTEGER_4 * restrict ret,
|
||||
minval0_s4 (GFC_UINTEGER_4 * restrict ret,
|
||||
gfc_charlen_type xlen,
|
||||
gfc_array_s4 * const restrict array, gfc_charlen_type len)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
|
||||
|
|
@ -83,7 +83,7 @@ minval0_s4 (GFC_INTEGER_4 * restrict ret,
|
|||
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
retval = ret;
|
||||
|
||||
while (base)
|
||||
|
|
@ -130,13 +130,13 @@ minval0_s4 (GFC_INTEGER_4 * restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void mminval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void mminval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type, gfc_array_s4 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len);
|
||||
export_proto(mminval0_s4);
|
||||
|
||||
void
|
||||
mminval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
||||
mminval0_s4 (GFC_UINTEGER_4 * const restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
|
||||
gfc_array_l1 * const restrict mask, gfc_charlen_type len)
|
||||
{
|
||||
|
|
@ -144,7 +144,7 @@ mminval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 *base;
|
||||
const GFC_UINTEGER_4 *base;
|
||||
GFC_LOGICAL_1 *mbase;
|
||||
int rank;
|
||||
index_type n;
|
||||
|
|
@ -185,7 +185,7 @@ mminval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
base = array->base_addr;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
|
||||
retval = ret;
|
||||
|
||||
|
|
@ -236,13 +236,13 @@ mminval0_s4 (GFC_INTEGER_4 * const restrict ret,
|
|||
}
|
||||
|
||||
|
||||
extern void sminval0_s4 (GFC_INTEGER_4 * restrict,
|
||||
extern void sminval0_s4 (GFC_UINTEGER_4 * restrict,
|
||||
gfc_charlen_type,
|
||||
gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
|
||||
export_proto(sminval0_s4);
|
||||
|
||||
void
|
||||
sminval0_s4 (GFC_INTEGER_4 * restrict ret,
|
||||
sminval0_s4 (GFC_UINTEGER_4 * restrict ret,
|
||||
gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
|
||||
GFC_LOGICAL_4 *mask, gfc_charlen_type len)
|
||||
|
||||
|
|
|
|||
|
|
@ -26,15 +26,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
|
||||
#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_UINTEGER_1)
|
||||
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_1) == 1)
|
||||
if (sizeof (GFC_UINTEGER_1) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -54,8 +54,8 @@ minval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
|
|
@ -119,7 +119,7 @@ minval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
|
||||
* string_len;
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
|
|
@ -155,11 +155,11 @@ minval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
retval = base;
|
||||
if (len <= 0)
|
||||
memset (dest, 255, sizeof (*dest) * string_len);
|
||||
|
|
@ -228,8 +228,8 @@ mminval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
const GFC_INTEGER_1 * restrict base;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
const GFC_UINTEGER_1 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -319,7 +319,7 @@ mminval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
|
||||
}
|
||||
else
|
||||
|
|
@ -349,14 +349,14 @@ mminval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_1 * restrict src;
|
||||
const GFC_UINTEGER_1 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_1 *retval;
|
||||
const GFC_UINTEGER_1 *retval;
|
||||
memset (dest, 255, sizeof (*dest) * string_len);
|
||||
retval = dest;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
@ -430,7 +430,7 @@ sminval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_1 * restrict dest;
|
||||
GFC_UINTEGER_1 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type dim;
|
||||
|
|
@ -497,7 +497,7 @@ sminval1_s1 (gfc_array_s1 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_1));
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
|
|||
|
|
@ -26,15 +26,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
||||
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
|
||||
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
|
||||
static inline int
|
||||
compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
|
||||
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
||||
{
|
||||
if (sizeof (GFC_INTEGER_4) == 1)
|
||||
if (sizeof (GFC_UINTEGER_4) == 1)
|
||||
return memcmp (a, b, n);
|
||||
else
|
||||
return memcmp_char4 (a, b, n);
|
||||
|
|
@ -54,8 +54,8 @@ minval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
|
|
@ -119,7 +119,7 @@ minval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
|
||||
* string_len;
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
|
|
@ -155,11 +155,11 @@ minval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
continue_loop = 1;
|
||||
while (continue_loop)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
src = base;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
retval = base;
|
||||
if (len <= 0)
|
||||
memset (dest, 255, sizeof (*dest) * string_len);
|
||||
|
|
@ -228,8 +228,8 @@ mminval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type mstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
const GFC_INTEGER_4 * restrict base;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
const GFC_UINTEGER_4 * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type rank;
|
||||
index_type dim;
|
||||
|
|
@ -319,7 +319,7 @@ mminval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
|
||||
}
|
||||
else
|
||||
|
|
@ -349,14 +349,14 @@ mminval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
|
||||
while (base)
|
||||
{
|
||||
const GFC_INTEGER_4 * restrict src;
|
||||
const GFC_UINTEGER_4 * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
{
|
||||
|
||||
const GFC_INTEGER_4 *retval;
|
||||
const GFC_UINTEGER_4 *retval;
|
||||
memset (dest, 255, sizeof (*dest) * string_len);
|
||||
retval = dest;
|
||||
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
|
||||
|
|
@ -430,7 +430,7 @@ sminval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
GFC_INTEGER_4 * restrict dest;
|
||||
GFC_UINTEGER_4 * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type dim;
|
||||
|
|
@ -497,7 +497,7 @@ sminval1_s4 (gfc_array_s4 * const restrict retarray,
|
|||
return;
|
||||
}
|
||||
else
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1486,5 +1486,91 @@ GFORTRAN_C99_8 {
|
|||
|
||||
GFORTRAN_9 {
|
||||
global:
|
||||
_gfortran_findloc0_c16;
|
||||
_gfortran_findloc0_c4;
|
||||
_gfortran_findloc0_c8;
|
||||
_gfortran_findloc0_i1;
|
||||
_gfortran_findloc0_i16;
|
||||
_gfortran_findloc0_i4;
|
||||
_gfortran_findloc0_i8;
|
||||
_gfortran_findloc0_l1;
|
||||
_gfortran_findloc0_l16;
|
||||
_gfortran_findloc0_l2;
|
||||
_gfortran_findloc0_l4;
|
||||
_gfortran_findloc0_l8;
|
||||
_gfortran_findloc0_r16;
|
||||
_gfortran_findloc0_r4;
|
||||
_gfortran_findloc0_r8;
|
||||
_gfortran_findloc0_s1;
|
||||
_gfortran_findloc0_s4;
|
||||
_gfortran_findloc1_c16;
|
||||
_gfortran_findloc1_c4;
|
||||
_gfortran_findloc1_c8;
|
||||
_gfortran_findloc1_i1;
|
||||
_gfortran_findloc1_i16;
|
||||
_gfortran_findloc1_i2;
|
||||
_gfortran_findloc1_i4;
|
||||
_gfortran_findloc1_i8;
|
||||
_gfortran_findloc1_r16;
|
||||
_gfortran_findloc1_r4;
|
||||
_gfortran_findloc1_r8;
|
||||
_gfortran_findloc1_s1;
|
||||
_gfortran_findloc1_s4;
|
||||
_gfortran_findloc2_s1;
|
||||
_gfortran_findloc2_s4;
|
||||
_gfortran_mfindloc0_c16;
|
||||
_gfortran_mfindloc0_c4;
|
||||
_gfortran_mfindloc0_c8;
|
||||
_gfortran_mfindloc0_i1;
|
||||
_gfortran_mfindloc0_i16;
|
||||
_gfortran_mfindloc0_i4;
|
||||
_gfortran_mfindloc0_i8;
|
||||
_gfortran_mfindloc0_r16;
|
||||
_gfortran_mfindloc0_r4;
|
||||
_gfortran_mfindloc0_r8;
|
||||
_gfortran_mfindloc0_s1;
|
||||
_gfortran_mfindloc0_s4;
|
||||
_gfortran_mfindloc1_c16;
|
||||
_gfortran_mfindloc1_c4;
|
||||
_gfortran_mfindloc1_c8;
|
||||
_gfortran_mfindloc1_i1;
|
||||
_gfortran_mfindloc1_i16;
|
||||
_gfortran_mfindloc1_i2;
|
||||
_gfortran_mfindloc1_i4;
|
||||
_gfortran_mfindloc1_i8;
|
||||
_gfortran_mfindloc1_r16;
|
||||
_gfortran_mfindloc1_r4;
|
||||
_gfortran_mfindloc1_r8;
|
||||
_gfortran_mfindloc1_s1;
|
||||
_gfortran_mfindloc1_s4;
|
||||
_gfortran_mfindloc2_s1;
|
||||
_gfortran_mfindloc2_s4;
|
||||
_gfortran_sfindloc0_c16;
|
||||
_gfortran_sfindloc0_c4;
|
||||
_gfortran_sfindloc0_c8;
|
||||
_gfortran_sfindloc0_i1;
|
||||
_gfortran_sfindloc0_i16;
|
||||
_gfortran_sfindloc0_i4;
|
||||
_gfortran_sfindloc0_i8;
|
||||
_gfortran_sfindloc0_r16;
|
||||
_gfortran_sfindloc0_r4;
|
||||
_gfortran_sfindloc0_r8;
|
||||
_gfortran_sfindloc0_s1;
|
||||
_gfortran_sfindloc0_s4;
|
||||
_gfortran_sfindloc1_c16;
|
||||
_gfortran_sfindloc1_c4;
|
||||
_gfortran_sfindloc1_c8;
|
||||
_gfortran_sfindloc1_i1;
|
||||
_gfortran_sfindloc1_i16;
|
||||
_gfortran_sfindloc1_i2;
|
||||
_gfortran_sfindloc1_i4;
|
||||
_gfortran_sfindloc1_i8;
|
||||
_gfortran_sfindloc1_r16;
|
||||
_gfortran_sfindloc1_r4;
|
||||
_gfortran_sfindloc1_r8;
|
||||
_gfortran_sfindloc1_s1;
|
||||
_gfortran_sfindloc1_s4;
|
||||
_gfortran_sfindloc2_s1;
|
||||
_gfortran_sfindloc2_s4;
|
||||
_gfortran_st_wait_async;
|
||||
};
|
||||
|
|
|
|||
|
|
@ -359,6 +359,7 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_1) gfc_array_i1;
|
|||
typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_2) gfc_array_i2;
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_4) gfc_array_i4;
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_8) gfc_array_i8;
|
||||
typedef GFC_ARRAY_DESCRIPTOR (index_type) gfc_array_index_type;
|
||||
#ifdef HAVE_GFC_INTEGER_16
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_16) gfc_array_i16;
|
||||
#endif
|
||||
|
|
@ -385,8 +386,9 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_LOGICAL_8) gfc_array_l8;
|
|||
#ifdef HAVE_GFC_LOGICAL_16
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_LOGICAL_16) gfc_array_l16;
|
||||
#endif
|
||||
typedef gfc_array_i1 gfc_array_s1;
|
||||
typedef gfc_array_i4 gfc_array_s4;
|
||||
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_UINTEGER_1) gfc_array_s1;
|
||||
typedef GFC_ARRAY_DESCRIPTOR (GFC_UINTEGER_4) gfc_array_s4;
|
||||
|
||||
/* These are for when you actually want to declare a descriptor, as
|
||||
opposed to a pointer to it. */
|
||||
|
|
@ -1757,7 +1759,9 @@ void cshift1_16_c16 (gfc_array_c16 * const restrict,
|
|||
internal_proto(cshift1_16_c16);
|
||||
#endif
|
||||
|
||||
/* Define this if we support asynchronous I/O on this platform. This
|
||||
currently requires weak symbols. */
|
||||
/* We always have these. */
|
||||
|
||||
#define HAVE_GFC_UINTEGER_1 1
|
||||
#define HAVE_GFC_UINTEGER_4 1
|
||||
|
||||
#endif /* LIBGFOR_H */
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
dnl Support macros for findloc.
|
||||
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
|
||||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
include(iparm.m4)dnl
|
||||
define(header1,`extern void findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
GFC_LOGICAL_4);
|
||||
export_proto(findloc0_'atype_code`);
|
||||
|
||||
void
|
||||
findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
GFC_LOGICAL_4 back)')dnl
|
||||
dnl
|
||||
define(header2,`extern void mfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
gfc_array_l1 *const restrict, GFC_LOGICAL_4);
|
||||
export_proto(mfindloc0_'atype_code`);
|
||||
|
||||
void
|
||||
mfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)')
|
||||
dnl
|
||||
define(header3,`extern void sfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
GFC_LOGICAL_4 *, GFC_LOGICAL_4);
|
||||
export_proto(sfindloc0_'atype_code`);
|
||||
|
||||
void
|
||||
sfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)')dnl
|
||||
dnl
|
||||
define(comparison,`*base == value')dnl
|
||||
define(len_arg,`')dnl
|
||||
define(base_mult,1)dnl
|
||||
include(ifindloc0.m4)dnl
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
dnl Support macros for findloc.
|
||||
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
|
||||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
include(iparm.m4)dnl
|
||||
define(header1,`extern void findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
|
||||
export_proto(findloc0_'atype_code`);
|
||||
|
||||
void
|
||||
findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(header2,`extern void mfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(mfindloc0_'atype_code`);
|
||||
|
||||
void
|
||||
mfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)')
|
||||
dnl
|
||||
define(header3,`extern void sfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value);
|
||||
export_proto(sfindloc0_'atype_code`);
|
||||
|
||||
void
|
||||
sfindloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *value,
|
||||
GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(comparison,ifelse(atype_kind,4,dnl
|
||||
`compare_string_char4 (len_array, base, len_value, value) == 0',dnl
|
||||
`compare_string (len_array, (char *) base, len_value, (char *) value) == 0'))dnl
|
||||
define(len_arg,`, len_array, len_value')dnl
|
||||
define(base_mult,`len_array')dnl
|
||||
include(ifindloc0.m4)dnl
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
dnl Support macros for findloc.
|
||||
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
|
||||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
include(iparm.m4)dnl
|
||||
define(header1,`extern void findloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 back);
|
||||
export_proto(findloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
findloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 back)')dnl
|
||||
dnl
|
||||
define(header2,`extern void mfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(mfindloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
mfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)')dnl
|
||||
define(header3,`extern void sfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back);
|
||||
export_proto(sfindloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
sfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back)')dnl
|
||||
define(comparison,`*src == value')dnl
|
||||
define(len_arg,`')dnl
|
||||
define(base_mult,1)dnl
|
||||
include(ifindloc1.m4)dnl
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
dnl Support macros for findloc.
|
||||
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
|
||||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
include(iparm.m4)dnl
|
||||
define(header1,`extern void findloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
findloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(header2,`extern void mfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
mfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)')dnl
|
||||
define(header3,`extern void sfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc1_'atype_code`);
|
||||
|
||||
extern void
|
||||
sfindloc1_'atype_code` (gfc_array_index_type * const restrict retarray,
|
||||
'atype` * const restrict array, 'atype_name` *const restrict value,
|
||||
const 'index_type` * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)')dnl
|
||||
define(comparison,ifelse(atype_kind,4,dnl
|
||||
`compare_string_char4 (len_array, src, len_value, value) == 0',dnl
|
||||
`compare_string (len_array, (char *) src, len_value, (char *) value) == 0'))dnl
|
||||
define(len_arg,`, len_array, len_value')dnl
|
||||
define(base_mult,`len_array')dnl
|
||||
include(ifindloc1.m4)dnl
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
dnl Support macros for findloc.
|
||||
dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
|
||||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
include(iparm.m4)dnl
|
||||
define(header1,`index_type findloc2_'atype_code` ('atype` * const restrict array,
|
||||
const 'atype_name` * restrict value, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(findloc2_'atype_code`);
|
||||
|
||||
index_type
|
||||
findloc2_'atype_code` ('atype` * const restrict array, const 'atype_name` * restrict value,
|
||||
GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(header2,`index_type mfindloc2_'atype_code` ('atype` * const restrict array,
|
||||
const 'atype_name` * restrict value,
|
||||
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(mfindloc2_'atype_code`);
|
||||
|
||||
index_type
|
||||
mfindloc2_'atype_code` ('atype` * const restrict array,
|
||||
const 'atype_name` * restrict value, gfc_array_l1 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(header3,`index_type sfindloc2_'atype_code` ('atype` * const restrict array,
|
||||
const 'atype_name` * restrict value,
|
||||
GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back,
|
||||
gfc_charlen_type len_array, gfc_charlen_type len_value);
|
||||
export_proto(sfindloc2_'atype_code`);
|
||||
|
||||
index_type
|
||||
sfindloc2_'atype_code` ('atype` * const restrict array,
|
||||
const 'atype_name` * restrict value, GFC_LOGICAL_4 *const restrict mask,
|
||||
GFC_LOGICAL_4 back, gfc_charlen_type len_array,
|
||||
gfc_charlen_type len_value)')dnl
|
||||
dnl
|
||||
define(comparison,ifelse(atype_kind,4,dnl
|
||||
`compare_string_char4 (len_array, src, len_value, value) == 0',dnl
|
||||
`compare_string (len_array, (char *) src, len_value, (char *) value) == 0'))dnl
|
||||
define(len_arg,`len_array, len_value')dnl
|
||||
define(base_mult,`len_array')dnl
|
||||
include(ifindloc2.m4)dnl
|
||||
|
|
@ -0,0 +1,350 @@
|
|||
`/* 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_'atype_name`)
|
||||
'header1`
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride;
|
||||
const 'atype_name` *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) * 'base_mult`'`;
|
||||
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely('comparison`))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * 'base_mult`'`;
|
||||
} 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] * 'base_mult`'`;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * 'base_mult`'`;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely('comparison`))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * 'base_mult`'`;
|
||||
} 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] * 'base_mult`'`;
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 'base_mult`'`;
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
'header2`
|
||||
{
|
||||
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 'atype_name` *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) * 'base_mult`'`;
|
||||
mbase = mbase + (sz - 1) * mask_kind;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && 'comparison`))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = extent[n] - count[n];
|
||||
|
||||
return;
|
||||
}
|
||||
base -= sstride[0] * 'base_mult`'`;
|
||||
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] * 'base_mult`'`;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base -= sstride[n] * 'base_mult`'`;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
base = array->base_addr;
|
||||
while (1)
|
||||
{
|
||||
do
|
||||
{
|
||||
if (unlikely(*mbase && 'comparison`))
|
||||
{
|
||||
for (n = 0; n < rank; n++)
|
||||
dest[n * dstride] = count[n] + 1;
|
||||
|
||||
return;
|
||||
}
|
||||
base += sstride[0] * 'base_mult`'`;
|
||||
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] * 'base_mult`'`;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
return;
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n]* 'base_mult`'`;
|
||||
mbase += mstride[n];
|
||||
}
|
||||
} while (count[n] == extent[n]);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
'header3`
|
||||
{
|
||||
index_type rank;
|
||||
index_type dstride;
|
||||
index_type * restrict dest;
|
||||
index_type n;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc0_'atype_code` (retarray, array, value, back'len_arg`);
|
||||
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'
|
||||
|
|
@ -0,0 +1,495 @@
|
|||
`/* 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_'atype_name`)
|
||||
'header1`
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type sstride[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
const 'atype_name`'` * restrict base;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type dim;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const 'atype_name`'` * restrict src;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 'base_mult`;
|
||||
for (n = len; n > 0; n--, src -= delta * 'base_mult`)
|
||||
{
|
||||
if ('comparison`'`)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
for (n = 1; n <= len; n++, src += delta * 'base_mult`)
|
||||
{
|
||||
if ('comparison`'`)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 'base_mult`;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 'base_mult`;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 'base_mult`;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
'header2`'`
|
||||
{
|
||||
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[GFC_MAX_DIMENSIONS];
|
||||
const 'atype_name`'` * restrict base;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type delta;
|
||||
index_type mdelta;
|
||||
index_type dim;
|
||||
int mask_kind;
|
||||
int continue_loop;
|
||||
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
delta = GFC_DESCRIPTOR_STRIDE(array,dim);
|
||||
mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
|
||||
|
||||
mbase = mask->base_addr;
|
||||
|
||||
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
|
||||
|
||||
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");
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
|
||||
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
|
||||
|
||||
if (extent[n] < 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
base = array->base_addr;
|
||||
while (continue_loop)
|
||||
{
|
||||
const 'atype_name`'` * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict msrc;
|
||||
index_type result;
|
||||
|
||||
result = 0;
|
||||
if (back)
|
||||
{
|
||||
src = base + (len - 1) * delta * 'base_mult`;
|
||||
msrc = mbase + (len - 1) * mdelta;
|
||||
for (n = len; n > 0; n--, src -= delta * 'base_mult`, msrc -= mdelta)
|
||||
{
|
||||
if (*msrc && 'comparison`'`)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = base;
|
||||
msrc = mbase;
|
||||
for (n = 1; n <= len; n++, src += delta * 'base_mult`, msrc += mdelta)
|
||||
{
|
||||
if (*msrc && 'comparison`'`)
|
||||
{
|
||||
result = n;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
*dest = result;
|
||||
|
||||
count[0]++;
|
||||
base += sstride[0] * 'base_mult`;
|
||||
mbase += mstride[0];
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
base -= sstride[n] * extent[n] * 'base_mult`;
|
||||
mbase -= mstride[n] * extent[n];
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
base += sstride[n] * 'base_mult`;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
'header3`'`
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type dstride[GFC_MAX_DIMENSIONS];
|
||||
index_type * restrict dest;
|
||||
index_type rank;
|
||||
index_type n;
|
||||
index_type len;
|
||||
index_type dim;
|
||||
bool continue_loop;
|
||||
|
||||
if (*mask)
|
||||
{
|
||||
findloc1_'atype_code`'` (retarray, array, value, pdim, back'len_arg`'`);
|
||||
return;
|
||||
}
|
||||
/* Make dim zero based to avoid confusion. */
|
||||
rank = GFC_DESCRIPTOR_RANK (array) - 1;
|
||||
dim = (*pdim) - 1;
|
||||
|
||||
if (unlikely (dim < 0 || dim > rank))
|
||||
{
|
||||
runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
|
||||
"is %ld, should be between 1 and %ld",
|
||||
(long int) dim + 1, (long int) rank + 1);
|
||||
}
|
||||
|
||||
len = GFC_DESCRIPTOR_EXTENT(array,dim);
|
||||
if (len < 0)
|
||||
len = 0;
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
for (n = dim; n < rank; n++)
|
||||
{
|
||||
extent[n] =
|
||||
GFC_DESCRIPTOR_EXTENT(array,n + 1);
|
||||
|
||||
if (extent[n] <= 0)
|
||||
extent[n] = 0;
|
||||
}
|
||||
|
||||
|
||||
if (retarray->base_addr == NULL)
|
||||
{
|
||||
size_t alloc_size, str;
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
if (n == 0)
|
||||
str = 1;
|
||||
else
|
||||
str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
|
||||
|
||||
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
|
||||
}
|
||||
|
||||
retarray->offset = 0;
|
||||
retarray->dtype.rank = rank;
|
||||
|
||||
alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
|
||||
|
||||
retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
|
||||
if (alloc_size == 0)
|
||||
{
|
||||
/* Make sure we have a zero-sized array. */
|
||||
GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
if (rank != GFC_DESCRIPTOR_RANK (retarray))
|
||||
runtime_error ("rank of return array incorrect in"
|
||||
" FINDLOC intrinsic: is %ld, should be %ld",
|
||||
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
|
||||
(long int) rank);
|
||||
|
||||
if (unlikely (compile_options.bounds_check))
|
||||
bounds_ifunction_return ((array_t *) retarray, extent,
|
||||
"return value", "FINDLOC");
|
||||
}
|
||||
|
||||
for (n = 0; n < rank; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
dest = retarray->base_addr;
|
||||
continue_loop = 1;
|
||||
|
||||
while (continue_loop)
|
||||
{
|
||||
*dest = 0;
|
||||
|
||||
count[0]++;
|
||||
dest += dstride[0];
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
count[n] = 0;
|
||||
dest -= dstride[n] * extent[n];
|
||||
n++;
|
||||
if (n >= rank)
|
||||
{
|
||||
continue_loop = 0;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += dstride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif'
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
`/* 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"
|
||||
|
||||
#ifdef HAVE_'atype_name`'`
|
||||
'header1`'`
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const 'atype_name`'` * restrict src;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`;
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if ('comparison`'`)
|
||||
return i;
|
||||
src -= sstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if ('comparison`'`)
|
||||
return i;
|
||||
src += sstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
'header2`'`
|
||||
{
|
||||
index_type i;
|
||||
index_type sstride;
|
||||
index_type extent;
|
||||
const 'atype_name`'` * restrict src;
|
||||
const GFC_LOGICAL_1 * restrict mbase;
|
||||
int mask_kind;
|
||||
index_type mstride;
|
||||
|
||||
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
||||
if (extent <= 0)
|
||||
return 0;
|
||||
|
||||
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");
|
||||
|
||||
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`;
|
||||
mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
|
||||
|
||||
if (back)
|
||||
{
|
||||
src = array->base_addr + (extent - 1) * sstride;
|
||||
mbase += (extent - 1) * mstride;
|
||||
for (i = extent; i >= 0; i--)
|
||||
{
|
||||
if (*mbase && ('comparison`'`))
|
||||
return i;
|
||||
src -= sstride;
|
||||
mbase -= mstride;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
src = array->base_addr;
|
||||
for (i = 1; i <= extent; i++)
|
||||
{
|
||||
if (*mbase && ('comparison`'`))
|
||||
return i;
|
||||
src += sstride;
|
||||
mbase += mstride;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
'header3`'`
|
||||
{
|
||||
if (*mask)
|
||||
{
|
||||
return findloc2_'atype_code` (array, value, back, len_array, len_value);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
#endif'
|
||||
|
|
@ -4,7 +4,7 @@ dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)
|
|||
dnl Distributed under the GNU GPL with exception. See COPYING for details.
|
||||
dnl M4 macro file to get type names from filenames
|
||||
define(get_typename2, `GFC_$1_$2')dnl
|
||||
define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,ifelse($1,s,INTEGER,unknown))))),`$2')')dnl
|
||||
define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,ifelse($1,s,UINTEGER,unknown))))),`$2')')dnl
|
||||
define(get_arraytype, `gfc_array_$1$2')dnl
|
||||
define(define_type, `dnl
|
||||
ifelse(regexp($2,`^[0-9]'),-1,`dnl
|
||||
|
|
|
|||
Loading…
Reference in New Issue