aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/check.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/check.c')
-rw-r--r--gcc/fortran/check.c106
1 files changed, 70 insertions, 36 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cdabbf5..74e5e44 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -67,7 +67,7 @@ gfc_invalid_boz (const char *msg, locus *loc)
return false;
}
- const char hint[] = " [see %<-fno-allow-invalid-boz%>]";
+ const char *hint = _(" [see %<-fno-allow-invalid-boz%>]");
size_t len = strlen (msg) + strlen (hint) + 1;
char *msg2 = (char *) alloca (len);
strcpy (msg2, msg);
@@ -1142,7 +1142,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
if (array->expr_type == EXPR_VARIABLE)
{
- ar = gfc_find_array_ref (array);
+ ar = gfc_find_array_ref (array, true);
+ if (!ar)
+ return false;
if (ar->as->type == AS_ASSUMED_SIZE
&& !allow_assumed
&& ar->type != AR_ELEMENT
@@ -1313,8 +1315,8 @@ gfc_check_achar (gfc_expr *a, gfc_expr *kind)
{
if (a->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
- "ACHAR intrinsic subprogram", &a->where))
+ if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
+ "ACHAR intrinsic subprogram"), &a->where))
return false;
if (!gfc_boz2int (a, gfc_default_integer_kind))
@@ -1431,6 +1433,18 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
return true;
}
+bool
+gfc_invalid_null_arg (gfc_expr *x)
+{
+ if (x->expr_type == EXPR_NULL)
+ {
+ gfc_error ("NULL at %L is not permitted as actual argument "
+ "to %qs intrinsic function", &x->where,
+ gfc_current_intrinsic);
+ return true;
+ }
+ return false;
+}
bool
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
@@ -1438,12 +1452,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
symbol_attribute attr1, attr2;
int i;
bool t;
- locus *where;
- where = &pointer->where;
-
- if (pointer->expr_type == EXPR_NULL)
- goto null_arg;
+ if (gfc_invalid_null_arg (pointer))
+ return false;
attr1 = gfc_expr_attr (pointer);
@@ -1468,9 +1479,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (target == NULL)
return true;
- where = &target->where;
- if (target->expr_type == EXPR_NULL)
- goto null_arg;
+ if (gfc_invalid_null_arg (target))
+ return false;
if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
attr2 = gfc_expr_attr (target);
@@ -1518,13 +1528,6 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
}
}
return t;
-
-null_arg:
-
- gfc_error ("NULL pointer at %L is not permitted as actual argument "
- "of %qs intrinsic function", where, gfc_current_intrinsic);
- return false;
-
}
@@ -1972,8 +1975,8 @@ gfc_check_char (gfc_expr *i, gfc_expr *kind)
{
if (i->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in "
- "CHAR intrinsic subprogram", &i->where))
+ if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in "
+ "CHAR intrinsic subprogram"), &i->where))
return false;
if (!gfc_boz2int (i, gfc_default_integer_kind))
@@ -2423,8 +2426,8 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y)
if (x->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
- "intrinsic subprogram", &x->where))
+ if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
+ " intrinsic subprogram"), &x->where))
{
reset_boz (x);
return false;
@@ -2437,8 +2440,8 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y)
if (y->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX "
- "intrinsic subprogram", &y->where))
+ if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX"
+ " intrinsic subprogram"), &y->where))
{
reset_boz (y);
return false;
@@ -2902,8 +2905,8 @@ gfc_check_float (gfc_expr *a)
{
if (a->ts.type == BT_BOZ)
{
- if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the "
- "FLOAT intrinsic subprogram", &a->where))
+ if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the"
+ " FLOAT intrinsic subprogram"), &a->where))
{
reset_boz (a);
return false;
@@ -3373,6 +3376,9 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
bool
gfc_check_kind (gfc_expr *x)
{
+ if (gfc_invalid_null_arg (x))
+ return false;
+
if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of "
@@ -3449,6 +3455,9 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
if (!type_check (s, 0, BT_CHARACTER))
return false;
+ if (gfc_invalid_null_arg (s))
+ return false;
+
if (!kind_check (kind, 1, BT_INTEGER))
return false;
if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
@@ -3699,8 +3708,8 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
if (!gfc_check_conformance (tmp->expr, x,
- "arguments 'a%d' and 'a%d' for "
- "intrinsic '%s'", m, n,
+ _("arguments 'a%d' and 'a%d' for "
+ "intrinsic '%s'"), m, n,
gfc_current_intrinsic))
return false;
}
@@ -3907,7 +3916,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
if (m != NULL
&& !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
+ _("arguments '%s' and '%s' for intrinsic %s"),
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
@@ -3988,7 +3997,7 @@ gfc_check_findloc (gfc_actual_arglist *ap)
if (m != NULL
&& !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
+ _("arguments '%s' and '%s' for intrinsic %s"),
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[3]->name,
gfc_current_intrinsic))
@@ -4053,7 +4062,7 @@ check_reduction (gfc_actual_arglist *ap)
if (m != NULL
&& !gfc_check_conformance (a, m,
- "arguments '%s' and '%s' for intrinsic %s",
+ _("arguments '%s' and '%s' for intrinsic %s"),
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[2]->name,
gfc_current_intrinsic))
@@ -4134,6 +4143,12 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
bool
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
+ if (gfc_invalid_null_arg (tsource))
+ return false;
+
+ if (gfc_invalid_null_arg (fsource))
+ return false;
+
if (!same_type_check (tsource, 0, fsource, 1))
return false;
@@ -4385,7 +4400,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
return false;
if (!gfc_check_conformance (array, mask,
- "arguments '%s' and '%s' for intrinsic '%s'",
+ _("arguments '%s' and '%s' for intrinsic '%s'"),
gfc_current_intrinsic_arg[0]->name,
gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic))
@@ -4729,7 +4744,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
&& shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER
&& shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT
&& shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER
- && shape->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ && shape->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && shape->symtree->n.sym->value)
{
int i, extent;
gfc_expr *e, *v;
@@ -5051,6 +5067,9 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
{
gfc_array_ref *ar;
+ if (gfc_invalid_null_arg (source))
+ return false;
+
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return true;
@@ -5133,6 +5152,9 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
bool
gfc_check_sizeof (gfc_expr *arg)
{
+ if (gfc_invalid_null_arg (arg))
+ return false;
+
if (arg->ts.type == BT_PROCEDURE)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
@@ -5618,6 +5640,9 @@ gfc_check_sngl (gfc_expr *a)
bool
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
+ if (gfc_invalid_null_arg (source))
+ return false;
+
if (source->rank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be less "
@@ -6148,6 +6173,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
size_t source_size;
size_t result_size;
+ if (gfc_invalid_null_arg (source))
+ return false;
+
/* SOURCE shall be a scalar or array of any type. */
if (source->ts.type == BT_PROCEDURE
&& source->symtree->n.sym->attr.subroutine == 1)
@@ -6164,6 +6192,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
return false;
+ if (gfc_invalid_null_arg (mold))
+ return false;
+
/* MOLD shall be a scalar or array of any type. */
if (mold->ts.type == BT_PROCEDURE
&& mold->symtree->n.sym->attr.subroutine == 1)
@@ -6387,6 +6418,9 @@ gfc_check_trim (gfc_expr *x)
if (!type_check (x, 0, BT_CHARACTER))
return false;
+ if (gfc_invalid_null_arg (x))
+ return false;
+
if (!scalar_check (x, 0))
return false;
@@ -6612,7 +6646,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- where, (int) mpz_get_ui (put_size), seed_size);
+ &put->where, (int) mpz_get_ui (put_size), seed_size);
}
if (get != NULL)
@@ -6644,7 +6678,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
gfc_error ("Size of %qs argument of %qs intrinsic at %L "
"too small (%i/%i)",
gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
- where, (int) mpz_get_ui (get_size), seed_size);
+ &get->where, (int) mpz_get_ui (get_size), seed_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
generated by cgit v1.1 at 2025-09-27 17:26:00 +0000