From: Paul Thomas <pault@gcc.gnu.org>
Date: Thu, 26 Mar 2026 18:50:13 +0000 (+0000)
Subject: Fortran: Minor PDT cleanup and fix in gfc_simplify_exp [PR115315]
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=9780a52dffaf5e476bbce80dac84514cd6863483;p=thirdparty%2Fgcc.git

Fortran: Minor PDT cleanup and fix in gfc_simplify_exp [PR115315]

2026-03-26  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/115315
	* decl.cc (insert_parameter_exprs): Make strcmp condition more
	concise.
	(gfc_get_pdt_instance): Use gf_replace_expr where possible and
	use return value of gfc_simplify_expr. Correct error in which
	params->expr was being simplified instead of c2->initializer.
	* expr.cc (gfc_simplify_expr): If the substring 'start' value
	is less than zero, it is clearly out of range and so return
	false.

gcc/testsuite/
	PR fortran/115315
	* gfortran.dg/pdt_90.f03: New test.
---

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index d8aa7d1c06f..454b65f2c47 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3931,14 +3931,13 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
       || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
     {
       for (param = type_param_spec_list; param; param = param->next)
-	if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+	if (!strcmp (e->symtree->n.sym->name, param->name))
 	  break;
 
       if (param && param->expr)
 	{
 	  copy = gfc_copy_expr (param->expr);
-	  *e = *copy;
-	  free (copy);
+	  gfc_replace_expr (e, copy);
 	  /* Catch variables declared without a value expression.  */
 	  if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
 	    e->ts = e->symtree->n.sym->ts;
@@ -4456,14 +4455,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	      gfc_expr *e;
 	      e = gfc_copy_expr (c1->as->lower[i]);
 	      gfc_insert_kind_parameter_exprs (e);
-	      gfc_simplify_expr (e, 1);
-	      gfc_free_expr (c2->as->lower[i]);
-	      c2->as->lower[i] = e;
+	      if (gfc_simplify_expr (e, 1))
+		gfc_replace_expr (c2->as->lower[i], e);
+	      else
+		gfc_free_expr (e);
 	      e = gfc_copy_expr (c1->as->upper[i]);
 	      gfc_insert_kind_parameter_exprs (e);
-	      gfc_simplify_expr (e, 1);
-	      gfc_free_expr (c2->as->upper[i]);
-	      c2->as->upper[i] = e;
+	      if (gfc_simplify_expr (e, 1))
+		gfc_replace_expr (c2->as->upper[i], e);
+	      else
+		gfc_free_expr (e);
 	    }
 
 	  c2->attr.pdt_array = 1;
@@ -4483,9 +4484,10 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	  gfc_expr *e;
 	  e = gfc_copy_expr (c1->ts.u.cl->length);
 	  gfc_insert_kind_parameter_exprs (e);
-	  gfc_simplify_expr (e, 1);
-	  gfc_free_expr (c2->ts.u.cl->length);
-	  c2->ts.u.cl->length = e;
+	  if (gfc_simplify_expr (e, 1))
+	    gfc_replace_expr (c2->ts.u.cl->length, e);
+	  else
+	    gfc_free_expr (e);
 	  c2->attr.pdt_string = 1;
 	}
 
@@ -4530,7 +4532,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 		  if (!s)
 		    gfc_insert_parameter_exprs (c2->initializer,
 						type_param_spec_list);
-		  gfc_simplify_expr (params->expr, 1);
+		  gfc_simplify_expr (c2->initializer, 1);
 		}
 	    }
 
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index fa5aeced2f3..791474b1524 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -2506,6 +2506,9 @@ gfc_simplify_expr (gfc_expr *p, int type)
 	      start--;  /* Convert from one-based to zero-based.  */
 	    }
 
+	  if (start < 0)
+	    return false;
+
 	  end = p->value.character.length;
 	  if (p->ref && p->ref->u.ss.end)
 	    gfc_extract_hwi (p->ref->u.ss.end, &end);
diff --git a/gcc/testsuite/gfortran.dg/pdt_90.f03 b/gcc/testsuite/gfortran.dg/pdt_90.f03
new file mode 100644
index 00000000000..af60b5cce8d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_90.f03
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check the fix for PR115315.f90 in which line 14 caused the error,
+! "Argument of IACHAR at (1) must be of length one".
+!
+! Contributed by David Binderman  <dcb314@hotmail.com>
+!
+  call p2
+contains
+  subroutine p2
+    type t1(n1,n2)
+      integer,kind :: n1,n2
+      integer :: c2(iachar('ABCDEFGHIJ'(n1:n2)))
+    end type
+
+    type(t1(4,4)) :: x
+    if (char (size (x%c2, 1)) .ne. "D") then
+      print *, "Wrong!"
+    else
+      print *, "Right"
+    endif
+  end
+end
+! { dg-final { scan-tree-dump-times "Wrong" 0 "original" } }
+! { dg-final { scan-tree-dump-times "Right" 1 "original" } }