Add an analysis time check for bounds on port association.

Fix issue #148

8 files changed, 133 insertions, 6 deletions

diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads
index bdc67226a..4b1ed23ee 100644
--- a/src/vhdl/errorout.ads
+++ b/src/vhdl/errorout.ads
@@ -80,6 +80,10 @@ package Errorout is
       --  Incorrect use of universal value.
       Warnid_Universal,
 
+      --  Mismatch of bounds between actual and formal in a scalar port
+      --  association
+      Warnid_Port_Bounds,
+
       --  Runtime error detected at analysis time.
       Warnid_Runtime_Error,
 
diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb
index f774208b2..e681ee651 100644
--- a/src/vhdl/evaluation.adb
+++ b/src/vhdl/evaluation.adb
@@ -2873,6 +2873,26 @@ package body Evaluation is
       return Get_Left_Limit (Range_Expr);
    end Eval_Discrete_Range_Left;
 
+   function Eval_Is_Eq (L, R : Iir) return Boolean
+   is
+      Expr_Type : constant Iir := Get_Type (L);
+   begin
+      case Get_Kind (Expr_Type) is
+         when Iir_Kind_Integer_Subtype_Definition
+           | Iir_Kind_Integer_Type_Definition
+           | Iir_Kind_Physical_Subtype_Definition
+           | Iir_Kind_Physical_Type_Definition
+           | Iir_Kind_Enumeration_Subtype_Definition
+           | Iir_Kind_Enumeration_Type_Definition =>
+            return Eval_Pos (L) = Eval_Pos (R);
+         when Iir_Kind_Floating_Subtype_Definition
+           | Iir_Kind_Floating_Type_Definition =>
+            return Get_Fp_Value (L) = Get_Fp_Value (R);
+         when others =>
+            Error_Kind ("eval_is_eq", Expr_Type);
+      end case;
+   end Eval_Is_Eq;
+
    procedure Eval_Operator_Symbol_Name (Id : Name_Id)
    is
    begin
diff --git a/src/vhdl/evaluation.ads b/src/vhdl/evaluation.ads
index 256d687bf..4d2bb218f 100644
--- a/src/vhdl/evaluation.ads
+++ b/src/vhdl/evaluation.ads
@@ -123,6 +123,9 @@ package Evaluation is
    --  EXPR must be of a discrete subtype.
    function Eval_Pos (Expr : Iir) return Iir_Int64;
 
+   --  Return True iff L and R (scalar literals) are equal.
+   function Eval_Is_Eq (L, R : Iir) return Boolean;
+
    --  Replace ORIGIN (an overflow literal) with extreme positive value (if
    --  IS_POS is true) or extreme negative value.
    function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir;
diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads
index 8b3904e3a..c93fad0c7 100644
--- a/src/vhdl/iirs.ads
+++ b/src/vhdl/iirs.ads
@@ -408,7 +408,7 @@ package Iirs is
    -- Only for Iir_Kind_Association_Element_By_Individual:
    --   Get/Set_Individual_Association_Chain (Field4)
    --
-   --  A function call or a type conversion for the association.
+   --  A function call or a type conversion for the actual.
    --  FIXME: should be a name ?
    -- Only for Iir_Kind_Association_Element_By_Expression:
    --   Get/Set_In_Conversion (Field4)
@@ -419,6 +419,7 @@ package Iirs is
    -- Only for Iir_Kind_Association_Element_By_Individual:
    --   Get/Set_Actual_Type (Field5)
    --
+   --  A function call or a type conversion for the formal.
    -- Only for Iir_Kind_Association_Element_By_Expression:
    --   Get/Set_Out_Conversion (Field5)
    --
diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb
index 8de3f149c..90cdc3179 100644
--- a/src/vhdl/sem.adb
+++ b/src/vhdl/sem.adb
@@ -555,13 +555,15 @@ package body Sem is
                   if Get_Name_Staticness (Object) < Globally then
                      Error_Msg_Sem (+Actual, "actual must be a static name");
                   end if;
+                  Check_Port_Association_Bounds_Restrictions
+                    (Formal, Actual, El);
                   if Get_Kind (Prefix) = Iir_Kind_Interface_Signal_Declaration
                   then
                      declare
                         P : Boolean;
                         pragma Unreferenced (P);
                      begin
-                        P := Check_Port_Association_Restriction
+                        P := Check_Port_Association_Mode_Restrictions
                           (Formal_Base, Prefix, El);
                      end;
                   end if;
diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb
index 3ae609ac1..a56840df0 100644
--- a/src/vhdl/sem_assocs.adb
+++ b/src/vhdl/sem_assocs.adb
@@ -397,7 +397,7 @@ package body Sem_Assocs is
 
    --  Check for restrictions in LRM 1.1.1.2
    --  Return FALSE in case of error.
-   function Check_Port_Association_Restriction
+   function Check_Port_Association_Mode_Restrictions
      (Formal : Iir_Interface_Signal_Declaration;
       Actual : Iir_Interface_Signal_Declaration;
       Assoc : Iir)
@@ -426,7 +426,97 @@ package body Sem_Assocs is
               & Get_Mode_Name (Amode), +Formal);
       end if;
       return False;
-   end Check_Port_Association_Restriction;
+   end Check_Port_Association_Mode_Restrictions;
+
+   --  Check restrictions of LRM02 12.2.4
+   procedure Check_Port_Association_Bounds_Restrictions
+     (Formal : Iir; Actual : Iir; Assoc : Iir)
+   is
+      function Is_Scalar_Type_Compatible (Src : Iir; Dest : Iir)
+                                         return Boolean
+      is
+         Src_Range : Iir;
+         Dst_Range : Iir;
+      begin
+         if Get_Kind (Src) not in Iir_Kinds_Scalar_Type_Definition then
+            return True;
+         end if;
+
+         Src_Range := Get_Range_Constraint (Src);
+         Dst_Range := Get_Range_Constraint (Dest);
+         if Get_Expr_Staticness (Src_Range) /= Locally
+           or else Get_Expr_Staticness (Dst_Range) /= Locally
+         then
+            return True;
+         end if;
+
+         --  FIXME: non-static bounds have to be checked at run-time
+         --  (during elaboration).
+         if not Eval_Is_Eq (Get_Left_Limit (Src_Range),
+                            Get_Left_Limit (Dst_Range))
+           or else not Eval_Is_Eq (Get_Right_Limit (Src_Range),
+                                      Get_Right_Limit (Dst_Range))
+           or else Get_Direction (Src_Range) /= Get_Direction (Dst_Range)
+         then
+            return False;
+         end if;
+
+         return True;
+      end Is_Scalar_Type_Compatible;
+
+      Inter : constant Iir := Get_Object_Prefix (Formal, False);
+      Ftype : constant Iir := Get_Type (Formal);
+      Atype : constant Iir := Get_Type (Actual);
+      F_Conv : constant Iir := Get_Out_Conversion (Assoc);
+      A_Conv : constant Iir := Get_In_Conversion (Assoc);
+      F2a_Type : Iir;
+      A2f_Type : Iir;
+   begin
+      --  LRM02 12.2.4 The port map aspect
+      --  If an actual signal is associated with a port of any mode, and if
+      --  the type of the formal is a scalar type, then it is an error if
+      --  (after applying any conversion function or type conversion
+      --  expression present in the actual part) the bounds and direction of
+      --  the subtype denoted by the subtype indication of the formal are not
+      --  identical to the bounds and direction of the subtype denoted by the
+      --  subtype indication of the actual.
+      if Is_Valid (F_Conv) then
+         F2a_Type := Get_Type (F_Conv);
+      else
+         F2a_Type := Ftype;
+      end if;
+      if Is_Valid (A_Conv) then
+         A2f_Type := Get_Type (A_Conv);
+      else
+         A2f_Type := Atype;
+      end if;
+      if Get_Mode (Inter) in Iir_In_Modes
+        and then not Is_Scalar_Type_Compatible (A2f_Type, Ftype)
+      then
+         if Flag_Elaborate then
+            Error_Msg_Elab
+              (Assoc,
+               "bounds or direction of formal and actual mismatch");
+         else
+            Warning_Msg_Sem
+              (Warnid_Port_Bounds, +Assoc,
+               "bounds or direction of formal and actual mismatch");
+         end if;
+      end if;
+      if Get_Mode (Inter) in Iir_Out_Modes
+        and then not Is_Scalar_Type_Compatible (F2a_Type, Atype)
+      then
+         if Flag_Elaborate then
+            Error_Msg_Elab
+              (Assoc,
+               "bounds or direction of formal and actual mismatch");
+         else
+            Warning_Msg_Sem
+              (Warnid_Port_Bounds, +Assoc,
+               "bounds or direction of formal and actual mismatch");
+         end if;
+      end if;
+   end Check_Port_Association_Bounds_Restrictions;
 
    --  Handle indexed name
    --  FORMAL is the formal name to be handled.
diff --git a/src/vhdl/sem_assocs.ads b/src/vhdl/sem_assocs.ads
index e40258915..9563138ce 100644
--- a/src/vhdl/sem_assocs.ads
+++ b/src/vhdl/sem_assocs.ads
@@ -55,9 +55,14 @@ package Sem_Assocs is
 
    --  Check for restrictions in LRM93 1.1.1.2
    --  Return FALSE in case of error.
-   function Check_Port_Association_Restriction
+   function Check_Port_Association_Mode_Restrictions
      (Formal : Iir_Interface_Signal_Declaration;
       Actual : Iir_Interface_Signal_Declaration;
       Assoc : Iir)
      return Boolean;
+
+   --  Check restrictions of LRM02 12.2.4
+   procedure Check_Port_Association_Bounds_Restrictions
+     (Formal : Iir; Actual : Iir; Assoc : Iir);
+
 end Sem_Assocs;
diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb
index 3cc08d03c..03a95ccad 100644
--- a/src/vhdl/sem_specs.adb
+++ b/src/vhdl/sem_specs.adb
@@ -1608,7 +1608,7 @@ package body Sem_Specs is
                   (+Ent_El, +Ent_El));
                Error := True;
             elsif Kind = Map_Port
-              and then not Check_Port_Association_Restriction
+              and then not Check_Port_Association_Mode_Restrictions
               (Ent_El, Comp_El, Null_Iir)
             then
                if not Error then
@@ -1627,6 +1627,8 @@ package body Sem_Specs is
             Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression);
             Location_Copy (Assoc, Parent);
             Set_Actual (Assoc, Comp_El);
+            Check_Port_Association_Bounds_Restrictions
+              (Ent_El, Comp_El, Assoc);
             Found := Found + 1;
          end if;
          Set_Whole_Association_Flag (Assoc, True);