diff options
Diffstat (limited to 'src/vhdl/sem_expr.adb')
| -rw-r--r-- | src/vhdl/sem_expr.adb | 137 |
1 files changed, 107 insertions, 30 deletions
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; |