summaryrefslogtreecommitdiff
path: root/src/vhdl/translate/trans-chap8.adb
diff options
context:
space:
mode:
authorTristan Gingold2014-11-09 18:31:54 +0100
committerTristan Gingold2014-11-09 18:31:54 +0100
commitfe94cb3cc3fd4517271faa9046c74b0c455aeb79 (patch)
tree17ba28586cb5eb22d530c568d917931f309d871f /src/vhdl/translate/trans-chap8.adb
parent3c9a77e9e6f3b8047080f7d8c11bb9881cabf968 (diff)
downloadghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.gz
ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.tar.bz2
ghdl-fe94cb3cc3fd4517271faa9046c74b0c455aeb79.zip
Split translation into child packages.
Diffstat (limited to 'src/vhdl/translate/trans-chap8.adb')
-rw-r--r--src/vhdl/translate/trans-chap8.adb2959
1 files changed, 2959 insertions, 0 deletions
diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
new file mode 100644
index 0000000..72aa77a
--- /dev/null
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -0,0 +1,2959 @@
+-- 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))));
+
+ 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 Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration
+ 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;