Display aggregates with initial choice order.

2 files changed, 180 insertions, 63 deletions

diff --git a/src/vhdl/disp_vhdl.adb b/src/vhdl/disp_vhdl.adb
index e675e718c..37e6f21c6 100644
--- a/src/vhdl/disp_vhdl.adb
+++ b/src/vhdl/disp_vhdl.adb
@@ -2547,23 +2547,26 @@ package body Disp_Vhdl is
       Put (")");
    end Disp_Indexed_Name;
 
+   procedure Disp_A_Choice (Choice : Iir) is
+   begin
+      case Iir_Kinds_Choice (Get_Kind (Choice)) is
+         when Iir_Kind_Choice_By_Others =>
+            Put ("others");
+         when Iir_Kind_Choice_By_None =>
+            null;
+         when Iir_Kind_Choice_By_Expression =>
+            Disp_Expression (Get_Choice_Expression (Choice));
+         when Iir_Kind_Choice_By_Range =>
+            Disp_Range (Get_Choice_Range (Choice));
+         when Iir_Kind_Choice_By_Name =>
+            Disp_Name_Of (Get_Choice_Name (Choice));
+      end case;
+   end Disp_A_Choice;
+
    procedure Disp_Choice (Choice: in out Iir) is
    begin
       loop
-         case Get_Kind (Choice) is
-            when Iir_Kind_Choice_By_Others =>
-               Put ("others");
-            when Iir_Kind_Choice_By_None =>
-               null;
-            when Iir_Kind_Choice_By_Expression =>
-               Disp_Expression (Get_Choice_Expression (Choice));
-            when Iir_Kind_Choice_By_Range =>
-               Disp_Range (Get_Choice_Range (Choice));
-            when Iir_Kind_Choice_By_Name =>
-               Disp_Name_Of (Get_Choice_Name (Choice));
-            when others =>
-               Error_Kind ("disp_choice", Choice);
-         end case;
+         Disp_A_Choice (Choice);
          Choice := Get_Chain (Choice);
          exit when Choice = Null_Iir;
          exit when Get_Same_Alternative_Flag (Choice) = False;
@@ -2572,13 +2575,37 @@ package body Disp_Vhdl is
       end loop;
    end Disp_Choice;
 
+   --  Build an array of lexical appareance of choices in CHAIN.
+   --  (They have been re-ordered during analysis).
+   procedure Build_Choice_Order (Chain : Iir; Arr : out Iir_Array_Acc)
+   is
+      Count : Natural;
+      Assoc : Iir;
+   begin
+      Assoc := Chain;
+      Count := 0;
+      while Assoc /= Null_Iir loop
+         Count := Count + 1;
+         Assoc := Get_Chain (Assoc);
+      end loop;
+      Arr := new Iir_Array (0 .. Count - 1);
+
+      Assoc := Chain;
+      while Assoc /= Null_Iir loop
+         Arr (Natural (Get_Choice_Position (Assoc))) := Assoc;
+         Assoc := Get_Chain (Assoc);
+      end loop;
+   end Build_Choice_Order;
+
    --  EL_TYPE is Null_Iir for record aggregates.
    procedure Disp_Aggregate_1
      (Aggr: Iir_Aggregate; Index : Positive; El_Type : Iir)
    is
-      Indent: Count;
-      Assoc: Iir;
+      Indent : Count;
+      Assoc : Iir;
       Expr : Iir;
+      Prev_Expr : Iir;
+      Choices : Iir_Array_Acc;
    begin
       Indent := Col + 1;
       if Indent > Line_Length - 10 then
@@ -2586,31 +2613,44 @@ package body Disp_Vhdl is
       end if;
       Put ("(");
       Assoc := Get_Association_Choices_Chain (Aggr);
-      loop
+      Build_Choice_Order (Assoc, Choices);
+      Prev_Expr := Null_Iir;
+      for I in Choices'Range loop
+         Assoc := Choices (I);
          Expr := Get_Associated_Expr (Assoc);
-         if Get_Kind (Assoc) /= Iir_Kind_Choice_By_None then
-            Disp_Choice (Assoc);
-            Put (" => ");
-         else
-            Assoc := Get_Chain (Assoc);
+         pragma Assert (Expr /= Null_Iir);
+         if Expr = Prev_Expr then
+            Put (" | ");
+         elsif I /= Choices'First then
+            Put (", ");
          end if;
-         if Index > 1 then
-            Set_Col (Indent);
-            if Get_Kind (Expr) = Iir_Kind_String_Literal8 then
-               Disp_String_Literal (Expr, El_Type);
-            else
-               Disp_Aggregate_1 (Expr, Index - 1, El_Type);
+         Disp_A_Choice (Assoc);
+         if I = Choices'Last
+           or else Expr /= Get_Associated_Expr (Choices (I + 1))
+         then
+            if Get_Kind (Assoc) /= Iir_Kind_Choice_By_None then
+               Put (" => ");
             end if;
-         else
-            if Get_Kind (Expr) = Iir_Kind_Aggregate then
+
+            if Index > 1 then
                Set_Col (Indent);
+               if Get_Kind (Expr) = Iir_Kind_String_Literal8 then
+                  Disp_String_Literal (Expr, El_Type);
+               else
+                  Disp_Aggregate_1 (Expr, Index - 1, El_Type);
+               end if;
+            else
+               if Get_Kind (Expr) = Iir_Kind_Aggregate then
+                  Set_Col (Indent);
+               end if;
+               Disp_Expression (Expr);
             end if;
-            Disp_Expression (Expr);
          end if;
-         exit when Assoc = Null_Iir;
-         Put (", ");
+         Prev_Expr := Expr;
       end loop;
       Put (")");
+
+      Free (Choices);
    end Disp_Aggregate_1;
 
    procedure Disp_Aggregate (Aggr: Iir_Aggregate)
diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb
index 9a0aded79..1fc98c592 100644
--- a/src/vhdl/sem_expr.adb
+++ b/src/vhdl/sem_expr.adb
@@ -2571,9 +2571,11 @@ package body Sem_Expr is
                Pos := Pos_Max + 1;
                exit;
             end if;
-            if Pos < E_Pos and then Info.Others_Choice = Null_Iir then
-               Error_No_Choice
-                 (Bt, Pos, E_Pos - 1, Get_Location (Info.Arr (I)));
+            if Pos < E_Pos then
+               if Info.Others_Choice = Null_Iir then
+                  Error_No_Choice
+                    (Bt, Pos, E_Pos - 1, Get_Location (Info.Arr (I)));
+               end if;
             elsif Pos > E_Pos then
                if Pos = E_Pos + 1 then
                   Error_Msg_Sem
@@ -2588,35 +2590,102 @@ package body Sem_Expr is
             end if;
             Pos := Eval_Pos (Get_Assoc_High (Info.Arr (I))) + 1;
          end loop;
-         if Pos /= Pos_Max + 1 and then Info.Others_Choice = Null_Iir then
-            Error_No_Choice (Bt, Pos, Pos_Max, Loc);
+         if Pos /= Pos_Max + 1 then
+            if Info.Others_Choice = Null_Iir then
+               Error_No_Choice (Bt, Pos, Pos_Max, Loc);
+            end if;
          end if;
       end;
 
       if Reorder_Choices then
-         --  First, set Associated_Expr and Associated_Chain for nodes with
-         --  the same alternative.
          declare
-            Assoc_Expr : Iir;
-            Assoc_Chain : Iir;
-            Assoc : Iir;
+            Ngroups : Int32;
          begin
-            Assoc := Choice_Chain;
-            Choice_Chain := Assoc; -- For the warning.
-            Assoc_Expr := Null_Iir;
-            Assoc_Chain := Null_Iir;
-            while Assoc /= Null_Iir loop
-               if Get_Same_Alternative_Flag (Assoc) then
-                  Set_Is_Ref (Assoc, True);
-                  Set_Associated_Expr (Assoc, Assoc_Expr);
-                  Set_Associated_Chain (Assoc, Assoc_Chain);
-               else
-                  Set_Is_Ref (Assoc, False);
-                  Assoc_Expr := Get_Associated_Expr (Assoc);
-                  Assoc_Chain := Get_Associated_Chain (Assoc);
+
+            --  First, set Associated_Expr and Associated_Chain for nodes with
+            --  the same alternative.
+            declare
+               Assoc_Expr : Iir;
+               Assoc_Chain : Iir;
+               Assoc : Iir;
+            begin
+               Assoc := Choice_Chain;
+               Assoc_Expr := Null_Iir;
+               Assoc_Chain := Null_Iir;
+               Ngroups := 0;
+               while Assoc /= Null_Iir loop
+                  if Get_Same_Alternative_Flag (Assoc) then
+                     Set_Is_Ref (Assoc, True);
+                     Set_Associated_Expr (Assoc, Assoc_Expr);
+                     Set_Associated_Chain (Assoc, Assoc_Chain);
+                     Set_Same_Alternative_Flag (Assoc, False);
+                  else
+                     Set_Is_Ref (Assoc, False);
+                     Assoc_Expr := Get_Associated_Expr (Assoc);
+                     Assoc_Chain := Get_Associated_Chain (Assoc);
+                     Ngroups := Ngroups + 1;
+                  end if;
+
+                  --  The choice position is now a group id.
+                  Set_Choice_Position (Assoc, Ngroups);
+                  Assoc := Get_Chain (Assoc);
+               end loop;
+            end;
+
+            --  Then set Is_Ref on the first alternative.
+            declare
+               type Group_Array is array (1 .. Ngroups) of Boolean;
+               type Group_Acc is access Group_Array;
+               procedure Free is new Ada.Unchecked_Deallocation
+                 (Group_Array, Group_Acc);
+               Groups : Group_Acc;
+               Gid : Int32;
+               Pos : Int32;
+               Assoc : Iir;
+            begin
+               Groups := new Group_Array'(others => False);
+               for I in Info.Arr'Range loop
+                  Gid := Get_Choice_Position (Info.Arr (I));
+                  if Groups (Gid) then
+                     --  Already handled.
+                     Set_Is_Ref (Info.Arr (I), True);
+                  else
+                     Groups (Gid) := True;
+                     Set_Is_Ref (Info.Arr (I), False);
+                  end if;
+               end loop;
+
+               Free (Groups);
+
+               --  Restore Choice_Position.
+               Assoc := Choice_Chain;
+               Pos := 0;
+               while Assoc /= Null_Iir loop
+                  Set_Choice_Position (Assoc, Pos);
+                  Pos := Pos + 1;
+                  Assoc := Get_Chain (Assoc);
+               end loop;
+            end;
+
+            --  Then reorder.
+            declare
+               Assoc : Iir;
+               Assoc1 : Iir;
+            begin
+               Choice_Chain := Info.Arr (Info.Arr'First);
+               Assoc := Choice_Chain;
+               for I in Info.Arr'First + 1 .. Info.Arr'Last loop
+                  Assoc1 := Info.Arr (I);
+                  Set_Chain (Assoc, Assoc1);
+                  Assoc := Assoc1;
+               end loop;
+               Assoc1 := Info.Others_Choice;
+               if Assoc1 /= Null_Iir then
+                  Set_Chain (Assoc, Assoc1);
+                  Assoc := Assoc1;
                end if;
-               Assoc := Get_Chain (Assoc);
-            end loop;
+               Set_Chain (Assoc, Null_Iir);
+            end;
          end;
       end if;
 
@@ -2924,6 +2993,7 @@ package body Sem_Expr is
          Set_Named_Entity (Expr, Aggr_El);
          Xref_Ref (Expr, Aggr_El);
 
+         --  Was a choice_by_expression, now by_name.
          N_El := Create_Iir (Iir_Kind_Choice_By_Name);
          Location_Copy (N_El, Ass);
          Set_Choice_Name (N_El, Expr);
@@ -2931,6 +3001,7 @@ package body Sem_Expr is
          Set_Associated_Chain (N_El, Get_Associated_Chain (Ass));
          Set_Chain (N_El, Get_Chain (Ass));
          Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass));
+         Set_Choice_Position (N_El, Get_Choice_Position (Ass));
 
          Free_Iir (Ass);
          Add_Match (N_El, Aggr_El);
@@ -2962,7 +3033,8 @@ package body Sem_Expr is
 
          --  If there is an associated expression with the choice, then the
          --  choice is a new alternative, and has no expected type.
-         if Expr /= Null_Iir then
+         if not Get_Same_Alternative_Flag (El) then
+            pragma Assert (Expr /= Null_Iir);
             El_Type := Null_Iir;
          end if;
 
@@ -3014,7 +3086,7 @@ package body Sem_Expr is
          end case;
 
          --  Analyze the expression associated.
-         if Expr /= Null_Iir then
+         if not Get_Same_Alternative_Flag (El) then
             if El_Type /= Null_Iir then
                Expr := Sem_Expression (Expr, El_Type);
                if Expr /= Null_Iir then
@@ -3026,10 +3098,15 @@ package body Sem_Expr is
                end if;
             else
                --  This case is not possible unless there is an error.
-               if Ok then
-                  raise Internal_Error;
-               end if;
+               pragma Assert (not Ok);
+               null;
             end if;
+         else
+            --  Always set associated expression.
+            pragma Assert (Expr = Null_Iir);
+            pragma Assert (Prev_El /= Null_Iir);
+            Set_Associated_Expr (El, Get_Associated_Expr (Prev_El));
+            Set_Is_Ref (El, True);
          end if;
 
          Prev_El := El;