vhdl/translate/trans_analyzes.adb

--  Analysis for translation.
--  Copyright (C) 2009 Tristan Gingold
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.

with Errorout;
with Simple_IO;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk;
with Vhdl.Prints;
with Vhdl.Errors; use Vhdl.Errors;

package body Trans_Analyzes is
   Driver_List : Iir_List;

   Has_After : Boolean;

   function Extract_Driver_Target (Target : Iir) return Walk_Status
   is
      Base : Iir;
      Prefix : Iir;
   begin
      Base := Get_Object_Prefix (Target);
      --  Assigment to subprogram interface does not create a driver.
      if Get_Kind (Base) = Iir_Kind_Interface_Signal_Declaration
        and then Is_Parameter (Base)
      then
         return Walk_Continue;
      end if;

      Prefix := Get_Longuest_Static_Prefix (Target);
      Add_Element (Driver_List, Prefix);
      if Has_After then
         Set_After_Drivers_Flag (Base, True);
      end if;
      return Walk_Continue;
   end Extract_Driver_Target;

   --  Set Has_After to True iff WF requires a non-direct driver.
   procedure Extract_Has_After (Wf : Iir) is
   begin
      --  Disconnect, or time expression.
      if Wf = Null_Iir
        or else Get_Chain (Wf) /= Null_Iir
        or else Get_Time (Wf) /= Null_Iir
        or else Get_Kind (Get_We_Value (Wf)) = Iir_Kind_Null_Literal
      then
         Has_After := True;
      end if;
   end Extract_Has_After;

   function Extract_Driver_Stmt (Stmt : Iir) return Walk_Status
   is
      Status : Walk_Status;
      pragma Unreferenced (Status);
   begin
      --  Clear Has_After.  It will be set to True if a signal assignment
      --  has an delay expression or a null transaction.
      --  (It is cleared for any statement, just to factorize code).
      Has_After := False;

      case Iir_Kinds_Sequential_Statement (Get_Kind (Stmt)) is
         when Iir_Kind_Simple_Signal_Assignment_Statement =>
            declare
               Wf : constant Iir := Get_Waveform_Chain (Stmt);
            begin
               if Is_Null (Wf)
                 or else Get_Kind (Wf) /= Iir_Kind_Unaffected_Waveform
               then
                  --  Not unaffected or implicit disconnect.
                  Extract_Has_After (Wf);
                  Status := Walk_Assignment_Target
                    (Get_Target (Stmt), Extract_Driver_Target'Access);
               end if;
            end;
         when Iir_Kind_Signal_Force_Assignment_Statement
            | Iir_Kind_Signal_Release_Assignment_Statement =>
            null;
         when Iir_Kind_Conditional_Signal_Assignment_Statement =>
            declare
               Cond_Wf : Iir;
               Wf : Iir;
               Has_Drv : Boolean;
            begin
               Cond_Wf := Get_Conditional_Waveform_Chain (Stmt);
               Has_Drv := False;
               while Cond_Wf /= Null_Iir loop
                  Wf := Get_Waveform_Chain (Cond_Wf);
                  if Get_Kind (Wf) /= Iir_Kind_Unaffected_Waveform then
                     --  Not unaffected
                     Extract_Has_After (Wf);
                     Has_Drv := True;
                  end if;
                  Cond_Wf := Get_Chain (Cond_Wf);
               end loop;
               if Has_Drv then
                  Status := Walk_Assignment_Target
                    (Get_Target (Stmt), Extract_Driver_Target'Access);
               end if;
            end;
         when Iir_Kind_Selected_Waveform_Assignment_Statement =>
            declare
               Swf : Iir;
               Wf : Iir;
               Has_Drv : Boolean;
            begin
               Swf := Get_Selected_Waveform_Chain (Stmt);
               Has_Drv := False;
               while Swf /= Null_Iir loop
                  if not Get_Same_Alternative_Flag (Swf) then
                     Wf := Get_Associated_Chain (Swf);
                     if Get_Kind (Wf) /= Iir_Kind_Unaffected_Waveform then
                        --  Not unaffected
                        Extract_Has_After (Wf);
                        Has_Drv := True;
                     end if;
                  end if;
                  Swf := Get_Chain (Swf);
               end loop;
               if Has_Drv then
                  Status := Walk_Assignment_Target
                    (Get_Target (Stmt), Extract_Driver_Target'Access);
               end if;
            end;
         when Iir_Kind_Procedure_Call_Statement =>
            declare
               Call : constant Iir := Get_Procedure_Call (Stmt);
               Assoc : Iir;
               Formal : Iir;
               Inter : Iir;
            begin
               --  Very pessimist.
               Has_After := True;

               Assoc := Get_Parameter_Association_Chain (Call);
               Inter := Get_Interface_Declaration_Chain
                 (Get_Implementation (Call));
               while Assoc /= Null_Iir loop
                  Formal := Get_Association_Interface (Assoc, Inter);
                  if Get_Kind (Assoc)
                    = Iir_Kind_Association_Element_By_Expression
                    and then
                    Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration
                    and then Get_Mode (Formal) /= Iir_In_Mode
                  then
                     Status := Extract_Driver_Target (Get_Actual (Assoc));
                  end if;
                  Next_Association_Interface (Assoc, Inter);
               end loop;
            end;
         when Iir_Kind_Null_Statement
           | Iir_Kind_Assertion_Statement
           | Iir_Kind_Report_Statement
           | Iir_Kind_Wait_Statement
           | Iir_Kind_Return_Statement
           | Iir_Kind_Next_Statement
           | Iir_Kind_Exit_Statement
           | Iir_Kind_Variable_Assignment_Statement
           | Iir_Kind_Conditional_Variable_Assignment_Statement
           | Iir_Kind_For_Loop_Statement
           | Iir_Kind_While_Loop_Statement
           | Iir_Kind_Case_Statement
           | Iir_Kind_If_Statement
           | Iir_Kind_Break_Statement =>
            null;
      end case;
      return Walk_Continue;
   end Extract_Driver_Stmt;

   procedure Extract_Drivers_Sequential_Stmt_Chain (Chain : Iir)
   is
      Status : Walk_Status;
      pragma Unreferenced (Status);
   begin
      Status := Walk_Sequential_Stmt_Chain (Chain, Extract_Driver_Stmt'Access);
   end Extract_Drivers_Sequential_Stmt_Chain;

   procedure Extract_Drivers_Declaration_Chain (Chain : Iir)
   is
      Decl : Iir := Chain;
   begin
      while Decl /= Null_Iir loop

         --  Only procedures and impure functions may contain assignment.
         if Get_Kind (Decl) = Iir_Kind_Procedure_Body
           or else (Get_Kind (Decl) = Iir_Kind_Function_Body
                    and then
                      not Get_Pure_Flag (Get_Subprogram_Specification (Decl)))
         then
            Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl));
            Extract_Drivers_Sequential_Stmt_Chain
              (Get_Sequential_Statement_Chain (Decl));
         end if;

         Decl := Get_Chain (Decl);
      end loop;
   end Extract_Drivers_Declaration_Chain;

   function Extract_Drivers (Proc : Iir) return Iir_List
   is
   begin
      Driver_List := Create_Iir_List;
      Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Proc));
      Extract_Drivers_Sequential_Stmt_Chain
              (Get_Sequential_Statement_Chain (Proc));

      return Driver_List;
   end Extract_Drivers;

   procedure Free_Drivers_List (List : in out Iir_List)
   is
      It : List_Iterator;
   begin
      It := List_Iterate (List);
      while Is_Valid (It) loop
         Set_After_Drivers_Flag (Get_Object_Prefix (Get_Element (It)), False);
         Next (It);
      end loop;
      Destroy_Iir_List (List);
   end Free_Drivers_List;

   procedure Dump_Drivers (Proc : Iir; List : Iir_List)
   is
      use Simple_IO;
      use Errorout;
      El : Iir;
      It : List_Iterator;
   begin
      Report_Msg (Msgid_Note, Semantic, +Proc,
                  "List of drivers for %n:", (1 => +Proc));
      Report_Msg (Msgid_Note, Semantic, +Proc,
                  " (declared at %l)", (1 => +Proc));
      It := List_Iterate (List);
      while Is_Valid (It) loop
         El := Get_Element (It);
         if Get_After_Drivers_Flag (Get_Object_Prefix (El)) then
            Put ("*  ");
         else
            Put ("   ");
         end if;
         Vhdl.Prints.Disp_Vhdl (El);
         New_Line;
         Next (It);
      end loop;
   end Dump_Drivers;

end Trans_Analyzes;