@@ -1055,6 +1055,13 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
return true;
}
+ /* F2018:R902: function reference having a data pointer result. */
+ if (e->expr_type == EXPR_FUNCTION
+ && e->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && e->symtree->n.sym->attr.function
+ && e->symtree->n.sym->attr.pointer)
+ return true;
+
gfc_error ("%qs argument of %qs intrinsic at %L must be a variable",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where);
@@ -5689,6 +5691,19 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
functions). */
+bool
+arg_strlen_is_zero (gfc_expr *c, int n)
+{
+ if (gfc_var_strlen (c) == 0)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L must have "
+ "length at least 1", gfc_current_intrinsic_arg[n]->name,
+ gfc_current_intrinsic, &c->where);
+ return true;
+ }
+ return false;
+}
+
bool
gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
{
@@ -5702,13 +5717,19 @@ gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status)
return false;
if (!kind_value_check (c, 1, gfc_default_character_kind))
return false;
+ if (strcmp (gfc_current_intrinsic, "fgetc") == 0
+ && !variable_check (c, 1, false))
+ return false;
+ if (arg_strlen_is_zero (c, 1))
+ return false;
if (status == NULL)
return true;
if (!type_check (status, 2, BT_INTEGER)
|| !kind_value_check (status, 2, gfc_default_integer_kind)
- || !scalar_check (status, 2))
+ || !scalar_check (status, 2)
+ || !variable_check (status, 2, false))
return false;
return true;
@@ -5729,13 +5750,19 @@ gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status)
return false;
if (!kind_value_check (c, 0, gfc_default_character_kind))
return false;
+ if (strcmp (gfc_current_intrinsic, "fget") == 0
+ && !variable_check (c, 0, false))
+ return false;
+ if (arg_strlen_is_zero (c, 0))
+ return false;
if (status == NULL)
return true;
if (!type_check (status, 1, BT_INTEGER)
|| !kind_value_check (status, 1, gfc_default_integer_kind)
- || !scalar_check (status, 1))
+ || !scalar_check (status, 1)
+ || !variable_check (status, 1, false))
return false;
return true;
@@ -3460,7 +3460,7 @@ add_subroutines (void)
/* Argument names. These are used as argument keywords and so need to
match the documentation. Please keep this list in sorted order. */
static const char
- *a = "a", *c = "count", *cm = "count_max", *com = "command",
+ *a = "a", *c_ = "c", *c = "count", *cm = "count_max", *com = "command",
*cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from",
*fp = "frompos", *gt = "get", *h = "harvest", *han = "handler",
*length = "length", *ln = "len", *md = "mode", *msk = "mask",
@@ -3840,12 +3840,12 @@ add_subroutines (void)
add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
- c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+ c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
- c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
+ c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -3855,12 +3855,12 @@ add_subroutines (void)
add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
- c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
- c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
new file mode 100644
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-std=gnu" }
+! PR100154 - ICE in gfc_conv_procedure_call, at fortran/trans-expr.c:6131
+
+program p
+ implicit none
+ integer :: n
+ character, target :: c
+ character(len=0) :: c0
+ character(len=:), allocatable :: cc
+ n = fget(cc)
+ n = fget('a') ! { dg-error "must be a variable" }
+ n = fget(c0) ! { dg-error "must have length at least 1" }
+ call fget('x') ! { dg-error "must be a variable" }
+ n = fgetc(5,'a') ! { dg-error "must be a variable" }
+ call fgetc(5,c0) ! { dg-error "must have length at least 1" }
+ call fgetc(5,c,1) ! { dg-error "must be a variable" }
+ call fputc(5,'x',1) ! { dg-error "must be a variable" }
+ n = fget (ptr_returning_func())
+ print *, c
+contains
+ function ptr_returning_func () result (res)
+ character, pointer :: res
+ res => c
+ end
+end