View | Details | Return to bug 54613 | Differences between
and this patch

Collapse All | Expand All

(-)gcc/fortran/check.c (+91 lines)
Lines 148-153 int_or_real_or_char_check_f2003 (gfc_expr *e, int Link Here
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.
(-)gcc/fortran/gfortran.h (-1 / +9 lines)
Lines 437-442 enum gfc_isym_id Link Here
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);
(-)gcc/fortran/intrinsic.c (-10 / +81 lines)
Lines 60-69 enum klass Link Here
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.  */
(-)gcc/fortran/intrinsic.h (-2 / +7 lines)
Lines 74-79 bool gfc_check_event_query (gfc_expr *, gfc_expr * Link Here
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];
(-)gcc/fortran/iresolve.c (+97 lines)
Lines 1784-1789 gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, Link Here
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
{
(-)gcc/fortran/simplify.c (+7 lines)
Lines 5453-5458 gfc_simplify_maxloc (gfc_expr *array, gfc_expr *di Link Here
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);
(-)gcc/fortran/trans-intrinsic.c (+47 lines)
Lines 5177-5182 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_exp Link Here
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
  gfc_expr *value_expr;
5188
5189
  array_arg = expr->value.function.actual;
5190
  value_arg = array_arg->next;
5191
  dim_arg   = value_arg->next;
5192
  mask_arg  = dim_arg->next;
5193
  kind_arg  = mask_arg->next;
5194
  back_arg  = kind_arg->next;
5195
5196
  /* Remove kind.  */
5197
  if (kind_arg->expr)
5198
    {
5199
      gfc_free_expr (kind_arg->expr);
5200
      kind_arg->expr = NULL;
5201
    }
5202
5203
  value_expr = value_arg->expr;
5204
5205
  /* Unless it's a string, pass VALUE by value.  */
5206
  if (value_expr->ts.type != BT_CHARACTER)
5207
    value_arg->name = "%VAL";
5208
5209
  /* Pass BACK argument by value.  */
5210
  back_arg->name = "%VAL";
5211
5212
  if (se->ss)
5213
    {
5214
      gfc_conv_intrinsic_funcall (se, expr);
5215
      return;
5216
    }
5217
5218
  /* This is for later.  */
5219
  gcc_unreachable ();
5220
}
5221
5180
/* Emit code for minval or maxval intrinsic.  There are many different cases
5222
/* Emit code for minval or maxval intrinsic.  There are many different cases
5181
   we need to handle.  For performance reasons we sometimes create two
5223
   we need to handle.  For performance reasons we sometimes create two
5182
   loops instead of one, where the second one is much simpler.
5224
   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);
9058
	      conv_generic_with_optional_char_arg (se, expr, 1, 3);
9017
	      break;
9059
	      break;
9018
9060
9061
	    case GFC_ISYM_FINDLOC:
9062
	      gfc_conv_intrinsic_findloc (se, expr);
9063
	      break;
9064
9019
	    case GFC_ISYM_MINLOC:
9065
	    case GFC_ISYM_MINLOC:
9020
	      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9066
	      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9021
	      break;
9067
	      break;
Lines 9934-9939 gfc_is_intrinsic_libcall (gfc_expr * expr) Link Here
9934
    case GFC_ISYM_ALL:
9980
    case GFC_ISYM_ALL:
9935
    case GFC_ISYM_ANY:
9981
    case GFC_ISYM_ANY:
9936
    case GFC_ISYM_COUNT:
9982
    case GFC_ISYM_COUNT:
9983
    case GFC_ISYM_FINDLOC:
9937
    case GFC_ISYM_JN2:
9984
    case GFC_ISYM_JN2:
9938
    case GFC_ISYM_IANY:
9985
    case GFC_ISYM_IANY:
9939
    case GFC_ISYM_IALL:
9986
    case GFC_ISYM_IALL:
(-)libgfortran/Makefile.am (-2 / +52 lines)
Lines 266-271 $(srcdir)/generated/iparity_i4.c \ Link Here
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
282
i_findloc0s_c= \
283
$(srcdir)/generated/findloc0_s1.c \
284
$(srcdir)/generated/findloc0_s4.c
285
286
i_findloc1_c= \
287
$(srcdir)/generated/findloc1_i1.c \
288
$(srcdir)/generated/findloc1_i2.c \
289
$(srcdir)/generated/findloc1_i4.c \
290
$(srcdir)/generated/findloc1_i8.c \
291
$(srcdir)/generated/findloc1_i16.c \
292
$(srcdir)/generated/findloc1_r4.c \
293
$(srcdir)/generated/findloc1_r8.c \
294
$(srcdir)/generated/findloc1_r16.c \
295
$(srcdir)/generated/findloc1_c4.c \
296
$(srcdir)/generated/findloc1_c8.c \
297
$(srcdir)/generated/findloc1_c16.c
298
299
i_findloc1s_c= \
300
$(srcdir)/generated/findloc1_s1.c \
301
$(srcdir)/generated/findloc1_s4.c
302
269
i_maxloc0_c= \
303
i_maxloc0_c= \
270
$(srcdir)/generated/maxloc0_4_i1.c \
304
$(srcdir)/generated/maxloc0_4_i1.c \
271
$(srcdir)/generated/maxloc0_8_i1.c \
305
$(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 \
788
    m4/pow.m4 \
755
    m4/misc_specifics.m4 m4/pack.m4 \
789
    m4/misc_specifics.m4 m4/pack.m4 \
756
    m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
790
    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
791
    m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4 m4/findloc0.m4 \
792
    m4/findloc0s.m4 m4/ifindloc0.m4 m4/findloc1.m4 m4/ifindloc1.m4
758
793
759
gfor_built_src= $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
794
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) \
795
    $(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 \
802
    $(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) \
803
    $(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) \
804
    $(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)
805
    $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
806
    $(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c)
771
807
772
# Machine generated specifics
808
# Machine generated specifics
773
gfor_built_specific_src= \
809
gfor_built_specific_src= \
Lines 995-1000 I_M4_DEPS3=$(I_M4_DEPS) m4/iforeach-s.m4 Link Here
995
I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4
1031
I_M4_DEPS4=$(I_M4_DEPS) m4/ifunction-s.m4
996
I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4
1032
I_M4_DEPS5=$(I_M4_DEPS) m4/iforeach-s2.m4
997
I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4
1033
I_M4_DEPS6=$(I_M4_DEPS) m4/ifunction-s2.m4
1034
I_M4_DEPS7=$(I_M4_DEPS) m4/ifindloc0.m4
1035
I_M4_DEPS8=$(I_M4_DEPS) m4/ifindloc1.m4
998
1036
999
kinds.h: $(srcdir)/mk-kinds-h.sh
1037
kinds.h: $(srcdir)/mk-kinds-h.sh
1000
	$(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@
1038
	$(SHELL) $(srcdir)/mk-kinds-h.sh '$(FCCOMPILE)' > $@ || rm $@
Lines 1034-1039 $(i_any_c): m4/any.m4 $(I_M4_DEPS2) Link Here
1034
$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
1072
$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
1035
	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
1073
	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
1036
1074
1075
$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS7)
1076
	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
1077
1078
$(i_findloc0s_c): m4/findloc0s.m4 $(I_M4_DEPS7)
1079
	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0s.m4 > $@
1080
1081
$(i_findloc1_c): m4/findloc1.m4 $(I_M4_DEPS8)
1082
	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1.m4 > $@
1083
1084
$(i_findloc1s_c): m4/findloc1s.m4 $(I_M4_DEPS8)
1085
	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1s.m4 > $@
1086
1037
$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
1087
$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
1038
	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
1088
	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
1039
1089
(-)libgfortran/Makefile.in (-20 / +287 lines)
Lines 334-340 am__objects_43 = maxval0_s1.lo maxval0_s4.lo Link Here
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 = findloc0_s1.lo findloc0_s4.lo
341
am__objects_49 = findloc1_i1.lo findloc1_i2.lo findloc1_i4.lo \
342
	findloc1_i8.lo findloc1_i16.lo findloc1_r4.lo findloc1_r8.lo \
343
	findloc1_r16.lo findloc1_c4.lo findloc1_c8.lo findloc1_c16.lo
344
am__objects_50 = findloc1_s1.lo findloc1_s4.lo
345
am__objects_51 = $(am__objects_4) $(am__objects_5) $(am__objects_6) \
338
	$(am__objects_7) $(am__objects_8) $(am__objects_9) \
346
	$(am__objects_7) $(am__objects_8) $(am__objects_9) \
339
	$(am__objects_10) $(am__objects_11) $(am__objects_12) \
347
	$(am__objects_10) $(am__objects_11) $(am__objects_12) \
340
	$(am__objects_13) $(am__objects_14) $(am__objects_15) \
348
	$(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) \
356
	$(am__objects_37) $(am__objects_38) $(am__objects_39) \
349
	$(am__objects_40) $(am__objects_41) $(am__objects_42) \
357
	$(am__objects_40) $(am__objects_41) $(am__objects_42) \
350
	$(am__objects_43) $(am__objects_44) $(am__objects_45) \
358
	$(am__objects_43) $(am__objects_44) $(am__objects_45) \
351
	$(am__objects_46)
359
	$(am__objects_46) $(am__objects_47) $(am__objects_48) \
352
@LIBGFOR_MINIMAL_FALSE@am__objects_48 = close.lo file_pos.lo format.lo \
360
	$(am__objects_49) $(am__objects_50)
361
@LIBGFOR_MINIMAL_FALSE@am__objects_52 = close.lo file_pos.lo format.lo \
353
@LIBGFOR_MINIMAL_FALSE@	inquire.lo intrinsics.lo list_read.lo \
362
@LIBGFOR_MINIMAL_FALSE@	inquire.lo intrinsics.lo list_read.lo \
354
@LIBGFOR_MINIMAL_FALSE@	lock.lo open.lo read.lo transfer.lo \
363
@LIBGFOR_MINIMAL_FALSE@	lock.lo open.lo read.lo transfer.lo \
355
@LIBGFOR_MINIMAL_FALSE@	transfer128.lo unit.lo unix.lo write.lo \
364
@LIBGFOR_MINIMAL_FALSE@	transfer128.lo unit.lo unix.lo write.lo \
356
@LIBGFOR_MINIMAL_FALSE@	fbuf.lo async.lo
365
@LIBGFOR_MINIMAL_FALSE@	fbuf.lo async.lo
357
am__objects_49 = size_from_kind.lo $(am__objects_48)
366
am__objects_53 = size_from_kind.lo $(am__objects_52)
358
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
367
@LIBGFOR_MINIMAL_FALSE@am__objects_54 = access.lo c99_functions.lo \
359
@LIBGFOR_MINIMAL_FALSE@	chdir.lo chmod.lo clock.lo cpu_time.lo \
368
@LIBGFOR_MINIMAL_FALSE@	chdir.lo chmod.lo clock.lo cpu_time.lo \
360
@LIBGFOR_MINIMAL_FALSE@	ctime.lo date_and_time.lo dtime.lo \
369
@LIBGFOR_MINIMAL_FALSE@	ctime.lo date_and_time.lo dtime.lo \
361
@LIBGFOR_MINIMAL_FALSE@	env.lo etime.lo execute_command_line.lo \
370
@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 \
374
@LIBGFOR_MINIMAL_FALSE@	rename.lo stat.lo symlnk.lo \
366
@LIBGFOR_MINIMAL_FALSE@	system_clock.lo time.lo umask.lo \
375
@LIBGFOR_MINIMAL_FALSE@	system_clock.lo time.lo umask.lo \
367
@LIBGFOR_MINIMAL_FALSE@	unlink.lo
376
@LIBGFOR_MINIMAL_FALSE@	unlink.lo
368
@IEEE_SUPPORT_TRUE@am__objects_51 = ieee_helper.lo
377
@IEEE_SUPPORT_TRUE@am__objects_55 = ieee_helper.lo
369
am__objects_52 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
378
am__objects_56 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \
370
	eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
379
	eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \
371
	ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
380
	ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \
372
	selected_char_kind.lo size.lo spread_generic.lo \
381
	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 \
382
	string_intrinsics.lo rand.lo random.lo reshape_generic.lo \
374
	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
383
	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
375
	unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
384
	unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
376
	$(am__objects_50) $(am__objects_51)
385
	$(am__objects_54) $(am__objects_55)
377
@IEEE_SUPPORT_TRUE@am__objects_53 = ieee_arithmetic.lo \
386
@IEEE_SUPPORT_TRUE@am__objects_57 = ieee_arithmetic.lo \
378
@IEEE_SUPPORT_TRUE@	ieee_exceptions.lo ieee_features.lo
387
@IEEE_SUPPORT_TRUE@	ieee_exceptions.lo ieee_features.lo
379
am__objects_54 =
388
am__objects_58 =
380
am__objects_55 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
389
am__objects_59 = _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 \
390
	_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 \
391
	_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 \
392
	_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 \
410
	_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 \
411
	_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
412
	_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 \
413
am__objects_60 = _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 \
414
	_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 \
415
	_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 \
416
	_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 \
417
	_mod_i4.lo _mod_i8.lo _mod_i16.lo _mod_r4.lo _mod_r8.lo \
409
	_mod_r10.lo _mod_r16.lo
418
	_mod_r10.lo _mod_r16.lo
410
am__objects_57 = misc_specifics.lo
419
am__objects_61 = misc_specifics.lo
411
am__objects_58 = $(am__objects_55) $(am__objects_56) $(am__objects_57) \
420
am__objects_62 = $(am__objects_59) $(am__objects_60) $(am__objects_61) \
412
	dprod_r8.lo f2c_specifics.lo random_init.lo
421
	dprod_r8.lo f2c_specifics.lo random_init.lo
413
am__objects_59 = $(am__objects_3) $(am__objects_47) $(am__objects_49) \
422
am__objects_63 = $(am__objects_3) $(am__objects_51) $(am__objects_53) \
414
	$(am__objects_52) $(am__objects_53) $(am__objects_54) \
423
	$(am__objects_56) $(am__objects_57) $(am__objects_58) \
415
	$(am__objects_58)
424
	$(am__objects_62)
416
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_59)
425
@onestep_FALSE@am_libgfortran_la_OBJECTS = $(am__objects_63)
417
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
426
@onestep_TRUE@am_libgfortran_la_OBJECTS = libgfortran_c.lo
418
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
427
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
419
DEFAULT_INCLUDES = -I.@am__isrc@
428
DEFAULT_INCLUDES = -I.@am__isrc@
Lines 725-730 $(srcdir)/generated/iparity_i4.c \ Link Here
725
$(srcdir)/generated/iparity_i8.c \
734
$(srcdir)/generated/iparity_i8.c \
726
$(srcdir)/generated/iparity_i16.c
735
$(srcdir)/generated/iparity_i16.c
727
736
737
i_findloc0_c = \
738
$(srcdir)/generated/findloc0_i1.c \
739
$(srcdir)/generated/findloc0_i2.c \
740
$(srcdir)/generated/findloc0_i4.c \
741
$(srcdir)/generated/findloc0_i8.c \
742
$(srcdir)/generated/findloc0_i16.c \
743
$(srcdir)/generated/findloc0_r4.c \
744
$(srcdir)/generated/findloc0_r8.c \
745
$(srcdir)/generated/findloc0_r16.c \
746
$(srcdir)/generated/findloc0_c4.c \
747
$(srcdir)/generated/findloc0_c8.c \
748
$(srcdir)/generated/findloc0_c16.c
749
750
i_findloc0s_c = \
751
$(srcdir)/generated/findloc0_s1.c \
752
$(srcdir)/generated/findloc0_s4.c
753
754
i_findloc1_c = \
755
$(srcdir)/generated/findloc1_i1.c \
756
$(srcdir)/generated/findloc1_i2.c \
757
$(srcdir)/generated/findloc1_i4.c \
758
$(srcdir)/generated/findloc1_i8.c \
759
$(srcdir)/generated/findloc1_i16.c \
760
$(srcdir)/generated/findloc1_r4.c \
761
$(srcdir)/generated/findloc1_r8.c \
762
$(srcdir)/generated/findloc1_r16.c \
763
$(srcdir)/generated/findloc1_c4.c \
764
$(srcdir)/generated/findloc1_c8.c \
765
$(srcdir)/generated/findloc1_c16.c
766
767
i_findloc1s_c = \
768
$(srcdir)/generated/findloc1_s1.c \
769
$(srcdir)/generated/findloc1_s4.c
770
728
i_maxloc0_c = \
771
i_maxloc0_c = \
729
$(srcdir)/generated/maxloc0_4_i1.c \
772
$(srcdir)/generated/maxloc0_4_i1.c \
730
$(srcdir)/generated/maxloc0_8_i1.c \
773
$(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 \
1256
    m4/pow.m4 \
1214
    m4/misc_specifics.m4 m4/pack.m4 \
1257
    m4/misc_specifics.m4 m4/pack.m4 \
1215
    m4/unpack.m4 m4/spread.m4 m4/bessel.m4 m4/norm2.m4 m4/parity.m4 \
1258
    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
1259
    m4/iall.m4 m4/iany.m4 m4/iparity.m4 m4/iforeach-s.m4 m4/findloc0.m4 \
1260
    m4/findloc0s.m4 m4/ifindloc0.m4 m4/findloc1.m4 m4/ifindloc1.m4
1217
1261
1218
gfor_built_src = $(i_all_c) $(i_any_c) $(i_count_c) $(i_maxloc0_c) \
1262
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) \
1263
    $(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 \
1270
    $(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) \
1271
    $(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) \
1272
    $(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)
1273
    $(i_maxval0s_c) $(i_minval0s_c) $(i_maxval1s_c) $(i_minval1s_c) \
1274
    $(i_findloc0_c) $(i_findloc0s_c) $(i_findloc1_c) $(i_findloc1s_c)
1230
1275
1231
1276
1232
# Machine generated specifics
1277
# Machine generated specifics
Lines 1407-1412 I_M4_DEPS3 = $(I_M4_DEPS) m4/iforeach-s.m4 Link Here
1407
I_M4_DEPS4 = $(I_M4_DEPS) m4/ifunction-s.m4
1452
I_M4_DEPS4 = $(I_M4_DEPS) m4/ifunction-s.m4
1408
I_M4_DEPS5 = $(I_M4_DEPS) m4/iforeach-s2.m4
1453
I_M4_DEPS5 = $(I_M4_DEPS) m4/iforeach-s2.m4
1409
I_M4_DEPS6 = $(I_M4_DEPS) m4/ifunction-s2.m4
1454
I_M4_DEPS6 = $(I_M4_DEPS) m4/ifunction-s2.m4
1455
I_M4_DEPS7 = $(I_M4_DEPS) m4/ifindloc0.m4
1456
I_M4_DEPS8 = $(I_M4_DEPS) m4/ifindloc1.m4
1410
EXTRA_DIST = $(m4_files)
1457
EXTRA_DIST = $(m4_files)
1411
all: $(BUILT_SOURCES) config.h
1458
all: $(BUILT_SOURCES) config.h
1412
	$(MAKE) $(AM_MAKEFLAGS) all-am
1459
	$(MAKE) $(AM_MAKEFLAGS) all-am
Lines 1650-1655 distclean-compile: Link Here
1650
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
1697
@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@
1698
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
1652
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
1699
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
1700
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c16.Plo@am__quote@
1701
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c4.Plo@am__quote@
1702
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_c8.Plo@am__quote@
1703
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i1.Plo@am__quote@
1704
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i16.Plo@am__quote@
1705
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i2.Plo@am__quote@
1706
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i4.Plo@am__quote@
1707
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_i8.Plo@am__quote@
1708
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r16.Plo@am__quote@
1709
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r4.Plo@am__quote@
1710
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_r8.Plo@am__quote@
1711
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_s1.Plo@am__quote@
1712
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc0_s4.Plo@am__quote@
1713
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c16.Plo@am__quote@
1714
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c4.Plo@am__quote@
1715
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_c8.Plo@am__quote@
1716
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i1.Plo@am__quote@
1717
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i16.Plo@am__quote@
1718
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i2.Plo@am__quote@
1719
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i4.Plo@am__quote@
1720
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_i8.Plo@am__quote@
1721
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r16.Plo@am__quote@
1722
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r4.Plo@am__quote@
1723
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_r8.Plo@am__quote@
1724
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_s1.Plo@am__quote@
1725
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/findloc1_s4.Plo@am__quote@
1653
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnum.Plo@am__quote@
1726
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fnum.Plo@am__quote@
1654
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/format.Plo@am__quote@
1727
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/format.Plo@am__quote@
1655
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fpu.Plo@am__quote@
1728
@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@
5778
@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
5779
@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
5780
5781
findloc0_i1.lo: $(srcdir)/generated/findloc0_i1.c
5782
@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
5783
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_i1.Tpo $(DEPDIR)/findloc0_i1.Plo
5784
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_i1.c' object='findloc0_i1.lo' libtool=yes @AMDEPBACKSLASH@
5785
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5786
@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
5787
5788
findloc0_i2.lo: $(srcdir)/generated/findloc0_i2.c
5789
@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
5790
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_i2.Tpo $(DEPDIR)/findloc0_i2.Plo
5791
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_i2.c' object='findloc0_i2.lo' libtool=yes @AMDEPBACKSLASH@
5792
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5793
@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
5794
5795
findloc0_i4.lo: $(srcdir)/generated/findloc0_i4.c
5796
@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
5797
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_i4.Tpo $(DEPDIR)/findloc0_i4.Plo
5798
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_i4.c' object='findloc0_i4.lo' libtool=yes @AMDEPBACKSLASH@
5799
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5800
@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
5801
5802
findloc0_i8.lo: $(srcdir)/generated/findloc0_i8.c
5803
@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
5804
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_i8.Tpo $(DEPDIR)/findloc0_i8.Plo
5805
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_i8.c' object='findloc0_i8.lo' libtool=yes @AMDEPBACKSLASH@
5806
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5807
@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
5808
5809
findloc0_i16.lo: $(srcdir)/generated/findloc0_i16.c
5810
@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
5811
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_i16.Tpo $(DEPDIR)/findloc0_i16.Plo
5812
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_i16.c' object='findloc0_i16.lo' libtool=yes @AMDEPBACKSLASH@
5813
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5814
@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
5815
5816
findloc0_r4.lo: $(srcdir)/generated/findloc0_r4.c
5817
@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
5818
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_r4.Tpo $(DEPDIR)/findloc0_r4.Plo
5819
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_r4.c' object='findloc0_r4.lo' libtool=yes @AMDEPBACKSLASH@
5820
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5821
@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
5822
5823
findloc0_r8.lo: $(srcdir)/generated/findloc0_r8.c
5824
@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
5825
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_r8.Tpo $(DEPDIR)/findloc0_r8.Plo
5826
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_r8.c' object='findloc0_r8.lo' libtool=yes @AMDEPBACKSLASH@
5827
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5828
@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
5829
5830
findloc0_r16.lo: $(srcdir)/generated/findloc0_r16.c
5831
@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
5832
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_r16.Tpo $(DEPDIR)/findloc0_r16.Plo
5833
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_r16.c' object='findloc0_r16.lo' libtool=yes @AMDEPBACKSLASH@
5834
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5835
@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
5836
5837
findloc0_c4.lo: $(srcdir)/generated/findloc0_c4.c
5838
@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
5839
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_c4.Tpo $(DEPDIR)/findloc0_c4.Plo
5840
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_c4.c' object='findloc0_c4.lo' libtool=yes @AMDEPBACKSLASH@
5841
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5842
@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
5843
5844
findloc0_c8.lo: $(srcdir)/generated/findloc0_c8.c
5845
@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
5846
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_c8.Tpo $(DEPDIR)/findloc0_c8.Plo
5847
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_c8.c' object='findloc0_c8.lo' libtool=yes @AMDEPBACKSLASH@
5848
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5849
@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
5850
5851
findloc0_c16.lo: $(srcdir)/generated/findloc0_c16.c
5852
@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
5853
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_c16.Tpo $(DEPDIR)/findloc0_c16.Plo
5854
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_c16.c' object='findloc0_c16.lo' libtool=yes @AMDEPBACKSLASH@
5855
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5856
@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
5857
5858
findloc0_s1.lo: $(srcdir)/generated/findloc0_s1.c
5859
@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
5860
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_s1.Tpo $(DEPDIR)/findloc0_s1.Plo
5861
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_s1.c' object='findloc0_s1.lo' libtool=yes @AMDEPBACKSLASH@
5862
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5863
@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
5864
5865
findloc0_s4.lo: $(srcdir)/generated/findloc0_s4.c
5866
@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
5867
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc0_s4.Tpo $(DEPDIR)/findloc0_s4.Plo
5868
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc0_s4.c' object='findloc0_s4.lo' libtool=yes @AMDEPBACKSLASH@
5869
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5870
@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
5871
5872
findloc1_i1.lo: $(srcdir)/generated/findloc1_i1.c
5873
@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
5874
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_i1.Tpo $(DEPDIR)/findloc1_i1.Plo
5875
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_i1.c' object='findloc1_i1.lo' libtool=yes @AMDEPBACKSLASH@
5876
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5877
@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
5878
5879
findloc1_i2.lo: $(srcdir)/generated/findloc1_i2.c
5880
@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
5881
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_i2.Tpo $(DEPDIR)/findloc1_i2.Plo
5882
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_i2.c' object='findloc1_i2.lo' libtool=yes @AMDEPBACKSLASH@
5883
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5884
@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
5885
5886
findloc1_i4.lo: $(srcdir)/generated/findloc1_i4.c
5887
@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
5888
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_i4.Tpo $(DEPDIR)/findloc1_i4.Plo
5889
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_i4.c' object='findloc1_i4.lo' libtool=yes @AMDEPBACKSLASH@
5890
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5891
@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
5892
5893
findloc1_i8.lo: $(srcdir)/generated/findloc1_i8.c
5894
@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
5895
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_i8.Tpo $(DEPDIR)/findloc1_i8.Plo
5896
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_i8.c' object='findloc1_i8.lo' libtool=yes @AMDEPBACKSLASH@
5897
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5898
@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
5899
5900
findloc1_i16.lo: $(srcdir)/generated/findloc1_i16.c
5901
@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
5902
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_i16.Tpo $(DEPDIR)/findloc1_i16.Plo
5903
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_i16.c' object='findloc1_i16.lo' libtool=yes @AMDEPBACKSLASH@
5904
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5905
@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
5906
5907
findloc1_r4.lo: $(srcdir)/generated/findloc1_r4.c
5908
@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
5909
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_r4.Tpo $(DEPDIR)/findloc1_r4.Plo
5910
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_r4.c' object='findloc1_r4.lo' libtool=yes @AMDEPBACKSLASH@
5911
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5912
@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
5913
5914
findloc1_r8.lo: $(srcdir)/generated/findloc1_r8.c
5915
@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
5916
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_r8.Tpo $(DEPDIR)/findloc1_r8.Plo
5917
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_r8.c' object='findloc1_r8.lo' libtool=yes @AMDEPBACKSLASH@
5918
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5919
@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
5920
5921
findloc1_r16.lo: $(srcdir)/generated/findloc1_r16.c
5922
@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
5923
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_r16.Tpo $(DEPDIR)/findloc1_r16.Plo
5924
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_r16.c' object='findloc1_r16.lo' libtool=yes @AMDEPBACKSLASH@
5925
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5926
@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
5927
5928
findloc1_c4.lo: $(srcdir)/generated/findloc1_c4.c
5929
@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
5930
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_c4.Tpo $(DEPDIR)/findloc1_c4.Plo
5931
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_c4.c' object='findloc1_c4.lo' libtool=yes @AMDEPBACKSLASH@
5932
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5933
@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
5934
5935
findloc1_c8.lo: $(srcdir)/generated/findloc1_c8.c
5936
@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
5937
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_c8.Tpo $(DEPDIR)/findloc1_c8.Plo
5938
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_c8.c' object='findloc1_c8.lo' libtool=yes @AMDEPBACKSLASH@
5939
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5940
@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
5941
5942
findloc1_c16.lo: $(srcdir)/generated/findloc1_c16.c
5943
@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
5944
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_c16.Tpo $(DEPDIR)/findloc1_c16.Plo
5945
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_c16.c' object='findloc1_c16.lo' libtool=yes @AMDEPBACKSLASH@
5946
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5947
@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
5948
5949
findloc1_s1.lo: $(srcdir)/generated/findloc1_s1.c
5950
@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
5951
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_s1.Tpo $(DEPDIR)/findloc1_s1.Plo
5952
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_s1.c' object='findloc1_s1.lo' libtool=yes @AMDEPBACKSLASH@
5953
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5954
@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
5955
5956
findloc1_s4.lo: $(srcdir)/generated/findloc1_s4.c
5957
@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
5958
@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/findloc1_s4.Tpo $(DEPDIR)/findloc1_s4.Plo
5959
@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='$(srcdir)/generated/findloc1_s4.c' object='findloc1_s4.lo' libtool=yes @AMDEPBACKSLASH@
5960
@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
5961
@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
5962
5708
size_from_kind.lo: io/size_from_kind.c
5963
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
5964
@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
5965
@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)
6838
@MAINTAINER_MODE_TRUE@$(i_count_c): m4/count.m4 $(I_M4_DEPS2)
6584
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
6839
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 count.m4 > $@
6585
6840
6841
@MAINTAINER_MODE_TRUE@$(i_findloc0_c): m4/findloc0.m4 $(I_M4_DEPS7)
6842
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0.m4 > $@
6843
6844
@MAINTAINER_MODE_TRUE@$(i_findloc0s_c): m4/findloc0s.m4 $(I_M4_DEPS7)
6845
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc0s.m4 > $@
6846
6847
@MAINTAINER_MODE_TRUE@$(i_findloc1_c): m4/findloc1.m4 $(I_M4_DEPS8)
6848
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1.m4 > $@
6849
6850
@MAINTAINER_MODE_TRUE@$(i_findloc1s_c): m4/findloc1s.m4 $(I_M4_DEPS8)
6851
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 findloc1s.m4 > $@
6852
6586
@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
6853
@MAINTAINER_MODE_TRUE@$(i_iall_c): m4/iall.m4 $(I_M4_DEPS1)
6587
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
6854
@MAINTAINER_MODE_TRUE@	$(M4) -Dfile=$@ -I$(srcdir)/m4 iall.m4 > $@
6588
6855
(-)libgfortran/generated/findloc0_c16.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_COMPLEX_16)
31
extern void findloc0_c16 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_c16);
35
36
void
37
findloc0_c16 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_COMPLEX_16 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_c16);
171
172
void
173
mfindloc0_c16 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_COMPLEX_16 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_c16);
334
335
void
336
sfindloc0_c16 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_c16 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_c4.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_COMPLEX_4)
31
extern void findloc0_c4 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_c4);
35
36
void
37
findloc0_c4 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_COMPLEX_4 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_c4 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_c4);
171
172
void
173
mfindloc0_c4 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_COMPLEX_4 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_c4 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_c4);
334
335
void
336
sfindloc0_c4 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_c4 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_c8.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_COMPLEX_8)
31
extern void findloc0_c8 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_c8);
35
36
void
37
findloc0_c8 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_COMPLEX_8 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_c8 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_c8);
171
172
void
173
mfindloc0_c8 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_COMPLEX_8 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_c8 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_c8);
334
335
void
336
sfindloc0_c8 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_c8 * const restrict array, GFC_COMPLEX_8 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_c8 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_i1.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_INTEGER_1)
31
extern void findloc0_i1 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_i1);
35
36
void
37
findloc0_i1 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_INTEGER_1 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_i1 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_i1);
171
172
void
173
mfindloc0_i1 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_INTEGER_1 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_i1 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_i1);
334
335
void
336
sfindloc0_i1 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_i1 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_i16.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_INTEGER_16)
31
extern void findloc0_i16 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_i16);
35
36
void
37
findloc0_i16 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_INTEGER_16 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_i16);
171
172
void
173
mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_INTEGER_16 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_i16);
334
335
void
336
sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_i16 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_i2.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_INTEGER_2)
31
extern void findloc0_i2 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_i2);
35
36
void
37
findloc0_i2 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_INTEGER_2 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_i2 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_i2);
171
172
void
173
mfindloc0_i2 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_INTEGER_2 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_i2 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_i2);
334
335
void
336
sfindloc0_i2 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_i2 * const restrict array, GFC_INTEGER_2 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_i2 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_i4.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_INTEGER_4)
31
extern void findloc0_i4 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_i4);
35
36
void
37
findloc0_i4 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_INTEGER_4 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_i4 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_i4);
171
172
void
173
mfindloc0_i4 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_INTEGER_4 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_i4 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_i4);
334
335
void
336
sfindloc0_i4 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_i4 * const restrict array, GFC_INTEGER_4 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_i4 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_i8.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_INTEGER_8)
31
extern void findloc0_i8 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_i8);
35
36
void
37
findloc0_i8 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_INTEGER_8 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_i8 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_i8);
171
172
void
173
mfindloc0_i8 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_INTEGER_8 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_i8 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_i8);
334
335
void
336
sfindloc0_i8 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_i8 * const restrict array, GFC_INTEGER_8 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_i8 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_r16.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_REAL_16)
31
extern void findloc0_r16 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_r16 * const restrict array, GFC_REAL_16 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_r16);
35
36
void
37
findloc0_r16 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_r16 * const restrict array, GFC_REAL_16 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_REAL_16 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_r16 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_r16 * const restrict array, GFC_REAL_16 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_r16);
171
172
void
173
mfindloc0_r16 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_r16 * const restrict array, GFC_REAL_16 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_REAL_16 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_r16 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_r16 * const restrict array, GFC_REAL_16 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_r16);
334
335
void
336
sfindloc0_r16 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_r16 * const restrict array, GFC_REAL_16 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_r16 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_r4.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_REAL_4)
31
extern void findloc0_r4 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_r4 * const restrict array, GFC_REAL_4 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_r4);
35
36
void
37
findloc0_r4 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_r4 * const restrict array, GFC_REAL_4 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_REAL_4 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_r4 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_r4 * const restrict array, GFC_REAL_4 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_r4);
171
172
void
173
mfindloc0_r4 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_r4 * const restrict array, GFC_REAL_4 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_REAL_4 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_r4 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_r4 * const restrict array, GFC_REAL_4 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_r4);
334
335
void
336
sfindloc0_r4 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_r4 * const restrict array, GFC_REAL_4 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_r4 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_r8.c (+375 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_REAL_8)
31
extern void findloc0_r8 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
33
			 GFC_LOGICAL_4);
34
export_proto(findloc0_r8);
35
36
void
37
findloc0_r8 (gfc_array_index_type * const restrict retarray,
38
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
39
	    GFC_LOGICAL_4 back)
40
{
41
  index_type count[GFC_MAX_DIMENSIONS];
42
  index_type extent[GFC_MAX_DIMENSIONS];
43
  index_type sstride[GFC_MAX_DIMENSIONS];
44
  index_type dstride;
45
  const GFC_REAL_8 *base;
46
  index_type * restrict dest;
47
  index_type rank;
48
  index_type n;
49
  index_type sz;
50
51
  rank = GFC_DESCRIPTOR_RANK (array);
52
  if (rank <= 0)
53
    runtime_error ("Rank of array needs to be > 0");
54
55
  if (retarray->base_addr == NULL)
56
    {
57
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58
      retarray->dtype.rank = 1;
59
      retarray->offset = 0;
60
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
61
    }
62
  else
63
    {
64
      if (unlikely (compile_options.bounds_check))
65
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66
				"FINDLOC");
67
    }
68
69
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70
  dest = retarray->base_addr;
71
72
  /* Set the return value.  */
73
  for (n = 0; n < rank; n++)
74
    dest[n * dstride] = 0;
75
76
  sz = 1;
77
  for (n = 0; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81
      sz *= extent[n];
82
      if (extent[n] <= 0)
83
	return;
84
    }
85
86
    for (n = 0; n < rank; n++)
87
      count[n] = 0;
88
89
  if (back)
90
    {
91
      base = array->base_addr + (sz - 1) * 1;
92
93
      while (1)
94
        {
95
	  do
96
	    {
97
	      if (unlikely(*base == value))
98
	        {
99
		  for (n = 0; n < rank; n++)
100
		    dest[n * dstride] = extent[n] - count[n];
101
102
		  return;
103
		}
104
	      base -= sstride[0] * 1;
105
	    } while(++count[0] != extent[0]);
106
107
	  n = 0;
108
	  do
109
	    {
110
	      /* When we get to the end of a dimension, reset it and increment
111
		 the next dimension.  */
112
	      count[n] = 0;
113
	      /* We could precalculate these products, but this is a less
114
		 frequently used path so probably not worth it.  */
115
	      base += sstride[n] * extent[n] * 1;
116
	      n++;
117
	      if (n >= rank)
118
	        return;
119
	      else
120
		{
121
		  count[n]++;
122
		  base -= sstride[n] * 1;
123
		}
124
	    } while (count[n] == extent[n]);      
125
	}
126
    }
127
  else
128
    {
129
      base = array->base_addr;
130
      while (1)
131
        {
132
	  do
133
	    {
134
	      if (unlikely(*base == value))
135
	        {
136
		  for (n = 0; n < rank; n++)
137
		    dest[n * dstride] = count[n] + 1;
138
139
		  return;
140
		}
141
	      base += sstride[0] * 1;
142
	    } while(++count[0] != extent[0]);
143
144
	  n = 0;
145
	  do
146
	    {
147
	      /* When we get to the end of a dimension, reset it and increment
148
		 the next dimension.  */
149
	      count[n] = 0;
150
	      /* We could precalculate these products, but this is a less
151
		 frequently used path so probably not worth it.  */
152
	      base -= sstride[n] * extent[n] * 1;
153
	      n++;
154
	      if (n >= rank)
155
	        return;
156
	      else
157
		{
158
		  count[n]++;
159
		  base += sstride[n] * 1;
160
		}
161
	    } while (count[n] == extent[n]);
162
	}
163
    }
164
  return;
165
}
166
167
extern void mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
168
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
169
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170
export_proto(mfindloc0_r8);
171
172
void
173
mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
174
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
175
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176
{
177
  index_type count[GFC_MAX_DIMENSIONS];
178
  index_type extent[GFC_MAX_DIMENSIONS];
179
  index_type sstride[GFC_MAX_DIMENSIONS];
180
  index_type mstride[GFC_MAX_DIMENSIONS];
181
  index_type dstride;
182
  const GFC_REAL_8 *base;
183
  index_type * restrict dest;
184
  GFC_LOGICAL_1 *mbase;
185
  index_type rank;
186
  index_type n;
187
  int mask_kind;
188
  index_type sz;
189
190
  rank = GFC_DESCRIPTOR_RANK (array);
191
  if (rank <= 0)
192
    runtime_error ("Rank of array needs to be > 0");
193
194
  if (retarray->base_addr == NULL)
195
    {
196
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197
      retarray->dtype.rank = 1;
198
      retarray->offset = 0;
199
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
200
    }
201
  else
202
    {
203
      if (unlikely (compile_options.bounds_check))
204
	{
205
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206
				  "FINDLOC");
207
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208
				"MASK argument", "FINDLOC");
209
	}
210
    }
211
212
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213
214
  mbase = mask->base_addr;
215
216
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217
#ifdef HAVE_GFC_LOGICAL_16
218
      || mask_kind == 16
219
#endif
220
      )
221
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222
  else
223
    internal_error (NULL, "Funny sized logical array");
224
225
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226
  dest = retarray->base_addr;
227
228
  /* Set the return value.  */
229
  for (n = 0; n < rank; n++)
230
    dest[n * dstride] = 0;
231
232
  sz = 1;
233
  for (n = 0; n < rank; n++)
234
    {
235
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238
      sz *= extent[n];
239
      if (extent[n] <= 0)
240
	return;
241
    }
242
243
    for (n = 0; n < rank; n++)
244
      count[n] = 0;
245
246
  if (back)
247
    {
248
      base = array->base_addr + (sz - 1) * 1;
249
      mbase = mbase + (sz - 1) * mask_kind;
250
      while (1)
251
        {
252
	  do
253
	    {
254
	      if (unlikely(*mbase && *base == value))
255
	        {
256
		  for (n = 0; n < rank; n++)
257
		    dest[n * dstride] = extent[n] - count[n];
258
259
		  return;
260
		}
261
	      base -= sstride[0] * 1;
262
	      mbase -= mstride[0];
263
	    } while(++count[0] != extent[0]);
264
265
	  n = 0;
266
	  do
267
	    {
268
	      /* When we get to the end of a dimension, reset it and increment
269
		 the next dimension.  */
270
	      count[n] = 0;
271
	      /* We could precalculate these products, but this is a less
272
		 frequently used path so probably not worth it.  */
273
	      base += sstride[n] * extent[n] * 1;
274
	      mbase -= mstride[n] * extent[n];
275
	      n++;
276
	      if (n >= rank)
277
		return;
278
	      else
279
		{
280
		  count[n]++;
281
		  base -= sstride[n] * 1;
282
		  mbase += mstride[n];
283
		}
284
	    } while (count[n] == extent[n]);      
285
	}
286
    }
287
  else
288
    {
289
      base = array->base_addr;
290
      while (1)
291
        {
292
	  do
293
	    {
294
	      if (unlikely(*mbase && *base == value))
295
	        {
296
		  for (n = 0; n < rank; n++)
297
		    dest[n * dstride] = count[n] + 1;
298
299
		  return;
300
		}
301
	      base += sstride[0] * 1;
302
	      mbase += mstride[0];
303
	    } while(++count[0] != extent[0]);
304
305
	  n = 0;
306
	  do
307
	    {
308
	      /* When we get to the end of a dimension, reset it and increment
309
		 the next dimension.  */
310
	      count[n] = 0;
311
	      /* We could precalculate these products, but this is a less
312
		 frequently used path so probably not worth it.  */
313
	      base -= sstride[n] * extent[n] * 1;
314
	      mbase -= mstride[n] * extent[n];
315
	      n++;
316
	      if (n >= rank)
317
		return;
318
	      else
319
		{
320
		  count[n]++;
321
		  base += sstride[n]* 1;
322
		  mbase += mstride[n];
323
		}
324
	    } while (count[n] == extent[n]);
325
	}
326
    }
327
  return;
328
}
329
330
extern void sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
331
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
332
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333
export_proto(sfindloc0_r8);
334
335
void
336
sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
337
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
338
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339
{
340
  index_type rank;
341
  index_type dstride;
342
  index_type * restrict dest;
343
  index_type n;
344
345
  if (*mask)
346
    {
347
      findloc0_r8 (retarray, array, value, back);
348
      return;
349
    }
350
351
  rank = GFC_DESCRIPTOR_RANK (array);
352
353
  if (rank <= 0)
354
    internal_error (NULL, "Rank of array needs to be > 0");
355
356
  if (retarray->base_addr == NULL)
357
    {
358
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359
      retarray->dtype.rank = 1;
360
      retarray->offset = 0;
361
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
362
    }
363
  else if (unlikely (compile_options.bounds_check))
364
    {
365
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366
			       "FINDLOC");
367
    }
368
369
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370
  dest = retarray->base_addr;
371
  for (n = 0; n<rank; n++)
372
    dest[n * dstride] = 0 ;
373
}
374
375
#endif
(-)libgfortran/generated/findloc0_s1.c (+383 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_UINTEGER_1)
31
extern void findloc0_s1 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
33
			 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
34
35
export_proto(findloc0_s1);
36
37
void
38
findloc0_s1 (gfc_array_index_type * const restrict retarray,
39
    	    gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
40
	    GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
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 GFC_UINTEGER_1 *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
				"FINDLOC");
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) * len_array;
93
94
      while (1)
95
        {
96
	  do
97
	    {
98
	      if (unlikely(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
99
	        {
100
		  for (n = 0; n < rank; n++)
101
		    dest[n * dstride] = extent[n] - count[n];
102
103
		  return;
104
		}
105
	      base -= sstride[0] * len_array;
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] * len_array;
117
	      n++;
118
	      if (n >= rank)
119
	        return;
120
	      else
121
		{
122
		  count[n]++;
123
		  base -= sstride[n] * len_array;
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(compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
136
	        {
137
		  for (n = 0; n < rank; n++)
138
		    dest[n * dstride] = count[n] + 1;
139
140
		  return;
141
		}
142
	      base += sstride[0] * len_array;
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] * len_array;
154
	      n++;
155
	      if (n >= rank)
156
	        return;
157
	      else
158
		{
159
		  count[n]++;
160
		  base += sstride[n] * len_array;
161
		}
162
	    } while (count[n] == extent[n]);
163
	}
164
    }
165
  return;
166
}
167
168
extern void mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
169
       	    		gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
170
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
171
			 gfc_charlen_type len_value);
172
export_proto(mfindloc0_s1);
173
174
void
175
mfindloc0_s1 (gfc_array_index_type * const restrict retarray,
176
    	    gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
177
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
178
	    gfc_charlen_type len_array, gfc_charlen_type len_value)
179
{
180
  index_type count[GFC_MAX_DIMENSIONS];
181
  index_type extent[GFC_MAX_DIMENSIONS];
182
  index_type sstride[GFC_MAX_DIMENSIONS];
183
  index_type mstride[GFC_MAX_DIMENSIONS];
184
  index_type dstride;
185
  const GFC_UINTEGER_1 *base;
186
  index_type * restrict dest;
187
  GFC_LOGICAL_1 *mbase;
188
  index_type rank;
189
  index_type n;
190
  int mask_kind;
191
  index_type sz;
192
193
  rank = GFC_DESCRIPTOR_RANK (array);
194
  if (rank <= 0)
195
    runtime_error ("Rank of array needs to be > 0");
196
197
  if (retarray->base_addr == NULL)
198
    {
199
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
200
      retarray->dtype.rank = 1;
201
      retarray->offset = 0;
202
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
203
    }
204
  else
205
    {
206
      if (unlikely (compile_options.bounds_check))
207
	{
208
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
209
				  "FINDLOC");
210
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
211
				"MASK argument", "FINDLOC");
212
	}
213
    }
214
215
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
216
217
  mbase = mask->base_addr;
218
219
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
220
#ifdef HAVE_GFC_LOGICAL_16
221
      || mask_kind == 16
222
#endif
223
      )
224
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
225
  else
226
    internal_error (NULL, "Funny sized logical array");
227
228
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
229
  dest = retarray->base_addr;
230
231
  /* Set the return value.  */
232
  for (n = 0; n < rank; n++)
233
    dest[n * dstride] = 0;
234
235
  sz = 1;
236
  for (n = 0; n < rank; n++)
237
    {
238
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
239
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
240
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
241
      sz *= extent[n];
242
      if (extent[n] <= 0)
243
	return;
244
    }
245
246
    for (n = 0; n < rank; n++)
247
      count[n] = 0;
248
249
  if (back)
250
    {
251
      base = array->base_addr + (sz - 1) * len_array;
252
      mbase = mbase + (sz - 1) * mask_kind;
253
      while (1)
254
        {
255
	  do
256
	    {
257
	      if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
258
	        {
259
		  for (n = 0; n < rank; n++)
260
		    dest[n * dstride] = extent[n] - count[n];
261
262
		  return;
263
		}
264
	      base -= sstride[0] * len_array;
265
	      mbase -= mstride[0];
266
	    } while(++count[0] != extent[0]);
267
268
	  n = 0;
269
	  do
270
	    {
271
	      /* When we get to the end of a dimension, reset it and increment
272
		 the next dimension.  */
273
	      count[n] = 0;
274
	      /* We could precalculate these products, but this is a less
275
		 frequently used path so probably not worth it.  */
276
	      base += sstride[n] * extent[n] * len_array;
277
	      mbase -= mstride[n] * extent[n];
278
	      n++;
279
	      if (n >= rank)
280
		return;
281
	      else
282
		{
283
		  count[n]++;
284
		  base -= sstride[n] * len_array;
285
		  mbase += mstride[n];
286
		}
287
	    } while (count[n] == extent[n]);      
288
	}
289
    }
290
  else
291
    {
292
      base = array->base_addr;
293
      while (1)
294
        {
295
	  do
296
	    {
297
	      if (unlikely(*mbase && compare_string (len_array, (char *) base, len_value, (char *) value) == 0))
298
	        {
299
		  for (n = 0; n < rank; n++)
300
		    dest[n * dstride] = count[n] + 1;
301
302
		  return;
303
		}
304
	      base += sstride[0] * len_array;
305
	      mbase += mstride[0];
306
	    } while(++count[0] != extent[0]);
307
308
	  n = 0;
309
	  do
310
	    {
311
	      /* When we get to the end of a dimension, reset it and increment
312
		 the next dimension.  */
313
	      count[n] = 0;
314
	      /* We could precalculate these products, but this is a less
315
		 frequently used path so probably not worth it.  */
316
	      base -= sstride[n] * extent[n] * len_array;
317
	      mbase -= mstride[n] * extent[n];
318
	      n++;
319
	      if (n >= rank)
320
		return;
321
	      else
322
		{
323
		  count[n]++;
324
		  base += sstride[n]* len_array;
325
		  mbase += mstride[n];
326
		}
327
	    } while (count[n] == extent[n]);
328
	}
329
    }
330
  return;
331
}
332
333
extern void sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
334
       	    		gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
335
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
336
			 gfc_charlen_type len_value);
337
export_proto(sfindloc0_s1);
338
339
void
340
sfindloc0_s1 (gfc_array_index_type * const restrict retarray,
341
    	    gfc_array_s1 * const restrict array, GFC_UINTEGER_1 *value,
342
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
343
	    gfc_charlen_type len_value)
344
{
345
  index_type rank;
346
  index_type dstride;
347
  index_type * restrict dest;
348
  index_type n;
349
350
  if (*mask)
351
    {
352
      findloc0_s1 (retarray, array, value, back, len_array, len_value);
353
      return;
354
    }
355
356
  rank = GFC_DESCRIPTOR_RANK (array);
357
358
  if (rank <= 0)
359
    internal_error (NULL, "Rank of array needs to be > 0");
360
361
  if (retarray->base_addr == NULL)
362
    {
363
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
364
      retarray->dtype.rank = 1;
365
      retarray->offset = 0;
366
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
367
    }
368
  else if (unlikely (compile_options.bounds_check))
369
    {
370
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
371
			       "FINDLOC");
372
    }
373
374
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
375
  dest = retarray->base_addr;
376
  for (n = 0; n<rank; n++)
377
    dest[n * dstride] = 0 ;
378
}
379
380
#endif
381
382
383
(-)libgfortran/generated/findloc0_s4.c (+383 lines)
Line 0 Link Here
1
2
/* Implementation of the FINDLOC intrinsic
3
   Copyright (C) 2018 Free Software Foundation, Inc.
4
   Contributed by Thomas König <tk@tkoenig.net>
5
6
This file is part of the GNU Fortran 95 runtime library (libgfortran).
7
8
Libgfortran is free software; you can redistribute it and/or
9
modify it under the terms of the GNU General Public
10
License as published by the Free Software Foundation; either
11
version 3 of the License, or (at your option) any later version.
12
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
27
#include "libgfortran.h"
28
#include <assert.h>
29
30
#if defined (HAVE_GFC_UINTEGER_4)
31
extern void findloc0_s4 (gfc_array_index_type * const restrict retarray,
32
       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
33
			 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
34
35
export_proto(findloc0_s4);
36
37
void
38
findloc0_s4 (gfc_array_index_type * const restrict retarray,
39
    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
40
	    GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
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 GFC_UINTEGER_4 *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
				"FINDLOC");
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) * len_array;
93
94
      while (1)
95
        {
96
	  do
97
	    {
98
	      if (unlikely(compare_string_char4 (len_array, base, len_value, value) == 0))
99
	        {
100
		  for (n = 0; n < rank; n++)
101
		    dest[n * dstride] = extent[n] - count[n];
102
103
		  return;
104
		}
105
	      base -= sstride[0] * len_array;
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] * len_array;
117
	      n++;
118
	      if (n >= rank)
119
	        return;
120
	      else
121
		{
122
		  count[n]++;
123
		  base -= sstride[n] * len_array;
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(compare_string_char4 (len_array, base, len_value, value) == 0))
136
	        {
137
		  for (n = 0; n < rank; n++)
138
		    dest[n * dstride] = count[n] + 1;
139
140
		  return;
141
		}
142
	      base += sstride[0] * len_array;
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] * len_array;
154
	      n++;
155
	      if (n >= rank)
156
	        return;
157
	      else
158
		{
159
		  count[n]++;
160
		  base += sstride[n] * len_array;
161
		}
162
	    } while (count[n] == extent[n]);
163
	}
164
    }
165
  return;
166
}
167
168
extern void mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
169
       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
170
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
171
			 gfc_charlen_type len_value);
172
export_proto(mfindloc0_s4);
173
174
void
175
mfindloc0_s4 (gfc_array_index_type * const restrict retarray,
176
    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
177
	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
178
	    gfc_charlen_type len_array, gfc_charlen_type len_value)
179
{
180
  index_type count[GFC_MAX_DIMENSIONS];
181
  index_type extent[GFC_MAX_DIMENSIONS];
182
  index_type sstride[GFC_MAX_DIMENSIONS];
183
  index_type mstride[GFC_MAX_DIMENSIONS];
184
  index_type dstride;
185
  const GFC_UINTEGER_4 *base;
186
  index_type * restrict dest;
187
  GFC_LOGICAL_1 *mbase;
188
  index_type rank;
189
  index_type n;
190
  int mask_kind;
191
  index_type sz;
192
193
  rank = GFC_DESCRIPTOR_RANK (array);
194
  if (rank <= 0)
195
    runtime_error ("Rank of array needs to be > 0");
196
197
  if (retarray->base_addr == NULL)
198
    {
199
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
200
      retarray->dtype.rank = 1;
201
      retarray->offset = 0;
202
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
203
    }
204
  else
205
    {
206
      if (unlikely (compile_options.bounds_check))
207
	{
208
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
209
				  "FINDLOC");
210
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
211
				"MASK argument", "FINDLOC");
212
	}
213
    }
214
215
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
216
217
  mbase = mask->base_addr;
218
219
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
220
#ifdef HAVE_GFC_LOGICAL_16
221
      || mask_kind == 16
222
#endif
223
      )
224
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
225
  else
226
    internal_error (NULL, "Funny sized logical array");
227
228
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
229
  dest = retarray->base_addr;
230
231
  /* Set the return value.  */
232
  for (n = 0; n < rank; n++)
233
    dest[n * dstride] = 0;
234
235
  sz = 1;
236
  for (n = 0; n < rank; n++)
237
    {
238
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
239
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
240
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
241
      sz *= extent[n];
242
      if (extent[n] <= 0)
243
	return;
244
    }
245
246
    for (n = 0; n < rank; n++)
247
      count[n] = 0;
248
249
  if (back)
250
    {
251
      base = array->base_addr + (sz - 1) * len_array;
252
      mbase = mbase + (sz - 1) * mask_kind;
253
      while (1)
254
        {
255
	  do
256
	    {
257
	      if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0))
258
	        {
259
		  for (n = 0; n < rank; n++)
260
		    dest[n * dstride] = extent[n] - count[n];
261
262
		  return;
263
		}
264
	      base -= sstride[0] * len_array;
265
	      mbase -= mstride[0];
266
	    } while(++count[0] != extent[0]);
267
268
	  n = 0;
269
	  do
270
	    {
271
	      /* When we get to the end of a dimension, reset it and increment
272
		 the next dimension.  */
273
	      count[n] = 0;
274
	      /* We could precalculate these products, but this is a less
275
		 frequently used path so probably not worth it.  */
276
	      base += sstride[n] * extent[n] * len_array;
277
	      mbase -= mstride[n] * extent[n];
278
	      n++;
279
	      if (n >= rank)
280
		return;
281
	      else
282
		{
283
		  count[n]++;
284
		  base -= sstride[n] * len_array;
285
		  mbase += mstride[n];
286
		}
287
	    } while (count[n] == extent[n]);      
288
	}
289
    }
290
  else
291
    {
292
      base = array->base_addr;
293
      while (1)
294
        {
295
	  do
296
	    {
297
	      if (unlikely(*mbase && compare_string_char4 (len_array, base, len_value, value) == 0))
298
	        {
299
		  for (n = 0; n < rank; n++)
300
		    dest[n * dstride] = count[n] + 1;
301
302
		  return;
303
		}
304
	      base += sstride[0] * len_array;
305
	      mbase += mstride[0];
306
	    } while(++count[0] != extent[0]);
307
308
	  n = 0;
309
	  do
310
	    {
311
	      /* When we get to the end of a dimension, reset it and increment
312
		 the next dimension.  */
313
	      count[n] = 0;
314
	      /* We could precalculate these products, but this is a less
315
		 frequently used path so probably not worth it.  */
316
	      base -= sstride[n] * extent[n] * len_array;
317
	      mbase -= mstride[n] * extent[n];
318
	      n++;
319
	      if (n >= rank)
320
		return;
321
	      else
322
		{
323
		  count[n]++;
324
		  base += sstride[n]* len_array;
325
		  mbase += mstride[n];
326
		}
327
	    } while (count[n] == extent[n]);
328
	}
329
    }
330
  return;
331
}
332
333
extern void sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
334
       	    		gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
335
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
336
			 gfc_charlen_type len_value);
337
export_proto(sfindloc0_s4);
338
339
void
340
sfindloc0_s4 (gfc_array_index_type * const restrict retarray,
341
    	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *value,
342
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back, gfc_charlen_type len_array,
343
	    gfc_charlen_type len_value)
344
{
345
  index_type rank;
346
  index_type dstride;
347
  index_type * restrict dest;
348
  index_type n;
349
350
  if (*mask)
351
    {
352
      findloc0_s4 (retarray, array, value, back, len_array, len_value);
353
      return;
354
    }
355
356
  rank = GFC_DESCRIPTOR_RANK (array);
357
358
  if (rank <= 0)
359
    internal_error (NULL, "Rank of array needs to be > 0");
360
361
  if (retarray->base_addr == NULL)
362
    {
363
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
364
      retarray->dtype.rank = 1;
365
      retarray->offset = 0;
366
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
367
    }
368
  else if (unlikely (compile_options.bounds_check))
369
    {
370
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
371
			       "FINDLOC");
372
    }
373
374
  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
375
  dest = retarray->base_addr;
376
  for (n = 0; n<rank; n++)
377
    dest[n * dstride] = 0 ;
378
}
379
380
#endif
381
382
383
(-)libgfortran/generated/findloc1_c16.c (+523 lines)
Line 0 Link Here
1
/* Implementation of the FINDLOC 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
#if defined (HAVE_GFC_COMPLEX_16)
30
extern void findloc1_c16 (gfc_array_index_type * const restrict retarray,
31
		         gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
32
			 const index_type * restrict pdim, GFC_LOGICAL_4 back);
33
export_proto(findloc1_c16);
34
35
extern void
36
findloc1_c16 (gfc_array_index_type * const restrict retarray,
37
	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
38
	    const index_type * restrict pdim, GFC_LOGICAL_4 back)
39
{
40
  index_type count[GFC_MAX_DIMENSIONS];
41
  index_type extent[GFC_MAX_DIMENSIONS];
42
  index_type sstride[GFC_MAX_DIMENSIONS];
43
  index_type dstride[GFC_MAX_DIMENSIONS];
44
  const GFC_COMPLEX_16 * restrict base;
45
  index_type * restrict dest;
46
  index_type rank;
47
  index_type n;
48
  index_type len;
49
  index_type delta;
50
  index_type dim;
51
  int continue_loop;
52
53
  /* Make dim zero based to avoid confusion.  */
54
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
55
  dim = (*pdim) - 1;
56
57
  if (unlikely (dim < 0 || dim > rank))
58
    {
59
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
60
 		     "is %ld, should be between 1 and %ld",
61
		     (long int) dim + 1, (long int) rank + 1);
62
    }
63
64
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
65
  if (len < 0)
66
    len = 0;
67
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
68
69
  for (n = 0; n < dim; n++)
70
    {
71
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
72
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
73
74
      if (extent[n] < 0)
75
	extent[n] = 0;
76
    }
77
  for (n = dim; n < rank; n++)
78
    {
79
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
80
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
81
82
      if (extent[n] < 0)
83
	extent[n] = 0;
84
    }
85
86
  if (retarray->base_addr == NULL)
87
    {
88
      size_t alloc_size, str;
89
90
      for (n = 0; n < rank; n++)
91
	{
92
	  if (n == 0)
93
	    str = 1;
94
	  else
95
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
96
97
	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
98
99
	}
100
101
      retarray->offset = 0;
102
      retarray->dtype.rank = rank;
103
104
      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
105
106
      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
107
      if (alloc_size == 0)
108
	{
109
	  /* Make sure we have a zero-sized array.  */
110
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
111
	  return;
112
	}
113
    }
114
  else
115
    {
116
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
117
	runtime_error ("rank of return array incorrect in"
118
		       " FINDLOC intrinsic: is %ld, should be %ld",
119
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
120
		       (long int) rank);
121
122
      if (unlikely (compile_options.bounds_check))
123
	bounds_ifunction_return ((array_t *) retarray, extent,
124
				 "return value", "FINDLOC");
125
    }
126
127
  for (n = 0; n < rank; n++)
128
    {
129
      count[n] = 0;
130
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
131
      if (extent[n] <= 0)
132
	return;
133
    }
134
135
  dest = retarray->base_addr;
136
  continue_loop = 1;
137
138
  base = array->base_addr;
139
  while (continue_loop)
140
    {
141
      const GFC_COMPLEX_16 * restrict src;
142
      index_type result;
143
144
      result = 0;
145
      if (back)
146
	{
147
	  src = base + (len - 1) * delta * 1;
148
	  for (n = len; n > 0; n--, src -= delta * 1)
149
	    {
150
	      if (*src == value)
151
		{
152
		  result = n;
153
		  break;
154
		}
155
	    }
156
	}
157
      else
158
	{
159
	  src = base;
160
	  for (n = 1; n <= len; n++, src += delta * 1)
161
	    {
162
	      if (*src == value)
163
		{
164
		  result = n;
165
		  break;
166
		}
167
	    }
168
	}
169
      *dest = result;
170
171
      count[0]++;
172
      base += sstride[0] * 1;
173
      dest += dstride[0];
174
      n = 0;
175
      while (count[n] == extent[n])
176
	{
177
	  count[n] = 0;
178
	  base -= sstride[n] * extent[n] * 1;
179
	  dest -= dstride[n] * extent[n];
180
	  n++;
181
	  if (n >= rank)
182
	    {
183
	      continue_loop = 0;
184
	      break;
185
	    }
186
	  else
187
	    {
188
	      count[n]++;
189
	      base += sstride[n] * 1;
190
	      dest += dstride[n];
191
	    }
192
	}
193
    }
194
}
195
extern void mfindloc1_c16 (gfc_array_index_type * const restrict retarray,
196
		         gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
197
			 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
198
			 GFC_LOGICAL_4 back);
199
export_proto(mfindloc1_c16);
200
201
extern void
202
mfindloc1_c16 (gfc_array_index_type * const restrict retarray,
203
	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
204
	    const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
205
	    GFC_LOGICAL_4 back)
206
{
207
  index_type count[GFC_MAX_DIMENSIONS];
208
  index_type extent[GFC_MAX_DIMENSIONS];
209
  index_type sstride[GFC_MAX_DIMENSIONS];
210
  index_type mstride[GFC_MAX_DIMENSIONS];
211
  index_type dstride[GFC_MAX_DIMENSIONS];
212
  const GFC_COMPLEX_16 * restrict base;
213
  const GFC_LOGICAL_1 * restrict mbase;
214
  index_type * restrict dest;
215
  index_type rank;
216
  index_type n;
217
  index_type len;
218
  index_type delta;
219
  index_type mdelta;
220
  index_type dim;
221
  int mask_kind;
222
  int continue_loop;
223
224
  /* Make dim zero based to avoid confusion.  */
225
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
226
  dim = (*pdim) - 1;
227
228
  if (unlikely (dim < 0 || dim > rank))
229
    {
230
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
231
 		     "is %ld, should be between 1 and %ld",
232
		     (long int) dim + 1, (long int) rank + 1);
233
    }
234
235
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
236
  if (len < 0)
237
    len = 0;
238
239
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
240
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
241
242
  mbase = mask->base_addr;
243
244
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
245
246
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
247
#ifdef HAVE_GFC_LOGICAL_16
248
      || mask_kind == 16
249
#endif
250
      )
251
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
252
  else
253
    internal_error (NULL, "Funny sized logical array");
254
255
  for (n = 0; n < dim; n++)
256
    {
257
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
258
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
259
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
260
261
      if (extent[n] < 0)
262
	extent[n] = 0;
263
    }
264
  for (n = dim; n < rank; n++)
265
    {
266
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
267
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
268
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
269
270
      if (extent[n] < 0)
271
	extent[n] = 0;
272
    }
273
274
  if (retarray->base_addr == NULL)
275
    {
276
      size_t alloc_size, str;
277
278
      for (n = 0; n < rank; n++)
279
	{
280
	  if (n == 0)
281
	    str = 1;
282
	  else
283
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
284
285
	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
286
287
	}
288
289
      retarray->offset = 0;
290
      retarray->dtype.rank = rank;
291
292
      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
293
294
      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
295
      if (alloc_size == 0)
296
	{
297
	  /* Make sure we have a zero-sized array.  */
298
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
299
	  return;
300
	}
301
    }
302
  else
303
    {
304
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
305
	runtime_error ("rank of return array incorrect in"
306
		       " FINDLOC intrinsic: is %ld, should be %ld",
307
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
308
		       (long int) rank);
309
310
      if (unlikely (compile_options.bounds_check))
311
	bounds_ifunction_return ((array_t *) retarray, extent,
312
				 "return value", "FINDLOC");
313
    }
314
315
  for (n = 0; n < rank; n++)
316
    {
317
      count[n] = 0;
318
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
319
      if (extent[n] <= 0)
320
	return;
321
    }
322
323
  dest = retarray->base_addr;
324
  continue_loop = 1;
325
326
  base = array->base_addr;
327
  while (continue_loop)
328
    {
329
      const GFC_COMPLEX_16 * restrict src;
330
      const GFC_LOGICAL_1 * restrict msrc;
331
      index_type result;
332
333
      result = 0;
334
      if (back)
335
	{
336
	  src = base + (len - 1) * delta * 1;
337
	  msrc = mbase + (len - 1) * mdelta; 
338
	  for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
339
	    {
340
	      if (*msrc && *src == value)
341
		{
342
		  result = n;
343
		  break;
344
		}
345
	    }
346
	}
347
      else
348
	{
349
	  src = base;
350
	  msrc = mbase;
351
	  for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
352
	    {
353
	      if (*msrc && *src == value)
354
		{
355
		  result = n;
356
		  break;
357
		}
358
	    }
359
	}
360
      *dest = result;
361
362
      count[0]++;
363
      base += sstride[0] * 1;
364
      mbase += mstride[0];
365
      dest += dstride[0];
366
      n = 0;
367
      while (count[n] == extent[n])
368
	{
369
	  count[n] = 0;
370
	  base -= sstride[n] * extent[n] * 1;
371
	  mbase -= mstride[n] * extent[n];
372
	  dest -= dstride[n] * extent[n];
373
	  n++;
374
	  if (n >= rank)
375
	    {
376
	      continue_loop = 0;
377
	      break;
378
	    }
379
	  else
380
	    {
381
	      count[n]++;
382
	      base += sstride[n] * 1;
383
	      dest += dstride[n];
384
	    }
385
	}
386
    }
387
}
388
extern void sfindloc1_c16 (gfc_array_index_type * const restrict retarray,
389
		         gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
390
			 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
391
			 GFC_LOGICAL_4 back);
392
export_proto(sfindloc1_c16);
393
394
extern void
395
sfindloc1_c16 (gfc_array_index_type * const restrict retarray,
396
	    gfc_array_c16 * const restrict array, GFC_COMPLEX_16 value,
397
	    const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict  mask,
398
	    GFC_LOGICAL_4 back)
399
{
400
  index_type count[GFC_MAX_DIMENSIONS];
401
  index_type extent[GFC_MAX_DIMENSIONS];
402
  index_type dstride[GFC_MAX_DIMENSIONS];
403
  index_type * restrict dest;
404
  index_type rank;
405
  index_type n;
406
  index_type len;
407
  index_type dim;
408
  bool continue_loop;
409
410
  if (*mask)
411
    {
412
      findloc1_c16 (retarray, array, value, pdim, back);
413
      return;
414
    }
415
    /* Make dim zero based to avoid confusion.  */
416
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
417
  dim = (*pdim) - 1;
418
419
  if (unlikely (dim < 0 || dim > rank))
420
    {
421
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
422
 		     "is %ld, should be between 1 and %ld",
423
		     (long int) dim + 1, (long int) rank + 1);
424
    }
425
426
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
427
  if (len < 0)
428
    len = 0;
429
430
  for (n = 0; n < dim; n++)
431
    {
432
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
433
434
      if (extent[n] <= 0)
435
	extent[n] = 0;
436
    }
437
438
  for (n = dim; n < rank; n++)
439
    {
440
      extent[n] =
441
	GFC_DESCRIPTOR_EXTENT(array,n + 1);
442
443
      if (extent[n] <= 0)
444
	extent[n] = 0;
445
    }
446
447
448
  if (retarray->base_addr == NULL)
449
    {
450
      size_t alloc_size, str;
451
452
      for (n = 0; n < rank; n++)
453
	{
454
	  if (n == 0)
455
	    str = 1;
456
	  else
457
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
458
459
	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
460
	}
461
462
      retarray->offset = 0;
463
      retarray->dtype.rank = rank;
464
465
      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
466
467
      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
468
      if (alloc_size == 0)
469
	{
470
	  /* Make sure we have a zero-sized array.  */
471
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
472
	  return;
473
	}
474
    }
475
  else
476
    {
477
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
478
	runtime_error ("rank of return array incorrect in"
479
		       " FINDLOC intrinsic: is %ld, should be %ld",
480
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
481
		       (long int) rank);
482
483
      if (unlikely (compile_options.bounds_check))
484
	bounds_ifunction_return ((array_t *) retarray, extent,
485
				 "return value", "FINDLOC");
486
    }
487
488
  for (n = 0; n < rank; n++)
489
    {
490
      count[n] = 0;
491
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
492
      if (extent[n] <= 0)
493
	return;
494
    }
495
  dest = retarray->base_addr;
496
  continue_loop = 1;
497
498
  while (continue_loop)
499
    {
500
      *dest = 0;
501
502
      count[0]++;
503
      dest += dstride[0];
504
      n = 0;
505
      while (count[n] == extent[n])
506
	{
507
	  count[n] = 0;
508
	  dest -= dstride[n] * extent[n];
509
	  n++;
510
	  if (n >= rank)
511
	    {
512
	      continue_loop = 0;
513
	      break;
514
	    }
515
	  else
516
	    {
517
	      count[n]++;
518
	      dest += dstride[n];
519
	    }
520
	}
521
    }
522
}
523
#endif
(-)libgfortran/generated/findloc1_c4.c (+523 lines)
Line 0 Link Here
1
/* Implementation of the FINDLOC 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 <