Attachment #44813 for bug #54613

View | Details | Return to bug 54613 | Differences between
Collapse All | Expand All

Lines 148-153 int_or_real_or_char_check_f2003 (gfc_expr *e, int Link Here

(-)gcc/fortran/check.c (+91 lines)
148	return true;	148	return true;
149	}	149	}
150		150
		151	/* Check that en expression is an intrinsic type. */
		152	static bool
		153	intrinsic_type_check (gfc_expr *e, int n)
		154	{
		155	if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL
		156	&& e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER
		157	&& e->ts.type != BT_LOGICAL)
		158	{
		159	gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
		160	gfc_current_intrinsic_arg[n]->name,
		161	gfc_current_intrinsic, &e->where);
		162	return false;
		163	}
		164	return true;
		165	}
151		166
152	/* Check that an expression is real or complex. */	167	/* Check that an expression is real or complex. */
153		168
Lines 3345-3351 gfc_check_minloc_maxloc (gfc_actual_arglist *ap) Link Here
3345	return true;	3360	return true;
3346	}	3361	}
3347		3362
		3363	/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
		3364	above, with the additional "value" argument. */
3348		3365
		3366	bool
		3367	gfc_check_findloc (gfc_actual_arglist *ap)
		3368	{
		3369	gfc_expr a, v, m, d, k, b;
		3370
		3371	a = ap->expr;
		3372	if (!intrinsic_type_check (a, 0) \|\| !array_check (a, 0))
		3373	return false;
		3374
		3375	v = ap->next->expr;
		3376	if (!scalar_check (v,1))
		3377	return false;
		3378
		3379	/* Check if the type is compatible. */
		3380
		3381	if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
		3382	\|\| (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
		3383	{
		3384	gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
		3385	"conformance to argument %qs at %L",
		3386	gfc_current_intrinsic_arg[0]->name,
		3387	gfc_current_intrinsic, &a->where,
		3388	gfc_current_intrinsic_arg[1]->name, &v->where);
		3389	}
		3390
		3391	d = ap->next->next->expr;
		3392	m = ap->next->next->next->expr;
		3393	k = ap->next->next->next->next->expr;
		3394	b = ap->next->next->next->next->next->expr;
		3395
		3396	if (b)
		3397	{
		3398	if (!type_check (b, 5, BT_LOGICAL) \|\| !scalar_check (b,4))
		3399	return false;
		3400	}
		3401	else
		3402	{
		3403	b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
		3404	ap->next->next->next->next->next->expr = b;
		3405	}
		3406
		3407	if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
		3408	&& ap->next->name == NULL)
		3409	{
		3410	m = d;
		3411	d = NULL;
		3412	ap->next->next->expr = NULL;
		3413	ap->next->next->next->expr = m;
		3414	}
		3415
		3416	if (!dim_check (d, 2, false))
		3417	return false;
		3418
		3419	if (!dim_rank_check (d, a, 0))
		3420	return false;
		3421
		3422	if (m != NULL && !type_check (m, 3, BT_LOGICAL))
		3423	return false;
		3424
		3425	if (m != NULL
		3426	&& !gfc_check_conformance (a, m,
		3427	"arguments '%s' and '%s' for intrinsic %s",
		3428	gfc_current_intrinsic_arg[0]->name,
		3429	gfc_current_intrinsic_arg[3]->name,
3430	gfc_current_intrinsic))
3431	return false;
3432
3433	if (!kind_check (k, 1, BT_INTEGER))
3434	return false;
3435
3436	return true;
3437	}
3438
3439
3349	/* Similar to minloc/maxloc, the argument list might need to be	3440	/* Similar to minloc/maxloc, the argument list might need to be
3350	reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The	3441	reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The
3351	difference is that MINLOC/MAXLOC take an additional KIND argument.	3442	difference is that MINLOC/MAXLOC take an additional KIND argument.

Lines 437-442 enum gfc_isym_id Link Here

(-)gcc/fortran/gfortran.h (-1 / +9 lines)
437	GFC_ISYM_FE_RUNTIME_ERROR,	437	GFC_ISYM_FE_RUNTIME_ERROR,
438	GFC_ISYM_FGET,	438	GFC_ISYM_FGET,
439	GFC_ISYM_FGETC,	439	GFC_ISYM_FGETC,
		440	GFC_ISYM_FINDLOC,
440	GFC_ISYM_FLOOR,	441	GFC_ISYM_FLOOR,
441	GFC_ISYM_FLUSH,	442	GFC_ISYM_FLUSH,
442	GFC_ISYM_FNUM,	443	GFC_ISYM_FNUM,
Lines 2001-2006 typedef union Link Here
2001	bool (f2)(struct gfc_expr , struct gfc_expr *);	2002	bool (f2)(struct gfc_expr , struct gfc_expr *);
2002	bool (f3)(struct gfc_expr , struct gfc_expr , struct gfc_expr );	2003	bool (f3)(struct gfc_expr , struct gfc_expr , struct gfc_expr );
2003	bool (f5ml)(gfc_actual_arglist );	2004	bool (f5ml)(gfc_actual_arglist );
		2005	bool (f6fl)(gfc_actual_arglist );
2004	bool (f3red)(gfc_actual_arglist );	2006	bool (f3red)(gfc_actual_arglist );
2005	bool (f4)(struct gfc_expr , struct gfc_expr , struct gfc_expr ,	2007	bool (f4)(struct gfc_expr , struct gfc_expr , struct gfc_expr ,
2006	struct gfc_expr *);	2008	struct gfc_expr *);
Lines 2025-2030 typedef union Link Here
2025	struct gfc_expr (f5)(struct gfc_expr , struct gfc_expr ,	2027	struct gfc_expr (f5)(struct gfc_expr , struct gfc_expr ,
2026	struct gfc_expr , struct gfc_expr ,	2028	struct gfc_expr , struct gfc_expr ,
2027	struct gfc_expr *);	2029	struct gfc_expr *);
		2030	struct gfc_expr (f6)(struct gfc_expr , struct gfc_expr ,
		2031	struct gfc_expr , struct gfc_expr ,
		2032	struct gfc_expr , struct gfc_expr );
2028	struct gfc_expr (cc)(struct gfc_expr *, bt, int);	2033	struct gfc_expr (cc)(struct gfc_expr *, bt, int);
2029	}	2034	}
2030	gfc_simplify_f;	2035	gfc_simplify_f;
Lines 2045-2050 typedef union Link Here
2045	struct gfc_expr , struct gfc_expr );	2050	struct gfc_expr , struct gfc_expr );
2046	void (f5)(struct gfc_expr , struct gfc_expr , struct gfc_expr ,	2051	void (f5)(struct gfc_expr , struct gfc_expr , struct gfc_expr ,
2047	struct gfc_expr , struct gfc_expr , struct gfc_expr *);	2052	struct gfc_expr , struct gfc_expr , struct gfc_expr *);
		2053	void (f6)(struct gfc_expr , struct gfc_expr , struct gfc_expr ,
		2054	struct gfc_expr , struct gfc_expr , struct gfc_expr *,
		2055	struct gfc_expr *);
2048	void (s1)(struct gfc_code );	2056	void (s1)(struct gfc_code );
2049	}	2057	}
2050	gfc_resolve_f;	2058	gfc_resolve_f;
Lines 3094-3100 extern bool gfc_init_expr_flag; Link Here
3094	void gfc_intrinsic_init_1 (void);	3102	void gfc_intrinsic_init_1 (void);
3095	void gfc_intrinsic_done_1 (void);	3103	void gfc_intrinsic_done_1 (void);
3096		3104
3097	char gfc_type_letter (bt);	3105	char gfc_type_letter (bt, bool logical_equals_int = false);
3098	gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);	3106	gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
3099	bool gfc_convert_type (gfc_expr , gfc_typespec , int);	3107	bool gfc_convert_type (gfc_expr , gfc_typespec , int);
3100	bool gfc_convert_type_warn (gfc_expr , gfc_typespec , int, int);	3108	bool gfc_convert_type_warn (gfc_expr , gfc_typespec , int, int);






/* Return a letter based on the passed type.  Used to construct the
   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, bool logical_equals_int)
{
  char c;


  switch (type)
    {
    case BT_LOGICAL:
      if (logical_equals_int)
	c = 'i';
      else
	c = 'l';

      break;
    case BT_CHARACTER:
      c = 's';

}


/* 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,

	   (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.  */


    *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", *val = "value", *x = "x", *y = "y",
    *z = "z";

  int di, dr, dd, dl, dc, dz, ii;



  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,

static void
resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
{
  gfc_expr *a1, *a2, *a3, *a4, *a5, *a6;
  gfc_actual_arglist *arg;

  if (specific->resolve.f1 == NULL)

      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");
}


static bool
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
{
  gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6;
  gfc_actual_arglist *arg;

  /* Max and min require special handling due to the variable number

		  if (arg == NULL)
		    result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
		  else
		    {
		      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");
		    }
		}
	    }
	}

  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.  */






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;

  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 (array->ts.type != BT_CHARACTER || 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);

  if (f->ts.kind != fkind)
    {
      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)
{

Lines 5453-5458 gfc_simplify_maxloc (gfc_expr array, gfc_expr di Link Here

(-)gcc/fortran/simplify.c (+7 lines)
5453	}	5453	}
5454		5454
5455	gfc_expr *	5455	gfc_expr *
		5456	gfc_simplify_findloc (gfc_expr array ATTRIBUTE_UNUSED, gfc_expr value ATTRIBUTE_UNUSED, gfc_expr *dim ATTRIBUTE_UNUSED,
		5457	gfc_expr mask ATTRIBUTE_UNUSED, gfc_expr kind ATTRIBUTE_UNUSED, gfc_expr *back ATTRIBUTE_UNUSED)
		5458	{
		5459	return NULL;
		5460	}
		5461
		5462	gfc_expr *
5456	gfc_simplify_maxexponent (gfc_expr *x)	5463	gfc_simplify_maxexponent (gfc_expr *x)
5457	{	5464	{
5458	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);	5465	int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);




  se->expr = convert (type, pos);
}

/* Emit code for findloc.  For now, only library calls.  */

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;

  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.  */
  if (kind_arg->expr)
    {
      gfc_free_expr (kind_arg->expr);
      kind_arg->expr = NULL;
    }

  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";

  if (se->ss)
    {
      gfc_conv_intrinsic_funcall (se, expr);
      return;
    }

  /* Later... */
  gcc_unreachable ();
}

/* 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.

	      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;

    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:




$(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_maxloc0_c= \
$(srcdir)/generated/maxloc0_4_i1.c \
$(srcdir)/generated/maxloc0_8_i1.c \

    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/findloc0.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) \

    $(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_findloc0_c)

# Machine generated specifics
gfor_built_specific_src= \

$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@

$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS)
	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@

$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@


Lines 334-340 am__objects_43 = maxval0_s1.lo maxval0_s4.lo Link Here

(-)libgfortran/Makefile.in (-20 / +128 lines)
334	am__objects_44 = minval0_s1.lo minval0_s4.lo	334	am__objects_44 = minval0_s1.lo minval0_s4.lo
335	am__objects_45 = maxval1_s1.lo maxval1_s4.lo	335	am__objects_45 = maxval1_s1.lo maxval1_s4.lo
336	am__objects_46 = minval1_s1.lo minval1_s4.lo	336	am__objects_46 = minval1_s1.lo minval1_s4.lo
337	am__objects_47 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \	337	am__objects_47 = findloc0_i1.lo findloc0_i2.lo findloc0_i4.lo \
		338	findloc0_i8.lo findloc0_i16.lo findloc0_r4.lo findloc0_r8.lo \
		339	findloc0_r16.lo findloc0_c4.lo findloc0_c8.lo findloc0_c16.lo
		340	am__objects_48 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
338	$(am__objects_7) $(am__objects_8) $(am__objects_9) \	341	$(am__objects_7) $(am__objects_8) $(am__objects_9) \
339	$(am__objects_10) $(am__objects_11) $(am__objects_12) \	342	$(am__objects_10) $(am__objects_11) $(am__objects_12) \
340	$(am__objects_13) $(am__objects_14) $(am__objects_15) \	343	$(am__objects_13) $(am__objects_14) $(am__objects_15) \
Lines 348-361 am__objects_46 = minval1_s1.lo minval1_s4.lo Link Here
348	$(am__objects_37) $(am__objects_38) $(am__objects_39) \	351	$(am__objects_37) $(am__objects_38) $(am__objects_39) \
349	$(am__objects_40) $(am__objects_41) $(am__objects_42) \	352	$(am__objects_40) $(am__objects_41) $(am__objects_42) \
350	$(am__objects_43) $(am__objects_44) $(am__objects_45) \	353	$(am__objects_43) $(am__objects_44) $(am__objects_45) \
351	$(am__objects_46)	354	$(am__objects_46) $(am__objects_47)
352	@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \	355	@LIBGFOR_MINIMAL_FALSE@am__objects_49 = close.lo file_pos.lo format.lo \
353	@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \	356	@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
354	@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \	357	@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
355	@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \	358	@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
356	@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo	359	@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
357	am__objects_49 = size_from_kind.lo $(am__objects_48)	360	am__objects_50 = size_from_kind.lo $(am__objects_49)
358	@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \	361	@LIBGFOR_MINIMAL_FALSE@am__objects_51 = access.lo c99_functions.lo \
359	@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \	362	@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
360	@LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \	363	@LIBGFOR_MINIMAL_FALSE@ ctime.lo date_and_time.lo dtime.lo \
361	@LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \	364	@LIBGFOR_MINIMAL_FALSE@ env.lo etime.lo execute_command_line.lo \
Lines 365-372 am__objects_46 = minval1_s1.lo minval1_s4.lo Link Here
365	@LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \	368	@LIBGFOR_MINIMAL_FALSE@ rename.lo stat.lo symlnk.lo \
366	@LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \	369	@LIBGFOR_MINIMAL_FALSE@ system_clock.lo time.lo umask.lo \
367	@LIBGFOR_MINIMAL_FALSE@ unlink.lo	370	@LIBGFOR_MINIMAL_FALSE@ unlink.lo
368	@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo	371	@IEEE_SUPPORT_TRUE@am__objects_52 = ieee_helper.lo
369	am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \	372	am__objects_53 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
370	eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \	373	eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
371	ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \	374	ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
372	selected_char_kind.lo size.lo spread_generic.lo \	375	selected_char_kind.lo size.lo spread_generic.lo \
Lines 373-383 am__objects_46 = minval1_s1.lo minval1_s4.lo Link Here
373	string_intrinsics.lo rand.lo random.lo reshape_generic.lo \	376	string_intrinsics.lo rand.lo random.lo reshape_generic.lo \
374	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \	377	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
375	unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \	378	unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
376	$(am__objects_50) $(am__objects_51)	379	$(am__objects_51) $(am__objects_52)
377	@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \	380	@IEEE_SUPPORT_TRUE@am__objects_54 = ieee_arithmetic.lo \
378	@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo	381	@IEEE_SUPPORT_TRUE@ ieee_exceptions.lo ieee_features.lo
379	am__objects_54 =	382	am__objects_55 =
380	am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \	383	am__objects_56 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
381	_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \	384	_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
382	_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \	385	_abs_r10.lo _abs_r16.lo _aimag_c4.lo _aimag_c8.lo \
383	_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \	386	_aimag_c10.lo _aimag_c16.lo _exp_r4.lo _exp_r8.lo _exp_r10.lo \
Lines 401-419 am__objects_46 = minval1_s1.lo minval1_s4.lo Link Here
401	_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \	404	_conjg_c4.lo _conjg_c8.lo _conjg_c10.lo _conjg_c16.lo \
402	_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \	405	_aint_r4.lo _aint_r8.lo _aint_r10.lo _aint_r16.lo _anint_r4.lo \
403	_anint_r8.lo _anint_r10.lo _anint_r16.lo	406	_anint_r8.lo _anint_r10.lo _anint_r16.lo
404	am__objects_56 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \	407	am__objects_57 = _sign_i4.lo _sign_i8.lo _sign_i16.lo _sign_r4.lo \
405	_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \	408	_sign_r8.lo _sign_r10.lo _sign_r16.lo _dim_i4.lo _dim_i8.lo \
406	_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \	409	_dim_i16.lo _dim_r4.lo _dim_r8.lo _dim_r10.lo _dim_r16.lo \
407	_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \	410	_atan2_r4.lo _atan2_r8.lo _atan2_r10.lo _atan2_r16.lo \
408	_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \	411	_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
409	_mod_r10.lo _mod_r16.lo	412	_mod_r10.lo _mod_r16.lo
410	am__objects_57 = misc_specifics.lo	413	am__objects_58 = misc_specifics.lo
411	am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \	414	am__objects_59 = $(am__objects_56) $(am__objects_57) $(am__objects_58) \
412	dprod_r8.lo f2c_specifics.lo random_init.lo	415	dprod_r8.lo f2c_specifics.lo random_init.lo
413	am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \	416	am__objects_60 = $(am__objects_3) $(am__objects_48) $(am__objects_50) \
414	$(am__objects_52) $(am__objects_53) $(am__objects_54) \	417	$(am__objects_53) $(am__objects_54) $(am__objects_55) \
415	$(am__objects_58)	418	$(am__objects_59)
416	@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59)	419	@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_60)
417	@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo	420	@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
418	libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)	421	libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
419	DEFAULT_INCLUDES = -I.@am__isrc@	422	DEFAULT_INCLUDES = -I.@am__isrc@
Lines 725-730 $(srcdir)/generated/iparity_i4.c \ Link Here
725	$(srcdir)/generated/iparity_i8.c \	728	$(srcdir)/generated/iparity_i8.c \
726	$(srcdir)/generated/iparity_i16.c	729	$(srcdir)/generated/iparity_i16.c
727		730
		731	i_findloc0_c = \
		732	$(srcdir)/generated/findloc0_i1.c \
		733	$(srcdir)/generated/findloc0_i2.c \
		734	$(srcdir)/generated/findloc0_i4.c \
		735	$(srcdir)/generated/findloc0_i8.c \
		736	$(srcdir)/generated/findloc0_i16.c \
		737	$(srcdir)/generated/findloc0_r4.c \
		738	$(srcdir)/generated/findloc0_r8.c \
		739	$(srcdir)/generated/findloc0_r16.c \
		740	$(srcdir)/generated/findloc0_c4.c \
		741	$(srcdir)/generated/findloc0_c8.c \
		742	$(srcdir)/generated/findloc0_c16.c
		743
728	i_maxloc0_c = \	744	i_maxloc0_c = \
729	$(srcdir)/generated/maxloc0_4_i1.c \	745	$(srcdir)/generated/maxloc0_4_i1.c \
730	$(srcdir)/generated/maxloc0_8_i1.c \	746	$(srcdir)/generated/maxloc0_8_i1.c \
Lines 1213-1219 m4_files = m4/iparm.m4 m4/ifunction.m4 m4/iforeach Link Here
1213	m4/pow.m4 \	1229	m4/pow.m4 \
1214	m4/misc_specifics.m4 m4/pack.m4 \	1230	m4/misc_specifics.m4 m4/pack.m4 \
1215	m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \	1231	m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
1216	m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4	1232	m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4 m4/findloc0.m4
1217		1233
1218	gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \	1234	gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
1219	$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \	1235	$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
Lines 1226-1232 gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c Link Here
1226	$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \	1242	$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \
1227	$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \	1243	$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \
1228	$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \	1244	$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
1229	$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c)	1245	$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
		1246	$(i_findloc0_c)
1230		1247
1231		1248
1232	# Machine generated specifics	1249	# Machine generated specifics
Lines 1650-1655 distclean-compile: Link Here
1650	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@	1667	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
1651	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@	1668	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
1652	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@	1669	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
		1670	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c16.Plo@am__quote@
		1671	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c4.Plo@am__quote@
		1672	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c8.Plo@am__quote@
		1673	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i1.Plo@am__quote@
		1674	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i16.Plo@am__quote@
		1675	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i2.Plo@am__quote@
		1676	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i4.Plo@am__quote@
		1677	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i8.Plo@am__quote@
		1678	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r16.Plo@am__quote@
		1679	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r4.Plo@am__quote@
		1680	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r8.Plo@am__quote@
1653	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnum.Plo@am__quote@	1681	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnum.Plo@am__quote@
1654	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/format.Plo@am__quote@	1682	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/format.Plo@am__quote@
1655	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fpu.Plo@am__quote@	1683	@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fpu.Plo@am__quote@
Lines 5705-5710 minval1_s4.lo: $(srcdir)/generated/minval1_s4.c Link Here
5705	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@	5733	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5706	@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	5734	@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
5707		5735
		5736	findloc0_i1.lo: $(srcdir)/generated/findloc0_i1.c
		5737	@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
		5738	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i1.Tpo $(DEPDIR)/findloc0_i1.Plo
		5739	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i1.c' object='findloc0_i1.lo' libtool=yes @AMDEPBACKSLASH@
		5740	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5741	@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
		5742
		5743	findloc0_i2.lo: $(srcdir)/generated/findloc0_i2.c
		5744	@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
		5745	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i2.Tpo $(DEPDIR)/findloc0_i2.Plo
		5746	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i2.c' object='findloc0_i2.lo' libtool=yes @AMDEPBACKSLASH@
		5747	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5748	@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
		5749
		5750	findloc0_i4.lo: $(srcdir)/generated/findloc0_i4.c
		5751	@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
		5752	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i4.Tpo $(DEPDIR)/findloc0_i4.Plo
		5753	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i4.c' object='findloc0_i4.lo' libtool=yes @AMDEPBACKSLASH@
		5754	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5755	@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
		5756
		5757	findloc0_i8.lo: $(srcdir)/generated/findloc0_i8.c
		5758	@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
		5759	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i8.Tpo $(DEPDIR)/findloc0_i8.Plo
		5760	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i8.c' object='findloc0_i8.lo' libtool=yes @AMDEPBACKSLASH@
		5761	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5762	@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
		5763
		5764	findloc0_i16.lo: $(srcdir)/generated/findloc0_i16.c
		5765	@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
		5766	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_i16.Tpo $(DEPDIR)/findloc0_i16.Plo
		5767	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_i16.c' object='findloc0_i16.lo' libtool=yes @AMDEPBACKSLASH@
		5768	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5769	@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
		5770
		5771	findloc0_r4.lo: $(srcdir)/generated/findloc0_r4.c
		5772	@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
		5773	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r4.Tpo $(DEPDIR)/findloc0_r4.Plo
		5774	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r4.c' object='findloc0_r4.lo' libtool=yes @AMDEPBACKSLASH@
		5775	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5776	@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
		5777
		5778	findloc0_r8.lo: $(srcdir)/generated/findloc0_r8.c
		5779	@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
		5780	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r8.Tpo $(DEPDIR)/findloc0_r8.Plo
		5781	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r8.c' object='findloc0_r8.lo' libtool=yes @AMDEPBACKSLASH@
		5782	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5783	@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
		5784
		5785	findloc0_r16.lo: $(srcdir)/generated/findloc0_r16.c
		5786	@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
		5787	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_r16.Tpo $(DEPDIR)/findloc0_r16.Plo
		5788	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_r16.c' object='findloc0_r16.lo' libtool=yes @AMDEPBACKSLASH@
		5789	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5790	@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
		5791
		5792	findloc0_c4.lo: $(srcdir)/generated/findloc0_c4.c
		5793	@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
		5794	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c4.Tpo $(DEPDIR)/findloc0_c4.Plo
		5795	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c4.c' object='findloc0_c4.lo' libtool=yes @AMDEPBACKSLASH@
		5796	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
		5797	@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
		5798
		5799	findloc0_c8.lo: $(srcdir)/generated/findloc0_c8.c
5800	@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
5801	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c8.Tpo $(DEPDIR)/findloc0_c8.Plo
5802	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c8.c' object='findloc0_c8.lo' libtool=yes @AMDEPBACKSLASH@
5803	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5804	@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
5805
5806	findloc0_c16.lo: $(srcdir)/generated/findloc0_c16.c
5807	@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
5808	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/findloc0_c16.Tpo $(DEPDIR)/findloc0_c16.Plo
5809	@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$(srcdir)/generated/findloc0_c16.c' object='findloc0_c16.lo' libtool=yes @AMDEPBACKSLASH@
5810	@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5811	@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
5812
5708	size_from_kind.lo: io/size_from_kind.c	5813	size_from_kind.lo: io/size_from_kind.c
5709	@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	5814	@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
5710	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo	5815	@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/size_from_kind.Tpo $(DEPDIR)/size_from_kind.Plo
Lines 6583-6588 fpu-target.inc: fpu-target.h $(srcdir)/libgfortran Link Here
6583	@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2)	6688	@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
6584	@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@	6689	@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
6585		6690
		6691	@MAINTAINER_MODE_TRUE@$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS)
		6692	@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
		6693
6586	@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)	6694	@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
6587	@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@	6695	@MAINTAINER_MODE_TRUE@ $(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
6588		6696

Lines 359-364 typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_1) gfc_a Link Here

(-)libgfortran/libgfortran.h (+1 lines)
359	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_2) gfc_array_i2;	359	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_2) gfc_array_i2;
360	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_4) gfc_array_i4;	360	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_4) gfc_array_i4;
361	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_8) gfc_array_i8;	361	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_8) gfc_array_i8;
		362	typedef GFC_ARRAY_DESCRIPTOR (index_type) gfc_array_index_type;
362	#ifdef HAVE_GFC_INTEGER_16	363	#ifdef HAVE_GFC_INTEGER_16
363	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_16) gfc_array_i16;	364	typedef GFC_ARRAY_DESCRIPTOR (GFC_INTEGER_16) gfc_array_i16;
364	#endif	365	#endif




`/* Implementation of the MAXLOC 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>

'include(iparm.m4)dnl

`#if defined (HAVE_'atype_name`)
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)
{
  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,
				"MAXLOC");
    }

  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;

      while (1)
        {
	  do
	    {
	      if (unlikely(*base == value))
	        {
		  for (n = 0; n < rank; n++)
		    dest[n * dstride] = extent[n] - count[n];

		  return;
		}
	      base -= sstride[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];
	      n++;
	      if (n >= rank)
		return;
	      else
		{
		  count[n]++;
		  base -= sstride[n];
		}
	    } 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];
	    } 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];
	      n++;
	      if (n >= rank)
		return;
	      else
		{
		  count[n]++;
		  base += sstride[n];
		}
	    } while (count[n] == extent[n]);
	}
    }
}
#endif'

Return to bug 54613

Lines 1784-1789 gfc_resolve_maxloc (gfc_expr f, gfc_expr array, Link Here

(-)gcc/fortran/iresolve.c (+97 lines)
1784		1784
1785		1785
1786	void	1786	void
		1787	gfc_resolve_findloc (gfc_expr f, gfc_expr array, gfc_expr *value,
		1788	gfc_expr dim, gfc_expr mask, gfc_expr *kind,
		1789	gfc_expr *back)
		1790	{
		1791	const char *name;
		1792	int i, j, idim;
		1793	int fkind;
		1794	int d_num;
		1795
		1796	f->ts.type = BT_INTEGER;
		1797
		1798	/* We have a single library version, which uses index_type. */
		1799
		1800	if (kind)
		1801	fkind = mpz_get_si (kind->value.integer);
		1802	else
		1803	fkind = gfc_default_integer_kind;
		1804
		1805	f->ts.kind = gfc_index_integer_kind;
		1806
		1807	/* Convert value. If array is not LOGICAL and value is, we already
		1808	issued an error earlier. */
		1809
		1810	if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL)
		1811	\|\| array->ts.kind != value->ts.kind)
		1812	gfc_convert_type_warn (value, &array->ts, 2, 0);
		1813
		1814	if (dim == NULL)
		1815	{
		1816	f->rank = 1;
		1817	f->shape = gfc_get_shape (1);
		1818	mpz_init_set_si (f->shape[0], array->rank);
		1819	}
		1820	else
		1821	{
		1822	f->rank = array->rank - 1;
		1823	gfc_resolve_dim_arg (dim);
		1824	if (array->shape && dim->expr_type == EXPR_CONSTANT)
		1825	{
		1826	idim = (int) mpz_get_si (dim->value.integer);
		1827	f->shape = gfc_get_shape (f->rank);
		1828	for (i = 0, j = 0; i < f->rank; i++, j++)
		1829	{
		1830	if (i == (idim - 1))
		1831	j++;
		1832	mpz_init_set (f->shape[i], array->shape[j]);
		1833	}
		1834	}
		1835	}
		1836
		1837	if (mask)
		1838	{
		1839	if (mask->rank == 0)
		1840	name = "sfindloc";
		1841	else
		1842	name = "mfindloc";
		1843
		1844	resolve_mask_arg (mask);
		1845	}
		1846	else
		1847	name = "findloc";
		1848
		1849	if (dim)
		1850	{
1851	if (array->ts.type != BT_CHARACTER \|\| f->rank != 0)
1852	d_num = 1;
1853	else
1854	d_num = 2;
1855	}
1856	else
1857	d_num = 0;
1858
1859	if (back->ts.kind != gfc_logical_4_kind)
1860	{
1861	gfc_typespec ts;
1862	gfc_clear_ts (&ts);
1863	ts.type = BT_LOGICAL;
1864	ts.kind = gfc_logical_4_kind;
1865	gfc_convert_type_warn (back, &ts, 2, 0);
1866	}
1867
1868	f->value.function.name =
1869	gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num,
1870	gfc_type_letter (array->ts.type, true), array->ts.kind);
1871
1872	if (f->ts.kind != fkind)
1873	{
1874	gfc_typespec ts;
1875	gfc_clear_ts (&ts);
1876
1877	ts.type = BT_INTEGER;
1878	ts.kind = fkind;
1879	gfc_convert_type_warn (f, &ts, 2, 0);
1880	}
1881	}
1882
1883	void
1787	gfc_resolve_maxval (gfc_expr f, gfc_expr array, gfc_expr *dim,	1884	gfc_resolve_maxval (gfc_expr f, gfc_expr array, gfc_expr *dim,
1788	gfc_expr *mask)	1885	gfc_expr *mask)
1789	{	1886	{

Lines 5177-5182 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_exp Link Here

(-)gcc/fortran/trans-intrinsic.c (+48 lines)
5177	se->expr = convert (type, pos);	5177	se->expr = convert (type, pos);
5178	}	5178	}
5179		5179
		5180	/* Emit code for findloc. For now, only library calls. */
		5181
		5182	static void
		5183	gfc_conv_intrinsic_findloc (gfc_se se, gfc_expr expr)
		5184	{
		5185	gfc_actual_arglist array_arg, value_arg, dim_arg, mask_arg,
		5186	kind_arg, back_arg;
		5187
		5188	gfc_expr *value_expr;
		5189
		5190	array_arg = expr->value.function.actual;
		5191	value_arg = array_arg->next;
		5192	dim_arg = value_arg->next;
		5193	mask_arg = dim_arg->next;
		5194	kind_arg = mask_arg->next;
		5195	back_arg = kind_arg->next;
		5196
		5197	/* Remove kind. */
		5198	if (kind_arg->expr)
		5199	{
		5200	gfc_free_expr (kind_arg->expr);
		5201	kind_arg->expr = NULL;
		5202	}
		5203
		5204	value_expr = value_arg->expr;
		5205
		5206	/* Unless it's a string, pass VALUE by value. */
		5207	if (value_expr->ts.type != BT_CHARACTER)
		5208	value_arg->name = "%VAL";
		5209
		5210	/* Pass BACK argument by value. */
		5211	back_arg->name = "%VAL";
		5212
		5213	if (se->ss)
		5214	{
		5215	gfc_conv_intrinsic_funcall (se, expr);
		5216	return;
		5217	}
		5218
		5219	/* Later... */
		5220	gcc_unreachable ();
		5221	}
		5222
5180	/* Emit code for minval or maxval intrinsic. There are many different cases	5223	/* Emit code for minval or maxval intrinsic. There are many different cases
5181	we need to handle. For performance reasons we sometimes create two	5224	we need to handle. For performance reasons we sometimes create two
5182	loops instead of one, where the second one is much simpler.	5225	loops instead of one, where the second one is much simpler.
Lines 9016-9021 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr Link Here
9016	conv_generic_with_optional_char_arg (se, expr, 1, 3);	9059	conv_generic_with_optional_char_arg (se, expr, 1, 3);
9017	break;	9060	break;
9018		9061
		9062	case GFC_ISYM_FINDLOC:
		9063	gfc_conv_intrinsic_findloc (se, expr);
		9064	break;
		9065
9019	case GFC_ISYM_MINLOC:	9066	case GFC_ISYM_MINLOC:
9020	gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);	9067	gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9021	break;	9068	break;
Lines 9934-9939 gfc_is_intrinsic_libcall (gfc_expr * expr) Link Here
9934	case GFC_ISYM_ALL:	9981	case GFC_ISYM_ALL:
9935	case GFC_ISYM_ANY:	9982	case GFC_ISYM_ANY:
9936	case GFC_ISYM_COUNT:	9983	case GFC_ISYM_COUNT:
		9984	case GFC_ISYM_FINDLOC:
9937	case GFC_ISYM_JN2:	9985	case GFC_ISYM_JN2:
9938	case GFC_ISYM_IANY:	9986	case GFC_ISYM_IANY:
9939	case GFC_ISYM_IALL:	9987	case GFC_ISYM_IALL:

Lines 60-69 enum klass Link Here

(-)gcc/fortran/intrinsic.c (-10 / +81 lines)
60		60
61		61
62	/* Return a letter based on the passed type. Used to construct the	62	/* Return a letter based on the passed type. Used to construct the
63	name of a type-dependent subroutine. */	63	name of a type-dependent subroutine. If logical_equals_int is
		64	true, we can treat a logical like an int. */
64		65
65	char	66	char
66	gfc_type_letter (bt type)	67	gfc_type_letter (bt type, bool logical_equals_int)
67	{	68	{
68	char c;	69	char c;
69		70
Lines 70-76 char Link Here
70	switch (type)	71	switch (type)
71	{	72	{
72	case BT_LOGICAL:	73	case BT_LOGICAL:
73	c = 'l';	74	if (logical_equals_int)
		75	c = 'i';
		76	else
		77	c = 'l';
		78
74	break;	79	break;
75	case BT_CHARACTER:	80	case BT_CHARACTER:
76	c = 's';	81	c = 's';
Lines 683-690 add_sym_3 (const char *name, gfc_isym_id id, enum Link Here
683	}	688	}
684		689
685		690
686	/* MINLOC and MAXLOC get special treatment because their argument	691	/* MINLOC and MAXLOC get special treatment because their
687	might have to be reordered. */	692	argument might have to be reordered. */
688		693
689	static void	694	static void
690	add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,	695	add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
Lines 717-723 add_sym_5ml (const char *name, gfc_isym_id id, enu Link Here
717	(void *) 0);	722	(void *) 0);
718	}	723	}
719		724
		725	/* Similar for FINDLOC. */
720		726
		727	static void
		728	add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
		729	int kind, int standard,
		730	bool (check) (gfc_actual_arglist ),
		731	gfc_expr (simplify) (gfc_expr , gfc_expr , gfc_expr *,
		732	gfc_expr , gfc_expr , gfc_expr *),
		733	void (resolve) (gfc_expr , gfc_expr , gfc_expr , gfc_expr *,
		734	gfc_expr , gfc_expr , gfc_expr *),
		735	const char *a1, bt type1, int kind1, int optional1,
		736	const char *a2, bt type2, int kind2, int optional2,
		737	const char *a3, bt type3, int kind3, int optional3,
		738	const char *a4, bt type4, int kind4, int optional4,
		739	const char *a5, bt type5, int kind5, int optional5,
		740	const char *a6, bt type6, int kind6, int optional6)
		741
		742	{
		743	gfc_check_f cf;
		744	gfc_simplify_f sf;
		745	gfc_resolve_f rf;
		746
		747	cf.f6fl = check;
		748	sf.f6 = simplify;
		749	rf.f6 = resolve;
		750
		751	add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
		752	a1, type1, kind1, optional1, INTENT_IN,
		753	a2, type2, kind2, optional2, INTENT_IN,
		754	a3, type3, kind3, optional3, INTENT_IN,
		755	a4, type4, kind4, optional4, INTENT_IN,
		756	a5, type5, kind5, optional5, INTENT_IN,
		757	a6, type6, kind6, optional6, INTENT_IN,
		758	(void *) 0);
		759	}
		760
		761
721	/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because	762	/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
722	their argument also might have to be reordered. */	763	their argument also might have to be reordered. */
723		764
Lines 1248-1254 add_functions (void) Link Here
1248	sta = "string_a", stb = "string_b", *stg = "string",	1289	sta = "string_a", stb = "string_b", *stg = "string",
1249	sub = "sub", sz = "size", tg = "target", team = "team", *tm = "time",	1290	sub = "sub", sz = "size", tg = "target", team = "team", *tm = "time",
1250	ts = "tsource", ut = "unit", v = "vector", va = "vector_a",	1291	ts = "tsource", ut = "unit", v = "vector", va = "vector_a",
1251	vb = "vector_b", vl = "values", x = "x", y = "y", *z = "z";	1292	vb = "vector_b", vl = "values", val = "value", x = "x", *y = "y",
		1293	*z = "z";
1252		1294
1253	int di, dr, dd, dl, dc, dz, ii;	1295	int di, dr, dd, dl, dc, dz, ii;
1254		1296
Lines 2476-2481 add_functions (void) Link Here
2476		2518
2477	make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);	2519	make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
2478		2520
		2521	add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
		2522	BT_INTEGER, di, GFC_STD_F2008,
		2523	gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc,
		2524	ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED,
		2525	dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL,
		2526	kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL);
		2527
		2528	make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008);
		2529
2479	add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,	2530	add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2480	gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,	2531	gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
2481	ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,	2532	ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
Lines 4279-4285 check_arglist (gfc_actual_arglist **ap, gfc_intrin Link Here
4279	static void	4330	static void
4280	resolve_intrinsic (gfc_intrinsic_sym specific, gfc_expr e)	4331	resolve_intrinsic (gfc_intrinsic_sym specific, gfc_expr e)
4281	{	4332	{
4282	gfc_expr a1, a2, a3, a4, *a5;	4333	gfc_expr a1, a2, a3, a4, a5, a6;
4283	gfc_actual_arglist *arg;	4334	gfc_actual_arglist *arg;
4284		4335
4285	if (specific->resolve.f1 == NULL)	4336	if (specific->resolve.f1 == NULL)
Lines 4353-4358 resolve_intrinsic (gfc_intrinsic_sym *specific, gf Link Here
4353	return;	4404	return;
4354	}	4405	}
4355		4406
		4407	a6 = arg->expr;
		4408	arg = arg->next;
		4409
		4410	if (arg == NULL)
		4411	{
		4412	(*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6);
		4413	return;
		4414	}
		4415
4356	gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");	4416	gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
4357	}	4417	}
4358		4418
Lines 4366-4372 resolve_intrinsic (gfc_intrinsic_sym *specific, gf Link Here
4366	static bool	4426	static bool
4367	do_simplify (gfc_intrinsic_sym specific, gfc_expr e)	4427	do_simplify (gfc_intrinsic_sym specific, gfc_expr e)
4368	{	4428	{
4369	gfc_expr result, a1, a2, a3, a4, a5;	4429	gfc_expr result, a1, a2, a3, a4, a5, *a6;
4370	gfc_actual_arglist *arg;	4430	gfc_actual_arglist *arg;
4371		4431
4372	/* Max and min require special handling due to the variable number	4432	/* Max and min require special handling due to the variable number
Lines 4447-4454 do_simplify (gfc_intrinsic_sym *specific, gfc_expr Link Here
4447	if (arg == NULL)	4507	if (arg == NULL)
4448	result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);	4508	result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
4449	else	4509	else
4450	gfc_internal_error	4510	{
4451	("do_simplify(): Too many args for intrinsic");	4511	a6 = arg->expr;
		4512	arg = arg->next;
		4513
		4514	if (arg == NULL)
		4515	result = (*specific->simplify.f6)
		4516	(a1, a2, a3, a4, a5, a6);
		4517	else
		4518	gfc_internal_error
		4519	("do_simplify(): Too many args for intrinsic");
		4520	}
4452	}	4521	}
4453	}	4522	}
4454	}	4523	}
Lines 4528-4533 check_specific (gfc_intrinsic_sym *specific, gfc_e Link Here
4528	if (specific->check.f5ml == gfc_check_minloc_maxloc)	4597	if (specific->check.f5ml == gfc_check_minloc_maxloc)
4529	/* This is special because we might have to reorder the argument list. */	4598	/* This is special because we might have to reorder the argument list. */
4530	t = gfc_check_minloc_maxloc (*ap);	4599	t = gfc_check_minloc_maxloc (*ap);
		4600	else if (specific->check.f6fl == gfc_check_findloc)
		4601	t = gfc_check_findloc (*ap);
4531	else if (specific->check.f3red == gfc_check_minval_maxval)	4602	else if (specific->check.f3red == gfc_check_minval_maxval)
4532	/* This is also special because we also might have to reorder the	4603	/* This is also special because we also might have to reorder the
4533	argument list. */	4604	argument list. */

Lines 74-79 bool gfc_check_event_query (gfc_expr , gfc_expr Link Here

(-)gcc/fortran/intrinsic.h (-2 / +7 lines)
74	bool gfc_check_failed_or_stopped_images (gfc_expr , gfc_expr );	74	bool gfc_check_failed_or_stopped_images (gfc_expr , gfc_expr );
75	bool gfc_check_fgetputc (gfc_expr , gfc_expr );	75	bool gfc_check_fgetputc (gfc_expr , gfc_expr );
76	bool gfc_check_fgetput (gfc_expr *);	76	bool gfc_check_fgetput (gfc_expr *);
		77	bool gfc_check_findloc (gfc_actual_arglist *);
77	bool gfc_check_float (gfc_expr *);	78	bool gfc_check_float (gfc_expr *);
78	bool gfc_check_fstat (gfc_expr , gfc_expr );	79	bool gfc_check_fstat (gfc_expr , gfc_expr );
79	bool gfc_check_ftell (gfc_expr *);	80	bool gfc_check_ftell (gfc_expr *);
Lines 299-304 gfc_expr gfc_simplify_exp (gfc_expr ); Link Here
299	gfc_expr gfc_simplify_exponent (gfc_expr );	300	gfc_expr gfc_simplify_exponent (gfc_expr );
300	gfc_expr gfc_simplify_extends_type_of (gfc_expr , gfc_expr *);	301	gfc_expr gfc_simplify_extends_type_of (gfc_expr , gfc_expr *);
301	gfc_expr gfc_simplify_failed_or_stopped_images (gfc_expr , gfc_expr *);	302	gfc_expr gfc_simplify_failed_or_stopped_images (gfc_expr , gfc_expr *);
		303	gfc_expr gfc_simplify_findloc (gfc_expr , gfc_expr , gfc_expr , gfc_expr *,
		304	gfc_expr , gfc_expr );
302	gfc_expr gfc_simplify_float (gfc_expr );	305	gfc_expr gfc_simplify_float (gfc_expr );
303	gfc_expr gfc_simplify_floor (gfc_expr , gfc_expr *);	306	gfc_expr gfc_simplify_floor (gfc_expr , gfc_expr *);
304	gfc_expr gfc_simplify_fraction (gfc_expr );	307	gfc_expr gfc_simplify_fraction (gfc_expr );
Lines 488-493 void gfc_resolve_exponent (gfc_expr , gfc_expr ) Link Here
488	void gfc_resolve_extends_type_of (gfc_expr , gfc_expr , gfc_expr *);	491	void gfc_resolve_extends_type_of (gfc_expr , gfc_expr , gfc_expr *);
489	void gfc_resolve_failed_images (gfc_expr , gfc_expr , gfc_expr *);	492	void gfc_resolve_failed_images (gfc_expr , gfc_expr , gfc_expr *);
490	void gfc_resolve_fdate (gfc_expr *);	493	void gfc_resolve_fdate (gfc_expr *);
		494	void gfc_resolve_findloc (gfc_expr ,gfc_expr , gfc_expr , gfc_expr ,
		495	gfc_expr , gfc_expr , gfc_expr *);
491	void gfc_resolve_floor (gfc_expr , gfc_expr , gfc_expr *);	496	void gfc_resolve_floor (gfc_expr , gfc_expr , gfc_expr *);
492	void gfc_resolve_fnum (gfc_expr , gfc_expr );	497	void gfc_resolve_fnum (gfc_expr , gfc_expr );
493	void gfc_resolve_fraction (gfc_expr , gfc_expr );	498	void gfc_resolve_fraction (gfc_expr , gfc_expr );
Lines 670-678 void gfc_resolve_umask_sub (gfc_code *); Link Here
670	void gfc_resolve_unlink_sub (gfc_code *);	675	void gfc_resolve_unlink_sub (gfc_code *);
671		676
672		677
673	/* The mvbits() subroutine requires the most arguments: five. */	678	/* The findloc() subroutine requires the most arguments: six. */
674		679
675	#define MAX_INTRINSIC_ARGS 5	680	#define MAX_INTRINSIC_ARGS 6
676		681
677	extern const char *gfc_current_intrinsic;	682	extern const char *gfc_current_intrinsic;
678	extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];	683	extern gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];

Lines 266-271 $(srcdir)/generated/iparity_i4.c \ Link Here

(-)libgfortran/Makefile.am (-2 / +19 lines)
266	$(srcdir)/generated/iparity_i8.c \	266	$(srcdir)/generated/iparity_i8.c \
267	$(srcdir)/generated/iparity_i16.c	267	$(srcdir)/generated/iparity_i16.c
268		268
		269	i_findloc0_c= \
		270	$(srcdir)/generated/findloc0_i1.c \
		271	$(srcdir)/generated/findloc0_i2.c \
		272	$(srcdir)/generated/findloc0_i4.c \
		273	$(srcdir)/generated/findloc0_i8.c \
		274	$(srcdir)/generated/findloc0_i16.c \
		275	$(srcdir)/generated/findloc0_r4.c \
		276	$(srcdir)/generated/findloc0_r8.c \
		277	$(srcdir)/generated/findloc0_r16.c \
		278	$(srcdir)/generated/findloc0_c4.c \
		279	$(srcdir)/generated/findloc0_c8.c \
		280	$(srcdir)/generated/findloc0_c16.c
		281
269	i_maxloc0_c= \	282	i_maxloc0_c= \
270	$(srcdir)/generated/maxloc0_4_i1.c \	283	$(srcdir)/generated/maxloc0_4_i1.c \
271	$(srcdir)/generated/maxloc0_8_i1.c \	284	$(srcdir)/generated/maxloc0_8_i1.c \
Lines 754-760 m4_files= m4/iparm.m4 m4/ifunction.m4 m4/iforeach. Link Here
754	m4/pow.m4 \	767	m4/pow.m4 \
755	m4/misc_specifics.m4 m4/pack.m4 \	768	m4/misc_specifics.m4 m4/pack.m4 \
756	m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \	769	m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
757	m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4	770	m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4 m4/findloc0.m4
758		771
759	gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \	772	gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
760	$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \	773	$(i_maxloc1_c) $(i_maxval_c) $(i_minloc0_c) $(i_minloc1_c) $(i_minval_c) \
Lines 767-773 gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) Link Here
767	$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \	780	$(i_cshift0_c) kinds.inc c99_protos.inc fpu-target.h fpu-target.inc \
768	$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \	781	$(i_cshift1a_c) $(i_maxloc0s_c) $(i_minloc0s_c) $(i_maxloc1s_c) \
769	$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \	782	$(i_minloc1s_c) $(i_maxloc2s_c) $(i_minloc2s_c) $(i_maxvals_c) \
770	$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c)	783	$(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
		784	$(i_findloc0_c)
771		785
772	# Machine generated specifics	786	# Machine generated specifics
773	gfor_built_specific_src= \	787	gfor_built_specific_src= \
Lines 1034-1039 $(i_any_c): m4/any.m4 $(I_M4_DEPS2) Link Here
1034	$(i_count_c): m4/count.m4 $(I_M4_DEPS2)	1048	$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
1035	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@	1049	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
1036		1050
		1051	$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS)
		1052	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
		1053
1037	$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)	1054	$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
1038	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@	1055	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
1039		1056

Line 0 Link Here

(-)libgfortran/m4/findloc0.m4 (+166 lines)
		1	`/* Implementation of the MAXLOC intrinsic
		2	Copyright (C) 2018 Free Software Foundation, Inc.
		3	Contributed by Thomas König <tk@tkoenig.net>
		4
		5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
		6
		7	Libgfortran is free software; you can redistribute it and/or
		8	modify it under the terms of the GNU General Public
		9	License as published by the Free Software Foundation; either
		10	version 3 of the License, or (at your option) any later version.
		11
		12	Libgfortran is distributed in the hope that it will be useful,
		13	but WITHOUT ANY WARRANTY; without even the implied warranty of
		14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
		15	GNU General Public License for more details.
		16
		17	Under Section 7 of GPL version 3, you are granted additional
		18	permissions described in the GCC Runtime Library Exception, version
		19	3.1, as published by the Free Software Foundation.
		20
		21	You should have received a copy of the GNU General Public License and
		22	a copy of the GCC Runtime Library Exception along with this program;
		23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
		24	<http://www.gnu.org/licenses/>. */
		25
		26	#include "libgfortran.h"
		27	#include <assert.h>
		28
		29	'include(iparm.m4)dnl
		30
		31	`#if defined (HAVE_'atype_name`)
		32	extern void findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
		33	'atype` * const restrict array, 'atype_name` value,
		34	GFC_LOGICAL_4);
		35	export_proto(findloc0_'atype_code`);
		36
		37	void
		38	findloc0_'atype_code` (gfc_array_index_type * const restrict retarray,
		39	'atype` * const restrict array, 'atype_name` value,
		40	GFC_LOGICAL_4 back)
		41	{
		42	index_type count[GFC_MAX_DIMENSIONS];
		43	index_type extent[GFC_MAX_DIMENSIONS];
		44	index_type sstride[GFC_MAX_DIMENSIONS];
		45	index_type dstride;
		46	const 'atype_name` *base;
		47	index_type * restrict dest;
		48	index_type rank;
		49	index_type n;
		50	index_type sz;
		51
		52	rank = GFC_DESCRIPTOR_RANK (array);
		53	if (rank <= 0)
		54	runtime_error ("Rank of array needs to be > 0");
		55
		56	if (retarray->base_addr == NULL)
		57	{
		58	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
		59	retarray->dtype.rank = 1;
		60	retarray->offset = 0;
		61	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
		62	}
		63	else
		64	{
65	if (unlikely (compile_options.bounds_check))
66	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
67	"MAXLOC");
68	}
69
70	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
71	dest = retarray->base_addr;
72
73	/* Set the return value. */
74	for (n = 0; n < rank; n++)
75	dest[n * dstride] = 0;
76
77	sz = 1;
78	for (n = 0; n < rank; n++)
79	{
80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
81	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
82	sz *= extent[n];
83	if (extent[n] <= 0)
84	return;
85	}
86
87	for (n = 0; n < rank; n++)
88	count[n] = 0;
89
90	if (back)
91	{
92	base = array->base_addr + sz - 1;
93
94	while (1)
95	{
96	do
97	{
98	if (unlikely(*base == value))
99	{
100	for (n = 0; n < rank; n++)
101	dest[n * dstride] = extent[n] - count[n];
102
103	return;
104	}
105	base -= sstride[0];
106	} while(++count[0] != extent[0]);
107
108	n = 0;
109	do
110	{
111	/* When we get to the end of a dimension, reset it and increment
112	the next dimension. */
113	count[n] = 0;
114	/* We could precalculate these products, but this is a less
115	frequently used path so probably not worth it. */
116	base += sstride[n] * extent[n];
117	n++;
118	if (n >= rank)
119	return;
120	else
121	{
122	count[n]++;
123	base -= sstride[n];
124	}
125	} while (count[n] == extent[n]);
126	}
127	}
128	else
129	{
130	base = array->base_addr;
131	while (1)
132	{
133	do
134	{
135	if (unlikely(*base == value))
136	{
137	for (n = 0; n < rank; n++)
138	dest[n * dstride] = count[n] + 1;
139
140	return;
141	}
142	base += sstride[0];
143	} while(++count[0] != extent[0]);
144
145	n = 0;
146	do
147	{
148	/* When we get to the end of a dimension, reset it and increment
149	the next dimension. */
150	count[n] = 0;
151	/* We could precalculate these products, but this is a less
152	frequently used path so probably not worth it. */
153	base -= sstride[n] * extent[n];
154	n++;
155	if (n >= rank)
156	return;
157	else
158	{
159	count[n]++;
160	base += sstride[n];
161	}
162	} while (count[n] == extent[n]);
163	}
164	}
165	}
166	#endif'