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

Collapse All | Expand All

(-)check.c (+90 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
    {
158
      gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type",
159
		 gfc_current_intrinsic_arg[n]->name,
160
		 gfc_current_intrinsic, &e->where);
161
      return false;
162
    }
163
  return true;
164
}
151
165
152
/* Check that an expression is real or complex.  */
166
/* Check that an expression is real or complex.  */
153
167
Lines 3345-3351 gfc_check_minloc_maxloc (gfc_actual_arglist *ap) Link Here
3345
  return true;
3359
  return true;
3346
}
3360
}
3347
3361
3362
/* Check function for findloc. Mostly like gfc_check_minloc_maxloc
3363
   above, with the additional "value" argument.  */
3348
3364
3365
bool
3366
gfc_check_findloc (gfc_actual_arglist *ap)
3367
{
3368
  gfc_expr *a, *v, *m, *d, *k, *b;
3369
3370
  a = ap->expr;
3371
  if (!intrinsic_type_check (a, 0) || !array_check (a, 0))
3372
    return false;
3373
3374
  v = ap->next->expr;
3375
  if (!scalar_check (v,1))
3376
    return false;
3377
3378
  /* Check if the type is compatible.  */
3379
3380
  if ((a->ts.type == BT_LOGICAL && v->ts.type != BT_LOGICAL)
3381
      || (a->ts.type != BT_LOGICAL && v->ts.type == BT_LOGICAL))
3382
    {
3383
      gfc_error ("Argument %qs of %qs intrinsic at %L must be in type "
3384
		 "conformance to argument %qs at %L",
3385
		 gfc_current_intrinsic_arg[0]->name,
3386
		 gfc_current_intrinsic, &a->where,
3387
		 gfc_current_intrinsic_arg[1]->name, &v->where);
3388
    }
3389
		 
3390
  d = ap->next->next->expr;
3391
  m = ap->next->next->next->expr;
3392
  k = ap->next->next->next->next->expr;
3393
  b = ap->next->next->next->next->next->expr;
3394
3395
  if (b)
3396
    {
3397
      if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4))
3398
	return false;
3399
    }
3400
  else
3401
    {
3402
      b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0);
3403
      ap->next->next->next->next->next->expr = b;
3404
    }
3405
3406
  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
3407
      && ap->next->name == NULL)
3408
    {
3409
      m = d;
3410
      d = NULL;
3411
      ap->next->next->expr = NULL;
3412
      ap->next->next->next->expr = m;
3413
    }
3414
3415
  if (!dim_check (d, 2, false))
3416
    return false;
3417
3418
  if (!dim_rank_check (d, a, 0))
3419
    return false;
3420
3421
  if (m != NULL && !type_check (m, 3, BT_LOGICAL))
3422
    return false;
3423
3424
  if (m != NULL
3425
      && !gfc_check_conformance (a, m,
3426
				 "arguments '%s' and '%s' for intrinsic %s",
3427
				 gfc_current_intrinsic_arg[0]->name,
3428
				 gfc_current_intrinsic_arg[3]->name,
3429
				 gfc_current_intrinsic))
3430
    return false;
3431
3432
  if (!kind_check (k, 1, BT_INTEGER))
3433
    return false;
3434
3435
  return true;
3436
}
3437
3438
3349
/* Similar to minloc/maxloc, the argument list might need to be
3439
/* Similar to minloc/maxloc, the argument list might need to be
3350
   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
3440
   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
3351
   difference is that MINLOC/MAXLOC take an additional KIND argument.
3441
   difference is that MINLOC/MAXLOC take an additional KIND argument.
(-)gfortran.h (+8 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;
(-)intrinsic.c (-7 / +73 lines)
Lines 683-690 add_sym_3 (const char *name, gfc_isym_id id, enum Link Here
683
}
683
}
684
684
685
685
686
/* MINLOC and MAXLOC get special treatment because their argument
686
/* MINLOC and MAXLOC get special treatment because their
687
   might have to be reordered.  */
687
   argument might have to be reordered.  */
688
688
689
static void
689
static void
690
add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
690
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);
717
	   (void *) 0);
718
}
718
}
719
719
720
/* Similar for FINDLOC.  */
720
721
722
static void
723
add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
724
	     int kind, int standard,
725
	     bool (*check) (gfc_actual_arglist *),
726
	     gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
727
				    gfc_expr *, gfc_expr *, gfc_expr *),
728
	     void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
729
			      gfc_expr *, gfc_expr *, gfc_expr *),
730
	     const char *a1, bt type1, int kind1, int optional1,
731
	     const char *a2, bt type2, int kind2, int optional2,
732
	     const char *a3, bt type3, int kind3, int optional3,
733
	     const char *a4, bt type4, int kind4, int optional4,
734
	     const char *a5, bt type5, int kind5, int optional5,
735
	     const char *a6, bt type6, int kind6, int optional6)
736
737
{
738
  gfc_check_f cf;
739
  gfc_simplify_f sf;
740
  gfc_resolve_f rf;
741
742
  cf.f6fl = check;
743
  sf.f6 = simplify;
744
  rf.f6 = resolve;
745
746
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
747
	   a1, type1, kind1, optional1, INTENT_IN,
748
	   a2, type2, kind2, optional2, INTENT_IN,
749
	   a3, type3, kind3, optional3, INTENT_IN,
750
	   a4, type4, kind4, optional4, INTENT_IN,
751
	   a5, type5, kind5, optional5, INTENT_IN,
752
	   a6, type6, kind6, optional6, INTENT_IN,
753
	   (void *) 0);
754
}
755
756
721
/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
757
/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
722
   their argument also might have to be reordered.  */
758
   their argument also might have to be reordered.  */
723
759
Lines 1248-1254 add_functions (void) Link Here
1248
    *sta = "string_a", *stb = "string_b", *stg = "string",
1284
    *sta = "string_a", *stb = "string_b", *stg = "string",
1249
    *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time",
1285
    *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time",
1250
    *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a",
1286
    *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a",
1251
    *vb = "vector_b", *vl = "values", *x = "x", *y = "y", *z = "z";
1287
    *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y",
1288
    *z = "z";
1252
1289
1253
  int di, dr, dd, dl, dc, dz, ii;
1290
  int di, dr, dd, dl, dc, dz, ii;
1254
1291
Lines 2476-2481 add_functions (void) Link Here
2476
2513
2477
  make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
2514
  make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
2478
2515
2516
  add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
2517
	       BT_INTEGER, di, GFC_STD_F2008,
2518
	       gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc,
2519
	       ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED,
2520
	       dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL,
2521
	       kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL);
2522
2523
  make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008);
2524
2479
  add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2525
  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,
2526
		gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
2481
		ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2527
		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
4325
static void
4280
resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
4326
resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
4281
{
4327
{
4282
  gfc_expr *a1, *a2, *a3, *a4, *a5;
4328
  gfc_expr *a1, *a2, *a3, *a4, *a5, *a6;
4283
  gfc_actual_arglist *arg;
4329
  gfc_actual_arglist *arg;
4284
4330
4285
  if (specific->resolve.f1 == NULL)
4331
  if (specific->resolve.f1 == NULL)
Lines 4353-4358 resolve_intrinsic (gfc_intrinsic_sym *specific, gf Link Here
4353
      return;
4399
      return;
4354
    }
4400
    }
4355
4401
4402
  a6 = arg->expr;
4403
  arg = arg->next;
4404
4405
  if (arg == NULL)
4406
    {
4407
      (*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6);
4408
      return;
4409
    }
4410
4356
  gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
4411
  gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
4357
}
4412
}
4358
4413
Lines 4366-4372 resolve_intrinsic (gfc_intrinsic_sym *specific, gf Link Here
4366
static bool
4421
static bool
4367
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
4422
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
4368
{
4423
{
4369
  gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
4424
  gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6;
4370
  gfc_actual_arglist *arg;
4425
  gfc_actual_arglist *arg;
4371
4426
4372
  /* Max and min require special handling due to the variable number
4427
  /* 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)
4502
		  if (arg == NULL)
4448
		    result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
4503
		    result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
4449
		  else
4504
		  else
4450
		    gfc_internal_error
4505
		    {
4451
		      ("do_simplify(): Too many args for intrinsic");
4506
		      a6 = arg->expr;
4507
		      arg = arg->next;
4508
4509
		      if (arg == NULL)
4510
			result = (*specific->simplify.f6)
4511
		       			(a1, a2, a3, a4, a5, a6);
4512
		      else
4513
			gfc_internal_error
4514
			  ("do_simplify(): Too many args for intrinsic");
4515
		    }
4452
		}
4516
		}
4453
	    }
4517
	    }
4454
	}
4518
	}
Lines 4528-4533 check_specific (gfc_intrinsic_sym *specific, gfc_e Link Here
4528
  if (specific->check.f5ml == gfc_check_minloc_maxloc)
4592
  if (specific->check.f5ml == gfc_check_minloc_maxloc)
4529
    /* This is special because we might have to reorder the argument list.  */
4593
    /* This is special because we might have to reorder the argument list.  */
4530
    t = gfc_check_minloc_maxloc (*ap);
4594
    t = gfc_check_minloc_maxloc (*ap);
4595
  else if (specific->check.f6fl == gfc_check_findloc)
4596
    t = gfc_check_findloc (*ap);
4531
  else if (specific->check.f3red == gfc_check_minval_maxval)
4597
  else if (specific->check.f3red == gfc_check_minval_maxval)
4532
    /* This is also special because we also might have to reorder the
4598
    /* This is also special because we also might have to reorder the
4533
       argument list.  */
4599
       argument list.  */
(-)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];
(-)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), 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
{
(-)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);
(-)trans-intrinsic.c (+48 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
5188
  gfc_expr *value_expr;
5189
5190
  array_arg = expr->value.function.actual;
5191
  value_arg = array_arg->next;
5192
  dim_arg   = value_arg->next;
5193
  mask_arg  = dim_arg->next;
5194
  kind_arg  = mask_arg->next;
5195
  back_arg  = kind_arg->next;
5196
5197
  /* Remove kind.  */
5198
  if (kind_arg->expr)
5199
    {
5200
      gfc_free_expr (kind_arg->expr);
5201
      kind_arg->expr = NULL;
5202
    }
5203
5204
  value_expr = value_arg->expr;
5205
5206
  /* Unless it's a string, pass VALUE by value.  */
5207
  if (value_expr->ts.type != BT_CHARACTER)
5208
    value_arg->name = "%VAL";
5209
5210
  /* Pass BACK argument by value.  */
5211
  back_arg->name = "%VAL";
5212
5213
  if (se->ss)
5214
    {
5215
      gfc_conv_intrinsic_funcall (se, expr);
5216
      return;
5217
    }
5218
5219
  /* Later... */
5220
  gcc_unreachable ();
5221
}
5222
5180
/* Emit code for minval or maxval intrinsic.  There are many different cases
5223
/* Emit code for minval or maxval intrinsic.  There are many different cases
5181
   we need to handle.  For performance reasons we sometimes create two
5224
   we need to handle.  For performance reasons we sometimes create two
5182
   loops instead of one, where the second one is much simpler.
5225
   loops instead of one, where the second one is much simpler.
Lines 9016-9021 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr Link Here
9016
	      conv_generic_with_optional_char_arg (se, expr, 1, 3);
9059
	      conv_generic_with_optional_char_arg (se, expr, 1, 3);
9017
	      break;
9060
	      break;
9018
9061
9062
	    case GFC_ISYM_FINDLOC:
9063
	      gfc_conv_intrinsic_findloc (se, expr);
9064
	      break;
9065
9019
	    case GFC_ISYM_MINLOC:
9066
	    case GFC_ISYM_MINLOC:
9020
	      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9067
	      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9021
	      break;
9068
	      break;
Lines 9934-9939 gfc_is_intrinsic_libcall (gfc_expr * expr) Link Here
9934
    case GFC_ISYM_ALL:
9981
    case GFC_ISYM_ALL:
9935
    case GFC_ISYM_ANY:
9982
    case GFC_ISYM_ANY:
9936
    case GFC_ISYM_COUNT:
9983
    case GFC_ISYM_COUNT:
9984
    case GFC_ISYM_FINDLOC:
9937
    case GFC_ISYM_JN2:
9985
    case GFC_ISYM_JN2:
9938
    case GFC_ISYM_IANY:
9986
    case GFC_ISYM_IANY:
9939
    case GFC_ISYM_IALL:
9987
    case GFC_ISYM_IALL:

Return to bug 54613