[COMMITTED] algol68: implement multiple bound checking in assignations

Jose E. Marchesi jemarch@gnu.org
Sat Apr 12 09:40:48 GMT 2025


This uncovered several problems in some of the tests, which are fixed
by this patch.
---
 gcc/algol68/a68-low-decls.cc                  |  3 +-
 gcc/algol68/a68-low-multiples.cc              | 66 +++++++++++++++++++
 gcc/algol68/a68-low-prelude.cc                | 18 ++---
 gcc/algol68/a68-low-runtime.def               |  4 ++
 gcc/algol68/a68-low-units.cc                  |  3 +-
 gcc/algol68/a68-low.cc                        | 63 ++++++++++--------
 gcc/algol68/a68.h                             |  3 +-
 gcc/testsuite/algol68/execute/mcts/simp04.a68 |  4 +-
 gcc/testsuite/algol68/execute/trimmer-1.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-2.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-3.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-4.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-5.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-6.a68   |  2 +-
 gcc/testsuite/algol68/execute/trimmer-8.a68   |  2 +-
 libga68/ga68-error.c                          | 12 ++++
 libga68/ga68.h                                |  4 ++
 17 files changed, 144 insertions(+), 50 deletions(-)

diff --git a/gcc/algol68/a68-low-decls.cc b/gcc/algol68/a68-low-decls.cc
index 1f2fba7849a..7f71d75a452 100644
--- a/gcc/algol68/a68-low-decls.cc
+++ b/gcc/algol68/a68-low-decls.cc
@@ -208,7 +208,8 @@ a68_lower_variable_declaration (NODE_T *p, LOW_CTX_T ctx)
   if (unit != NO_NODE)
     {
       tree rhs = a68_lower_tree (unit, ctx);
-      tree assignation = a68_low_assignation (var_decl, MOID (defining_identifier),
+      tree assignation = a68_low_assignation (p,
+					      var_decl, MOID (defining_identifier),
 					      rhs, MOID (unit));
       if (expr != NULL_TREE)
 	expr = fold_build2_loc (a68_get_node_location (p),
diff --git a/gcc/algol68/a68-low-multiples.cc b/gcc/algol68/a68-low-multiples.cc
index b62a7cd0697..662d8c76981 100644
--- a/gcc/algol68/a68-low-multiples.cc
+++ b/gcc/algol68/a68-low-multiples.cc
@@ -972,3 +972,69 @@ a68_multiple_bounds_check (NODE_T *p, tree dim,
 			  ssizetype,
 			  bounds_check, call);
 }
+
+/* Emit a run-time error if the bounds of M1 and M2 are not the same.  Both
+   multiples are assumed to have the same type and therefore feature the same
+   number of dimensions.  */
+
+tree
+a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2)
+{
+  m1 = save_expr (m1);
+  m2 = save_expr (m2);
+
+  /* First determine the rank of the multiples and check they match.  */
+  tree m1_dimensions = a68_multiple_dimensions (m1);
+  tree m2_dimensions = a68_multiple_dimensions (m2);
+  gcc_assert (TREE_CODE (m1_dimensions) == INTEGER_CST
+	      && TREE_CODE (m2_dimensions) == INTEGER_CST);
+
+  int dim1 = tree_to_shwi (m1_dimensions);
+  int dim2 = tree_to_shwi (m2_dimensions);
+  gcc_assert (dim1 == dim2);
+
+  a68_push_range (NULL /* VOID */);
+
+  /* For each dimension, check that bounds are the same in both multiples.  */
+  int i;
+  for (i = 0; i < dim1; ++i)
+    {
+      tree dim_tree = build_int_cst (ssizetype, i);
+      tree dim_plus_one = fold_build2 (PLUS_EXPR, ssizetype,
+				       dim_tree,
+				       fold_convert (ssizetype, size_one_node));
+
+      tree lb1 = save_expr (a68_multiple_lower_bound (m1, dim_tree));
+      tree lb2 = save_expr (a68_multiple_lower_bound (m2, dim_tree));
+
+      tree ub1 = save_expr (a68_multiple_upper_bound (m1, dim_tree));
+      tree ub2 = save_expr (a68_multiple_upper_bound (m2, dim_tree));
+
+      tree bounds_equal = fold_build2 (TRUTH_AND_EXPR,
+				       boolean_type_node,
+				       fold_build2 (EQ_EXPR, boolean_type_node,
+						    lb1, lb2),
+				       fold_build2 (EQ_EXPR, boolean_type_node,
+						    ub1, ub2));
+
+      unsigned int lineno = NUMBER (LINE (INFO (p)));
+      const char *filename_str = FILENAME (LINE (INFO (p)));
+      tree filename = build_string_literal (strlen (filename_str) + 1,
+					    filename_str);
+      tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDSMISMATCH,
+				     void_type_node, 7,
+				     filename,
+				     build_int_cst (unsigned_type_node, lineno),
+				     dim_plus_one,
+				     lb1, ub1, lb2, ub2);
+      call = fold_build2 (COMPOUND_EXPR, boolean_type_node, call, boolean_false_node);
+
+      tree check = fold_build2_loc (a68_get_node_location (p),
+				    TRUTH_ORIF_EXPR, boolean_type_node,
+				    bounds_equal,
+				    call);
+      a68_add_stmt (check);
+    }
+
+  return a68_pop_range ();
+}
diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
index 9a66036717b..506817607cd 100644
--- a/gcc/algol68/a68-low-prelude.cc
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -227,7 +227,7 @@ a68_lower_multab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -480,7 +480,7 @@ a68_lower_plusab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -501,7 +501,7 @@ a68_lower_minusab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -522,7 +522,7 @@ a68_lower_overab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -543,7 +543,7 @@ a68_lower_modab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -564,7 +564,7 @@ a68_lower_divab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -875,7 +875,7 @@ a68_lower_string_plusab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
@@ -894,7 +894,7 @@ a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, lhs_mode,
+			  a68_low_assignation (p, lhs, lhs_mode,
 					       operation, MOID (rhs_node)),
 			  lhs);
 }
@@ -971,7 +971,7 @@ a68_lower_string_multab3 (NODE_T *p, LOW_CTX_T ctx)
   return fold_build2_loc (a68_get_node_location (p),
 			  COMPOUND_EXPR,
 			  TREE_TYPE (lhs),
-			  a68_low_assignation (lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
 			  lhs);
 }
 
diff --git a/gcc/algol68/a68-low-runtime.def b/gcc/algol68/a68-low-runtime.def
index 386425085ca..7fde40ce3aa 100644
--- a/gcc/algol68/a68-low-runtime.def
+++ b/gcc/algol68/a68-low-runtime.def
@@ -28,6 +28,8 @@ along with GCC; see the file COPYING3.  If not see
 		5, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5
 #define P6(T1, T2, T3, T4, T5, T6)  \
 		6, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6
+#define P7(T1, T2, T3, T4, T5, T6, T7)					\
+                7, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6, LCT_ ## T7
 #define RT(T1)	LCT_ ## T1
 
 /* Algol 68 runtime library functions.  */
@@ -52,6 +54,8 @@ DEF_A68_RUNTIME (ARRAYUPPERBOUND, "_libga68_upper_bound", RT(VOID),
 		 P4(CONSTCHARPTR, UINT, SSIZE, SSIZE), ECF_NORETURN)
 DEF_A68_RUNTIME (ARRAYBOUNDS, "_libga68_bounds", RT(VOID),
 		 P5(CONSTCHARPTR, UINT, SSIZE, SSIZE, SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYBOUNDSMISMATCH, "_libga68_bounds_mismatch", RT(VOID),
+		 P7(CONSTCHARPTR, UINT, SIZE, SSIZE, SSIZE, SSIZE, SSIZE), ECF_NORETURN)
 DEF_A68_RUNTIME (ARRAYDIM, "_libga68_dim", RT(VOID),
                  P4(CONSTCHARPTR, UINT, SIZE, SIZE), ECF_NORETURN)
 DEF_A68_RUNTIME (RANDOM, "_libga68_random", RT(FLOAT), P0(), 0)
diff --git a/gcc/algol68/a68-low-units.cc b/gcc/algol68/a68-low-units.cc
index 641a2e1d516..73831011a78 100644
--- a/gcc/algol68/a68-low-units.cc
+++ b/gcc/algol68/a68-low-units.cc
@@ -992,7 +992,8 @@ a68_lower_assignation (NODE_T *p, LOW_CTX_T ctx)
   tree lhs = a68_lower_tree (lhs_node, ctx);
   tree rhs = a68_lower_tree (rhs_node, ctx);
 
-  return a68_low_assignation (lhs, MOID (lhs_node),
+  return a68_low_assignation (p,
+			      lhs, MOID (lhs_node),
 			      rhs, MOID (rhs_node));
 }
 
diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc
index 6b69094ee66..6e7bef66ed5 100644
--- a/gcc/algol68/a68-low.cc
+++ b/gcc/algol68/a68-low.cc
@@ -706,7 +706,8 @@ a68_low_ascription (MOID_T *mode, tree lhs, tree rhs)
    MODE_LHS shall be REF [FLEX] MODE_LHS.  */
 
 tree
-a68_low_assignation (tree lhs, MOID_T *mode_lhs,
+a68_low_assignation (NODE_T *p,
+		     tree lhs, MOID_T *mode_lhs,
 		     tree rhs, MOID_T *mode_rhs)
 {
   tree assignation = NULL_TREE;
@@ -719,6 +720,7 @@ a68_low_assignation (tree lhs, MOID_T *mode_lhs,
 	 rhs.  */
       if (HAS_ROWS (mode_rhs))
 	rhs = a68_low_dup (rhs, true /* use_heap */);
+      rhs = save_expr (rhs);
 
       /* Determine whether the REF [FLEX] MODE_LHS is flexible.  */
       if (SUB (mode_lhs) == M_STRING || IS_FLEX (SUB (mode_lhs)))
@@ -755,43 +757,46 @@ a68_low_assignation (tree lhs, MOID_T *mode_lhs,
 	}
       else
 	{
-	  /* Check the bounds of the multiple at the rhs to make sure they are
-	     the same than the bounds of the multiple already referred by the
-	     lhs.  If the bounds don't match then emit a run-time error.  */
-	  // XXX
+	  /* Dereference the multiple at the left-hand side.  This may require
+	     indirection.  */
 
-	  /* Copy over the elements in a loop.  We need to access the multiple
-	     referred by the left hand side.  This may require indirecting.
-	     The space occupied by the previous elements stored in the lhs
-	     multiple will be recovered by either stack shrinkage or garbage
-	     collected.  */
+	  tree effective_lhs;
 	  if (POINTER_TYPE_P (TREE_TYPE (lhs)))
 	    {
+	      /* The name at the lhs is a pointer.  */
 	      gcc_assert (TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs));
-
-	      /* Make sure to not evaluate the expression yielding the pointer
-		 more than once.  */
 	      lhs = save_expr (lhs);
-	      tree deref_lhs = fold_build1 (INDIRECT_REF,
-					    TREE_TYPE (TREE_TYPE (lhs)),
-					    lhs);
-	      tree copy_elements = a68_multiple_copy_elems (deref_lhs, rhs);
-	      assignation = fold_build2 (COMPOUND_EXPR,
-					 TREE_TYPE (lhs),
-					 copy_elements,
-					 lhs);
+	      effective_lhs = fold_build1 (INDIRECT_REF,
+					   TREE_TYPE (TREE_TYPE (lhs)), lhs);
 	    }
 	  else
 	    {
-	      /* The lhs is either a variable or a component ref as a l-value.  It
-		 is ok to evaluate it as an r-value as well as doing so inroduces
-		 no side-effects.  */
-	      tree copy_elements = a68_multiple_copy_elems (lhs, rhs);
-	      assignation = fold_build2 (COMPOUND_EXPR,
-					 TREE_TYPE (lhs),
-					 copy_elements,
-					 lhs);
+	      /* The name at the lhs is either a variable or a component ref as
+		 a l-value.  It is ok to evaluate it as an r-value as well as
+		 doing so introduces no side-effects.  */
+	      effective_lhs = lhs;
 	    }
+
+	  /* Copy over the elements in a loop.  The space occupied by the
+	     previous elements stored in the lhs multiple will be recovered by
+	     either stack shrinkage or garbage collected.  */
+	  tree copy_elements = a68_multiple_copy_elems (effective_lhs, rhs);
+	  assignation = fold_build2 (COMPOUND_EXPR,
+				     TREE_TYPE (lhs),
+				     copy_elements,
+				     lhs);
+
+	  /* Check the bounds of the multiple at the rhs to make sure they are
+	     the same than the bounds of the multiple already referred by the
+	     lhs.  If the bounds don't match then emit a run-time error.  */
+	  if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+	    assignation = fold_build2 (COMPOUND_EXPR,
+				       TREE_TYPE (assignation),
+				       a68_multiple_bounds_check_equal (p,
+									effective_lhs,
+									rhs),
+				       assignation);
+
 	}
     }
   else
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 70905095d39..6630c446e0a 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -642,6 +642,7 @@ tree a68_multiple_single_bound_check (NODE_T *p, tree dim, tree multiple,
 				      tree index, bool upper_bound);
 tree a68_multiple_bounds_check (NODE_T *p, tree dim, tree multiple,
 				tree index);
+tree a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2);
 
 /* a68-low-ranges.cc  */
 
@@ -738,7 +739,7 @@ tree a68_lower_malloc (tree type, tree size);
 tree a68_low_deref (tree exp, NODE_T *p);
 tree a68_low_dup (tree exp, bool use_heap = false);
 tree a68_low_ascription (MOID_T *mode, tree lhs, tree rhs);
-tree a68_low_assignation (tree lhs, MOID_T *lhs_mode, tree rhs, MOID_T *rhs_mode);
+tree a68_low_assignation (NODE_T *p, tree lhs, MOID_T *lhs_mode, tree rhs, MOID_T *rhs_mode);
 tree a68_lower_memcpy (tree dst, tree src, tree size);
 tree a68_lower_tmpvar (const char *name, tree type, tree init);
 tree a68_get_mangled_identifier (const char *name);
diff --git a/gcc/testsuite/algol68/execute/mcts/simp04.a68 b/gcc/testsuite/algol68/execute/mcts/simp04.a68
index 716d385432d..ccf03c181c9 100644
--- a/gcc/testsuite/algol68/execute/mcts/simp04.a68
+++ b/gcc/testsuite/algol68/execute/mcts/simp04.a68
@@ -2,9 +2,9 @@
 multiples:
 structures:
 BEGIN [1:100]INT i, j, k;
-      FOR l TO 100 DO i[l] := j[l] := k[l] := 1 OD;
+      FOR l TO 100 DO i[l] := j[l] := k[l] := l OD;
       FOR l TO 100
-      DO IF i[l] /= 1 OR j[l] /= 1 OR k[l] /= 1
+      DO IF i[l] /= l OR j[l] /= l OR k[l] /= l
          THEN ASSERT (FALSE)
          FI
       OD;
diff --git a/gcc/testsuite/algol68/execute/trimmer-1.a68 b/gcc/testsuite/algol68/execute/trimmer-1.a68
index 5a837b1eb63..a0d5f73b1da 100644
--- a/gcc/testsuite/algol68/execute/trimmer-1.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-1.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[2:3@20];
       ASSERT (LWB jorl = 20 AND UPB jorl = 21);
diff --git a/gcc/testsuite/algol68/execute/trimmer-2.a68 b/gcc/testsuite/algol68/execute/trimmer-2.a68
index bae65b8c081..692f04006a1 100644
--- a/gcc/testsuite/algol68/execute/trimmer-2.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-2.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[2:3];
       ASSERT (LWB jorl = 1 AND UPB jorl = 2);
diff --git a/gcc/testsuite/algol68/execute/trimmer-3.a68 b/gcc/testsuite/algol68/execute/trimmer-3.a68
index 16f108cbe0e..fea938cbe45 100644
--- a/gcc/testsuite/algol68/execute/trimmer-3.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-3.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[:@20];
       ASSERT (LWB jorl = 20 AND UPB jorl = 22);
diff --git a/gcc/testsuite/algol68/execute/trimmer-4.a68 b/gcc/testsuite/algol68/execute/trimmer-4.a68
index 9a075c5bb74..f5bb712efa6 100644
--- a/gcc/testsuite/algol68/execute/trimmer-4.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-4.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[3:];
       ASSERT (LWB jorl = 1 AND UPB jorl = 2);
diff --git a/gcc/testsuite/algol68/execute/trimmer-5.a68 b/gcc/testsuite/algol68/execute/trimmer-5.a68
index c8846c64073..0e51746e6b8 100644
--- a/gcc/testsuite/algol68/execute/trimmer-5.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-5.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[:3 AT 10];
       ASSERT (LWB jorl = 10 AND UPB jorl = 11);
diff --git a/gcc/testsuite/algol68/execute/trimmer-6.a68 b/gcc/testsuite/algol68/execute/trimmer-6.a68
index e359678545e..493eb50f487 100644
--- a/gcc/testsuite/algol68/execute/trimmer-6.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-6.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       []INT jorl = arr[:3@10];
       ASSERT (LWB jorl = 10 AND UPB jorl = 11);
diff --git a/gcc/testsuite/algol68/execute/trimmer-8.a68 b/gcc/testsuite/algol68/execute/trimmer-8.a68
index 4aa8a9825f6..30a131e876d 100644
--- a/gcc/testsuite/algol68/execute/trimmer-8.a68
+++ b/gcc/testsuite/algol68/execute/trimmer-8.a68
@@ -1,4 +1,4 @@
-BEGIN [2:4]INT arr := (1,2,3);
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
       ASSERT (arr[3] = 2 AND arr[4] = 3);
       [10:11]INT jorl := arr[:3 AT 10];
       ASSERT (LWB jorl = 10 AND UPB jorl = 11);
diff --git a/libga68/ga68-error.c b/libga68/ga68-error.c
index a0621099269..493cc31ad61 100644
--- a/libga68/ga68-error.c
+++ b/libga68/ga68-error.c
@@ -135,3 +135,15 @@ _libga68_dim (const char *filename, unsigned int lineno,
   _libga68_abort ("%s:%d: runtime error: invalid dimension %d; shall be <= %d\n",
 		  filename, lineno, index, dim);
 }
+
+/* Multiples have different bounds in assignations.  */
+
+void
+_libga68_bounds_mismatch (const char *filename, unsigned int lineno,
+			  size_t dim, ssize_t lb1, ssize_t ub1,
+			  ssize_t lb2, ssize_t ub2)
+{
+  _libga68_abort ("%s:%d: runtime error: multiple bounds mismatch in \
+assignation: dim %d: [%d,%d] /= [%d,%d]\n",
+		  filename, lineno, dim, lb1, ub1, lb2, ub2);
+}
diff --git a/libga68/ga68.h b/libga68/ga68.h
index 2e4ad88729f..7f2daee71a5 100644
--- a/libga68/ga68.h
+++ b/libga68/ga68.h
@@ -38,6 +38,7 @@ void _libga68_assert (const char *filename, unsigned int lineno);
 void _libga68_derefnil (const char *filename, unsigned int lineno);
 void _libga68_invalidcharerror (const char *filename, unsigned int lineno,
 				int c);
+
 void _libga68_bitsboundserror (const char *filename, unsigned int lineno,
 			       ssize_t pos);
 void _libga68_unreachable (const char *filename, unsigned int lineno);
@@ -49,6 +50,9 @@ void _libga68_bounds (const char *filename, unsigned int lineno,
 		      ssize_t index, ssize_t lower_bound, ssize_t upper_bound);
 void _libga68_dim (const char *filename, unsigned int lineno,
 		   size_t dim, size_t index);
+void _libga68_bounds_mismatch (const char *filename, unsigned int lineno,
+			       size_t dim, ssize_t lb1, ssize_t ub1,
+			       ssize_t lb2, ssize_t ub2);
 
 /* ga68-alloc.c  */
 
-- 
2.30.2



More information about the Algol68 mailing list