synth: handle subtype conversions.

5 files changed, 154 insertions, 73 deletions

diff --git a/src/synth/synth-expr.adb b/src/synth/synth-expr.adb
index cda931798..c3f1f2589 100644
--- a/src/synth/synth-expr.adb
+++ b/src/synth/synth-expr.adb
@@ -705,41 +705,95 @@ package body Synth.Expr is
       return Res;
    end Create_Bounds_From_Length;
 
-   --  Implicit conversion of literals.
-   function Synth_Implicit_Conv (Syn_Inst : Synth_Instance_Acc;
-                                 Val : Value_Acc;
-                                 Vtype : Node;
-                                 Rtype : Node) return Value_Acc
+   function Synth_Subtype_Conversion
+     (Val : Value_Acc; Dtype : Type_Acc; Loc : Source.Syn_Src)
+     return Value_Acc
    is
-      Vtyp : Type_Acc;
-      Rtyp : Type_Acc;
+      Vtype : constant Type_Acc := Val.Typ;
    begin
-      if Rtype = Vtype or else Val.Kind /= Value_Discrete then
-         return Val;
-      end if;
-      if Vtype /= Vhdl.Std_Package.Convertible_Integer_Type_Definition then
-         raise Internal_Error;
-      end if;
-      Vtyp := Val.Typ;
-      Rtyp := Get_Value_Type (Syn_Inst, Rtype);
-      if Rtyp.Drange.W < Vtyp.Drange.W then
-         --  TODO: check bounds.
-         return Create_Value_Discrete (Val.Scal, Rtyp);
-      else
-         pragma Assert (Vtyp.Drange.W = Rtyp.Drange.W);
-         return Val;
-      end if;
-   end Synth_Implicit_Conv;
+      case Dtype.Kind is
+         when Type_Bit =>
+            pragma Assert (Vtype.Kind = Type_Bit);
+            return Val;
+         when Type_Discrete =>
+            pragma Assert (Vtype.Kind = Type_Discrete);
+            declare
+               Vrng : Discrete_Range_Type renames Vtype.Drange;
+               Drng : Discrete_Range_Type renames Dtype.Drange;
+               N : Net;
+            begin
+               if Vrng.W > Drng.W then
+                  --  Truncate.
+                  --  TODO: check overflow.
+                  case Val.Kind is
+                     when Value_Net
+                       | Value_Wire =>
+                        N := Get_Net (Val);
+                        N := Build_Trunc (Build_Context, Id_Utrunc, N, Drng.W);
+                        Set_Location (N, Loc);
+                        return Create_Value_Net (N, Dtype);
+                     when others =>
+                        raise Internal_Error;
+                  end case;
+               elsif Vrng.W < Drng.W then
+                  --  Extend.
+                  case Val.Kind is
+                     when Value_Discrete =>
+                        return Create_Value_Discrete (Val.Scal, Dtype);
+                     when Value_Net
+                       | Value_Wire =>
+                        N := Get_Net (Val);
+                        if Vrng.Is_Signed then
+                           N := Build_Extend
+                             (Build_Context, Id_Sextend, N, Drng.W);
+                        else
+                           N := Build_Extend
+                             (Build_Context, Id_Uextend, N, Drng.W);
+                        end if;
+                        Set_Location (N, Loc);
+                        return Create_Value_Net (N, Dtype);
+                     when others =>
+                        raise Internal_Error;
+                  end case;
+               else
+                  --  TODO: check overflow if sign differ.
+                  return Val;
+               end if;
+            end;
+         when Type_Float =>
+            pragma Assert (Vtype.Kind = Type_Float);
+            --  TODO: check range
+            return Val;
+         when Type_Vector =>
+            --  TODO: check width
+            return Val;
+         when Type_Array =>
+            --  TODO: check bounds, handle elements
+            return Val;
+         when Type_Unbounded_Array =>
+            pragma Assert (Vtype.Kind = Type_Vector
+                             or else Vtype.Kind = Type_Array);
+            return Val;
+         when Type_Record =>
+            --  TODO: handle elements.
+            return Val;
+      end case;
+   end Synth_Subtype_Conversion;
 
+   --  Implicit conversion of literals.
    function Synth_Dyadic_Operation (Syn_Inst : Synth_Instance_Acc;
-                                    Def : Iir_Predefined_Functions;
+                                    Imp : Node;
                                     Left_Expr : Node;
                                     Right_Expr : Node;
                                     Expr : Node) return Value_Acc
    is
+      Def : constant Iir_Predefined_Functions :=
+        Get_Implicit_Definition (Imp);
+      Inter_Chain : constant Node :=
+        Get_Interface_Declaration_Chain (Imp);
       Expr_Type : constant Node := Get_Type (Expr);
-      Ltype : constant Node := Get_Type (Left_Expr);
-      Rtype : constant Node := Get_Type (Right_Expr);
+      Left_Type : constant Node := Get_Type (Inter_Chain);
+      Right_Type : constant Node := Get_Type (Get_Chain (Inter_Chain));
       Left : Value_Acc;
       Right : Value_Acc;
 
@@ -768,7 +822,7 @@ package body Synth.Expr is
       is
          N : Net;
       begin
-         N := Synth_Uresize (Right, Rtype, Get_Width (Left));
+         N := Synth_Uresize (Right, Right_Type, Get_Width (Left));
          Set_Location (N, Expr);
          N := Build_Compare (Build_Context, Id, Get_Net (Left), N);
          Set_Location (N, Expr);
@@ -788,15 +842,10 @@ package body Synth.Expr is
       function Synth_Int_Dyadic (Id : Dyadic_Module_Id) return Value_Acc
       is
          Etype : constant Type_Acc := Get_Value_Type (Syn_Inst, Expr_Type);
-         L, R : Net;
          N : Net;
       begin
-         Left := Synth_Implicit_Conv (Syn_Inst, Left, Ltype, Expr_Type);
-         Right := Synth_Implicit_Conv (Syn_Inst, Right, Rtype, Expr_Type);
-
-         L := Synth_Resize (Left, Etype.Drange.W, Expr);
-         R := Synth_Resize (Right, Etype.Drange.W, Expr);
-         N := Build_Dyadic (Build_Context, Id, L, R);
+         N := Build_Dyadic
+           (Build_Context, Id, Get_Net (Left), Get_Net (Right));
          Set_Location (N, Expr);
          return Create_Value_Net (N, Etype);
       end Synth_Int_Dyadic;
@@ -849,15 +898,15 @@ package body Synth.Expr is
          R1 : Net;
          N : Net;
       begin
-         R1 := Synth_Uresize (Right, Rtype, Get_Width (Left));
+         R1 := Synth_Uresize (Right, Right_Type, Get_Width (Left));
          Set_Location (R1, Expr);
          N := Build_Dyadic (Build_Context, Id, L, R1);
          Set_Location (N, Expr);
          return Create_Value_Net (N, Create_Res_Bound (Left, L));
       end Synth_Dyadic_Uns_Nat;
    begin
-      Left := Synth_Expression (Syn_Inst, Left_Expr);
-      Right := Synth_Expression (Syn_Inst, Right_Expr);
+      Left := Synth_Expression_With_Type (Syn_Inst, Left_Expr, Left_Type);
+      Right := Synth_Expression_With_Type (Syn_Inst, Right_Expr, Right_Type);
 
       case Def is
          when Iir_Predefined_Error =>
@@ -892,8 +941,8 @@ package body Synth.Expr is
             return Synth_Vec_Dyadic (Id_Xor);
 
          when Iir_Predefined_Enum_Equality =>
-            if Is_Bit_Type (Ltype) then
-               pragma Assert (Is_Bit_Type (Rtype));
+            if Is_Bit_Type (Left_Type) then
+               pragma Assert (Is_Bit_Type (Right_Type));
                if Is_Const (Left) then
                   return Synth_Bit_Eq_Const (Left, Right, Expr);
                elsif Is_Const (Right) then
@@ -909,14 +958,14 @@ package body Synth.Expr is
 
          when Iir_Predefined_Array_Equality =>
             --  TODO: check size, handle non-vector.
-            if Is_Vector_Type (Ltype) then
+            if Is_Vector_Type (Left_Type) then
                return Synth_Compare (Id_Eq);
             else
                raise Internal_Error;
             end if;
          when Iir_Predefined_Array_Inequality =>
             --  TODO: check size, handle non-vector.
-            if Is_Vector_Type (Ltype) then
+            if Is_Vector_Type (Left_Type) then
                return Synth_Compare (Id_Ne);
             else
                raise Internal_Error;
@@ -924,7 +973,7 @@ package body Synth.Expr is
          when Iir_Predefined_Array_Greater =>
             --  TODO: check size, non-vector.
             --  TODO: that's certainly not the correct operator.
-            if Is_Vector_Type (Ltype) then
+            if Is_Vector_Type (Left_Type) then
                return Synth_Compare (Id_Ugt);
             else
                raise Internal_Error;
@@ -1979,7 +2028,9 @@ package body Synth.Expr is
 
    function Synth_Expression_With_Type
      (Syn_Inst : Synth_Instance_Acc; Expr : Node; Expr_Type : Node)
-     return Value_Acc is
+     return Value_Acc
+   is
+      Res : Value_Acc;
    begin
       case Get_Kind (Expr) is
          when Iir_Kinds_Dyadic_Operator =>
@@ -2002,7 +2053,7 @@ package body Synth.Expr is
                  or else Def in Iir_Predefined_IEEE_Explicit
                then
                   return Synth_Dyadic_Operation
-                    (Syn_Inst, Def, Get_Left (Expr), Get_Right (Expr), Expr);
+                    (Syn_Inst, Imp, Get_Left (Expr), Get_Right (Expr), Expr);
                else
                   Error_Unknown_Operator (Imp, Expr);
                   raise Internal_Error;
@@ -2026,7 +2077,9 @@ package body Synth.Expr is
             end;
          when Iir_Kind_Simple_Name
            | Iir_Kind_Interface_Signal_Declaration =>  -- For PSL...
-            return Synth_Name (Syn_Inst, Expr);
+            Res := Synth_Name (Syn_Inst, Expr);
+            return Synth_Subtype_Conversion
+              (Res, Get_Value_Type (Syn_Inst, Expr_Type), Expr);
          when Iir_Kind_Reference_Name =>
             return Synth_Name (Syn_Inst, Get_Named_Entity (Expr));
          when Iir_Kind_Indexed_Name =>
diff --git a/src/synth/synth-expr.ads b/src/synth/synth-expr.ads
index f7edc2417..be6daba0d 100644
--- a/src/synth/synth-expr.ads
+++ b/src/synth/synth-expr.ads
@@ -21,6 +21,7 @@
 with Ada.Unchecked_Deallocation;
 with Types; use Types;
 with Netlists; use Netlists;
+with Synth.Source;
 with Synth.Values; use Synth.Values;
 with Synth.Context; use Synth.Context;
 with Vhdl.Nodes; use Vhdl.Nodes;
@@ -32,6 +33,10 @@ package Synth.Expr is
    procedure Set_Location (N : Net; Loc : Node);
    pragma Inline (Set_Location);
 
+   function Synth_Subtype_Conversion
+     (Val : Value_Acc; Dtype : Type_Acc; Loc : Source.Syn_Src)
+     return Value_Acc;
+
    procedure From_Std_Logic (Enum : Int64; Val : out Uns32; Zx : out Uns32);
    procedure From_Bit (Enum : Int64; Val : out Uns32);
    procedure To_Logic
diff --git a/src/synth/synth-insts.adb b/src/synth/synth-insts.adb
index 721671e1e..74d0673f5 100644
--- a/src/synth/synth-insts.adb
+++ b/src/synth/synth-insts.adb
@@ -307,7 +307,7 @@ package body Synth.Insts is
                Port := Builders.Build_Port (Build_Context, Port);
                O := Create_Value_Net
                  (Port, Get_Value_Type (Inst_Obj.Syn_Inst, Get_Type (Inter)));
-               Synth_Assignment (Syn_Inst, Actual, O);
+               Synth_Assignment (Syn_Inst, Actual, O, Assoc);
                Nbr_Outputs := Nbr_Outputs + 1;
          end case;
          Next_Association_Interface (Assoc, Assoc_Inter);
@@ -577,8 +577,9 @@ package body Synth.Insts is
                  | Port_Inout =>
                   Port := Get_Output (Inst, Nbr_Outputs);
                   Port := Builders.Build_Port (Build_Context, Port);
-                  O := Create_Value_Net (Port, null);
-                  Synth_Assignment (Syn_Inst, Actual, O);
+                  O := Create_Value_Net
+                    (Port, Get_Value_Type (Syn_Inst, Get_Type (Inter)));
+                  Synth_Assignment (Syn_Inst, Actual, O, Assoc);
                   Nbr_Outputs := Nbr_Outputs + 1;
             end case;
             Next_Association_Interface (Assoc, Assoc_Inter);
diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-stmts.adb
index 8facedb95..f3623960a 100644
--- a/src/synth/synth-stmts.adb
+++ b/src/synth/synth-stmts.adb
@@ -41,6 +41,7 @@ with Synth.Decls; use Synth.Decls;
 with Synth.Expr; use Synth.Expr;
 with Synth.Environment; use Synth.Environment;
 with Synth.Insts; use Synth.Insts;
+with Synth.Source;
 
 with Vhdl.Annotations; use Vhdl.Annotations;
 
@@ -65,19 +66,27 @@ package body Synth.Stmts is
          --  Warning
          null;
       end if;
-      return Synth_Expression_With_Type
-        (Syn_Inst, Get_We_Value (Wf), Targ_Type);
+      if Targ_Type = Null_Node then
+         return Synth_Expression (Syn_Inst, Get_We_Value (Wf));
+      else
+         return Synth_Expression_With_Type
+           (Syn_Inst, Get_We_Value (Wf), Targ_Type);
+      end if;
    end Synth_Waveform;
 
-   procedure Synth_Assign (Dest : Value_Acc; Val : Value_Acc) is
+   procedure Synth_Assign
+     (Dest : Value_Acc; Val : Value_Acc; Loc : Source.Syn_Src) is
    begin
       pragma Assert (Dest.Kind = Value_Wire);
-      Phi_Assign (Dest.W, Get_Net (Val));
+      Phi_Assign
+        (Dest.W,
+         Get_Net (Synth_Subtype_Conversion (Val, Dest.Typ, Loc)));
    end Synth_Assign;
 
    procedure Synth_Assignment_Aggregate (Syn_Inst : Synth_Instance_Acc;
                                          Target : Node;
-                                         Val : Value_Acc)
+                                         Val : Value_Acc;
+                                         Loc : Node)
    is
       Targ_Type : constant Node := Get_Type (Target);
       Bnd : Bound_Type;
@@ -95,7 +104,7 @@ package body Synth.Stmts is
                when Iir_Kind_Choice_By_None =>
                   Pos := Pos - 1;
                   Synth_Assignment
-                    (Syn_Inst, Assoc, Bit_Extract (Val, Pos, Target));
+                    (Syn_Inst, Assoc, Bit_Extract (Val, Pos, Target), Loc);
                when others =>
                   Error_Kind ("synth_assignment_aggregate", Choice);
             end case;
@@ -106,8 +115,10 @@ package body Synth.Stmts is
       end if;
    end Synth_Assignment_Aggregate;
 
-   procedure Synth_Indexed_Assignment
-     (Syn_Inst : Synth_Instance_Acc; Target : Node; Val : Value_Acc)
+   procedure Synth_Indexed_Assignment (Syn_Inst : Synth_Instance_Acc;
+                                       Target : Node;
+                                       Val : Value_Acc;
+                                       Loc : Node)
    is
       Pfx : constant Node := Get_Prefix (Target);
       Targ : constant Value_Acc := Get_Value (Syn_Inst, Get_Base_Name (Pfx));
@@ -136,24 +147,26 @@ package body Synth.Stmts is
            (Build_Context, Targ_Net, Val_Net, Voff, Mul, Int32 (Off));
          Set_Location (V, Target);
       end if;
-      Synth_Assign (Targ, Create_Value_Net (V, Targ.Typ));
+      Synth_Assign (Targ, Create_Value_Net (V, Targ.Typ), Loc);
    end Synth_Indexed_Assignment;
 
-   procedure Synth_Assignment
-     (Syn_Inst : Synth_Instance_Acc; Target : Node; Val : Value_Acc) is
+   procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc;
+                               Target : Node;
+                               Val : Value_Acc;
+                               Loc : Node) is
    begin
       case Get_Kind (Target) is
          when Iir_Kind_Simple_Name =>
-            Synth_Assignment (Syn_Inst, Get_Named_Entity (Target), Val);
+            Synth_Assignment (Syn_Inst, Get_Named_Entity (Target), Val, Loc);
          when Iir_Kind_Interface_Signal_Declaration
            | Iir_Kind_Variable_Declaration
            | Iir_Kind_Signal_Declaration
            | Iir_Kind_Anonymous_Signal_Declaration =>
-            Synth_Assign (Get_Value (Syn_Inst, Target), Val);
+            Synth_Assign (Get_Value (Syn_Inst, Target), Val, Loc);
          when Iir_Kind_Aggregate =>
-            Synth_Assignment_Aggregate (Syn_Inst, Target, Val);
+            Synth_Assignment_Aggregate (Syn_Inst, Target, Val, Loc);
          when Iir_Kind_Indexed_Name =>
-            Synth_Indexed_Assignment (Syn_Inst, Target, Val);
+            Synth_Indexed_Assignment (Syn_Inst, Target, Val, Loc);
          when Iir_Kind_Slice_Name =>
             declare
                Pfx : constant Node := Get_Prefix (Target);
@@ -186,7 +199,7 @@ package body Synth.Stmts is
                end if;
                Set_Location (Res, Target);
                Res_Type := Create_Vector_Type (Res_Bnd, Targ.Typ.Vec_El);
-               Synth_Assign (Targ, Create_Value_Net (Res, Res_Type));
+               Synth_Assign (Targ, Create_Value_Net (Res, Res_Type), Loc);
             end;
          when others =>
             Error_Kind ("synth_assignment", Target);
@@ -198,11 +211,17 @@ package body Synth.Stmts is
      (Syn_Inst : Synth_Instance_Acc; Stmt : Node)
    is
       Target : constant Node := Get_Target (Stmt);
+      Wf_Type : Node;
       Val : Value_Acc;
    begin
-      Val := Synth_Waveform
-        (Syn_Inst, Get_Waveform_Chain (Stmt), Get_Type (Target));
-      Synth_Assignment (Syn_Inst, Target, Val);
+      --  FIXME: correctly handle target type when it is a slice.
+      if Get_Kind (Target) = Iir_Kind_Slice_Name then
+         Wf_Type := Null_Node;
+      else
+         Wf_Type := Get_Type (Target);
+      end if;
+      Val := Synth_Waveform (Syn_Inst, Get_Waveform_Chain (Stmt), Wf_Type);
+      Synth_Assignment (Syn_Inst, Target, Val, Stmt);
    end Synth_Simple_Signal_Assignment;
 
    procedure Synth_Conditional_Signal_Assignment
@@ -233,7 +252,7 @@ package body Synth.Stmts is
          Last := Val;
          Cwf := Get_Chain (Cwf);
       end loop;
-      Synth_Assignment (Syn_Inst, Target, First);
+      Synth_Assignment (Syn_Inst, Target, First, Stmt);
    end Synth_Conditional_Signal_Assignment;
 
    procedure Synth_Variable_Assignment
@@ -244,7 +263,7 @@ package body Synth.Stmts is
    begin
       Val := Synth_Expression_With_Type
         (Syn_Inst, Get_Expression (Stmt), Get_Type (Target));
-      Synth_Assignment (Syn_Inst, Target, Val);
+      Synth_Assignment (Syn_Inst, Target, Val, Stmt);
    end Synth_Variable_Assignment;
 
    procedure Synth_If_Statement
@@ -895,8 +914,10 @@ package body Synth.Stmts is
 
          --  Generate the muxes tree.
          Synth_Case (Sel_Net, Case_El.all, Default, Res);
-         Synth_Assignment (Syn_Inst, Get_Target (Stmt),
-                           Create_Value_Net (Res, null));
+         Synth_Assignment
+           (Syn_Inst, Get_Target (Stmt),
+            Create_Value_Net (Res, Get_Value_Type (Syn_Inst, Targ_Type)),
+            Stmt);
       end;
 
       --  free.
@@ -977,7 +998,7 @@ package body Synth.Stmts is
          if Get_Mode (Inter) = Iir_Out_Mode then
             Val := Synth_Expression_With_Type
               (Subprg_Inst, Inter, Get_Type (Inter));
-            Synth_Assignment (Caller_Inst, Get_Actual (Assoc), Val);
+            Synth_Assignment (Caller_Inst, Get_Actual (Assoc), Val, Assoc);
 
          end if;
 
diff --git a/src/synth/synth-stmts.ads b/src/synth/synth-stmts.ads
index 296e639e4..85f3eaa9f 100644
--- a/src/synth/synth-stmts.ads
+++ b/src/synth/synth-stmts.ads
@@ -31,7 +31,8 @@ package Synth.Stmts is
 
    procedure Synth_Assignment (Syn_Inst : Synth_Instance_Acc;
                                Target : Node;
-                               Val : Value_Acc);
+                               Val : Value_Acc;
+                               Loc : Node);
 
    procedure Synth_Sequential_Statements
      (Syn_Inst : Synth_Instance_Acc; Stmts : Node);