-- Iir to ortho translator. -- Copyright (C) 2002 - 2014 Tristan Gingold -- -- GHDL 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, or (at your option) any later -- version. -- -- GHDL 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 GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; with Std_Names; with Errorout; use Errorout; with Iir_Chains; with Canon; with Evaluation; use Evaluation; with Std_Package; use Std_Package; with Iirs_Utils; use Iirs_Utils; with Trans.Chap2; with Trans.Chap3; with Trans.Chap4; with Trans.Chap6; with Trans.Chap7; with Trans.Chap14; with Trans_Decls; use Trans_Decls; with Translation; use Translation; with Trans.Helpers2; use Trans.Helpers2; with Trans.Foreach_Non_Composite; package body Trans.Chap8 is use Trans.Helpers; procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) is Subprg_Info : constant Ortho_Info_Acc := Get_Info (Chap2.Current_Subprogram); Expr : constant Iir := Get_Expression (Stmt); Ret_Type : Iir; Ret_Info : Type_Info_Acc; procedure Gen_Return is begin if Subprg_Info.Subprg_Exit /= O_Snode_Null then New_Exit_Stmt (Subprg_Info.Subprg_Exit); else New_Return_Stmt; end if; end Gen_Return; procedure Gen_Return_Value (Val : O_Enode) is begin if Subprg_Info.Subprg_Exit /= O_Snode_Null then New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); New_Exit_Stmt (Subprg_Info.Subprg_Exit); else New_Return_Stmt (Val); end if; end Gen_Return_Value; begin if Expr = Null_Iir then -- Return in a procedure. Gen_Return; return; end if; -- Return in a function. Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); Ret_Info := Get_Info (Ret_Type); case Ret_Info.Type_Mode is when Type_Mode_Scalar => -- * if the return type is scalar, simply returns. declare V : O_Dnode; R : O_Enode; begin -- Always uses a temporary in case of the return expression -- uses secondary stack. -- FIXME: don't use the temp if not required. R := Chap7.Translate_Expression (Expr, Ret_Type); if Has_Stack2_Mark or else Chap3.Need_Range_Check (Expr, Ret_Type) then V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (V), R); Stack2_Release; Chap3.Check_Range (V, Expr, Ret_Type, Expr); Gen_Return_Value (New_Obj_Value (V)); else Gen_Return_Value (R); end if; end; when Type_Mode_Acc => -- * access: thin and no range. declare Res : O_Enode; begin Res := Chap7.Translate_Expression (Expr, Ret_Type); Gen_Return_Value (Res); end; when Type_Mode_Fat_Array => -- * if the return type is unconstrained: allocate an area from -- the secondary stack, copy it to the area, and fill the fat -- pointer. -- Evaluate the result. declare Val : Mnode; Area : Mnode; begin Area := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); Val := Stabilize (E2M (Chap7.Translate_Expression (Expr, Ret_Type), Ret_Info, Mode_Value)); Chap3.Translate_Object_Allocation (Area, Alloc_Return, Ret_Type, Chap3.Get_Array_Bounds (Val)); Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); Gen_Return; end; when Type_Mode_Record | Type_Mode_Array | Type_Mode_Fat_Acc => -- * if the return type is a constrained composite type, copy -- it to the result area. -- Create a temporary area so that if the expression use -- stack2, it will be freed before the return (otherwise, -- the stack area will be lost). declare V : Mnode; begin Open_Temp; V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); Chap3.Translate_Object_Copy (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); Close_Temp; Gen_Return; end; when Type_Mode_File => -- FIXME: Is it possible ? Error_Kind ("translate_return_statement", Ret_Type); when Type_Mode_Unknown | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Return_Statement; procedure Translate_If_Statement (Stmt : Iir) is Blk : O_If_Block; Else_Clause : Iir; begin Start_If_Stmt (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); Else_Clause := Get_Else_Clause (Stmt); if Else_Clause /= Null_Iir then New_Else_Stmt (Blk); if Get_Condition (Else_Clause) = Null_Iir then Translate_Statements_Chain (Get_Sequential_Statement_Chain (Else_Clause)); else Open_Temp; Translate_If_Statement (Else_Clause); Close_Temp; end if; end if; Finish_If_Stmt (Blk); end Translate_If_Statement; function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) return O_Enode is begin return New_Value (New_Selected_Element (New_Access_Element (New_Value (O_Range)), Field)); end Get_Range_Ptr_Field_Value; -- Inc or dec ITERATOR according to DIR. procedure Gen_Update_Iterator (Iterator : O_Dnode; Dir : Iir_Direction; Val : Unsigned_64; Itype : Iir) is Op : ON_Op_Kind; Base_Type : Iir; V : O_Enode; begin case Dir is when Iir_To => Op := ON_Add_Ov; when Iir_Downto => Op := ON_Sub_Ov; end case; Base_Type := Get_Base_Type (Itype); case Get_Kind (Base_Type) is when Iir_Kind_Integer_Type_Definition => V := New_Lit (New_Signed_Literal (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); when Iir_Kind_Enumeration_Type_Definition => declare List : Iir_List; begin List := Get_Enumeration_Literal_List (Base_Type); -- FIXME: what about type E is ('T') ?? if Natural (Val) > Get_Nbr_Elements (List) then raise Internal_Error; end if; V := New_Lit (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); end; when others => Error_Kind ("gen_update_iterator", Base_Type); end case; New_Assign_Stmt (New_Obj (Iterator), New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); end Gen_Update_Iterator; type For_Loop_Data is record Iterator : Iir_Iterator_Declaration; Stmt : Iir_For_Loop_Statement; -- If around the loop, to check if the loop must be executed. If_Blk : O_If_Block; Label_Next, Label_Exit : O_Snode; -- Right bound of the iterator, used only if the iterator is a -- range expression. O_Right : O_Dnode; -- Range variable of the iterator, used only if the iterator is not -- a range expression. O_Range : O_Dnode; end record; procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; Stmt : Iir_For_Loop_Statement; Data : out For_Loop_Data) is Iter_Type : Iir; Iter_Base_Type : Iir; Var_Iter : Var_Type; Constraint : Iir; Cond : O_Enode; Dir : Iir_Direction; Iter_Type_Info : Ortho_Info_Acc; Op : ON_Op_Kind; begin -- Initialize DATA. Data.Iterator := Iterator; Data.Stmt := Stmt; Iter_Type := Get_Type (Iterator); Iter_Base_Type := Get_Base_Type (Iter_Type); Iter_Type_Info := Get_Info (Iter_Base_Type); Var_Iter := Get_Info (Iterator).Iterator_Var; Open_Temp; Constraint := Get_Range_Constraint (Iter_Type); if Get_Kind (Constraint) = Iir_Kind_Range_Expression then New_Assign_Stmt (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left (Constraint, Iter_Base_Type)); Dir := Get_Direction (Constraint); Data.O_Right := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right (Constraint, Iter_Base_Type)); case Dir is when Iir_To => Op := ON_Le; when Iir_Downto => Op := ON_Ge; end case; -- Check for at least one iteration. Cond := New_Compare_Op (Op, New_Value (Get_Var (Var_Iter)), New_Obj_Value (Data.O_Right), Ghdl_Bool_Type); else Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); New_Assign_Stmt (New_Obj (Data.O_Range), New_Address (Chap7.Translate_Range (Constraint, Iter_Base_Type), Iter_Type_Info.T.Range_Ptr_Type)); New_Assign_Stmt (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); -- Before starting the loop, check wether there will be at least -- one iteration. Cond := New_Compare_Op (ON_Gt, Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Length), New_Lit (Ghdl_Index_0), Ghdl_Bool_Type); end if; Start_If_Stmt (Data.If_Blk, Cond); -- Start loop. -- There are two blocks: one for the exit, one for the next. Start_Loop_Stmt (Data.Label_Exit); Start_Loop_Stmt (Data.Label_Next); if Stmt /= Null_Iir then declare Loop_Info : Loop_Info_Acc; begin Loop_Info := Add_Info (Stmt, Kind_Loop); Loop_Info.Label_Exit := Data.Label_Exit; Loop_Info.Label_Next := Data.Label_Next; end; end if; end Start_For_Loop; procedure Finish_For_Loop (Data : in out For_Loop_Data) is Cond : O_Enode; If_Blk1 : O_If_Block; Iter_Type : Iir; Iter_Base_Type : Iir; Iter_Type_Info : Type_Info_Acc; Var_Iter : Var_Type; Constraint : Iir; Deep_Rng : Iir; Deep_Reverse : Boolean; begin New_Exit_Stmt (Data.Label_Next); Finish_Loop_Stmt (Data.Label_Next); -- Check end of loop. -- Equality is necessary and enough. Iter_Type := Get_Type (Data.Iterator); Iter_Base_Type := Get_Base_Type (Iter_Type); Iter_Type_Info := Get_Info (Iter_Base_Type); Var_Iter := Get_Info (Data.Iterator).Iterator_Var; Constraint := Get_Range_Constraint (Iter_Type); if Get_Kind (Constraint) = Iir_Kind_Range_Expression then Cond := New_Obj_Value (Data.O_Right); else Cond := Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); end if; Gen_Exit_When (Data.Label_Exit, New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), Cond, Ghdl_Bool_Type)); -- Update the iterator. Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); if Deep_Rng /= Null_Iir then if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then Gen_Update_Iterator (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); else Gen_Update_Iterator (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); end if; else Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Dir), New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); Gen_Update_Iterator (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); New_Else_Stmt (If_Blk1); Gen_Update_Iterator (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); Finish_If_Stmt (If_Blk1); end if; Finish_Loop_Stmt (Data.Label_Exit); Finish_If_Stmt (Data.If_Blk); Close_Temp; if Data.Stmt /= Null_Iir then Free_Info (Data.Stmt); end if; end Finish_For_Loop; Current_Loop : Iir := Null_Iir; procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) is Iterator : constant Iir := Get_Parameter_Specification (Stmt); Iter_Type : constant Iir := Get_Type (Iterator); Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); Data : For_Loop_Data; It_Info : Ortho_Info_Acc; Var_Iter : Var_Type; Prev_Loop : Iir; begin Prev_Loop := Current_Loop; Current_Loop := Stmt; Start_Declare_Stmt; Chap3.Translate_Object_Subtype (Iterator, False); -- Create info for the iterator. It_Info := Add_Info (Iterator, Kind_Iterator); Var_Iter := Create_Var (Create_Var_Identifier (Iterator), Iter_Type_Info.Ortho_Type (Mode_Value), O_Storage_Local); It_Info.Iterator_Var := Var_Iter; Start_For_Loop (Iterator, Stmt, Data); Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); Finish_For_Loop (Data); Finish_Declare_Stmt; Free_Info (Iterator); Current_Loop := Prev_Loop; end Translate_For_Loop_Statement; procedure Translate_While_Loop_Statement (Stmt : Iir_While_Loop_Statement) is Info : Loop_Info_Acc; Cond : Iir; Prev_Loop : Iir; begin Prev_Loop := Current_Loop; Current_Loop := Stmt; Info := Add_Info (Stmt, Kind_Loop); Start_Loop_Stmt (Info.Label_Exit); Info.Label_Next := O_Snode_Null; Open_Temp; Cond := Get_Condition (Stmt); if Cond /= Null_Iir then Gen_Exit_When (Info.Label_Exit, New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); end if; Close_Temp; Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); Finish_Loop_Stmt (Info.Label_Exit); Free_Info (Stmt); Current_Loop := Prev_Loop; end Translate_While_Loop_Statement; procedure Translate_Exit_Next_Statement (Stmt : Iir) is Cond : constant Iir := Get_Condition (Stmt); If_Blk : O_If_Block; Info : Loop_Info_Acc; Loop_Label : Iir; Loop_Stmt : Iir; begin if Cond /= Null_Iir then Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); end if; Loop_Label := Get_Loop_Label (Stmt); if Loop_Label = Null_Iir then Loop_Stmt := Current_Loop; else Loop_Stmt := Get_Named_Entity (Loop_Label); end if; Info := Get_Info (Loop_Stmt); case Get_Kind (Stmt) is when Iir_Kind_Exit_Statement => New_Exit_Stmt (Info.Label_Exit); when Iir_Kind_Next_Statement => if Info.Label_Next /= O_Snode_Null then -- For-loop. New_Exit_Stmt (Info.Label_Next); else -- While-loop. New_Next_Stmt (Info.Label_Exit); end if; when others => raise Internal_Error; end case; if Cond /= Null_Iir then Finish_If_Stmt (If_Blk); end if; end Translate_Exit_Next_Statement; procedure Translate_Variable_Aggregate_Assignment (Targ : Iir; Targ_Type : Iir; Val : Mnode); procedure Translate_Variable_Array_Aggr (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode; Index : in out Unsigned_64; Dim : Natural) is El : Iir; Final : Boolean; El_Type : Iir; begin Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); if Final then El_Type := Get_Element_Subtype (Targ_Type); end if; El := Get_Association_Choices_Chain (Targ); while El /= Null_Iir loop case Get_Kind (El) is when Iir_Kind_Choice_By_None => if Final then Translate_Variable_Aggregate_Assignment (Get_Associated_Expr (El), El_Type, Chap3.Index_Base (Val, Targ_Type, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Index)))); Index := Index + 1; else Translate_Variable_Array_Aggr (Get_Associated_Expr (El), Targ_Type, Val, Index, Dim + 1); end if; when others => Error_Kind ("translate_variable_array_aggr", El); end case; El := Get_Chain (El); end loop; end Translate_Variable_Array_Aggr; procedure Translate_Variable_Rec_Aggr (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) is Aggr_El : Iir; El_List : Iir_List; El_Index : Natural; Elem : Iir; begin El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Targ); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => Elem := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Elem := Get_Choice_Name (Aggr_El); when others => Error_Kind ("translate_variable_rec_aggr", Aggr_El); end case; Translate_Variable_Aggregate_Assignment (Get_Associated_Expr (Aggr_El), Get_Type (Elem), Chap6.Translate_Selected_Element (Val, Elem)); Aggr_El := Get_Chain (Aggr_El); end loop; end Translate_Variable_Rec_Aggr; procedure Translate_Variable_Aggregate_Assignment (Targ : Iir; Targ_Type : Iir; Val : Mnode) is Index : Unsigned_64; begin if Get_Kind (Targ) = Iir_Kind_Aggregate then case Get_Kind (Targ_Type) is when Iir_Kinds_Array_Type_Definition => Index := 0; Translate_Variable_Array_Aggr (Targ, Targ_Type, Val, Index, 1); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); when others => Error_Kind ("translate_variable_aggregate_assignment", Targ_Type); end case; else declare Targ_Node : Mnode; begin Targ_Node := Chap6.Translate_Name (Targ); Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); end; end if; end Translate_Variable_Aggregate_Assignment; procedure Translate_Variable_Assignment_Statement (Stmt : Iir_Variable_Assignment_Statement) is Target : constant Iir := Get_Target (Stmt); Targ_Type : constant Iir := Get_Type (Target); Expr : constant Iir := Get_Expression (Stmt); Targ_Node : Mnode; begin if Get_Kind (Target) = Iir_Kind_Aggregate then declare E : O_Enode; Temp : Mnode; begin Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True); -- Use a temporary variable, to avoid overlap. Temp := Create_Temp (Get_Info (Targ_Type)); Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); E := Chap7.Translate_Expression (Expr, Targ_Type); Chap3.Translate_Object_Copy (Temp, E, Targ_Type); Translate_Variable_Aggregate_Assignment (Target, Targ_Type, Temp); return; end; else Targ_Node := Chap6.Translate_Name (Target); if Get_Kind (Expr) = Iir_Kind_Aggregate then declare E : O_Enode; begin E := Chap7.Translate_Expression (Expr, Targ_Type); Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); end; else Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); end if; end if; end Translate_Variable_Assignment_Statement; procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) is Expr : Iir; Msg : O_Enode; Severity : O_Enode; Assocs : O_Assoc_List; Loc : O_Dnode; begin Loc := Chap4.Get_Location (Stmt); Expr := Get_Report_Expression (Stmt); if Expr = Null_Iir then Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); else Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); end if; Expr := Get_Severity_Expression (Stmt); if Expr = Null_Iir then Severity := New_Lit (Get_Ortho_Expr (Level)); else Severity := Chap7.Translate_Expression (Expr); end if; -- Do call. Start_Association (Assocs, Subprg); New_Association (Assocs, Msg); New_Association (Assocs, Severity); New_Association (Assocs, New_Address (New_Obj (Loc), Ghdl_Location_Ptr_Node)); New_Procedure_Call (Assocs); end Translate_Report; -- Return True if the current library unit is part of library IEEE. function Is_Within_Ieee_Library return Boolean is Design_File : Iir; Library : Iir; begin -- Guard. if Current_Library_Unit = Null_Iir then return False; end if; Design_File := Get_Design_File (Get_Design_Unit (Current_Library_Unit)); Library := Get_Library (Design_File); return Get_Identifier (Library) = Std_Names.Name_Ieee; end Is_Within_Ieee_Library; procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) is Expr : Iir; If_Blk : O_If_Block; Subprg : O_Dnode; begin -- Select the procedure to call in case of assertion (so that -- assertions within the IEEE library could be ignored). if Is_Within_Ieee_Library then Subprg := Ghdl_Ieee_Assert_Failed; else Subprg := Ghdl_Assert_Failed; end if; Expr := Get_Assertion_Condition (Stmt); if Get_Expr_Staticness (Expr) = Locally then if Eval_Pos (Expr) = 1 then -- Assert TRUE is a noop. -- FIXME: generate a noop ? return; end if; Translate_Report (Stmt, Subprg, Severity_Level_Error); else -- An assertion is reported if the condition is false! Start_If_Stmt (If_Blk, New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Expr))); -- Note: it is necessary to create a declare block, to avoid bad -- order with the if block. Open_Temp; Translate_Report (Stmt, Subprg, Severity_Level_Error); Close_Temp; Finish_If_Stmt (If_Blk); end if; end Translate_Assertion_Statement; procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is begin Translate_Report (Stmt, Ghdl_Report, Severity_Level_Note); end Translate_Report_Statement; -- Helper to compare a string choice with the selector. function Translate_Simple_String_Choice (Expr : O_Dnode; Val : O_Enode; Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Func : Iir) return O_Enode is Assoc : O_Assoc_List; Func_Info : Subprg_Info_Acc; begin New_Assign_Stmt (New_Selected_Element (New_Obj (Val_Node), Tinfo.T.Base_Field (Mode_Value)), Val); Func_Info := Get_Info (Func); Start_Association (Assoc, Func_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); New_Association (Assoc, New_Obj_Value (Expr)); New_Association (Assoc, New_Address (New_Obj (Val_Node), Tinfo.Ortho_Ptr_Type (Mode_Value))); return New_Function_Call (Assoc); end Translate_Simple_String_Choice; -- Helper to evaluate the selector and preparing a choice variable. procedure Translate_String_Case_Statement_Common (Stmt : Iir_Case_Statement; Expr_Type : out Iir; Tinfo : out Type_Info_Acc; Expr_Node : out O_Dnode; C_Node : out O_Dnode) is Expr : Iir; Base_Type : Iir; begin -- Translate into if/elsif statements. -- FIXME: if the number of literals ** length of the array < 256, -- use a case statement. Expr := Get_Expression (Stmt); Expr_Type := Get_Type (Expr); Base_Type := Get_Base_Type (Expr_Type); Tinfo := Get_Info (Base_Type); -- Translate selector. Expr_Node := Create_Temp_Init (Tinfo.Ortho_Ptr_Type (Mode_Value), Chap7.Translate_Expression (Expr, Base_Type)); -- Copy the bounds for the choices. C_Node := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Selected_Element (New_Obj (C_Node), Tinfo.T.Bounds_Field (Mode_Value)), New_Value_Selected_Acc_Value (New_Obj (Expr_Node), Tinfo.T.Bounds_Field (Mode_Value))); end Translate_String_Case_Statement_Common; -- Translate a string case statement using a dichotomy. procedure Translate_String_Case_Statement_Dichotomy (Stmt : Iir_Case_Statement) is -- Selector. Expr_Type : Iir; Tinfo : Type_Info_Acc; Expr_Node : O_Dnode; C_Node : O_Dnode; Choices_Chain : Iir; Choice : Iir; Has_Others : Boolean; Func : Iir; -- Number of non-others choices. Nbr_Choices : Natural; -- Number of associations. Nbr_Assocs : Natural; Info : Ortho_Info_Acc; First, Last : Ortho_Info_Acc; Sel_Length : Iir_Int64; -- Dichotomy table (table of choices). String_Type : O_Tnode; Table_Base_Type : O_Tnode; Table_Type : O_Tnode; Table : O_Dnode; List : O_Array_Aggr_List; Table_Cst : O_Cnode; -- Association table. -- Indexed by the choice, returns an index to the associated -- statement list. -- Could be replaced by jump table. Assoc_Table_Base_Type : O_Tnode; Assoc_Table_Type : O_Tnode; Assoc_Table : O_Dnode; begin Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); -- Count number of choices and number of associations. Nbr_Choices := 0; Nbr_Assocs := 0; Choice := Choices_Chain; First := null; Last := null; Has_Others := False; while Choice /= Null_Iir loop case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => Has_Others := True; exit; when Iir_Kind_Choice_By_Expression => null; when others => raise Internal_Error; end case; if not Get_Same_Alternative_Flag (Choice) then Nbr_Assocs := Nbr_Assocs + 1; end if; Info := Add_Info (Choice, Kind_Str_Choice); if First = null then First := Info; else Last.Choice_Chain := Info; end if; Last := Info; Info.Choice_Chain := null; Info.Choice_Assoc := Nbr_Assocs - 1; Info.Choice_Parent := Choice; Info.Choice_Expr := Get_Choice_Expression (Choice); Nbr_Choices := Nbr_Choices + 1; Choice := Get_Chain (Choice); end loop; -- Sort choices. declare procedure Merge_Sort (Head : Ortho_Info_Acc; Nbr : Natural; Res : out Ortho_Info_Acc; Next : out Ortho_Info_Acc) is L, R, L_End, R_End : Ortho_Info_Acc; E, Last : Ortho_Info_Acc; Half : constant Natural := Nbr / 2; begin -- Sorting less than 2 elements is easy! if Nbr < 2 then Res := Head; if Nbr = 0 then Next := Head; else Next := Head.Choice_Chain; end if; return; end if; Merge_Sort (Head, Half, L, L_End); Merge_Sort (L_End, Nbr - Half, R, R_End); Next := R_End; -- Merge Last := null; loop if L /= L_End and then (R = R_End or else Compare_String_Literals (L.Choice_Expr, R.Choice_Expr) = Compare_Lt) then E := L; L := L.Choice_Chain; elsif R /= R_End then E := R; R := R.Choice_Chain; else exit; end if; if Last = null then Res := E; else Last.Choice_Chain := E; end if; Last := E; end loop; Last.Choice_Chain := R_End; end Merge_Sort; Next : Ortho_Info_Acc; begin Merge_Sort (First, Nbr_Choices, First, Next); if Next /= null then raise Internal_Error; end if; end; Translate_String_Case_Statement_Common (Stmt, Expr_Type, Tinfo, Expr_Node, C_Node); -- Generate choices table. Sel_Length := Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Expr_Type)); String_Type := New_Constrained_Array_Type (Tinfo.T.Base_Type (Mode_Value), New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length))); Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type); New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type); Table_Type := New_Constrained_Array_Type (Table_Base_Type, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); New_Type_Decl (Create_Uniq_Identifier, Table_Type); New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private, Table_Type); Start_Const_Value (Table); Start_Array_Aggr (List, Table_Type); Info := First; while Info /= null loop New_Array_Aggr_El (List, Chap7.Translate_Static_Expression (Info.Choice_Expr, Expr_Type)); Info := Info.Choice_Chain; end loop; Finish_Array_Aggr (List, Table_Cst); Finish_Const_Value (Table, Table_Cst); -- Generate assoc table. Assoc_Table_Base_Type := New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type); New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type); Assoc_Table_Type := New_Constrained_Array_Type (Assoc_Table_Base_Type, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices))); New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Type); New_Const_Decl (Assoc_Table, Create_Uniq_Identifier, O_Storage_Private, Assoc_Table_Type); Start_Const_Value (Assoc_Table); Start_Array_Aggr (List, Assoc_Table_Type); Info := First; while Info /= null loop New_Array_Aggr_El (List, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Info.Choice_Assoc))); Info := Info.Choice_Chain; end loop; Finish_Array_Aggr (List, Table_Cst); Finish_Const_Value (Assoc_Table, Table_Cst); -- Generate dichotomy code. declare Var_Lo, Var_Hi, Var_Mid : O_Dnode; Var_Cmp : O_Dnode; Var_Idx : O_Dnode; Label : O_Snode; Others_Lit : O_Cnode; If_Blk1, If_Blk2 : O_If_Block; Case_Blk : O_Case_Block; begin Var_Idx := Create_Temp (Ghdl_Index_Type); Start_Declare_Stmt; New_Var_Decl (Var_Lo, Wki_Lo, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Hi, Wki_Hi, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Mid, Wki_Mid, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Cmp, Wki_Cmp, O_Storage_Local, Ghdl_Compare_Type); New_Assign_Stmt (New_Obj (Var_Lo), New_Lit (Ghdl_Index_0)); New_Assign_Stmt (New_Obj (Var_Hi), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Choices - 1)))); Func := Chap7.Find_Predefined_Function (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Greater); if Has_Others then Others_Lit := New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Assocs)); end if; Start_Loop_Stmt (Label); New_Assign_Stmt (New_Obj (Var_Mid), New_Dyadic_Op (ON_Div_Ov, New_Dyadic_Op (ON_Add_Ov, New_Obj_Value (Var_Lo), New_Obj_Value (Var_Hi)), New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, 2)))); New_Assign_Stmt (New_Obj (Var_Cmp), Translate_Simple_String_Choice (Expr_Node, New_Address (New_Indexed_Element (New_Obj (Table), New_Obj_Value (Var_Mid)), Tinfo.T.Base_Ptr_Type (Mode_Value)), C_Node, Tinfo, Func)); Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, New_Obj_Value (Var_Cmp), New_Lit (Ghdl_Compare_Eq), Ghdl_Bool_Type)); New_Assign_Stmt (New_Obj (Var_Idx), New_Value (New_Indexed_Element (New_Obj (Assoc_Table), New_Obj_Value (Var_Mid)))); New_Exit_Stmt (Label); Finish_If_Stmt (If_Blk1); Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, New_Obj_Value (Var_Cmp), New_Lit (Ghdl_Compare_Lt), Ghdl_Bool_Type)); Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Le, New_Obj_Value (Var_Mid), New_Obj_Value (Var_Lo), Ghdl_Bool_Type)); if not Has_Others then Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_Bad_Choice); else New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); New_Exit_Stmt (Label); end if; New_Else_Stmt (If_Blk2); New_Assign_Stmt (New_Obj (Var_Hi), New_Dyadic_Op (ON_Sub_Ov, New_Obj_Value (Var_Mid), New_Lit (Ghdl_Index_1))); Finish_If_Stmt (If_Blk2); New_Else_Stmt (If_Blk1); Start_If_Stmt (If_Blk2, New_Compare_Op (ON_Ge, New_Obj_Value (Var_Mid), New_Obj_Value (Var_Hi), Ghdl_Bool_Type)); if not Has_Others then Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); else New_Assign_Stmt (New_Obj (Var_Idx), New_Lit (Others_Lit)); New_Exit_Stmt (Label); end if; New_Else_Stmt (If_Blk2); New_Assign_Stmt (New_Obj (Var_Lo), New_Dyadic_Op (ON_Add_Ov, New_Obj_Value (Var_Mid), New_Lit (Ghdl_Index_1))); Finish_If_Stmt (If_Blk2); Finish_If_Stmt (If_Blk1); Finish_Loop_Stmt (Label); Finish_Declare_Stmt; Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Idx)); Choice := Choices_Chain; while Choice /= Null_Iir loop case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, Others_Lit); Finish_Choice (Case_Blk); Translate_Statements_Chain (Get_Associated_Chain (Choice)); when Iir_Kind_Choice_By_Expression => if not Get_Same_Alternative_Flag (Choice) then Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Get_Info (Choice).Choice_Assoc))); Finish_Choice (Case_Blk); Translate_Statements_Chain (Get_Associated_Chain (Choice)); end if; Free_Info (Choice); when others => raise Internal_Error; end case; Choice := Get_Chain (Choice); end loop; Start_Choice (Case_Blk); New_Default_Choice (Case_Blk); Finish_Choice (Case_Blk); Chap6.Gen_Program_Error (Stmt, Chap6.Prg_Err_No_Choice); Finish_Case_Stmt (Case_Blk); end; end Translate_String_Case_Statement_Dichotomy; -- Case statement whose expression is an unidim array. -- Translate into if/elsif statements (linear search). procedure Translate_String_Case_Statement_Linear (Stmt : Iir_Case_Statement) is Expr_Type : Iir; -- Node containing the address of the selector. Expr_Node : O_Dnode; -- Node containing the current choice. Val_Node : O_Dnode; Tinfo : Type_Info_Acc; Cond_Var : O_Dnode; Func : Iir; procedure Translate_String_Choice (Choice : Iir) is Cond : O_Enode; If_Blk : O_If_Block; Stmt_Chain : Iir; First : Boolean; Ch : Iir; Ch_Expr : Iir; begin if Choice = Null_Iir then return; end if; First := True; Stmt_Chain := Get_Associated_Chain (Choice); Ch := Choice; loop case Get_Kind (Ch) is when Iir_Kind_Choice_By_Expression => Ch_Expr := Get_Choice_Expression (Ch); Cond := Translate_Simple_String_Choice (Expr_Node, Chap7.Translate_Expression (Ch_Expr, Get_Type (Ch_Expr)), Val_Node, Tinfo, Func); when Iir_Kind_Choice_By_Others => Translate_Statements_Chain (Stmt_Chain); return; when others => Error_Kind ("translate_string_choice", Ch); end case; if not First then New_Assign_Stmt (New_Obj (Cond_Var), New_Dyadic_Op (ON_Or, New_Obj_Value (Cond_Var), Cond)); end if; Ch := Get_Chain (Ch); exit when Ch = Null_Iir; exit when not Get_Same_Alternative_Flag (Ch); exit when Get_Associated_Chain (Ch) /= Null_Iir; if First then New_Assign_Stmt (New_Obj (Cond_Var), Cond); First := False; end if; end loop; if not First then Cond := New_Obj_Value (Cond_Var); end if; Start_If_Stmt (If_Blk, Cond); Translate_Statements_Chain (Stmt_Chain); New_Else_Stmt (If_Blk); Translate_String_Choice (Ch); Finish_If_Stmt (If_Blk); end Translate_String_Choice; begin Translate_String_Case_Statement_Common (Stmt, Expr_Type, Tinfo, Expr_Node, Val_Node); Func := Chap7.Find_Predefined_Function (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); Cond_Var := Create_Temp (Std_Boolean_Type_Node); Translate_String_Choice (Get_Case_Statement_Alternative_Chain (Stmt)); end Translate_String_Case_Statement_Linear; procedure Translate_Case_Choice (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block) is Expr : Iir; begin case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => New_Default_Choice (Blk); when Iir_Kind_Choice_By_Expression => Expr := Get_Choice_Expression (Choice); New_Expr_Choice (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); when Iir_Kind_Choice_By_Range => declare H, L : Iir; begin Expr := Get_Choice_Range (Choice); Get_Low_High_Limit (Expr, L, H); New_Range_Choice (Blk, Chap7.Translate_Static_Expression (L, Choice_Type), Chap7.Translate_Static_Expression (H, Choice_Type)); end; when others => Error_Kind ("translate_case_choice", Choice); end case; end Translate_Case_Choice; procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) is Expr : Iir; Expr_Type : Iir; Case_Blk : O_Case_Block; Choice : Iir; Stmt_Chain : Iir; begin Expr := Get_Expression (Stmt); Expr_Type := Get_Type (Expr); if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then declare Nbr_Choices : Natural := 0; Choice : Iir; begin Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop case Get_Kind (Choice) is when Iir_Kind_Choice_By_Others => exit; when Iir_Kind_Choice_By_Expression => null; when others => raise Internal_Error; end case; Nbr_Choices := Nbr_Choices + 1; Choice := Get_Chain (Choice); end loop; if Nbr_Choices < 3 then Translate_String_Case_Statement_Linear (Stmt); else Translate_String_Case_Statement_Dichotomy (Stmt); end if; end; return; end if; Start_Case_Stmt (Case_Blk, Chap7.Translate_Expression (Expr)); Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop Start_Choice (Case_Blk); Stmt_Chain := Get_Associated_Chain (Choice); loop Translate_Case_Choice (Choice, Expr_Type, Case_Blk); Choice := Get_Chain (Choice); exit when Choice = Null_Iir; exit when not Get_Same_Alternative_Flag (Choice); pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); end loop; Finish_Choice (Case_Blk); Translate_Statements_Chain (Stmt_Chain); end loop; Finish_Case_Stmt (Case_Blk); end Translate_Case_Statement; procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) is F_Assoc : Iir; Value_Assoc : Iir; Value : O_Dnode; Formal_Type : Iir; Tinfo : Type_Info_Acc; Assocs : O_Assoc_List; Subprg_Info : Subprg_Info_Acc; begin F_Assoc := Param_Chain; Value_Assoc := Get_Chain (Param_Chain); Formal_Type := Get_Type (Get_Formal (Value_Assoc)); Tinfo := Get_Info (Formal_Type); case Tinfo.Type_Mode is when Type_Mode_Scalar => Open_Temp; Start_Association (Assocs, Ghdl_Write_Scalar); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); -- compute the value. Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); New_Assign_Stmt (New_Obj (Value), Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); New_Association (Assocs, New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); -- length. New_Association (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), Ghdl_Index_Type))); -- call a predefined procedure New_Procedure_Call (Assocs); Close_Temp; when Type_Mode_Array | Type_Mode_Record | Type_Mode_Fat_Array => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); New_Procedure_Call (Assocs); when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc | Type_Mode_Fat_Acc | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Write_Procedure_Call; procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) is F_Assoc : Iir; Value_Assoc : Iir; Value : Mnode; Formal_Type : Iir; Tinfo : Type_Info_Acc; Assocs : O_Assoc_List; Subprg_Info : Subprg_Info_Acc; begin F_Assoc := Param_Chain; Value_Assoc := Get_Chain (Param_Chain); Formal_Type := Get_Type (Get_Formal (Value_Assoc)); Tinfo := Get_Info (Formal_Type); case Tinfo.Type_Mode is when Type_Mode_Scalar => Open_Temp; Start_Association (Assocs, Ghdl_Read_Scalar); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); -- value Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); New_Association (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); -- length. New_Association (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), Ghdl_Index_Type))); -- call a predefined procedure New_Procedure_Call (Assocs); Close_Temp; when Type_Mode_Array | Type_Mode_Record => Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc))); New_Procedure_Call (Assocs); when Type_Mode_Fat_Array => declare Length_Assoc : Iir; Length : Mnode; begin Length_Assoc := Get_Chain (Value_Assoc); Subprg_Info := Get_Info (Imp); Start_Association (Assocs, Subprg_Info.Ortho_Func); Subprgs.Add_Subprg_Instance_Assoc (Assocs, Subprg_Info.Subprg_Instance); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Value_Assoc), Formal_Type)); Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); end; when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc | Type_Mode_Fat_Acc | Type_Mode_Protected => raise Internal_Error; end case; end Translate_Read_Procedure_Call; procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) is Imp : constant Iir := Get_Implementation (Call); Kind : constant Iir_Predefined_Functions := Get_Implicit_Definition (Imp); Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); begin case Kind is when Iir_Predefined_Write => -- Check wether text or not. declare File_Param : Iir; Assocs : O_Assoc_List; begin File_Param := Param_Chain; -- FIXME: do the test. if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) then -- If text: Start_Association (Assocs, Ghdl_Text_Write); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (File_Param))); -- compute string parameter (get a fat array pointer) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (Get_Chain (Param_Chain)), String_Type_Definition)); -- call a predefined procedure New_Procedure_Call (Assocs); else Translate_Write_Procedure_Call (Imp, Param_Chain); end if; end; when Iir_Predefined_Read_Length => -- FIXME: works only for text read length. declare File_Param : Iir; N_Param : Iir; Assocs : O_Assoc_List; Str : O_Enode; Res : Mnode; begin File_Param := Param_Chain; if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) then N_Param := Get_Chain (File_Param); Str := Chap7.Translate_Expression (Get_Actual (N_Param), String_Type_Definition); N_Param := Get_Chain (N_Param); Res := Chap6.Translate_Name (Get_Actual (N_Param)); Start_Association (Assocs, Ghdl_Text_Read_Length); -- compute file parameter (get an index) New_Association (Assocs, Chap7.Translate_Expression (Get_Actual (File_Param))); -- compute string parameter (get a fat array pointer) New_Association (Assocs, Str); -- call a predefined procedure New_Assign_Stmt (M2Lv (Res), New_Function_Call (Assocs)); else Translate_Read_Procedure_Call (Imp, Param_Chain); end if; end; when Iir_Predefined_Read => Translate_Read_Procedure_Call (Imp, Param_Chain); when Iir_Predefined_Deallocate => Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); when Iir_Predefined_File_Open => declare N_Param : Iir; File_Param : Iir; Name_Param : Iir; Kind_Param : Iir; Constr : O_Assoc_List; begin File_Param := Get_Actual (Param_Chain); N_Param := Get_Chain (Param_Chain); Name_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Kind_Param := Get_Actual (N_Param); if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Open); else Start_Association (Constr, Ghdl_File_Open); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Association (Constr, New_Convert_Ov (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); New_Association (Constr, Chap7.Translate_Expression (Name_Param, String_Type_Definition)); New_Procedure_Call (Constr); end; when Iir_Predefined_File_Open_Status => declare Std_File_Open_Status_Otype : constant O_Tnode := Get_Ortho_Type (File_Open_Status_Type_Definition, Mode_Value); N_Param : Iir; Status_Param : constant Iir := Get_Actual (Param_Chain); File_Param : Iir; Name_Param : Iir; Kind_Param : Iir; Constr : O_Assoc_List; Status : Mnode; begin Status := Chap6.Translate_Name (Status_Param); N_Param := Get_Chain (Param_Chain); File_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Name_Param := Get_Actual (N_Param); N_Param := Get_Chain (N_Param); Kind_Param := Get_Actual (N_Param); if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Open_Status); else Start_Association (Constr, Ghdl_File_Open_Status); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Association (Constr, New_Convert_Ov (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); New_Association (Constr, Chap7.Translate_Expression (Name_Param, String_Type_Definition)); New_Assign_Stmt (M2Lv (Status), New_Convert_Ov (New_Function_Call (Constr), Std_File_Open_Status_Otype)); end; when Iir_Predefined_File_Close => declare File_Param : constant Iir := Get_Actual (Param_Chain); Constr : O_Assoc_List; begin if Get_Text_File_Flag (Get_Type (File_Param)) then Start_Association (Constr, Ghdl_Text_File_Close); else Start_Association (Constr, Ghdl_File_Close); end if; New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Procedure_Call (Constr); end; when Iir_Predefined_Flush => declare File_Param : constant Iir := Get_Actual (Param_Chain); Constr : O_Assoc_List; begin Start_Association (Constr, Ghdl_File_Flush); New_Association (Constr, Chap7.Translate_Expression (File_Param)); New_Procedure_Call (Constr); end; when others => Ada.Text_IO.Put_Line ("translate_implicit_procedure_call: cannot handle " & Iir_Predefined_Functions'Image (Kind)); raise Internal_Error; end case; end Translate_Implicit_Procedure_Call; function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode) return O_Enode is Constr : O_Assoc_List; Conv_Info : Subprg_Info_Acc; Res : O_Dnode; Imp : Iir; begin if Conv = Null_Iir then return M2E (Src); -- case Get_Type_Info (Dest).Type_Mode is -- when Type_Mode_Thin => -- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); -- when Type_Mode_Fat_Acc => -- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); -- when others => -- raise Internal_Error; -- end case; else case Get_Kind (Conv) is when Iir_Kind_Function_Call => -- Call conversion function. Imp := Get_Implementation (Conv); Conv_Info := Get_Info (Imp); Start_Association (Constr, Conv_Info.Ortho_Func); if Conv_Info.Res_Interface /= O_Dnode_Null then Res := Create_Temp (Conv_Info.Res_Record_Type); -- Composite result. New_Association (Constr, New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); end if; Subprgs.Add_Subprg_Instance_Assoc (Constr, Conv_Info.Subprg_Instance); New_Association (Constr, M2E (Src)); if Conv_Info.Res_Interface /= O_Dnode_Null then -- Composite result. New_Procedure_Call (Constr); return New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr); else return New_Function_Call (Constr); end if; when Iir_Kind_Type_Conversion => return Chap7.Translate_Type_Conversion (M2E (Src), Get_Type (Expr), Get_Type (Conv), Null_Iir); when others => Error_Kind ("do_conversion", Conv); end case; end if; end Do_Conversion; procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) is type Mnode_Array is array (Natural range <>) of Mnode; type O_Enode_Array is array (Natural range <>) of O_Enode; Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); Nbr_Assoc : constant Natural := Iir_Chains.Get_Chain_Length (Assoc_Chain); Params : Mnode_Array (0 .. Nbr_Assoc - 1); E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); Imp : constant Iir := Get_Implementation (Stmt); Info : constant Subprg_Info_Acc := Get_Info (Imp); Res : O_Dnode; El : Iir; Pos : Natural; Constr : O_Assoc_List; Act : Iir; Actual_Type : Iir; Formal : Iir; Base_Formal : Iir; Formal_Type : Iir; Ftype_Info : Type_Info_Acc; Formal_Info : Ortho_Info_Acc; Val : O_Enode; Param : Mnode; Last_Individual : Natural; Ptr : O_Lnode; In_Conv : Iir; In_Expr : Iir; Out_Conv : Iir; Out_Expr : Iir; Formal_Object_Kind : Object_Kind_Type; Bounds : Mnode; Obj : Iir; begin -- Create an in-out result record for in-out arguments passed by -- value. if Info.Res_Record_Type /= O_Tnode_Null then Res := Create_Temp (Info.Res_Record_Type); else Res := O_Dnode_Null; end if; -- Evaluate in-out parameters and parameters passed by ref, since -- they can add declarations. -- Non-composite in-out parameters address are saved in order to -- be able to assignate the result. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop Params (Pos) := Mnode_Null; E_Params (Pos) := O_Enode_Null; Formal := Get_Formal (El); if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then Formal := Get_Named_Entity (Formal); end if; Base_Formal := Get_Association_Interface (El); Formal_Type := Get_Type (Formal); Formal_Info := Get_Info (Base_Formal); if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration then Formal_Object_Kind := Mode_Signal; else Formal_Object_Kind := Mode_Value; end if; Ftype_Info := Get_Info (Formal_Type); case Get_Kind (El) is when Iir_Kind_Association_Element_Open => Act := Get_Default_Value (Formal); In_Conv := Null_Iir; Out_Conv := Null_Iir; when Iir_Kind_Association_Element_By_Expression => Act := Get_Actual (El); In_Conv := Get_In_Conversion (El); Out_Conv := Get_Out_Conversion (El); when Iir_Kind_Association_Element_By_Individual => Actual_Type := Get_Actual_Type (El); if Formal_Info.Interface_Field /= O_Fnode_Null then -- A non-composite type cannot be associated by element. raise Internal_Error; end if; if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then Chap3.Create_Array_Subtype (Actual_Type, True); Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); Param := Create_Temp (Ftype_Info, Formal_Object_Kind); Chap3.Translate_Object_Allocation (Param, Alloc_Stack, Formal_Type, Bounds); else Param := Create_Temp (Ftype_Info, Formal_Object_Kind); Chap4.Allocate_Complex_Object (Formal_Type, Alloc_Stack, Param); end if; Last_Individual := Pos; Params (Pos) := Param; goto Continue; when others => Error_Kind ("translate_procedure_call", El); end case; Actual_Type := Get_Type (Act); if Formal_Info.Interface_Field /= O_Fnode_Null then -- Copy-out argument. -- This is not a composite type. Param := Chap6.Translate_Name (Act); if Get_Object_Kind (Param) /= Mode_Value then raise Internal_Error; end if; Params (Pos) := Stabilize (Param); if In_Conv /= Null_Iir or else Get_Mode (Formal) = Iir_Inout_Mode then -- Arguments may be assigned if there is an in conversion. Ptr := New_Selected_Element (New_Obj (Res), Formal_Info.Interface_Field); Param := Lv2M (Ptr, Ftype_Info, Mode_Value); if In_Conv /= Null_Iir then In_Expr := In_Conv; else In_Expr := Act; end if; Chap7.Translate_Assign (Param, Do_Conversion (In_Conv, Act, Params (Pos)), In_Expr, Formal_Type, El); end if; elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then -- Passed by reference. case Get_Kind (Base_Formal) is when Iir_Kind_Interface_Constant_Declaration | Iir_Kind_Interface_File_Declaration => -- No conversion here. E_Params (Pos) := Chap7.Translate_Expression (Act, Formal_Type); when Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_Signal_Declaration => Param := Chap6.Translate_Name (Act); -- Atype may not have been set (eg: slice). if Base_Formal /= Formal then Stabilize (Param); Params (Pos) := Param; end if; E_Params (Pos) := M2E (Param); if Formal_Type /= Actual_Type then -- Implicit array conversion or subtype check. E_Params (Pos) := Chap7.Translate_Implicit_Conv (E_Params (Pos), Actual_Type, Formal_Type, Get_Object_Kind (Param), Stmt); end if; when others => Error_Kind ("translate_procedure_call(2)", Formal); end case; end if; if Base_Formal /= Formal then -- Individual association. if Ftype_Info.Type_Mode not in Type_Mode_By_Value then -- Not by-value actual already translated. Val := E_Params (Pos); else -- By value association. Act := Get_Actual (El); if Get_Kind (Base_Formal) = Iir_Kind_Interface_Constant_Declaration then Val := Chap7.Translate_Expression (Act, Formal_Type); else Params (Pos) := Chap6.Translate_Name (Act); -- Since signals are passed by reference, they are not -- copied back, so do not stabilize them (furthermore, -- it is not possible to stabilize them). if Formal_Object_Kind = Mode_Value then Params (Pos) := Stabilize (Params (Pos)); end if; Val := M2E (Params (Pos)); end if; end if; -- Assign formal. -- Change the formal variable so that it is the local variable -- that will be passed to the subprogram. declare Prev_Node : O_Dnode; begin Prev_Node := Formal_Info.Interface_Node; -- We need a pointer since the interface is by reference. Formal_Info.Interface_Node := M2Dp (Params (Last_Individual)); Param := Chap6.Translate_Name (Formal); Formal_Info.Interface_Node := Prev_Node; end; Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); end if; << Continue >> null; El := Get_Chain (El); Pos := Pos + 1; end loop; -- Second stage: really perform the call. Start_Association (Constr, Info.Ortho_Func); if Res /= O_Dnode_Null then New_Association (Constr, New_Address (New_Obj (Res), Info.Res_Record_Ptr)); end if; Obj := Get_Method_Object (Stmt); if Obj /= Null_Iir then New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); else Subprgs.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); end if; -- Parameters. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop Formal := Get_Formal (El); if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then Formal := Get_Named_Entity (Formal); end if; Base_Formal := Get_Association_Interface (El); Formal_Info := Get_Info (Base_Formal); Formal_Type := Get_Type (Formal); Ftype_Info := Get_Info (Formal_Type); if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then Last_Individual := Pos; New_Association (Constr, M2E (Params (Pos))); elsif Base_Formal /= Formal then -- Individual association. null; elsif Formal_Info.Interface_Field = O_Fnode_Null then if Ftype_Info.Type_Mode in Type_Mode_By_Value then -- Parameter passed by value. if E_Params (Pos) /= O_Enode_Null then Val := E_Params (Pos); raise Internal_Error; else case Get_Kind (El) is when Iir_Kind_Association_Element_Open => Act := Get_Default_Value (Formal); In_Conv := Null_Iir; when Iir_Kind_Association_Element_By_Expression => Act := Get_Actual (El); In_Conv := Get_In_Conversion (El); when others => Error_Kind ("translate_procedure_call(2)", El); end case; case Get_Kind (Formal) is when Iir_Kind_Interface_Signal_Declaration => Param := Chap6.Translate_Name (Act); -- This is a scalar. Val := M2E (Param); when others => if In_Conv = Null_Iir then Val := Chap7.Translate_Expression (Act, Formal_Type); else Actual_Type := Get_Type (Act); Val := Do_Conversion (In_Conv, Act, E2M (Chap7.Translate_Expression (Act, Actual_Type), Get_Info (Actual_Type), Mode_Value)); end if; end case; end if; New_Association (Constr, Val); else -- Parameter passed by ref, which was already computed. New_Association (Constr, E_Params (Pos)); end if; end if; El := Get_Chain (El); Pos := Pos + 1; end loop; New_Procedure_Call (Constr); -- Copy-out non-composite parameters. El := Assoc_Chain; Pos := 0; while El /= Null_Iir loop Formal := Get_Formal (El); Base_Formal := Get_Association_Interface (El); Formal_Type := Get_Type (Formal); Ftype_Info := Get_Info (Formal_Type); Formal_Info := Get_Info (Base_Formal); if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration and then Get_Mode (Base_Formal) in Iir_Out_Modes and then Params (Pos) /= Mnode_Null then if Formal_Info.Interface_Field /= O_Fnode_Null then -- OUT parameters. Out_Conv := Get_Out_Conversion (El); if Out_Conv = Null_Iir then Out_Expr := Formal; else Out_Expr := Out_Conv; end if; Ptr := New_Selected_Element (New_Obj (Res), Formal_Info.Interface_Field); Param := Lv2M (Ptr, Ftype_Info, Mode_Value); Chap7.Translate_Assign (Params (Pos), Do_Conversion (Out_Conv, Formal, Param), Out_Expr, Get_Type (Get_Actual (El)), El); elsif Base_Formal /= Formal then -- By individual. -- Copy back. Act := Get_Actual (El); declare Prev_Node : O_Dnode; begin Prev_Node := Formal_Info.Interface_Node; -- We need a pointer since the interface is by reference. Formal_Info.Interface_Node := M2Dp (Params (Last_Individual)); Val := Chap7.Translate_Expression (Formal, Get_Type (Act)); Formal_Info.Interface_Node := Prev_Node; end; Chap7.Translate_Assign (Params (Pos), Val, Formal, Get_Type (Act), El); end if; end if; El := Get_Chain (El); Pos := Pos + 1; end loop; end Translate_Procedure_Call; procedure Translate_Wait_Statement (Stmt : Iir) is Sensitivity : Iir_List; Cond : Iir; Timeout : Iir; Constr : O_Assoc_List; begin Sensitivity := Get_Sensitivity_List (Stmt); Cond := Get_Condition_Clause (Stmt); Timeout := Get_Timeout_Clause (Stmt); if Sensitivity = Null_Iir_List and Cond /= Null_Iir then Sensitivity := Create_Iir_List; Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); Set_Sensitivity_List (Stmt, Sensitivity); end if; -- Check for simple cases. if Sensitivity = Null_Iir_List and then Cond = Null_Iir then if Timeout = Null_Iir then -- Process exit. Start_Association (Constr, Ghdl_Process_Wait_Exit); New_Procedure_Call (Constr); else -- Wait for a timeout. Start_Association (Constr, Ghdl_Process_Wait_Timeout); New_Association (Constr, Chap7.Translate_Expression (Timeout, Time_Type_Definition)); New_Procedure_Call (Constr); end if; return; end if; -- Evaluate the timeout (if any) and register it, if Timeout /= Null_Iir then Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); New_Association (Constr, Chap7.Translate_Expression (Timeout, Time_Type_Definition)); New_Procedure_Call (Constr); end if; -- Evaluate the sensitivity list and register it. if Sensitivity /= Null_Iir_List then Register_Signal_List (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); end if; if Cond = Null_Iir then declare V : O_Dnode; begin -- declare -- v : __ghdl_bool_type_node; -- begin -- v := suspend (); -- end; Open_Temp; V := Create_Temp (Ghdl_Bool_Type); Start_Association (Constr, Ghdl_Process_Wait_Suspend); New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); Close_Temp; end; else declare Label : O_Snode; begin -- start loop Start_Loop_Stmt (Label); -- if suspend() then -- return true if timeout. -- exit; -- end if; Start_Association (Constr, Ghdl_Process_Wait_Suspend); Gen_Exit_When (Label, New_Function_Call (Constr)); -- if condition then -- exit; -- end if; Open_Temp; Gen_Exit_When (Label, Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); Close_Temp; -- end loop; Finish_Loop_Stmt (Label); end; end if; -- wait_close; Start_Association (Constr, Ghdl_Process_Wait_Close); New_Procedure_Call (Constr); end Translate_Wait_Statement; -- Signal assignment. Signal_Assign_Line : Natural; procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Simple_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Simple_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Simple_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Simple_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Simple_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Simple_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_assign_non_composite", Targ_Type); end case; if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; Val2 : O_Dnode; Targ2 : O_Dnode; begin Open_Temp; Val2 := Create_Temp_Init (Type_Info.Ortho_Type (Mode_Value), Val); Targ2 := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); New_Association (Assoc, New_Obj_Value (Targ2)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Targ2)); New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Convert_Ov (Val, Conv)); New_Procedure_Call (Assoc); end if; end Gen_Simple_Signal_Assign_Non_Composite; procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite (Data_Type => O_Enode, Composite_Data_Type => Mnode, Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, Update_Data_Array => Gen_Oenode_Update_Data_Array, Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, Update_Data_Record => Gen_Oenode_Update_Data_Record, Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); type Signal_Assign_Data is record Expr : Mnode; Reject : O_Dnode; After : O_Dnode; end record; procedure Gen_Start_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin if Data.Expr = Mnode_Null then -- Null transaction. Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); return; end if; Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Start_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Start_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Start_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Start_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Start_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Start_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_assign_non_composite", Targ_Type); end case; -- Check range. if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; V : Mnode; Starg : O_Dnode; begin Open_Temp; V := Stabilize_Value (Data.Expr); Starg := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Obj_Value (Data.After)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.Reject)); New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); end if; end Gen_Start_Signal_Assign_Non_Composite; function Gen_Signal_Prepare_Data_Composite (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) return Signal_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Val; end Gen_Signal_Prepare_Data_Composite; function Gen_Signal_Prepare_Data_Record (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) return Signal_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin if Val.Expr = Mnode_Null then return Val; else return Signal_Assign_Data' (Expr => Stabilize (Val.Expr), Reject => Val.Reject, After => Val.After); end if; end Gen_Signal_Prepare_Data_Record; function Gen_Signal_Update_Data_Array (Val : Signal_Assign_Data; Targ_Type : Iir; Index : O_Dnode) return Signal_Assign_Data is Res : Signal_Assign_Data; begin if Val.Expr = Mnode_Null then -- Handle null transaction. return Val; end if; Res := Signal_Assign_Data' (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), Targ_Type, New_Obj_Value (Index)), Reject => Val.Reject, After => Val.After); return Res; end Gen_Signal_Update_Data_Array; function Gen_Signal_Update_Data_Record (Val : Signal_Assign_Data; Targ_Type : Iir; El : Iir_Element_Declaration) return Signal_Assign_Data is pragma Unreferenced (Targ_Type); Res : Signal_Assign_Data; begin if Val.Expr = Mnode_Null then -- Handle null transaction. return Val; end if; Res := Signal_Assign_Data' (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), Reject => Val.Reject, After => Val.After); return Res; end Gen_Signal_Update_Data_Record; procedure Gen_Signal_Finish_Data_Composite (Data : in out Signal_Assign_Data) is pragma Unreferenced (Data); begin null; end Gen_Signal_Finish_Data_Composite; procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite (Data_Type => Signal_Assign_Data, Composite_Data_Type => Signal_Assign_Data, Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Update_Data_Array, Finish_Data_Array => Gen_Signal_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record, Finish_Data_Record => Gen_Signal_Finish_Data_Composite); procedure Gen_Next_Signal_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) is Type_Info : Type_Info_Acc; Subprg : O_Dnode; Conv : O_Tnode; Assoc : O_Assoc_List; begin if Data.Expr = Mnode_Null then -- Null transaction. Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); return; end if; Type_Info := Get_Info (Targ_Type); case Type_Info.Type_Mode is when Type_Mode_B1 => Subprg := Ghdl_Signal_Next_Assign_B1; Conv := Ghdl_Bool_Type; when Type_Mode_E8 => Subprg := Ghdl_Signal_Next_Assign_E8; Conv := Ghdl_I32_Type; when Type_Mode_E32 => Subprg := Ghdl_Signal_Next_Assign_E32; Conv := Ghdl_I32_Type; when Type_Mode_I32 | Type_Mode_P32 => Subprg := Ghdl_Signal_Next_Assign_I32; Conv := Ghdl_I32_Type; when Type_Mode_P64 | Type_Mode_I64 => Subprg := Ghdl_Signal_Next_Assign_I64; Conv := Ghdl_I64_Type; when Type_Mode_F64 => Subprg := Ghdl_Signal_Next_Assign_F64; Conv := Ghdl_Real_Type; when Type_Mode_Array => raise Internal_Error; when others => Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); end case; if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then declare If_Blk : O_If_Block; V : Mnode; Starg : O_Dnode; begin Open_Temp; V := Stabilize_Value (Data.Expr); Starg := Create_Temp_Init (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); Start_If_Stmt (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Obj_Value (Data.After)); Assoc_Filename_Line (Assoc, Signal_Assign_Line); New_Procedure_Call (Assoc); New_Else_Stmt (If_Blk); Start_Association (Assoc, Subprg); New_Association (Assoc, New_Obj_Value (Starg)); New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); Finish_If_Stmt (If_Blk); Close_Temp; end; else Start_Association (Assoc, Subprg); New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); New_Association (Assoc, New_Obj_Value (Data.After)); New_Procedure_Call (Assoc); end if; end Gen_Next_Signal_Assign_Non_Composite; procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite (Data_Type => Signal_Assign_Data, Composite_Data_Type => Signal_Assign_Data, Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Update_Data_Array, Finish_Data_Array => Gen_Signal_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Update_Data_Record, Finish_Data_Record => Gen_Signal_Finish_Data_Composite); procedure Translate_Signal_Target_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir); procedure Translate_Signal_Target_Array_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir; Idx : O_Dnode; Dim : Natural) is Index_List : constant Iir_List := Get_Index_Subtype_List (Target_Type); Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); Sub_Aggr : Mnode; El : Iir; Expr : Iir; begin El := Get_Association_Choices_Chain (Target); while El /= Null_Iir loop case Get_Kind (El) is when Iir_Kind_Choice_By_None => Sub_Aggr := Chap3.Index_Base (Aggr, Target_Type, New_Obj_Value (Idx)); when others => Error_Kind ("translate_signal_target_array_aggr", El); end case; Expr := Get_Associated_Expr (El); if Dim = Nbr_Dim then Translate_Signal_Target_Aggr (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); if Get_Kind (El) = Iir_Kind_Choice_By_None then Inc_Var (Idx); else raise Internal_Error; end if; else Translate_Signal_Target_Array_Aggr (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); end if; El := Get_Chain (El); end loop; end Translate_Signal_Target_Array_Aggr; procedure Translate_Signal_Target_Record_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir) is Aggr_El : Iir; El_List : Iir_List; El_Index : Natural; Element : Iir_Element_Declaration; begin El_List := Get_Elements_Declaration_List (Get_Base_Type (Target_Type)); El_Index := 0; Aggr_El := Get_Association_Choices_Chain (Target); while Aggr_El /= Null_Iir loop case Get_Kind (Aggr_El) is when Iir_Kind_Choice_By_None => Element := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => Element := Get_Choice_Name (Aggr_El); El_Index := Natural'Last; when others => Error_Kind ("translate_signal_target_record_aggr", Aggr_El); end case; Translate_Signal_Target_Aggr (Chap6.Translate_Selected_Element (Aggr, Element), Get_Associated_Expr (Aggr_El), Get_Type (Element)); Aggr_El := Get_Chain (Aggr_El); end loop; end Translate_Signal_Target_Record_Aggr; procedure Translate_Signal_Target_Aggr (Aggr : Mnode; Target : Iir; Target_Type : Iir) is Src : Mnode; begin if Get_Kind (Target) = Iir_Kind_Aggregate then declare Idx : O_Dnode; St_Aggr : Mnode; begin Open_Temp; St_Aggr := Stabilize (Aggr); case Get_Kind (Target_Type) is when Iir_Kinds_Array_Type_Definition => Idx := Create_Temp (Ghdl_Index_Type); Init_Var (Idx); Translate_Signal_Target_Array_Aggr (St_Aggr, Target, Target_Type, Idx, 1); when Iir_Kind_Record_Type_Definition | Iir_Kind_Record_Subtype_Definition => Translate_Signal_Target_Record_Aggr (St_Aggr, Target, Target_Type); when others => Error_Kind ("translate_signal_target_aggr", Target_Type); end case; Close_Temp; end; else Src := Chap6.Translate_Name (Target); Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); end if; end Translate_Signal_Target_Aggr; type Signal_Direct_Assign_Data is record -- The driver Drv : Mnode; -- The value Expr : Mnode; -- The node for the expression (used to locate errors). Expr_Node : Iir; end record; procedure Gen_Signal_Direct_Assign_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) is Targ_Sig : Mnode; If_Blk : O_If_Block; Constr : O_Assoc_List; Cond : O_Dnode; Drv : Mnode; begin Open_Temp; Targ_Sig := Stabilize (Targ, True); Cond := Create_Temp (Ghdl_Bool_Type); Drv := Stabilize (Data.Drv, False); -- Set driver. Chap7.Translate_Assign (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); -- Test if the signal is active. Start_If_Stmt (If_Blk, New_Value (Chap14.Get_Signal_Field (Targ_Sig, Ghdl_Signal_Has_Active_Field))); -- Either because has_active is true. New_Assign_Stmt (New_Obj (Cond), New_Lit (Ghdl_Bool_True_Node)); New_Else_Stmt (If_Blk); -- Or because the value is different from the current driving value. -- FIXME: ideally, we should compare the value with the current -- value of the driver. This is an approximation that might break -- with weird resolution functions. New_Assign_Stmt (New_Obj (Cond), New_Compare_Op (ON_Neq, Chap7.Translate_Signal_Driving_Value (M2E (Targ_Sig), Targ_Type), M2E (Drv), Ghdl_Bool_Type)); Finish_If_Stmt (If_Blk); -- Put signal into active list (if not already in the list). -- FIXME: this is not thread-safe! Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); Start_Association (Constr, Ghdl_Signal_Direct_Assign); New_Association (Constr, New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), Ghdl_Signal_Ptr)); New_Procedure_Call (Constr); Finish_If_Stmt (If_Blk); Close_Temp; end Gen_Signal_Direct_Assign_Non_Composite; function Gen_Signal_Direct_Prepare_Data_Composite (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Val; end Gen_Signal_Direct_Prepare_Data_Composite; function Gen_Signal_Direct_Prepare_Data_Record (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ, Targ_Type); begin return Signal_Direct_Assign_Data' (Drv => Stabilize (Val.Drv), Expr => Stabilize (Val.Expr), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Prepare_Data_Record; function Gen_Signal_Direct_Update_Data_Array (Val : Signal_Direct_Assign_Data; Targ_Type : Iir; Index : O_Dnode) return Signal_Direct_Assign_Data is begin return Signal_Direct_Assign_Data' (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), Targ_Type, New_Obj_Value (Index)), Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), Targ_Type, New_Obj_Value (Index)), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Update_Data_Array; function Gen_Signal_Direct_Update_Data_Record (Val : Signal_Direct_Assign_Data; Targ_Type : Iir; El : Iir_Element_Declaration) return Signal_Direct_Assign_Data is pragma Unreferenced (Targ_Type); begin return Signal_Direct_Assign_Data' (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), Expr => Chap6.Translate_Selected_Element (Val.Expr, El), Expr_Node => Val.Expr_Node); end Gen_Signal_Direct_Update_Data_Record; procedure Gen_Signal_Direct_Finish_Data_Composite (Data : in out Signal_Direct_Assign_Data) is pragma Unreferenced (Data); begin null; end Gen_Signal_Direct_Finish_Data_Composite; procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite (Data_Type => Signal_Direct_Assign_Data, Composite_Data_Type => Signal_Direct_Assign_Data, Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) is Target : constant Iir := Get_Target (Stmt); Target_Type : constant Iir := Get_Type (Target); Arg : Signal_Direct_Assign_Data; Targ_Sig : Mnode; begin Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), Get_Info (Target_Type), Mode_Value); Arg.Expr_Node := We; Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); end Translate_Direct_Signal_Assignment; procedure Translate_Signal_Assignment_Statement (Stmt : Iir) is Target : Iir; Target_Type : Iir; We : Iir_Waveform_Element; Targ : Mnode; Val : O_Enode; Value : Iir; Is_Simple : Boolean; begin Target := Get_Target (Stmt); Target_Type := Get_Type (Target); We := Get_Waveform_Chain (Stmt); if We /= Null_Iir and then Get_Chain (We) = Null_Iir and then Get_Time (We) = Null_Iir and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay and then Get_Reject_Time_Expression (Stmt) = Null_Iir then -- Simple signal assignment ? Value := Get_We_Value (We); Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; else Is_Simple := False; end if; if Get_Kind (Target) = Iir_Kind_Aggregate then Chap3.Translate_Anonymous_Type_Definition (Target_Type, True); Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); Translate_Signal_Target_Aggr (Targ, Target, Target_Type); else if Is_Simple and then Flag_Direct_Drivers and then Chap4.Has_Direct_Driver (Target) then Translate_Direct_Signal_Assignment (Stmt, Value); return; end if; Targ := Chap6.Translate_Name (Target); if Get_Object_Kind (Targ) /= Mode_Signal then raise Internal_Error; end if; end if; if We = Null_Iir then -- Implicit disconnect statment. Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); return; end if; -- Handle a simple and common case: only one waveform, inertial, -- and no time (eg: sig <= expr). Value := Get_We_Value (We); Signal_Assign_Line := Get_Line_Number (Value); if Get_Chain (We) = Null_Iir and then Get_Time (We) = Null_Iir and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay and then Get_Reject_Time_Expression (Stmt) = Null_Iir and then Get_Kind (Value) /= Iir_Kind_Null_Literal then Val := Chap7.Translate_Expression (Value, Target_Type); Gen_Simple_Signal_Assign (Targ, Target_Type, Val); return; end if; -- General case. declare Var_Targ : Mnode; Targ_Tinfo : Type_Info_Acc; begin Open_Temp; Targ_Tinfo := Get_Info (Target_Type); Var_Targ := Stabilize (Targ, True); -- Translate the first waveform element. declare Reject_Time : O_Dnode; After_Time : O_Dnode; Del : Iir; Rej : Iir; Val : Mnode; Data : Signal_Assign_Data; begin Open_Temp; Reject_Time := Create_Temp (Std_Time_Otype); After_Time := Create_Temp (Std_Time_Otype); Del := Get_Time (We); if Del = Null_Iir then New_Assign_Stmt (New_Obj (After_Time), New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); else New_Assign_Stmt (New_Obj (After_Time), Chap7.Translate_Expression (Del, Time_Type_Definition)); end if; case Get_Delay_Mechanism (Stmt) is when Iir_Transport_Delay => New_Assign_Stmt (New_Obj (Reject_Time), New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); when Iir_Inertial_Delay => Rej := Get_Reject_Time_Expression (Stmt); if Rej = Null_Iir then New_Assign_Stmt (New_Obj (Reject_Time), New_Obj_Value (After_Time)); else New_Assign_Stmt (New_Obj (Reject_Time), Chap7.Translate_Expression (Rej, Time_Type_Definition)); end if; end case; if Get_Kind (Value) = Iir_Kind_Null_Literal then Val := Mnode_Null; else Val := E2M (Chap7.Translate_Expression (Value, Target_Type), Targ_Tinfo, Mode_Value); Val := Stabilize (Val); end if; Data := Signal_Assign_Data'(Expr => Val, Reject => Reject_Time, After => After_Time); Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); Close_Temp; end; -- Translate other waveform elements. We := Get_Chain (We); while We /= Null_Iir loop declare After_Time : O_Dnode; Val : Mnode; Data : Signal_Assign_Data; begin Open_Temp; After_Time := Create_Temp (Std_Time_Otype); New_Assign_Stmt (New_Obj (After_Time), Chap7.Translate_Expression (Get_Time (We), Time_Type_Definition)); Value := Get_We_Value (We); Signal_Assign_Line := Get_Line_Number (Value); if Get_Kind (Value) = Iir_Kind_Null_Literal then Val := Mnode_Null; else Val := E2M (Chap7.Translate_Expression (Value, Target_Type), Targ_Tinfo, Mode_Value); end if; Data := Signal_Assign_Data'(Expr => Val, Reject => O_Dnode_Null, After => After_Time); Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); Close_Temp; end; We := Get_Chain (We); end loop; Close_Temp; end; end Translate_Signal_Assignment_Statement; procedure Translate_Statement (Stmt : Iir) is begin New_Debug_Line_Stmt (Get_Line_Number (Stmt)); Open_Temp; case Get_Kind (Stmt) is when Iir_Kind_Return_Statement => Translate_Return_Statement (Stmt); when Iir_Kind_If_Statement => Translate_If_Statement (Stmt); when Iir_Kind_Assertion_Statement => Translate_Assertion_Statement (Stmt); when Iir_Kind_Report_Statement => Translate_Report_Statement (Stmt); when Iir_Kind_Case_Statement => Translate_Case_Statement (Stmt); when Iir_Kind_For_Loop_Statement => Translate_For_Loop_Statement (Stmt); when Iir_Kind_While_Loop_Statement => Translate_While_Loop_Statement (Stmt); when Iir_Kind_Next_Statement | Iir_Kind_Exit_Statement => Translate_Exit_Next_Statement (Stmt); when Iir_Kind_Signal_Assignment_Statement => Translate_Signal_Assignment_Statement (Stmt); when Iir_Kind_Variable_Assignment_Statement => Translate_Variable_Assignment_Statement (Stmt); when Iir_Kind_Null_Statement => -- A null statement is translated to a NOP, so that the -- statement generates code (and a breakpoint can be set on -- it). -- Emit_Nop; null; when Iir_Kind_Procedure_Call_Statement => declare Call : constant Iir := Get_Procedure_Call (Stmt); Imp : constant Iir := Get_Implementation (Call); begin Canon.Canon_Subprogram_Call (Call); if Is_Implicit_Subprogram (Imp) then Translate_Implicit_Procedure_Call (Call); else Translate_Procedure_Call (Call); end if; end; when Iir_Kind_Wait_Statement => Translate_Wait_Statement (Stmt); when others => Error_Kind ("translate_statement", Stmt); end case; Close_Temp; end Translate_Statement; procedure Translate_Statements_Chain (First : Iir) is Stmt : Iir; begin Stmt := First; while Stmt /= Null_Iir loop Translate_Statement (Stmt); Stmt := Get_Chain (Stmt); end loop; end Translate_Statements_Chain; function Translate_Statements_Chain_Has_Return (First : Iir) return Boolean is Stmt : Iir; Has_Return : Boolean := False; begin Stmt := First; while Stmt /= Null_Iir loop Translate_Statement (Stmt); if Get_Kind (Stmt) = Iir_Kind_Return_Statement then Has_Return := True; end if; Stmt := Get_Chain (Stmt); end loop; return Has_Return; end Translate_Statements_Chain_Has_Return; end Trans.Chap8;