diff mbox

[Ada] Crahs on indexing operation with named associations

Message ID 20151118135551.GA52049@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Nov. 18, 2015, 1:55 p.m. UTC
This patch fixes a crash on a variable indexing operation appearing on the
left-hand side of an assignment, when the index expressions are given by
parameter associations.

The following must compile quietly:

   gcc -c -gnatct test_indexing.adb

---
with Ada.Text_IO; use Ada.Text_IO;
with Project;     use Project;
with Matrix_3x3s; use Matrix_3x3s;
with Vector_3s;   use Vector_3s;
procedure Test_Indexing is
   V : Vector_3 := Create (X => 12.34,
                           Y => 123.4,
                           Z => 1234.0);
   M : Matrix_3x3 := (Create (X => V,
                              Y => V * 2.0,
                              Z => V * 4.0));
   Idx1 : Integer := 1;

   type Arr_Type is array (1 .. 10) of Integer;
   Arr : Arr_Type;
begin
   M (X => Idx1, Y=>1) := 20.0;
   M (Idx1, 2) := 20.0;
   M (1, 1) := 20.0;

   Arr (1) := 10;
end Test_Indexing;
---
with Project;             use Project;
with Project.Real_Arrays; use Project.Real_Arrays;
with Vector_3s;           use Vector_3s;
package Matrix_3x3s is
   pragma Pure (Matrix_3x3s);
   subtype An_Axis is Integer range 1 .. 3;
   type Matrix_3x3 is tagged private
     with Constant_Indexing => Matrix_3x3s.Constant_Reference,
          Variable_Indexing => Matrix_3x3s.Variable_Reference;
   function Create (X, Y, Z : Vector_3) return Matrix_3x3;
   type Constant_Reference_Type (Value : not null access constant Real) is
     private with Implicit_Dereference => Value;
   function Constant_Reference (This : Matrix_3x3;
                                X, Y : An_Axis) return Constant_Reference_Type;
   type Reference_Type (Value : not null access Real) is
     private with Implicit_Dereference => Value;
   function Variable_Reference (This : Matrix_3x3;
                                X, Y : An_Axis) return Reference_Type;
private
   type Matrix_3x3 is tagged record
      M : Real_Matrix (An_Axis, An_Axis);
   end record;
   function Create (X, Y, Z : Vector_3) return Matrix_3x3 is
     (M => (1 => (X.Get_X, X.Get_Y, X.Get_Z),
            2 => (Y.Get_X, Y.Get_Y, Y.Get_Z),
            3 => (Z.Get_X, Z.Get_Y, Z.Get_Z)));
   type Constant_Reference_Type (Value : not null access constant Real) is
     null record;
   type Reference_Type (Value : not null access Real) is
     null record;
   function Constant_Reference (This : Matrix_3x3;
                                X, Y : An_Axis)
                                return Constant_Reference_Type is
      (Value => This.M (X, Y)'Unrestricted_Access);
   function Variable_Reference (This : Matrix_3x3;
                                X, Y : An_Axis)
                                return Reference_Type is
      (Value => This.M (X, Y)'Unrestricted_Access);
end Matrix_3x3s;
---
with Ada.Numerics.Long_Real_Arrays;
package Project.Real_Arrays
   renames Ada.Numerics.Long_Real_Arrays;
package Project is
   pragma Pure (Project);
   subtype Real is Long_Float;
   pragma Assert (Real'Size >= 64);
   subtype Non_Negative_Real is Real range 0.0 .. Real'Last;
   subtype Positive_Real     is Real range Real'Succ (0.0) .. Real'Last;
end Project;
---
with Project;             use Project;
with Project.Real_Arrays; use Project.Real_Arrays;
package Vector_3s is
   pragma Pure (Vector_3s);
   subtype An_Axis is Integer range 1 .. 3;
   type Vector_3 is tagged private
     with Constant_Indexing => Vector_3s.Constant_Reference,
          Variable_Indexing => Vector_3s.Variable_Reference;
   function Create (X, Y, Z : Real) return Vector_3;
   function Get_X (This : Vector_3) return Real;
   function Get_Y (This : Vector_3) return Real;
   function Get_Z (This : Vector_3) return Real;
   function "*" (Left : Vector_3;
                 Right : Real'Base)
                 return Vector_3;
   subtype Real_Vector_3 is Real_Vector (An_Axis);
   type Constant_Reference_Type (Value : not null access constant Real) is
     private with Implicit_Dereference => Value;
   function Constant_Reference (This : Vector_3;
                                Axis : An_Axis)
                                return Constant_Reference_Type;
   type Reference_Type (Value : not null access Real) is
     private with Implicit_Dereference => Value;
   function Variable_Reference (This : Vector_3;
                                Axis : An_Axis)
                                return Reference_Type;
private
   type Vector_3 is tagged record
      V : Real_Vector (An_Axis);
   end record;
   function Create (X, Y, Z : Real) return Vector_3 is
     (V => (1 => X, 2 => Y, 3 => Z));
   function Get_X (This : Vector_3) return Real is
     (This.V (1));
   function Get_Y (This : Vector_3) return Real is
     (This.V (2));
   function Get_Z (This : Vector_3) return Real is
     (This.V (3));
   function "*" (Left : Vector_3; Right : Real'Base) return Vector_3 is
     (V => Left.V * Right);
   type Constant_Reference_Type (Value : not null access constant Real) is
     null record;
   type Reference_Type (Value : not null access Real) is
     null record;
   function Constant_Reference (This : Vector_3;
                                Axis : An_Axis)
                                return Constant_Reference_Type is
      (Value => This.V (Axis)'Unrestricted_Access);
   function Variable_Reference (This : Vector_3;
                                Axis : An_Axis)
                                return Reference_Type is
      (Value => This.V (Axis)'Unrestricted_Access);
end Vector_3s;

Tested on x86_64-pc-linux-gnu, committed on trunk

2015-11-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing): When constructing the
	parameter list for the potentially overloaded calls to indexing
	functions, do not propagate overloadings if the actual is a named
	association: overloadings appear directly on the expression in
	the association.
diff mbox

Patch

Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 230524)
+++ sem_ch4.adb	(working copy)
@@ -7437,7 +7437,14 @@ 
          Arg := First (Exprs);
          while Present (Arg) loop
             New_Arg := Relocate_Node (Arg);
-            Save_Interps (Arg, New_Arg);
+
+            --  The arguments can be parameter associations, in which case the
+            --  explicit actual parameter carries the overloadings.
+
+            if Nkind (New_Arg) /= N_Parameter_Association then
+               Save_Interps (Arg, New_Arg);
+            end if;
+
             Append (New_Arg, Assoc);
             Next (Arg);
          end loop;