From: Paul Thomas <pault@gcc.gnu.org>
Date: Thu, 1 Nov 2018 19:36:08 +0000 (+0000)
Subject: re PR fortran/40196 ([F03] [F08] Type parameter inquiry (str%len, a%kind) and Complex... 
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a5fbc2f36a291cbe80c4393950d6db9b56a34b05;p=gcc.git

re PR fortran/40196 ([F03] [F08] Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im))

2018-11-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40196
	* dependency.c (are_identical_variables): Return false if the
	inquiry refs are not the same.
	(gfc_ref_needs_temporary_p): Break on an inquiry ref.
	* dump_parse_tree.c (show_ref): Show the inquiry ref type.
	* expr.c (gfc_free_ref_list): Break on an inquiry ref.
	(gfc_copy_ref): Copy the inquiry ref types.
	(find_inquiry_ref): New function.
	(simplify_const_ref, simplify_ref_chain): Call it. Add new arg
	to simplify_ref_chain.
	(gfc_simplify_expr): Use the new arg in call to
	simplify_ref_chain.
	(gfc_get_full_arrayspec_from_expr, gfc_is_coarray): Break on
	inquiry ref.
	(gfc_traverse_expr): Return true for inquiry ref.
	* frontend-passes.c (gfc_expr_walker): Break on inquiry ref.
	* gfortran.h : Add enums and union member in gfc_ref to
	implement inquiry refs.
	* intrinsic.c : Fix white nois.
	* match.c (gfc_match_assignment): A constant lavlue is an
	error.
	* module.c : Add DECL_MIO_NAME for inquiry_type and the mstring
	for inquiry_types.
	(mio_ref): Handle inquiry refs.
	* primary.c (is_inquiry_ref): New function.
	(gfc_match_varspec): Handle inquiry refs calling new function.
	(gfc_variable_attr): Detect inquiry ref for disambiguation
	with components.
	(caf_variable_attr): Treat inquiry and substring refs in the
	same way.
	* resolve.c (find_array_spec): ditto.
	(gfc_resolve_substring_charlen): If there is neither a charlen
	ref not an inquiry ref, return.
	(resolve_ref): Handle inqiry refs as appropriate.
	(resolve_allocate_expr): Entities with an inquiry ref cannot be
	allocated.
	* simplify.c (simplify_bound, simplify_cobound): Punt on
	inquiry refs.
	* trans-array.c (get_array_ctor_var_strlen): Break on inquiry
	ref.
	*trans-expr.c (conv_inquiry): New function.
	(gfc_conv_variable): Retain the last typespec to pass to
	conv_inquiry on detecting an inquiry ref.


2018-11-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40196
	* gfortran.dg/inquiry_part_ref_1.f08: New test.
	* gfortran.dg/inquiry_part_ref_2.f90: New test.
	* gfortran.dg/inquiry_part_ref_3.f90: New test.

From-SVN: r265729
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 87f3312eeef..31e3fdd12ec 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,49 @@
+2018-11-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40196
+	* dependency.c (are_identical_variables): Return false if the
+	inquiry refs are not the same.
+	(gfc_ref_needs_temporary_p): Break on an inquiry ref.
+	* dump_parse_tree.c (show_ref): Show the inquiry ref type.
+	* expr.c (gfc_free_ref_list): Break on an inquiry ref.
+	(gfc_copy_ref): Copy the inquiry ref types.
+	(find_inquiry_ref): New function.
+	(simplify_const_ref, simplify_ref_chain): Call it. Add new arg
+	to simplify_ref_chain.
+	(gfc_simplify_expr): Use the new arg in call to
+	simplify_ref_chain.
+	(gfc_get_full_arrayspec_from_expr, gfc_is_coarray): Break on
+	inquiry ref.
+	(gfc_traverse_expr): Return true for inquiry ref.
+	* frontend-passes.c (gfc_expr_walker): Break on inquiry ref.
+	* gfortran.h : Add enums and union member in gfc_ref to
+	implement inquiry refs.
+	* intrinsic.c : Fix white nois.
+	* match.c (gfc_match_assignment): A constant lavlue is an
+	error.
+	* module.c : Add DECL_MIO_NAME for inquiry_type and the mstring
+	for inquiry_types.
+	(mio_ref): Handle inquiry refs.
+	* primary.c (is_inquiry_ref): New function.
+	(gfc_match_varspec): Handle inquiry refs calling new function.
+	(gfc_variable_attr): Detect inquiry ref for disambiguation
+	with components.
+	(caf_variable_attr): Treat inquiry and substring refs in the
+	same way.
+	* resolve.c (find_array_spec): ditto.
+	(gfc_resolve_substring_charlen): If there is neither a charlen
+	ref not an inquiry ref, return.
+	(resolve_ref): Handle inqiry refs as appropriate.
+	(resolve_allocate_expr): Entities with an inquiry ref cannot be
+	allocated.
+	* simplify.c (simplify_bound, simplify_cobound): Punt on
+	inquiry refs.
+	* trans-array.c (get_array_ctor_var_strlen): Break on inquiry
+	ref.
+	*trans-expr.c (conv_inquiry): New function.
+	(gfc_conv_variable): Retain the last typespec to pass to
+	conv_inquiry on detecting an inquiry ref.
+
 2018-11-01  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/46020
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index 86359e5967e..b78c138c483 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -189,6 +189,11 @@ are_identical_variables (gfc_expr *e1, gfc_expr *e2)
 
 	  break;
 
+	case REF_INQUIRY:
+	  if (r1->u.i != r2->u.i)
+	    return false;
+	  break;
+
 	default:
 	  gfc_internal_error ("are_identical_variables: Bad type");
 	}
@@ -905,6 +910,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
 	return subarray_p;
 
       case REF_COMPONENT:
+      case REF_INQUIRY:
 	break;
       }
 
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index f1be5a67a26..af64588786a 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -308,6 +308,23 @@ show_ref (gfc_ref *p)
 	fputc (')', dumpfile);
 	break;
 
+      case REF_INQUIRY:
+	switch (p->u.i)
+	{
+	  case INQUIRY_KIND:
+	    fprintf (dumpfile, " INQUIRY_KIND ");
+	    break;
+	  case INQUIRY_LEN:
+	    fprintf (dumpfile, " INQUIRY_LEN ");
+	    break;
+	  case INQUIRY_RE:
+	    fprintf (dumpfile, " INQUIRY_RE ");
+	    break;
+	  case INQUIRY_IM:
+	    fprintf (dumpfile, " INQUIRY_IM ");
+	}
+	break;
+
       default:
 	gfc_internal_error ("show_ref(): Bad component code");
       }
@@ -3167,7 +3184,7 @@ write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name,
 
   fputs (sym_name, dumpfile);
   fputs (post, dumpfile);
-    
+
   if (rok == T_WARN)
     fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */",
 	     gfc_typename (ts));
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index f68204f1ed8..1d1d48d0b81 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -599,6 +599,7 @@ gfc_free_ref_list (gfc_ref *p)
 	  break;
 
 	case REF_COMPONENT:
+	case REF_INQUIRY:
 	  break;
 	}
 
@@ -756,6 +757,10 @@ gfc_copy_ref (gfc_ref *src)
       dest->u.c = src->u.c;
       break;
 
+    case REF_INQUIRY:
+      dest->u.i = src->u.i;
+      break;
+
     case REF_SUBSTRING:
       dest->u.ss = src->u.ss;
       dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
@@ -1691,6 +1696,109 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp)
 }
 
 
+/* Pull an inquiry result out of an expression.  */
+
+static bool
+find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
+{
+  gfc_ref *ref;
+  gfc_ref *inquiry = NULL;
+  gfc_expr *tmp;
+
+  tmp = gfc_copy_expr (p);
+
+  if (tmp->ref && tmp->ref->type == REF_INQUIRY)
+    {
+      inquiry = tmp->ref;
+      tmp->ref = NULL;
+    }
+  else
+    {
+      for (ref = tmp->ref; ref; ref = ref->next)
+	if (ref->next && ref->next->type == REF_INQUIRY)
+	  {
+	    inquiry = ref->next;
+	    ref->next = NULL;
+	  }
+    }
+
+  if (!inquiry)
+    {
+      gfc_free_expr (tmp);
+      return false;
+    }
+
+  gfc_resolve_expr (tmp);
+
+  switch (inquiry->u.i)
+    {
+    case INQUIRY_LEN:
+      if (tmp->ts.type != BT_CHARACTER)
+	goto cleanup;
+
+      if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
+	goto cleanup;
+
+      if (!tmp->ts.u.cl->length
+	  || tmp->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	goto cleanup;
+
+      *newp = gfc_copy_expr (tmp->ts.u.cl->length);
+      break;
+
+    case INQUIRY_KIND:
+      if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
+	goto cleanup;
+
+      if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
+	goto cleanup;
+
+      *newp = gfc_get_int_expr (gfc_default_integer_kind,
+				NULL, tmp->ts.kind);
+      break;
+
+    case INQUIRY_RE:
+      if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+	goto cleanup;
+
+      if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
+	goto cleanup;
+
+      *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
+      mpfr_set ((*newp)->value.real,
+		mpc_realref (p->value.complex), GFC_RND_MODE);
+      break;
+
+    case INQUIRY_IM:
+      if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+	goto cleanup;
+
+      if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
+	goto cleanup;
+
+      *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
+      mpfr_set ((*newp)->value.real,
+		mpc_imagref (p->value.complex), GFC_RND_MODE);
+      break;
+    }
+
+  if (!(*newp))
+    goto cleanup;
+  else if ((*newp)->expr_type != EXPR_CONSTANT)
+    {
+      gfc_free_expr (*newp);
+      goto cleanup;
+    }
+
+  gfc_free_expr (tmp);
+  return true;
+
+cleanup:
+  gfc_free_expr (tmp);
+  return false;
+}
+
+
 
 /* Simplify a subobject reference of a constructor.  This occurs when
    parameter variable values are substituted.  */
@@ -1699,7 +1807,7 @@ static bool
 simplify_const_ref (gfc_expr *p)
 {
   gfc_constructor *cons, *c;
-  gfc_expr *newp;
+  gfc_expr *newp = NULL;
   gfc_ref *last_ref;
 
   while (p->ref)
@@ -1800,8 +1908,17 @@ simplify_const_ref (gfc_expr *p)
 	  remove_subobject_ref (p, cons);
 	  break;
 
+	case REF_INQUIRY:
+	  if (!find_inquiry_ref (p, &newp))
+	    return false;
+
+	  gfc_replace_expr (p, newp);
+	  gfc_free_ref_list (p->ref);
+	  p->ref = NULL;
+	  break;
+
 	case REF_SUBSTRING:
-  	  if (!find_substring_ref (p, &newp))
+	  if (!find_substring_ref (p, &newp))
 	    return false;
 
 	  gfc_replace_expr (p, newp);
@@ -1818,9 +1935,10 @@ simplify_const_ref (gfc_expr *p)
 /* Simplify a chain of references.  */
 
 static bool
-simplify_ref_chain (gfc_ref *ref, int type)
+simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
 {
   int n;
+  gfc_expr *newp;
 
   for (; ref; ref = ref->next)
     {
@@ -1845,6 +1963,15 @@ simplify_ref_chain (gfc_ref *ref, int type)
 	    return false;
 	  break;
 
+	case REF_INQUIRY:
+	  if (!find_inquiry_ref (*p, &newp))
+	    return false;
+
+	  gfc_replace_expr (*p, newp);
+	  gfc_free_ref_list ((*p)->ref);
+	  (*p)->ref = NULL;
+	  break;
+
 	default:
 	  break;
 	}
@@ -1933,6 +2060,9 @@ gfc_simplify_expr (gfc_expr *p, int type)
   switch (p->expr_type)
     {
     case EXPR_CONSTANT:
+      if (p->ref && p->ref->type == REF_INQUIRY)
+	simplify_ref_chain (p->ref, type, &p);
+      break;
     case EXPR_NULL:
       break;
 
@@ -1969,7 +2099,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
       break;
 
     case EXPR_SUBSTRING:
-      if (!simplify_ref_chain (p->ref, type))
+      if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
 
       if (gfc_is_constant_expr (p))
@@ -2031,14 +2161,14 @@ gfc_simplify_expr (gfc_expr *p, int type)
 	}
 
       /* Simplify subcomponent references.  */
-      if (!simplify_ref_chain (p->ref, type))
+      if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
 
       break;
 
     case EXPR_STRUCTURE:
     case EXPR_ARRAY:
-      if (!simplify_ref_chain (p->ref, type))
+      if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
 
       if (!simplify_constructor (p->value.constructor, type))
@@ -3306,14 +3436,22 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
 
   sym = lvalue->symtree->n.sym;
 
-  /* See if this is the component or subcomponent of a pointer.  */
+  /* See if this is the component or subcomponent of a pointer and guard
+     against assignment to LEN or KIND part-refs.  */
   has_pointer = sym->attr.pointer;
   for (ref = lvalue->ref; ref; ref = ref->next)
-    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
-      {
-	has_pointer = 1;
-	break;
-      }
+    {
+      if (!has_pointer && ref->type == REF_COMPONENT
+	  && ref->u.c.component->attr.pointer)
+        has_pointer = 1;
+      else if (ref->type == REF_INQUIRY
+	       && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
+	{
+	  gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
+		     "allowed", &lvalue->where);
+	  return false;
+	}
+    }
 
   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
      variable local to a function subprogram.  Its existence begins when
@@ -4791,6 +4929,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
 	      continue;
 
 	    case REF_SUBSTRING:
+	    case REF_INQUIRY:
 	      continue;
 
 	    case REF_ARRAY:
@@ -4943,6 +5082,9 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 	      }
 	  break;
 
+	case REF_INQUIRY:
+	  return true;
+
 	default:
 	  gcc_unreachable ();
 	}
@@ -5297,6 +5439,7 @@ gfc_is_coarray (gfc_expr *e)
 	break;
 
      case REF_SUBSTRING:
+     case REF_INQUIRY:
 	break;
     }
 
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index a6af96c43db..2c095cb8d5e 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -5037,6 +5037,7 @@ gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
 		    break;
 
 		  case REF_COMPONENT:
+		  case REF_INQUIRY:
 		    break;
 		  }
 	      }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 4a8d3602d72..d8ef35d9d6c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1937,7 +1937,10 @@ gfc_array_ref;
    before the component component.  */
 
 enum ref_type
-  { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING };
+  { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING, REF_INQUIRY };
+
+enum inquiry_type
+  { INQUIRY_RE, INQUIRY_IM, INQUIRY_KIND, INQUIRY_LEN };
 
 typedef struct gfc_ref
 {
@@ -1961,6 +1964,8 @@ typedef struct gfc_ref
     }
     ss;
 
+    inquiry_type i;
+
   }
   u;
 
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 17978c14d93..8c18706958d 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3367,7 +3367,7 @@ add_subroutines (void)
     *st = "status", *stat = "stat", *sz = "size", *t = "to",
     *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit",
     *val = "value", *vl = "values", *whence = "whence", *zn = "zone";
- 
+
   int di, dr, dc, dl, ii;
 
   di = gfc_default_integer_kind;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index badd3c4a5de..f22241da60b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1350,6 +1350,14 @@ gfc_match_assignment (void)
 
   rvalue = NULL;
   m = gfc_match (" %e%t", &rvalue);
+
+  if (lvalue->expr_type == EXPR_CONSTANT)
+    {
+      /* This clobbers %len and %kind.  */
+      m = MATCH_ERROR;
+      gfc_error ("Assignment to a constant expression at %C");
+    }
+
   if (m != MATCH_YES)
     {
       gfc_current_locus = old_loc;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 7b8e863ca0a..d42ab4789eb 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2125,6 +2125,7 @@ DECL_MIO_NAME (procedure_type)
 DECL_MIO_NAME (ref_type)
 DECL_MIO_NAME (sym_flavor)
 DECL_MIO_NAME (sym_intent)
+DECL_MIO_NAME (inquiry_type)
 #undef DECL_MIO_NAME
 
 /* Symbol attributes are stored in list with the first three elements
@@ -3140,6 +3141,15 @@ static const mstring ref_types[] = {
     minit ("ARRAY", REF_ARRAY),
     minit ("COMPONENT", REF_COMPONENT),
     minit ("SUBSTRING", REF_SUBSTRING),
+    minit ("INQUIRY", REF_INQUIRY),
+    minit (NULL, -1)
+};
+
+static const mstring inquiry_types[] = {
+    minit ("RE", INQUIRY_RE),
+    minit ("IM", INQUIRY_IM),
+    minit ("KIND", INQUIRY_KIND),
+    minit ("LEN", INQUIRY_LEN),
     minit (NULL, -1)
 };
 
@@ -3170,6 +3180,10 @@ mio_ref (gfc_ref **rp)
       mio_expr (&r->u.ss.end);
       mio_charlen (&r->u.ss.length);
       break;
+
+    case REF_INQUIRY:
+      r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
+      break;
     }
 
   mio_rparen ();
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 6f45afa86ea..d94a5c48adf 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1249,7 +1249,7 @@ match_sym_complex_part (gfc_expr **result)
   if (sym->attr.flavor != FL_PARAMETER)
     {
       /* Give the matcher for implied do-loops a chance to run.  This yields
-	 a much saner error message for "write(*,*) (i, i=1, 6" where the 
+	 a much saner error message for "write(*,*) (i, i=1, 6" where the
 	 right parenthesis is missing.  */
       char c;
       gfc_gobble_whitespace ();
@@ -1936,6 +1936,40 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
 }
 
 
+/* Used by gfc_match_varspec() to match an inquiry reference.  */
+
+static bool
+is_inquiry_ref (const char *name, gfc_ref **ref)
+{
+  inquiry_type type;
+
+  if (name == NULL)
+    return false;
+
+  if (ref) *ref = NULL;
+
+  if (strcmp (name, "re") == 0)
+    type = INQUIRY_RE;
+  else if (strcmp (name, "im") == 0)
+    type = INQUIRY_IM;
+  else if (strcmp (name, "kind") == 0)
+    type = INQUIRY_KIND;
+  else if (strcmp (name, "len") == 0)
+    type = INQUIRY_LEN;
+  else
+    return false;
+
+  if (ref)
+    {
+      *ref = gfc_get_ref ();
+      (*ref)->type = REF_INQUIRY;
+      (*ref)->u.i = type;
+    }
+
+  return true;
+}
+
+
 /* Match any additional specifications associated with the current
    variable like member references or substrings.  If equiv_flag is
    set we only match stuff that is allowed inside an EQUIVALENCE
@@ -1955,6 +1989,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   gfc_expr *tgt_expr = NULL;
   match m;
   bool unknown;
+  bool inquiry;
+  locus old_loc;
   char sep;
 
   tail = NULL;
@@ -2087,6 +2123,19 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
 
+  inquiry = false;
+  if (m == MATCH_YES && sep == '%'
+      && primary->ts.type != BT_CLASS
+      && primary->ts.type != BT_DERIVED)
+    {
+      match mm;
+      old_loc = gfc_current_locus;
+      mm = gfc_match_name (name);
+      if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
+	inquiry = true;
+      gfc_current_locus = old_loc;
+    }
+
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
@@ -2118,18 +2167,21 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	}
     }
   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
-           && m == MATCH_YES)
+           && m == MATCH_YES && !inquiry)
     {
       gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
 		 sep, sym->name);
       return MATCH_ERROR;
     }
 
-  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
       || m != MATCH_YES)
     goto check_substring;
 
-  sym = sym->ts.u.derived;
+  if (!inquiry)
+    sym = sym->ts.u.derived;
+  else
+    sym = NULL;
 
   for (;;)
     {
@@ -2142,6 +2194,15 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
+      if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
+	{
+	  inquiry = is_inquiry_ref (name, &tmp);
+	  if (inquiry)
+	    sym = NULL;
+	}
+      else
+	inquiry = false;
+
       if (sym && sym->f2k_derived)
 	tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
       else
@@ -2197,24 +2258,89 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  break;
 	}
 
-      component = gfc_find_component (sym, name, false, false, &tmp);
-      if (component == NULL)
+      if (!inquiry)
+	component = gfc_find_component (sym, name, false, false, &tmp);
+      else
+	component = NULL;
+
+      if (component == NULL && !inquiry)
 	return MATCH_ERROR;
 
-      /* Extend the reference chain determined by gfc_find_component.  */
+      /* Extend the reference chain determined by gfc_find_component or
+	 is_inquiry_ref.  */
       if (primary->ref == NULL)
-        primary->ref = tmp;
+	primary->ref = tmp;
       else
-        {
-          /* Set by the for loop below for the last component ref.  */
-          gcc_assert (tail != NULL);
-          tail->next = tmp;
-        }
+	{
+	  /* Set by the for loop below for the last component ref.  */
+	  gcc_assert (tail != NULL);
+	  tail->next = tmp;
+	}
 
       /* The reference chain may be longer than one hop for union
-         subcomponents; find the new tail.  */
+	 subcomponents; find the new tail.  */
       for (tail = tmp; tail->next; tail = tail->next)
-        ;
+	;
+
+      if (tmp && tmp->type == REF_INQUIRY)
+	{
+	  gfc_simplify_expr (primary, 0);
+
+	  if (primary->expr_type == EXPR_CONSTANT)
+	    goto check_done;
+
+	  switch (tmp->u.i)
+	    {
+	    case INQUIRY_RE:
+	    case INQUIRY_IM:
+	      if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
+		return MATCH_ERROR;
+
+	      if (primary->ts.type != BT_COMPLEX)
+		{
+		  gfc_error ("The RE or IM part_ref at %C must be "
+			     "applied to a COMPLEX expression");
+		  return MATCH_ERROR;
+		}
+	      primary->ts.type = BT_REAL;
+	      break;
+
+	    case INQUIRY_LEN:
+	      if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
+		return MATCH_ERROR;
+
+	      if (primary->ts.type != BT_CHARACTER)
+		{
+		  gfc_error ("The LEN part_ref at %C must be applied "
+			     "to a CHARACTER expression");
+		  return MATCH_ERROR;
+		}
+	      primary->ts.u.cl = NULL;
+	      primary->ts.type = BT_INTEGER;
+	      primary->ts.kind = gfc_default_integer_kind;
+	      break;
+
+	    case INQUIRY_KIND:
+	      if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
+		return MATCH_ERROR;
+
+	      if (primary->ts.type == BT_CLASS
+		  || primary->ts.type == BT_DERIVED)
+		{
+		  gfc_error ("The KIND part_ref at %C must be applied "
+			     "to an expression of intrinsic type");
+		  return MATCH_ERROR;
+		}
+	      primary->ts.type = BT_INTEGER;
+	      primary->ts.kind = gfc_default_integer_kind;
+	      break;
+
+	    default:
+	      gcc_unreachable ();
+	    }
+
+	  goto check_done;
+	}
 
       primary->ts = component->ts;
 
@@ -2263,11 +2389,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	    return m;
 	}
 
+check_done:
+      /* In principle, we could have eg. expr%re%kind so we must allow for
+	 this possibility.  */
+      if (gfc_match_char ('%') == MATCH_YES)
+	{
+	  if (component && (component->ts.type == BT_DERIVED
+			    || component->ts.type == BT_CLASS))
+	    sym = component->ts.u.derived;
+	  continue;
+	}
+      else if (inquiry)
+	break;
+
       if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
-	  || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
+  	  || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
 	break;
 
-      sym = component->ts.u.derived;
+      if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
+	sym = component->ts.u.derived;
     }
 
 check_substring:
@@ -2358,6 +2498,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   gfc_ref *ref;
   gfc_symbol *sym;
   gfc_component *comp;
+  bool has_inquiry_part;
 
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
@@ -2387,6 +2528,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
 
+  has_inquiry_part = false;
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_INQUIRY)
+      {
+	has_inquiry_part = true;
+	break;
+      }
+
   for (ref = expr->ref; ref; ref = ref->next)
     switch (ref->type)
       {
@@ -2423,7 +2572,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
       case REF_COMPONENT:
 	comp = ref->u.c.component;
 	attr = comp->attr;
-	if (ts != NULL)
+	if (ts != NULL && !has_inquiry_part)
 	  {
 	    *ts = comp->ts;
 	    /* Don't set the string length if a substring reference
@@ -2450,6 +2599,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 
 	break;
 
+      case REF_INQUIRY:
       case REF_SUBSTRING:
 	allocatable = pointer = 0;
 	break;
@@ -2630,6 +2780,7 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
 	break;
 
       case REF_SUBSTRING:
+      case REF_INQUIRY:
 	allocatable = pointer = 0;
 	break;
       }
@@ -2914,7 +3065,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
 	      to = e < c ? e : c;
 	      for (i = 0; i < to; i++)
 		dest[i] = actual->expr->value.character.string[i];
-	      
+
 	      for (i = e; i < c; i++)
 		dest[i] = ' ';
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7ec9e969c71..ba9623497d2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4740,6 +4740,7 @@ find_array_spec (gfc_expr *e)
 	break;
 
       case REF_SUBSTRING:
+      case REF_INQUIRY:
 	break;
       }
 
@@ -4962,13 +4963,13 @@ gfc_resolve_substring_charlen (gfc_expr *e)
 
   for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
     {
-      if (char_ref->type == REF_SUBSTRING)
-      	break;
+      if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY)
+	break;
       if (char_ref->type == REF_COMPONENT)
 	ts = &char_ref->u.c.component->ts;
     }
 
-  if (!char_ref)
+  if (!char_ref || char_ref->type == REF_INQUIRY)
     return;
 
   gcc_assert (char_ref->next == NULL);
@@ -5056,6 +5057,7 @@ resolve_ref (gfc_expr *expr)
 	break;
 
       case REF_COMPONENT:
+      case REF_INQUIRY:
 	break;
 
       case REF_SUBSTRING:
@@ -5129,6 +5131,7 @@ resolve_ref (gfc_expr *expr)
 	  break;
 
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  break;
 	}
 
@@ -7233,6 +7236,7 @@ resolve_deallocate_expr (gfc_expr *e)
 	  break;
 
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  allocatable = 0;
 	  break;
 	}
@@ -7525,6 +7529,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 		break;
 
 	      case REF_SUBSTRING:
+	      case REF_INQUIRY:
 		allocatable = 0;
 		pointer = 0;
 		break;
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2c87ae95f98..cdf748e4990 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -4182,6 +4182,7 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  continue;
 
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  continue;
 	}
     }
@@ -4324,6 +4325,7 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  continue;
 
 	case REF_SUBSTRING:
+	case REF_INQUIRY:
 	  continue;
 	}
     }
@@ -5395,7 +5397,7 @@ gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
 
       back_val = back->value.logical;
     }
-  
+
   if (sign < 0)
     init_val = INT_MAX;
   else if (sign > 0)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 47fec131c78..04fb4262b24 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2078,6 +2078,9 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
 	  mpz_clear (char_len);
 	  return;
 
+	case REF_INQUIRY:
+	  break;
+
 	default:
 	 gcc_unreachable ();
 	}
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 05b1d07eb02..64bda4c1e69 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2510,6 +2510,40 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)
   conv_parent_component_references (se, &parent);
 }
 
+
+static void
+conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
+{
+  tree res = se->expr;
+
+  switch (ref->u.i)
+    {
+    case INQUIRY_RE:
+      res = fold_build1_loc (input_location, REALPART_EXPR,
+			     TREE_TYPE (TREE_TYPE (res)), res);
+      break;
+
+    case INQUIRY_IM:
+      res = fold_build1_loc (input_location, IMAGPART_EXPR,
+			     TREE_TYPE (TREE_TYPE (res)), res);
+      break;
+
+    case INQUIRY_KIND:
+      res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
+			   ts->kind);
+      break;
+
+    case INQUIRY_LEN:
+      res = fold_convert (gfc_typenode_for_spec (&expr->ts),
+			  se->string_length);
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+  se->expr = res;
+}
+
 /* Return the contents of a variable. Also handles reference/pointer
    variables (all Fortran pointer references are implicit).  */
 
@@ -2720,6 +2754,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       gcc_assert (se->string_length);
     }
 
+  gfc_typespec *ts = &sym->ts;
   while (ref)
     {
       switch (ref->type)
@@ -2740,6 +2775,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  break;
 
 	case REF_COMPONENT:
+	  ts = &ref->u.c.component->ts;
 	  if (first_time && is_classarray && sym->attr.dummy
 	      && se->descriptor_only
 	      && !CLASS_DATA (sym)->attr.allocatable
@@ -2767,6 +2803,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 			      expr->symtree->name, &expr->where);
 	  break;
 
+	case REF_INQUIRY:
+	  conv_inquiry (se, ref, expr, ts);
+	  break;
+
 	default:
 	  gcc_unreachable ();
 	  break;
@@ -4135,6 +4175,7 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
 	break;
 
       case REF_COMPONENT:
+      case REF_INQUIRY:
 	break;
 
       case REF_SUBSTRING:
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2fd83f08bbf..4f1076169a1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2018-11-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/40196
+	* gfortran.dg/inquiry_part_ref_1.f08: New test.
+	* gfortran.dg/inquiry_part_ref_2.f90: New test.
+	* gfortran.dg/inquiry_part_ref_3.f90: New test.
+
 2018-11-01  Paul Koning  <ni1d@arrl.net>
 
 	* gcc.c-torture/execute/20010904-1.c: Align 2 if pdp11.
diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08
new file mode 100644
index 00000000000..5ef3b480a49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_1.f08
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! Test the implementation of inquiry part references (PR40196).
+! "Type parameter inquiry (str%len, a%kind) and Complex parts (z%re, z%im)"
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+module m
+  complex, target :: z
+  character (:), allocatable :: str
+  real, pointer :: r => z%re
+  real, pointer :: i => z%im
+  type :: mytype
+    complex :: z = ( 10.0, 11.0 )
+    character(6) :: str
+  end type
+end module
+
+  use m
+
+  type(mytype) :: der
+  integer :: j
+  character (len=der%str%len) :: str1
+  complex, parameter :: zc = ( 99.0, 199.0 )
+  REAL, parameter :: rc = zc%re
+  REAL, parameter :: ic = zc%im
+
+  z = (2.0,4.0)
+  str = "abcd"
+
+! Check the pointer initializations
+  if (r .ne. real (z)) stop 1
+  if (i .ne. imag (z)) stop 2
+
+! Check the use of inquiry part_refs on lvalues and rvalues.
+  z%im = 4.0 * z%re
+
+! Check that the result is OK.
+  if (z%re .ne. real (z)) stop 3
+  if (abs (z*im - 4.0 * real (z)) .lt. 1e-6) stop 4
+
+! Check a double inquiry part_ref.
+  if (z%im%kind .ne. kind (z)) stop 5
+
+! Test on deferred character length.
+  if (str%kind .ne. kind (str)) stop 6
+  if (str%len .ne. len (str)) stop 7
+
+! Check the use in specification expressions.
+  if (len (der%str) .ne. LEN (str1)) stop 8
+  if (rc .ne. real (zc)) stop 9
+  if (ic .ne. aimag (zc)) stop 10
+
+end
+
diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90
new file mode 100644
index 00000000000..3c33dcca6d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_2.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! Test the implementation of inquiry part references (PR40196):
+! Check the standards are correctly adhered to.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+program main
+   character(4) :: a
+   complex :: z
+   integer :: i
+   a%len = 2       ! { dg-error "Fortran 2003: LEN part_ref" }
+   i = a%kind      ! { dg-error "Fortran 2003: KIND part_ref" }
+   print *, z%re   ! { dg-error "Fortran 2008: RE or IM part_ref" }
+   print *, z%im   ! { dg-error "Fortran 2008: RE or IM part_ref" }
+end
diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
new file mode 100644
index 00000000000..4e8d8a07b4e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+! Test the implementation of inquiry part references (PR40196):
+! Check errors on invalid code.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+program main
+   type :: t
+     complex :: z
+     character(6) :: a
+   end type
+   character(4) :: a
+   character(:), allocatable :: b
+   real :: z
+   integer :: i
+   type(t) :: s
+   b = "abcdefg"
+   a%kind = 2        ! { dg-error "Assignment to a constant expression" }
+   b%len = 2         ! { dg-error "Assignment to a LEN or KIND part_ref" }
+   i = a%kind        ! OK
+   i = b%len         ! OK
+   print *, z%re     ! { dg-error "must be applied to a COMPLEX expression" }
+   print *, z%im     ! { dg-error "must be applied to a COMPLEX expression" }
+   i%re = 2.0        ! { dg-error "must be applied to a COMPLEX expression" }
+   print *, i%len    ! { dg-error "must be applied to a CHARACTER expression" }
+   print *, s%kind   ! { dg-error "is not a member" }
+   print *, s%z%kind ! OK
+   print *, s%a%len  ! OK
+end