diff options
| author | Tristan Gingold | 2014-09-25 07:38:09 +0200 |
|---|---|---|
| committer | Tristan Gingold | 2014-09-25 07:38:09 +0200 |
| commit | 68d26922e31aad3cb34dd3b7689bcec75ad70fcb (patch) | |
| tree | ed7d40115bd74b0c4216a94bfc21d5af0837ce4f | |
| parent | 5edf93b87e8f3528d9063df08bf70bf538d72545 (diff) | |
| download | ghdl-68d26922e31aad3cb34dd3b7689bcec75ad70fcb.tar.gz ghdl-68d26922e31aad3cb34dd3b7689bcec75ad70fcb.tar.bz2 ghdl-68d26922e31aad3cb34dd3b7689bcec75ad70fcb.zip | |
Add a python script to automatically generate disp_tree.
44 files changed, 5970 insertions, 3696 deletions
@@ -81,14 +81,14 @@ package body Canon is if Get_Nbr_Elements (Get_Index_Subtype_List (Aggr_Type)) = Dim then while Assoc /= Null_Iir loop Canon_Extract_Sensitivity - (Get_Associated (Assoc), Sensitivity_List, Is_Target); + (Get_Associated_Expr (Assoc), Sensitivity_List, Is_Target); Assoc := Get_Chain (Assoc); end loop; else while Assoc /= Null_Iir loop Canon_Extract_Sensitivity_Aggregate - (Get_Associated (Assoc), Sensitivity_List, Is_Target, Aggr_Type, - Dim + 1); + (Get_Associated_Expr (Assoc), Sensitivity_List, + Is_Target, Aggr_Type, Dim + 1); Assoc := Get_Chain (Assoc); end loop; end if; @@ -270,7 +270,8 @@ package body Canon is El := Get_Association_Choices_Chain (Expr); while El /= Null_Iir loop Canon_Extract_Sensitivity - (Get_Associated (El), Sensitivity_List, Is_Target); + (Get_Associated_Expr (El), Sensitivity_List, + Is_Target); El := Get_Chain (El); end loop; when others => @@ -391,7 +392,7 @@ package body Canon is Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop Canon_Extract_Sequential_Statement_Chain_Sensitivity - (Get_Associated (Choice), List); + (Get_Associated_Chain (Choice), List); Choice := Get_Chain (Choice); end loop; end; @@ -570,10 +571,10 @@ package body Canon is | Iir_Kind_Choice_By_Name => null; when Iir_Kind_Choice_By_Expression => - Canon_Expression (Get_Expression (Assoc)); + Canon_Expression (Get_Choice_Expression (Assoc)); when Iir_Kind_Choice_By_Range => declare - Choice : constant Iir := Get_Expression (Assoc); + Choice : constant Iir := Get_Choice_Range (Assoc); begin if Get_Kind (Choice) = Iir_Kind_Range_Expression then Canon_Expression (Choice); @@ -582,7 +583,7 @@ package body Canon is when others => Error_Kind ("canon_aggregate_expression", Assoc); end case; - Canon_Expression (Get_Associated (Assoc)); + Canon_Expression (Get_Associated_Expr (Assoc)); Assoc := Get_Chain (Assoc); end loop; end Canon_Aggregate_Expression; @@ -1053,7 +1054,7 @@ package body Canon is Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop -- FIXME: canon choice expr. - Canon_Sequential_Stmts (Get_Associated (Choice)); + Canon_Sequential_Stmts (Get_Associated_Chain (Choice)); Choice := Get_Chain (Choice); end loop; end; @@ -1427,11 +1428,11 @@ package body Canon is Selected_Waveform := Get_Selected_Waveform_Chain (Conc_Stmt); Set_Case_Statement_Alternative_Chain (Case_Stmt, Selected_Waveform); while Selected_Waveform /= Null_Iir loop - Assoc := Get_Associated (Selected_Waveform); + Assoc := Get_Associated_Chain (Selected_Waveform); if Assoc /= Null_Iir then Stmt := Canon_Wave_Transform (Conc_Stmt, Assoc, Proc); Set_Parent (Stmt, Case_Stmt); - Set_Associated (Selected_Waveform, Stmt); + Set_Associated_Chain (Selected_Waveform, Stmt); end if; Selected_Waveform := Get_Chain (Selected_Waveform); end loop; @@ -2412,12 +2413,15 @@ package body Canon is Canon_Component_Specification (El, Blk); when Iir_Kind_Block_Configuration => Sub_Blk := Get_Block_Specification (El); + if Get_Kind (Sub_Blk) = Iir_Kind_Simple_Name then + Sub_Blk := Get_Named_Entity (Sub_Blk); + end if; case Get_Kind (Sub_Blk) is when Iir_Kind_Block_Statement => Set_Block_Block_Configuration (Sub_Blk, El); when Iir_Kind_Indexed_Name | Iir_Kind_Slice_Name => - Sub_Blk := Get_Prefix (Sub_Blk); + Sub_Blk := Strip_Denoting_Name (Get_Prefix (Sub_Blk)); Set_Prev_Block_Configuration (El, Get_Generate_Block_Configuration (Sub_Blk)); Set_Generate_Block_Configuration (Sub_Blk, El); @@ -2523,6 +2527,9 @@ package body Canon is Append (Last_Item, Conf, Res); elsif Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then Blk_Spec := Get_Block_Specification (Blk_Config); + if Get_Kind (Blk_Spec) = Iir_Kind_Simple_Name then + Blk_Spec := Get_Named_Entity (Blk_Spec); + end if; if Get_Kind (Blk_Spec) /= Iir_Kind_Generate_Statement then -- There are partial configurations. -- Create a default block configuration. @@ -2532,7 +2539,7 @@ package body Canon is Blk_Spec := Create_Iir (Iir_Kind_Selected_Name); Location_Copy (Blk_Spec, Res); Set_Identifier (Blk_Spec, Std_Names.Name_Others); - Set_Prefix (Blk_Spec, El); + Set_Prefix (Blk_Spec, Build_Simple_Name (El, Res)); Set_Block_Specification (Res, Blk_Spec); Append (Last_Item, Conf, Res); end if; diff --git a/disp_tree.adb b/disp_tree.adb index 1bd6cd1..06f0b50 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -20,6 +20,7 @@ with Ada.Text_IO; use Ada.Text_IO; with Name_Table; +with Str_Table; with Tokens; with Errorout; with Files_Map; @@ -27,78 +28,84 @@ with PSL.Dump_Tree; -- Do not add a use clause for iirs_utils, as it may crash for ill-formed -- trees, which is annoying while debugging. -with Iirs_Utils; package body Disp_Tree is - function Is_Anonymous_Type_Definition (Def : Iir) return Boolean - renames Iirs_Utils.Is_Anonymous_Type_Definition; + -- function Is_Anonymous_Type_Definition (Def : Iir) return Boolean + -- renames Iirs_Utils.Is_Anonymous_Type_Definition; - procedure Disp_Tab (Tab: Natural) is - Blanks : constant String (1 .. Tab) := (others => ' '); + procedure Disp_Iir (N : Iir; + Indent : Natural := 1; + Flat : Boolean := False); + procedure Disp_Header (N : Iir); + + procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural); + pragma Unreferenced (Disp_Tree_List_Flat); + + procedure Put_Indent (Tab: Natural) is + Blanks : constant String (1 .. 2 * Tab) := (others => ' '); begin Put (Blanks); - end Disp_Tab; + end Put_Indent; - procedure Disp_Iir_Address (Node: Iir) + procedure Disp_Iir_Number (Node: Iir) is - Res : String (1 .. 10); - Hex_Digits : constant array (Int32 range 0 .. 15) of Character - := "0123456789abcdef"; + Res : String (1 .. 10) := " ]"; N : Int32 := Int32 (Node); begin for I in reverse 2 .. 9 loop - Res (I) := Hex_Digits (N mod 16); - N := N / 16; + Res (I) := Character'Val (Character'Pos ('0') + (N mod 10)); + N := N / 10; + if N = 0 then + Res (I - 1) := '['; + Put (Res (I - 1 .. Res'Last)); + return; + end if; end loop; - Res (1) := '['; - Res (10) := ']'; Put (Res); - end Disp_Iir_Address; - - function Inc_Tab (Tab: Natural) return Natural is - begin - return Tab + 4; - end Inc_Tab; - + end Disp_Iir_Number; -- For iir. - procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural); + procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural) is + begin + Disp_Iir (Tree, Tab, True); + end Disp_Tree_Flat; - procedure Disp_Tree_List - (Tree_List: Iir_List; Tab: Natural; Flat_Decl : Boolean := False) + procedure Disp_Iir_List + (Tree_List : Iir_List; Tab : Natural := 0; Flat : Boolean := False) is El: Iir; begin if Tree_List = Null_Iir_List then - Disp_Tab (Tab); - Put_Line (" null-list"); + Put_Line ("null-list"); elsif Tree_List = Iir_List_All then - Disp_Tab (Tab); - Put_Line (" list-all"); + Put_Line ("list-all"); elsif Tree_List = Iir_List_Others then - Disp_Tab (Tab); - Put_Line (" list-others"); + Put_Line ("list-others"); else + New_Line; for I in Natural loop El := Get_Nth_Element (Tree_List, I); exit when El = Null_Iir; - Disp_Tree (El, Tab, Flat_Decl); + Put_Indent (Tab); + Disp_Iir (El, Tab + 1, Flat); end loop; end if; - end Disp_Tree_List; + end Disp_Iir_List; - procedure Disp_Tree_Chain - (Tree_Chain: Iir; Tab: Natural; Flat_Decl : Boolean := False) + procedure Disp_Chain + (Tree_Chain: Iir; Indent: Natural; Flat : Boolean := False) is El: Iir; begin + New_Line; El := Tree_Chain; while El /= Null_Iir loop - Disp_Tree (El, Tab, Flat_Decl); + Put_Indent (Indent); + Disp_Iir (El, Indent + 1, Flat); El := Get_Chain (El); end loop; - end Disp_Tree_Chain; + end Disp_Chain; procedure Disp_Tree_Flat_Chain (Tree_Chain: Iir; Tab: Natural) is @@ -106,23 +113,24 @@ package body Disp_Tree is begin El := Tree_Chain; while El /= Null_Iir loop - Disp_Tree_Flat (El, Tab); + Disp_Iir (El, Tab, True); El := Get_Chain (El); end loop; end Disp_Tree_Flat_Chain; + pragma Unreferenced (Disp_Tree_Flat_Chain); procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural) is El: Iir; begin if Tree_List = Null_Iir_List then - Disp_Tab (Tab); + Put_Indent (Tab); Put_Line (" null-list"); elsif Tree_List = Iir_List_All then - Disp_Tab (Tab); + Put_Indent (Tab); Put_Line (" list-all"); elsif Tree_List = Iir_List_Others then - Disp_Tab (Tab); + Put_Indent (Tab); Put_Line (" list-others"); else for I in Natural loop @@ -133,1793 +141,3110 @@ package body Disp_Tree is end if; end Disp_Tree_List_Flat; - procedure Disp_Ident (Ident: Name_Id) + function Image_Name_Id (Ident: Name_Id) return String is use Name_Table; begin if Ident /= Null_Identifier then Image (Ident); - Put_Line (" '" & Name_Buffer (1 .. Name_Length) & '''); + return ''' & Name_Buffer (1 .. Name_Length) & '''; else - Put_Line (" <anonymous>"); + return "<anonymous>"; end if; - end Disp_Ident; - - procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural) - is - procedure Disp_Identifier (Identifying: Iir) - is - Ident : Name_Id; - begin - if Identifying /= Null_Iir then - Ident := Get_Identifier (Identifying); - Disp_Ident (Ident); - else - New_Line; - end if; - end Disp_Identifier; + end Image_Name_Id; - procedure Disp_Decl_Ident - is - A_Type: Iir; - begin - A_Type := Get_Type_Declarator (Tree); - if A_Type /= Null_Iir then - Disp_Identifier (A_Type); - else - Put_Line (" <unnamed>"); - return; - end if; - end Disp_Decl_Ident; - begin - Disp_Tab (Tab); - Disp_Iir_Address (Tree); - - if Tree = Null_Iir then - Put_Line (" *NULL*"); - return; - else - Put (' '); - end if; - - case Get_Kind (Tree) is - when Iir_Kind_Design_File => - Put_Line ("design file"); - - when Iir_Kind_Design_Unit => - Put ("design_unit"); - Disp_Identifier (Tree); - - when Iir_Kind_Use_Clause => - Put_Line ("use_clause"); - - when Iir_Kind_Library_Clause => - Put ("library clause"); - Disp_Identifier (Tree); - - when Iir_Kind_Library_Declaration => - Put ("library declaration"); - Disp_Identifier (Tree); - - when Iir_Kind_Waveform_Element => - Put_Line ("waveform_element"); - - when Iir_Kind_Package_Declaration => - Put ("package_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Package_Body => - Put ("package_body"); - Disp_Identifier (Tree); - when Iir_Kind_Entity_Declaration => - Put ("entity_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Architecture_Body => - Put ("architecture_body"); - Disp_Identifier (Tree); - when Iir_Kind_Configuration_Declaration => - Put ("configuration_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Function_Declaration => - Put ("function_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Function_Body => - Put_Line ("function_body"); - when Iir_Kind_Procedure_Declaration => - Put ("procedure_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Procedure_Body => - Put_Line ("procedure_body"); - when Iir_Kind_Object_Alias_Declaration => - Put ("object_alias_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Non_Object_Alias_Declaration => - Put ("non_object_alias_declaration"); - Disp_Identifier (Tree); - - when Iir_Kind_Signal_Interface_Declaration => - Put ("signal_interface_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Signal_Declaration => - Put ("signal_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Variable_Interface_Declaration => - Put ("variable_interface_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Variable_Declaration => - if Get_Shared_Flag (Tree) then - Put ("(shared) "); - end if; - Put ("variable_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Constant_Interface_Declaration => - Put ("constant_interface_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Constant_Declaration => - Put ("constant_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Iterator_Declaration => - Put ("iterator_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_File_Interface_Declaration => - Put ("file_interface_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_File_Declaration => - Put ("file_declaration"); - Disp_Identifier (Tree); - - when Iir_Kind_Type_Declaration => - Put ("type_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Anonymous_Type_Declaration => - Put ("anonymous_type_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Subtype_Declaration => - Put ("subtype_declaration"); - Disp_Identifier (Tree); - - when Iir_Kind_Nature_Declaration => - Put ("nature_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Subnature_Declaration => - Put ("subnature_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Terminal_Declaration => - Put ("terminal_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Through_Quantity_Declaration => - Put ("through_quantity_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Across_Quantity_Declaration => - Put ("across_quantity_declaration"); - Disp_Identifier (Tree); - - when Iir_Kind_Component_Declaration => - Put ("component_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Element_Declaration => - Put ("element_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Record_Element_Constraint => - Put ("record_element_constraint"); - Disp_Identifier (Tree); - when Iir_Kind_Attribute_Declaration => - Put ("attribute_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Group_Template_Declaration => - Put ("group_template_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Group_Declaration => - Put ("group_declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Psl_Declaration => - Put ("psl declaration"); - Disp_Identifier (Tree); - when Iir_Kind_Psl_Expression => - Put ("psl expression"); - - when Iir_Kind_Enumeration_Type_Definition => - Put ("enumeration_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_Enumeration_Subtype_Definition => - Put ("enumeration_subtype_definition"); - Disp_Decl_Ident; - when Iir_Kind_Integer_Subtype_Definition => - Put ("integer_subtype_definition"); - Disp_Decl_Ident; - when Iir_Kind_Integer_Type_Definition => - Put ("integer_type_definition"); - Disp_Identifier (Get_Type_Declarator (Tree)); - when Iir_Kind_Floating_Subtype_Definition => - Put ("floating_subtype_definition"); - Disp_Decl_Ident; - when Iir_Kind_Floating_Type_Definition => - Put ("floating_type_definition"); - Disp_Identifier (Get_Type_Declarator (Tree)); - when Iir_Kind_Array_Subtype_Definition => - Put ("array_subtype_definition"); - Disp_Decl_Ident; - when Iir_Kind_Array_Type_Definition => - Put ("array_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_Record_Type_Definition => - Put ("record_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_Access_Type_Definition => - Put ("access_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_File_Type_Definition => - Put ("file_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_Subtype_Definition => - Put_Line ("subtype_definition"); - when Iir_Kind_Physical_Type_Definition => - Put ("physical_type_definition"); - Disp_Decl_Ident; - when Iir_Kind_Physical_Subtype_Definition => - Put_Line ("physical_subtype_definition"); - when Iir_Kind_Protected_Type_Declaration => - Put ("protected_type_declaration"); - Disp_Decl_Ident; - - when Iir_Kind_Scalar_Nature_Definition => - Put ("scalar_nature_definition"); - Disp_Identifier (Get_Nature_Declarator (Tree)); - - when Iir_Kind_Simple_Name => - Put ("simple_name "); - Disp_Identifier (Tree); - - when Iir_Kind_Operator_Symbol => - Put ("operator_symbol """); - Name_Table.Image (Get_Identifier (Tree)); - Put (Name_Table.Name_Buffer (1 .. Name_Table.Name_Length)); - Put_Line (""""); - - when Iir_Kind_Null_Literal => - Put_Line ("null_literal"); - - when Iir_Kind_Physical_Int_Literal => - Put_Line ("physical_int_literal"); - - when Iir_Kind_Physical_Fp_Literal => - Put_Line ("physical_fp_literal"); - - when Iir_Kind_Component_Instantiation_Statement => - Put ("component_instantiation_statement"); - Disp_Ident (Get_Label (Tree)); - when Iir_Kind_Block_Statement => - Put ("block_statement"); - Disp_Ident (Get_Label (Tree)); - when Iir_Kind_Sensitized_Process_Statement => - Put ("sensitized_process_statement"); - Disp_Ident (Get_Label (Tree)); - when Iir_Kind_Process_Statement => - Put ("process_statement"); - Disp_Ident (Get_Label (Tree)); - when Iir_Kind_Case_Statement => - Put_Line ("case_statement"); - when Iir_Kind_If_Statement => - Put_Line ("if_statement"); - when Iir_Kind_Elsif => - Put_Line ("Elsif"); - when Iir_Kind_For_Loop_Statement => - Put_Line ("for_loop_statement"); - when Iir_Kind_While_Loop_Statement => - Put_Line ("while_loop_statement"); - when Iir_Kind_Exit_Statement => - Put_Line ("exit_statement"); - when Iir_Kind_Next_Statement => - Put_Line ("next_statement"); - when Iir_Kind_Wait_Statement => - Put_Line ("wait_statement"); - when Iir_Kind_Assertion_Statement => - Put_Line ("assertion_statement"); - when Iir_Kind_Variable_Assignment_Statement => - Put_Line ("variable_assignment_statement"); - when Iir_Kind_Signal_Assignment_Statement => - Put_Line ("signal_assignment_statement"); - when Iir_Kind_Concurrent_Assertion_Statement => - Put_Line ("concurrent_assertion_statement"); - when Iir_Kind_Procedure_Call_Statement => - Put_Line ("procedure_call_statement"); - when Iir_Kind_Concurrent_Procedure_Call_Statement => - Put_Line ("concurrent_procedure_call_statement"); - when Iir_Kind_Return_Statement => - Put_Line ("return_statement"); - when Iir_Kind_Null_Statement => - Put_Line ("null_statement"); - - when Iir_Kind_Enumeration_Literal => - Put ("enumeration_literal"); - Disp_Identifier (Tree); - - when Iir_Kind_Character_Literal => - Put_Line ("character_literal"); - when Iir_Kind_Integer_Literal => - Put_Line ("integer_literal: " - & Iir_Int64'Image (Get_Value (Tree))); - when Iir_Kind_Floating_Point_Literal => - Put_Line ("floating_point_literal: " - & Iir_Fp64'Image (Get_Fp_Value (Tree))); - when Iir_Kind_String_Literal => - Put_Line ("string_literal: " & Iirs_Utils.Image_String_Lit (Tree)); - when Iir_Kind_Unit_Declaration => - Put ("physical unit"); - Disp_Identifier (Tree); - when Iir_Kind_Entity_Class => - Put_Line ("entity_class '" - & Tokens.Image (Get_Entity_Class (Tree)) & '''); - - when Iir_Kind_Attribute_Name => - Put ("attribute_name"); - Disp_Ident (Get_Identifier (Tree)); - - when Iir_Kind_Implicit_Function_Declaration => - Put ("implicit_function_declaration: "); - Put_Line (Iirs_Utils.Get_Predefined_Function_Name - (Get_Implicit_Definition (Tree))); - when Iir_Kind_Implicit_Procedure_Declaration => - Put ("implicit_procedure_declaration: "); - Put_Line (Iirs_Utils.Get_Predefined_Function_Name - (Get_Implicit_Definition (Tree))); - - when others => - Put_Line (Iir_Kind'Image (Get_Kind (Tree))); - end case; - end Disp_Tree_Flat; - - procedure Disp_Staticness (Static: Iir_Staticness) is + function Image_Iir_Staticness (Static: Iir_Staticness) return String is begin case Static is when Unknown => - Put ("???"); + return "???"; when None => - Put ("none"); + return "none"; when Globally => - Put ("global"); + return "global"; when Locally => - Put ("local"); + return "local"; end case; - end Disp_Staticness; + end Image_Iir_Staticness; - procedure Disp_Flag (Bool : Boolean) is + function Image_Boolean (Bool : Boolean) return String is begin if Bool then - Put ("true"); + return "true"; else - Put ("false"); + return "false"; end if; - New_Line; - end Disp_Flag; + end Image_Boolean; - procedure Disp_Expr_Staticness (Expr: Iir) is + function Image_Iir_Delay_Mechanism (Mech : Iir_Delay_Mechanism) + return String is begin - Put (" expr: "); - Disp_Staticness (Get_Expr_Staticness (Expr)); - New_Line; - end Disp_Expr_Staticness; - - procedure Disp_Type_Staticness (Atype: Iir) is - begin - Put (" type: "); - Disp_Staticness (Get_Type_Staticness (Atype)); - New_Line; - end Disp_Type_Staticness; - - procedure Disp_Name_Staticness (Expr: Iir) is - begin - Put (" expr: "); - Disp_Staticness (Get_Expr_Staticness (Expr)); - Put (", name: "); - Disp_Staticness (Get_Name_Staticness (Expr)); - New_Line; - end Disp_Name_Staticness; - - procedure Disp_Choice_Staticness (Expr: Iir) is - begin - Put (" choice: "); - Disp_Staticness (Get_Choice_Staticness (Expr)); - New_Line; - end Disp_Choice_Staticness; + case Mech is + when Iir_Inertial_Delay => + return "inertial"; + when Iir_Transport_Delay => + return "transport"; + end case; + end Image_Iir_Delay_Mechanism; - procedure Disp_Type_Resolved_Flag (Atype : Iir) is + function Image_Iir_Lexical_Layout_Type (V : Iir_Lexical_Layout_Type) + return String is begin - if Get_Resolved_Flag (Atype) then - Put_Line ("resolved"); + if (V and Iir_Lexical_Has_Mode) /= 0 then + return " +mode" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Mode); + elsif (V and Iir_Lexical_Has_Class) /= 0 then + return " +class" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Class); + elsif (V and Iir_Lexical_Has_Type) /= 0 then + return " +type" + & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Type); else - New_Line; + return ""; end if; - end Disp_Type_Resolved_Flag; + end Image_Iir_Lexical_Layout_Type; - procedure Disp_Lexical_Layout (Decl : Iir) - is - V : Iir_Lexical_Layout_Type; + function Image_Iir_Mode (Mode : Iir_Mode) return String is begin - V := Get_Lexical_Layout (Decl); - if (V and Iir_Lexical_Has_Mode) /= 0 then - Put (" +mode"); - end if; - if (V and Iir_Lexical_Has_Class) /= 0 then - Put (" +class"); - end if; - if (V and Iir_Lexical_Has_Type) /= 0 then - Put (" +type"); - end if; - New_Line; - end Disp_Lexical_Layout; + case Mode is + when Iir_Unknown_Mode => + return "???"; + when Iir_Linkage_Mode => + return "linkage"; + when Iir_Buffer_Mode => + return "buffer"; + when Iir_Out_Mode => + return "out"; + when Iir_Inout_Mode => + return "inout"; + when Iir_In_Mode => + return "in"; + end case; + end Image_Iir_Mode; - procedure Disp_Purity_State (State : Iir_Pure_State) - is + function Image_Iir_Signal_Kind (Kind : Iir_Signal_Kind) return String is + begin + case Kind is + when Iir_No_Signal_Kind => + return "no"; + when Iir_Register_Kind => + return "register"; + when Iir_Bus_Kind => + return "bus"; + end case; + end Image_Iir_Signal_Kind; + + function Image_Iir_Pure_State (State : Iir_Pure_State) return String is begin case State is when Pure => - Put (" pure"); + return "pure"; when Impure => - Put (" impure"); + return "impure"; when Maybe_Impure => - Put (" maybe_impure"); + return "maybe_impure"; when Unknown => - Put (" unknown"); + return "unknown"; end case; - New_Line; - end Disp_Purity_State; + end Image_Iir_Pure_State; - procedure Disp_State (State : Tri_State_Type) - is + function Image_Iir_All_Sensitized (Sig : Iir_All_Sensitized) + return String is + begin + case Sig is + when Unknown => + return "???"; + when No_Signal => + return "no_signal"; + when Read_Signal => + return "read_signal"; + when Invalid_Signal => + return "invalid_signal"; + end case; + end Image_Iir_All_Sensitized; + + function Image_Iir_Constraint (Const : Iir_Constraint) return String is + begin + case Const is + when Unconstrained => + return "unconstrained"; + when Partially_Constrained => + return "partially constrained"; + when Fully_Constrained => + return "fully constrained"; + end case; + end Image_Iir_Constraint; + + function Image_Date_State_Type (State : Date_State_Type) return String is + begin + case State is + when Date_Extern => + return "extern"; + when Date_Disk => + return "disk"; + when Date_Parse => + return "parse"; + when Date_Analyze => + return "analyze"; + end case; + end Image_Date_State_Type; + + function Image_Tri_State_Type (State : Tri_State_Type) return String is begin case State is when True => - Put (" true"); + return "true"; when False => - Put (" false"); + return "false"; when Unknown => - Put (" unknown"); + return "unknown"; end case; - New_Line; - end Disp_State; + end Image_Tri_State_Type; + + function Image_Time_Stamp_Id (Id : Time_Stamp_Id) return String + renames Files_Map.Get_Time_Stamp_String; - procedure Disp_Depth (Depth : Iir_Int32) is + function Image_Iir_Predefined_Functions (F : Iir_Predefined_Functions) + return String is begin - Put (Iir_Int32'Image (Depth)); - New_Line; - end Disp_Depth; + return Iir_Predefined_Functions'Image (F); + end Image_Iir_Predefined_Functions; - procedure Disp_Tree (Tree: Iir; - Tab: Natural := 0; - Flat_Decl: Boolean := false) is - Ntab: constant Natural := Inc_Tab (Tab); - Kind : Iir_Kind; + function Image_String_Id (S : String_Id) return String + renames Str_Table.Image; - procedure Header (Str: String; Nl: Boolean := true) is - begin - Disp_Tab (Ntab); - Put (Str); - if Nl then - New_Line; - end if; - end Header; + procedure Disp_PSL_Node (N : PSL_Node; Indent : Natural) is + begin + Put_Indent (Indent); + PSL.Dump_Tree.Dump_Tree (N, True); + end Disp_PSL_Node; - procedure Disp_Label (Tree: Iir)is - Label : Name_Id; - begin - Label := Get_Label (Tree); - if Label /= Null_Identifier then - Header ("label: " & Name_Table.Image (Label)); - else - Header ("label: -"); - end if; - end Disp_Label; + procedure Disp_PSL_NFA (N : PSL_NFA; Indent : Natural) is begin - Disp_Tree_Flat (Tree, Tab); - if Tree = Null_Iir then - return; - end if; + null; + end Disp_PSL_NFA; - if Get_Location (Tree) /= Location_Nil then - Header ("loc: " & Errorout.Get_Location_Str (Get_Location (Tree))); - end if; - if False then - Header ("parent:"); - Disp_Tree_Flat (Get_Parent (Tree), Ntab); - end if; + function Image_Location_Type (Loc : Location_Type) return String is + begin + return Errorout.Get_Location_Str (Loc); + end Image_Location_Type; - Kind := Get_Kind (Tree); - case Kind is - when Iir_Kind_Overload_List => - Header ("overload_list"); - Disp_Tree_List (Get_Overload_List (Tree), Ntab, Flat_Decl); + function Image_Iir_Direction (Dir : Iir_Direction) return String is + begin + case Dir is + when Iir_To => + return "to"; + when Iir_Downto => + return "downto"; + end case; + end Image_Iir_Direction; - when Iir_Kind_Error => - null; + function Image_Token_Type (Tok : Tokens.Token_Type) return String + renames Tokens.Image; - when Iir_Kind_Design_File => - Header ("design_file_filename: " - & Name_Table.Image (Get_Design_File_Filename (Tree))); - Header ("design_file_directory: " - & Name_Table.Image (Get_Design_File_Directory (Tree))); - Header ("analysis_time_stamp: " - & Files_Map.Get_Time_Stamp_String - (Get_Analysis_Time_Stamp (Tree))); - Header ("file_time_stamp: " - & Files_Map.Get_Time_Stamp_String - (Get_File_Time_Stamp (Tree))); - Header ("library:"); - Disp_Tree_Flat (Get_Parent (Tree), Ntab); - Header ("design_unit_chain:"); - Disp_Tree_Chain (Get_First_Design_Unit (Tree), Ntab, Flat_Decl); + procedure Header (Str : String; Indent : Natural) is + begin + Put_Indent (Indent); + Put (Str); + end Header; + -- Subprograms + procedure Disp_Header (N : Iir) is + begin + if N = Null_Iir then + Put_Line ("*null*"); + return; + end if; + + case Get_Kind (N) is + when Iir_Kind_Unused => + Put ("unused"); + when Iir_Kind_Error => + Put ("error"); + when Iir_Kind_Design_File => + Put ("design_file"); when Iir_Kind_Design_Unit => - if Flat_Decl then - return; - end if; - Header ("flags: date_state: " - & Date_State_Type'Image (Get_Date_State (Tree)) - & ", elab: " - & Boolean'Image (Get_Elab_Flag (Tree))); - Header ("date:" & Date_Type'Image (Get_Date (Tree))); - Header ("parent (design file):"); - Disp_Tree_Flat (Get_Design_File (Tree), Ntab); - Header ("dependence list:"); - Disp_Tree_List_Flat (Get_Dependence_List (Tree), Ntab); - if Get_Date_State (Tree) /= Date_Disk then - Header ("context items:"); - Disp_Tree_Chain (Get_Context_Items (Tree), Ntab); - end if; - Header ("library unit:"); - Disp_Tree (Get_Library_Unit (Tree), Ntab); - when Iir_Kind_Use_Clause => - Header ("selected name:"); - Disp_Tree (Get_Selected_Name (Tree), Ntab, True); - Header ("use_clause_chain:"); - Disp_Tree (Get_Use_Clause_Chain (Tree), Ntab); + Put ("design_unit " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Library_Clause => - Header ("library declaration:"); - Disp_Tree_Flat (Get_Library_Declaration (Tree), Ntab); - - when Iir_Kind_Library_Declaration => - if Flat_Decl then - return; - end if; - Header ("library_directory: " - & Name_Table.Image (Get_Library_Directory (Tree))); - Header ("design file list:"); - Disp_Tree_Chain (Get_Design_File_Chain (Tree), Ntab); - - when Iir_Kind_Entity_Declaration => - Header ("generic chain:"); - Disp_Tree_Chain (Get_Generic_Chain (Tree), Ntab); - Header ("port chain:"); - Disp_Tree_Chain (Get_Port_Chain (Tree), Ntab); - Header ("declaration chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("concurrent_statements:"); - Disp_Tree_Chain (Get_Concurrent_Statement_Chain (Tree), Ntab); - when Iir_Kind_Package_Declaration => - if Flat_Decl then - return; - end if; - Header ("need_body: " & Boolean'Image (Get_Need_Body (Tree))); - Header ("declaration chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - when Iir_Kind_Package_Body => - Header ("package:"); - Disp_Tree_Flat (Get_Package (Tree), Ntab); - Header ("declaration:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - when Iir_Kind_Package_Header => - Header ("generic chain:"); - Disp_Tree_Chain (Get_Generic_Chain (Tree), Ntab); - Header ("generic map aspect chain:"); - Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); - when Iir_Kind_Architecture_Body => - if Flat_Decl then - return; - end if; - Header ("entity_name:"); - Disp_Tree (Get_Entity_Name (Tree), Ntab, True); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("concurrent_statements:"); - Disp_Tree_Chain (Get_Concurrent_Statement_Chain (Tree), Ntab); - Header ("default configuration:"); - Disp_Tree_Flat - (Get_Default_Configuration_Declaration (Tree), Ntab); - when Iir_Kind_Configuration_Declaration => - Header ("entity_Name:"); - Disp_Tree_Flat (Get_Entity_Name (Tree), Ntab); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("block_configuration:"); - Disp_Tree (Get_Block_Configuration (Tree), Ntab, True); - - when Iir_Kind_Package_Instantiation_Declaration => - if Flat_Decl then - return; - end if; - Header ("uninstantiated_name:"); - Disp_Tree_Flat (Get_Uninstantiated_Name (Tree), Ntab); - Header ("generic map aspect chain:"); - Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); - + Put ("library_clause " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Use_Clause => + Put ("use_clause"); + when Iir_Kind_Integer_Literal => + Put ("integer_literal"); + when Iir_Kind_Floating_Point_Literal => + Put ("floating_point_literal"); + when Iir_Kind_Null_Literal => + Put ("null_literal"); + when Iir_Kind_String_Literal => + Put ("string_literal"); + when Iir_Kind_Physical_Int_Literal => + Put ("physical_int_literal"); + when Iir_Kind_Physical_Fp_Literal => + Put ("physical_fp_literal"); + when Iir_Kind_Bit_String_Literal => + Put ("bit_string_literal"); + when Iir_Kind_Simple_Aggregate => + Put ("simple_aggregate"); + when Iir_Kind_Overflow_Literal => + Put ("overflow_literal"); + when Iir_Kind_Waveform_Element => + Put ("waveform_element"); + when Iir_Kind_Conditional_Waveform => + Put ("conditional_waveform"); + when Iir_Kind_Association_Element_By_Expression => + Put ("association_element_by_expression"); + when Iir_Kind_Association_Element_By_Individual => + Put ("association_element_by_individual"); + when Iir_Kind_Association_Element_Open => + Put ("association_element_open"); + when Iir_Kind_Choice_By_Others => + Put ("choice_by_others"); + when Iir_Kind_Choice_By_Expression => + Put ("choice_by_expression"); + when Iir_Kind_Choice_By_Range => + Put ("choice_by_range"); + when Iir_Kind_Choice_By_None => + Put ("choice_by_none"); + when Iir_Kind_Choice_By_Name => + Put ("choice_by_name"); when Iir_Kind_Entity_Aspect_Entity => - Header ("entity_name:"); - Disp_Tree_Flat (Get_Entity_Name (Tree), Ntab); - Header ("architecture:"); - Disp_Tree_Flat (Get_Architecture (Tree), Ntab); + Put ("entity_aspect_entity"); when Iir_Kind_Entity_Aspect_Configuration => - Header ("configuration:"); - Disp_Tree (Get_Configuration_Name (Tree), Ntab, True); + Put ("entity_aspect_configuration"); when Iir_Kind_Entity_Aspect_Open => - null; - + Put ("entity_aspect_open"); when Iir_Kind_Block_Configuration => - Header ("block_specification:"); - Disp_Tree (Get_Block_Specification (Tree), Ntab, True); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("configuration_item_chain:"); - Disp_Tree_Chain (Get_Configuration_Item_Chain (Tree), Ntab); - Header ("prev_block_configuration:"); - Disp_Tree_Flat (Get_Prev_Block_Configuration (Tree), Ntab); - when Iir_Kind_Attribute_Specification => - Header ("attribute_designator:"); - Disp_Tree (Get_Attribute_Designator (Tree), Ntab, True); - Header ("entity_name_list:"); - Disp_Tree_List_Flat (Get_Entity_Name_List (Tree), Ntab); - Header ("entity_class: " - & Tokens.Image (Get_Entity_Class (Tree))); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab); - Header ("attribute_value_spec_chain:"); - Disp_Tree_Chain (Get_Attribute_Value_Spec_Chain (Tree), Ntab); - when Iir_Kind_Configuration_Specification - | Iir_Kind_Component_Configuration => - Header ("instantiation_list:"); - Disp_Tree_List_Flat (Get_Instantiation_List (Tree), Ntab); - Header ("component_name:"); - Disp_Tree (Get_Component_Name (Tree), Ntab, True); - Header ("binding_indication:"); - Disp_Tree (Get_Binding_Indication (Tree), Ntab); - if Kind = Iir_Kind_Component_Configuration then - Header ("block_configuration:"); - Disp_Tree (Get_Block_Configuration (Tree), Ntab); - end if; - when Iir_Kind_Binding_Indication => - Header ("entity_aspect:"); - Disp_Tree (Get_Entity_Aspect (Tree), Ntab, True); - Header ("generic_map_aspect_chain:"); - Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); - Header ("port_map_aspect_chain:"); - Disp_Tree_Chain (Get_Port_Map_Aspect_Chain (Tree), Ntab); - Header ("default_generic_map_aspect_chain:"); - Disp_Tree_Chain - (Get_Default_Generic_Map_Aspect_Chain (Tree), Ntab); - Header ("default_port_map_aspect_chain:"); - Disp_Tree_Chain (Get_Default_Port_Map_Aspect_Chain (Tree), Ntab); + Put ("block_configuration"); when Iir_Kind_Block_Header => - Header ("generic chain:"); - Disp_Tree_Chain (Get_Generic_Chain (Tree), Ntab); - Header ("generic_map_aspect_chain:"); - Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); - Header ("port chain:"); - Disp_Tree_Chain (Get_Port_Chain (Tree), Ntab); - Header ("port_map_aspect_chain:"); - Disp_Tree_Chain (Get_Port_Map_Aspect_Chain (Tree), Ntab); + Put ("block_header"); + when Iir_Kind_Component_Configuration => + Put ("component_configuration"); + when Iir_Kind_Binding_Indication => + Put ("binding_indication"); + when Iir_Kind_Entity_Class => + Put ("entity_class"); when Iir_Kind_Attribute_Value => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("attribute_specification:"); - Disp_Tree_Flat (Get_Attribute_Specification (Tree), Ntab); - Header ("designated_entity:"); - Disp_Tree_Flat (Get_Designated_Entity (Tree), Ntab); + Put ("attribute_value"); when Iir_Kind_Signature => - Header ("return_type:"); - Disp_Tree_Flat (Get_Return_Type (Tree), Ntab); - Header ("type_marks_list:"); - Disp_Tree_List (Get_Type_Marks_List (Tree), Ntab); + Put ("signature"); + when Iir_Kind_Aggregate_Info => + Put ("aggregate_info"); + when Iir_Kind_Procedure_Call => + Put ("procedure_call"); + when Iir_Kind_Record_Element_Constraint => + Put ("record_element_constraint " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Attribute_Specification => + Put ("attribute_specification"); when Iir_Kind_Disconnection_Specification => - Header ("signal_list:"); - Disp_Tree_List (Get_Signal_List (Tree), Ntab, True); - Header ("type_mark:"); - Disp_Tree (Get_Type_Mark (Tree), Ntab, True); - Header ("time expression:"); - Disp_Tree (Get_Expression (Tree), Ntab); - - when Iir_Kind_Association_Element_By_Expression => - Header ("whole_association_flag: ", False); - Disp_Flag (Get_Whole_Association_Flag (Tree)); - Header ("collapse_signal_flag: ", False); - Disp_Flag (Get_Collapse_Signal_Flag (Tree)); - Header ("formal:"); - Disp_Tree (Get_Formal (Tree), Ntab, True); - Header ("out_conversion:"); - Disp_Tree (Get_Out_Conversion (Tree), Ntab, True); - Header ("actual:"); - Disp_Tree (Get_Actual (Tree), Ntab, True); - Header ("in_conversion:"); - Disp_Tree (Get_In_Conversion (Tree), Ntab, True); - when Iir_Kind_Association_Element_By_Individual => - Header ("whole_association_flag: ", False); - Disp_Flag (Get_Whole_Association_Flag (Tree)); - Header ("formal:"); - Disp_Tree (Get_Formal (Tree), Ntab, True); - Header ("actual_type:"); - Disp_Tree (Get_Actual_Type (Tree), Ntab, True); - Header ("individual_association_chain:"); - Disp_Tree_Chain (Get_Individual_Association_Chain (Tree), Ntab); - when Iir_Kind_Association_Element_Open => - Header ("formal:"); - Disp_Tree (Get_Formal (Tree), Ntab, True); - - when Iir_Kind_Waveform_Element => - Header ("value:"); - Disp_Tree (Get_We_Value (Tree), Ntab, True); - Header ("time:"); - Disp_Tree (Get_Time (Tree), Ntab); - when Iir_Kind_Conditional_Waveform => - Header ("condition:"); - Disp_Tree (Get_Condition (Tree), Ntab); - Header ("waveform_chain:"); - Disp_Tree_Chain (Get_Waveform_Chain (Tree), Ntab); - - when Iir_Kind_Choice_By_Name => - Header ("name:"); - Disp_Tree (Get_Name (Tree), Ntab); - Header ("associated:"); - Disp_Tree (Get_Associated (Tree), Ntab, True); - Header ("same_alternative_flag: ", False); - Disp_Flag (Get_Same_Alternative_Flag (Tree)); - when Iir_Kind_Choice_By_Others => - Header ("associated"); - Disp_Tree (Get_Associated (Tree), Ntab, True); - Header ("same_alternative_flag: ", False); - Disp_Flag (Get_Same_Alternative_Flag (Tree)); - when Iir_Kind_Choice_By_None => - Header ("associated"); - Disp_Tree (Get_Associated (Tree), Ntab, True); - Header ("same_alternative_flag: ", False); - Disp_Flag (Get_Same_Alternative_Flag (Tree)); - when Iir_Kind_Choice_By_Range => - Header ("staticness: ", False); - Disp_Choice_Staticness (Tree); - Header ("range:"); - Disp_Tree (Get_Expression (Tree), Ntab); - Header ("associated"); - Disp_Tree (Get_Associated (Tree), Ntab, True); - Header ("same_alternative_flag: ", False); - Disp_Flag (Get_Same_Alternative_Flag (Tree)); - when Iir_Kind_Choice_By_Expression => - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab); - Header ("staticness: ", False); - Disp_Choice_Staticness (Tree); - Header ("associated"); - Disp_Tree (Get_Associated (Tree), Ntab, True); - Header ("same_alternative_flag: ", False); - Disp_Flag (Get_Same_Alternative_Flag (Tree)); - - when Iir_Kind_Signal_Interface_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Name_Staticness (Tree); - Header ("lexical layout:", False); - Disp_Lexical_Layout (Tree); - Header ("mode: " & Iir_Mode'Image (Get_Mode (Tree))); - Header ("signal kind: " - & Iir_Signal_Kind'Image (Get_Signal_Kind (Tree))); - Header ("has_active_flag: ", False); - Disp_Flag (Get_Has_Active_Flag (Tree)); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Variable_Interface_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Name_Staticness (Tree); - Header ("lexical layout:", False); - Disp_Lexical_Layout (Tree); - Header ("mode: " & Iir_Mode'Image (Get_Mode (Tree))); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Constant_Interface_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Name_Staticness (Tree); - Header ("lexical layout:", False); - Disp_Lexical_Layout (Tree); - Header ("mode: " & Iir_Mode'Image (Get_Mode (Tree))); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_File_Interface_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Name_Staticness (Tree); - Header ("lexical layout:", False); - Disp_Lexical_Layout (Tree); - Header ("mode: " & Iir_Mode'Image (Get_Mode (Tree))); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - - when Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration => - if Flat_Decl then - return; - end if; - Header ("kind: " & Iir_Signal_Kind'Image (Get_Signal_Kind (Tree))); - Header ("has_active_flag: ", False); - Disp_Flag (Get_Has_Active_Flag (Tree)); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - if Kind = Iir_Kind_Signal_Declaration then - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - Header ("signal_driver:"); - Disp_Tree_Flat (Get_Signal_Driver (Tree), Ntab); - else - Header ("guard expr:"); - Disp_Tree (Get_Guard_Expression (Tree), Ntab); - Header ("guard sensitivity list:"); - Disp_Tree_List (Get_Guard_Sensitivity_List (Tree), Ntab); - end if; - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Constant_Declaration - | Iir_Kind_Iterator_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - if Kind = Iir_Kind_Constant_Declaration then - Header ("deferred flag: " & Boolean'Image - (Get_Deferred_Declaration_Flag (Tree))); - Header ("deferred: "); - Disp_Tree (Get_Deferred_Declaration (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - end if; - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Variable_Declaration => - if Flat_Decl then - return; - end if; - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_File_Declaration => - if Flat_Decl then - return; - end if; - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("logical name:"); - Disp_Tree (Get_File_Logical_Name (Tree), Ntab); - Header ("mode: " & Iir_Mode'Image (Get_Mode (Tree))); - Header ("file_open_kind:"); - Disp_Tree (Get_File_Open_Kind (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Put ("disconnection_specification"); + when Iir_Kind_Configuration_Specification => + Put ("configuration_specification"); + when Iir_Kind_Access_Type_Definition => + Put ("access_type_definition"); + when Iir_Kind_Incomplete_Type_Definition => + Put ("incomplete_type_definition"); + when Iir_Kind_File_Type_Definition => + Put ("file_type_definition"); + when Iir_Kind_Protected_Type_Declaration => + Put ("protected_type_declaration"); + when Iir_Kind_Record_Type_Definition => + Put ("record_type_definition"); + when Iir_Kind_Array_Type_Definition => + Put ("array_type_definition"); + when Iir_Kind_Array_Subtype_Definition => + Put ("array_subtype_definition"); + when Iir_Kind_Record_Subtype_Definition => + Put ("record_subtype_definition"); + when Iir_Kind_Access_Subtype_Definition => + Put ("access_subtype_definition"); + when Iir_Kind_Physical_Subtype_Definition => + Put ("physical_subtype_definition"); + when Iir_Kind_Floating_Subtype_Definition => + Put ("floating_subtype_definition"); + when Iir_Kind_Integer_Subtype_Definition => + Put ("integer_subtype_definition"); + when Iir_Kind_Enumeration_Subtype_Definition => + Put ("enumeration_subtype_definition"); + when Iir_Kind_Enumeration_Type_Definition => + Put ("enumeration_type_definition"); + when Iir_Kind_Integer_Type_Definition => + Put ("integer_type_definition"); + when Iir_Kind_Floating_Type_Definition => + Put ("floating_type_definition"); + when Iir_Kind_Physical_Type_Definition => + Put ("physical_type_definition"); + when Iir_Kind_Range_Expression => + Put ("range_expression"); + when Iir_Kind_Protected_Type_Body => + Put ("protected_type_body " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Subtype_Definition => + Put ("subtype_definition"); + when Iir_Kind_Scalar_Nature_Definition => + Put ("scalar_nature_definition"); + when Iir_Kind_Overload_List => + Put ("overload_list"); when Iir_Kind_Type_Declaration => - if Flat_Decl then - return; - end if; - Header ("type (definition):"); - Disp_Tree (Get_Type_Definition (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Put ("type_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Anonymous_Type_Declaration => - if Flat_Decl then - return; - end if; - Header ("type definition:"); - Disp_Tree (Get_Type_Definition (Tree), Ntab); + Put ("anonymous_type_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Subtype_Declaration => - if Flat_Decl then - return; - end if; - Header ("subtype indication:"); - Disp_Tree (Get_Type (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Nature_Declaration - | Iir_Kind_Subnature_Declaration => - if Flat_Decl then - return; - end if; - Header ("nature (definition):"); - Disp_Tree (Get_Nature (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Put ("subtype_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Nature_Declaration => + Put ("nature_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Subnature_Declaration => + Put ("subnature_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Configuration_Declaration => + Put ("configuration_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Entity_Declaration => + Put ("entity_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Package_Declaration => + Put ("package_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Package_Body => + Put ("package_body " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Architecture_Body => + Put ("architecture_body " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Package_Instantiation_Declaration => + Put ("package_instantiation_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Package_Header => + Put ("package_header"); + when Iir_Kind_Unit_Declaration => + Put ("unit_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Library_Declaration => + Put ("library_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Component_Declaration => - if Flat_Decl then - return; - end if; - Header ("generic chain:"); - Disp_Tree_Chain (Get_Generic_Chain (Tree), Ntab); - Header ("port chain:"); - Disp_Tree_Chain (Get_Port_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Element_Declaration => - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - when Iir_Kind_Record_Element_Constraint => - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("element_declaration:"); - Disp_Tree (Get_Element_Declaration (Tree), Ntab); + Put ("component_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Attribute_Declaration => - if Flat_Decl then - return; - end if; - Header ("type mark:"); - Disp_Tree (Get_Type_Mark (Tree), Ntab, True); + Put ("attribute_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Group_Template_Declaration => + Put ("group_template_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Group_Declaration => + Put ("group_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Element_Declaration => + Put ("element_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Non_Object_Alias_Declaration => + Put ("non_object_alias_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Psl_Declaration => + Put ("psl_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Terminal_Declaration => - if Flat_Decl then - return; - end if; - Header ("nature:"); - Disp_Tree (Get_Nature (Tree), Ntab, True); + Put ("terminal_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Free_Quantity_Declaration => - if Flat_Decl then - return; - end if; - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Across_Quantity_Declaration - | Iir_Kind_Through_Quantity_Declaration => - if Flat_Decl then - return; - end if; - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("default value:"); - Disp_Tree (Get_Default_Value (Tree), Ntab, True); - Header ("plus terminal:"); - Disp_Tree (Get_Plus_Terminal (Tree), Ntab, True); - Header ("minus terminal:"); - Disp_Tree (Get_Minus_Terminal (Tree), Ntab, True); - Header ("tolerance:"); - Disp_Tree (Get_Tolerance (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Psl_Declaration => - if Flat_Decl then - return; - end if; - when Iir_Kind_Psl_Expression => - return; - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - if Flat_Decl then - return; - end if; - Header ("interface_declaration_chain:"); - Disp_Tree_Chain (Get_Interface_Declaration_Chain (Tree), Ntab); - if Kind = Iir_Kind_Function_Declaration then - Header ("return type:"); - Disp_Tree (Get_Return_Type (Tree), Ntab, True); - Header ("pure_flag: ", False); - Disp_Flag (Get_Pure_Flag (Tree)); - else - Header ("purity_state:", False); - Disp_Purity_State (Get_Purity_State (Tree)); - end if; - Header ("wait_state:", False); - Disp_State (Get_Wait_State (Tree)); - Header ("all_sensitized_state: " & Iir_All_Sensitized'Image - (Get_All_Sensitized_State (Tree))); - Header ("subprogram_depth:", False); - Disp_Depth (Get_Subprogram_Depth (Tree)); - Header ("subprogram_body:"); - Disp_Tree_Flat (Get_Subprogram_Body (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body => - Header ("specification:"); - Disp_Tree_Flat (Get_Subprogram_Specification (Tree), Ntab); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("statements:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); + Put ("free_quantity_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Across_Quantity_Declaration => + Put ("across_quantity_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Through_Quantity_Declaration => + Put ("through_quantity_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Enumeration_Literal => + Put ("enumeration_literal " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Function_Declaration => + Put ("function_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Implicit_Function_Declaration => - if Flat_Decl then - return; - end if; - Header ("operation: " - & Iir_Predefined_Functions'Image - (Get_Implicit_Definition (Tree))); - Header ("interface declaration chain:"); - Disp_Tree_Chain (Get_Interface_Declaration_Chain (Tree), Ntab); - Header ("return type:"); - Disp_Tree (Get_Return_Type (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Put ("implicit_function_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Implicit_Procedure_Declaration => - if Flat_Decl then - return; - end if; - Header ("interface declaration chain:"); - Disp_Tree_Chain (Get_Interface_Declaration_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Put ("implicit_procedure_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Procedure_Declaration => + Put ("procedure_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Function_Body => + Put ("function_body"); + when Iir_Kind_Procedure_Body => + Put ("procedure_body"); when Iir_Kind_Object_Alias_Declaration => - if Flat_Decl then - return; - end if; - Header ("name:"); - Disp_Tree (Get_Name (Tree), Ntab); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - when Iir_Kind_Non_Object_Alias_Declaration => - if Flat_Decl then - return; - end if; - Header ("name:"); - Disp_Tree (Get_Name (Tree), Ntab); - Header ("signature:"); - Disp_Tree (Get_Alias_Signature (Tree), Ntab, True); + Put ("object_alias_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_File_Declaration => + Put ("file_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Guard_Signal_Declaration => + Put ("guard_signal_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Signal_Declaration => + Put ("signal_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Variable_Declaration => + Put ("variable_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Constant_Declaration => + Put ("constant_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Iterator_Declaration => + Put ("iterator_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Constant_Interface_Declaration => + Put ("constant_interface_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Variable_Interface_Declaration => + Put ("variable_interface_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Signal_Interface_Declaration => + Put ("signal_interface_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_File_Interface_Declaration => + Put ("file_interface_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Identity_Operator => + Put ("identity_operator"); + when Iir_Kind_Negation_Operator => + Put ("negation_operator"); + when Iir_Kind_Absolute_Operator => + Put ("absolute_operator"); + when Iir_Kind_Not_Operator => + Put ("not_operator"); + when Iir_Kind_Condition_Operator => + Put ("condition_operator"); + when Iir_Kind_Reduction_And_Operator => + Put ("reduction_and_operator"); + when Iir_Kind_Reduction_Or_Operator => + Put ("reduction_or_operator"); + when Iir_Kind_Reduction_Nand_Operator => + Put ("reduction_nand_operator"); + when Iir_Kind_Reduction_Nor_Operator => + Put ("reduction_nor_operator"); + when Iir_Kind_Reduction_Xor_Operator => + Put ("reduction_xor_operator"); + when Iir_Kind_Reduction_Xnor_Operator => + Put ("reduction_xnor_operator"); + when Iir_Kind_And_Operator => + Put ("and_operator"); + when Iir_Kind_Or_Operator => + Put ("or_operator"); + when Iir_Kind_Nand_Operator => + Put ("nand_operator"); + when Iir_Kind_Nor_Operator => + Put ("nor_operator"); + when Iir_Kind_Xor_Operator => + Put ("xor_operator"); + when Iir_Kind_Xnor_Operator => + Put ("xnor_operator"); + when Iir_Kind_Equality_Operator => + Put ("equality_operator"); + when Iir_Kind_Inequality_Operator => + Put ("inequality_operator"); + when Iir_Kind_Less_Than_Operator => + Put ("less_than_operator"); + when Iir_Kind_Less_Than_Or_Equal_Operator => + Put ("less_than_or_equal_operator"); + when Iir_Kind_Greater_Than_Operator => + Put ("greater_than_operator"); + when Iir_Kind_Greater_Than_Or_Equal_Operator => + Put ("greater_than_or_equal_operator"); + when Iir_Kind_Match_Equality_Operator => + Put ("match_equality_operator"); + when Iir_Kind_Match_Inequality_Operator => + Put ("match_inequality_operator"); + when Iir_Kind_Match_Less_Than_Operator => + Put ("match_less_than_operator"); + when Iir_Kind_Match_Less_Than_Or_Equal_Operator => + Put ("match_less_than_or_equal_operator"); + when Iir_Kind_Match_Greater_Than_Operator => + Put ("match_greater_than_operator"); + when Iir_Kind_Match_Greater_Than_Or_Equal_Operator => + Put ("match_greater_than_or_equal_operator"); + when Iir_Kind_Sll_Operator => + Put ("sll_operator"); + when Iir_Kind_Sla_Operator => + Put ("sla_operator"); + when Iir_Kind_Srl_Operator => + Put ("srl_operator"); + when Iir_Kind_Sra_Operator => + Put ("sra_operator"); + when Iir_Kind_Rol_Operator => + Put ("rol_operator"); + when Iir_Kind_Ror_Operator => + Put ("ror_operator"); + when Iir_Kind_Addition_Operator => + Put ("addition_operator"); + when Iir_Kind_Substraction_Operator => + Put ("substraction_operator"); + when Iir_Kind_Concatenation_Operator => + Put ("concatenation_operator"); + when Iir_Kind_Multiplication_Operator => + Put ("multiplication_operator"); + when Iir_Kind_Division_Operator => + Put ("division_operator"); + when Iir_Kind_Modulus_Operator => + Put ("modulus_operator"); + when Iir_Kind_Remainder_Operator => + Put ("remainder_operator"); + when Iir_Kind_Exponentiation_Operator => + Put ("exponentiation_operator"); + when Iir_Kind_Function_Call => + Put ("function_call"); + when Iir_Kind_Aggregate => + Put ("aggregate"); + when Iir_Kind_Parenthesis_Expression => + Put ("parenthesis_expression"); + when Iir_Kind_Qualified_Expression => + Put ("qualified_expression"); + when Iir_Kind_Type_Conversion => + Put ("type_conversion"); + when Iir_Kind_Allocator_By_Expression => + Put ("allocator_by_expression"); + when Iir_Kind_Allocator_By_Subtype => + Put ("allocator_by_subtype"); + when Iir_Kind_Selected_Element => + Put ("selected_element"); + when Iir_Kind_Dereference => + Put ("dereference"); + when Iir_Kind_Implicit_Dereference => + Put ("implicit_dereference"); + when Iir_Kind_Slice_Name => + Put ("slice_name"); + when Iir_Kind_Indexed_Name => + Put ("indexed_name"); + when Iir_Kind_Psl_Expression => + Put ("psl_expression"); + when Iir_Kind_Sensitized_Process_Statement => + Put ("sensitized_process_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Process_Statement => + Put ("process_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Put ("concurrent_conditional_signal_assignment " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + Put ("concurrent_selected_signal_assignment " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Concurrent_Assertion_Statement => + Put ("concurrent_assertion_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Psl_Default_Clock => + Put ("psl_default_clock " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Psl_Assert_Statement => + Put ("psl_assert_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Psl_Cover_Statement => + Put ("psl_cover_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + Put ("concurrent_procedure_call_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Block_Statement => + Put ("block_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Generate_Statement => + Put ("generate_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Component_Instantiation_Statement => + Put ("component_instantiation_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Simple_Simultaneous_Statement => + Put ("simple_simultaneous_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Signal_Assignment_Statement => + Put ("signal_assignment_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Null_Statement => + Put ("null_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Assertion_Statement => + Put ("assertion_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Report_Statement => + Put ("report_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Wait_Statement => + Put ("wait_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Variable_Assignment_Statement => + Put ("variable_assignment_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Return_Statement => + Put ("return_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_For_Loop_Statement => + Put ("for_loop_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_While_Loop_Statement => + Put ("while_loop_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Next_Statement => + Put ("next_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Exit_Statement => + Put ("exit_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Case_Statement => + Put ("case_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Procedure_Call_Statement => + Put ("procedure_call_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_If_Statement => + Put ("if_statement " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Elsif => + Put ("elsif"); + when Iir_Kind_Character_Literal => + Put ("character_literal " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Simple_Name => + Put ("simple_name " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Selected_Name => + Put ("selected_name " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Operator_Symbol => + Put ("operator_symbol " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Selected_By_All_Name => + Put ("selected_by_all_name"); + when Iir_Kind_Parenthesis_Name => + Put ("parenthesis_name"); + when Iir_Kind_Base_Attribute => + Put ("base_attribute"); + when Iir_Kind_Left_Type_Attribute => + Put ("left_type_attribute"); + when Iir_Kind_Right_Type_Attribute => + Put ("right_type_attribute"); + when Iir_Kind_High_Type_Attribute => + Put ("high_type_attribute"); + when Iir_Kind_Low_Type_Attribute => + Put ("low_type_attribute"); + when Iir_Kind_Ascending_Type_Attribute => + Put ("ascending_type_attribute"); + when Iir_Kind_Image_Attribute => + Put ("image_attribute"); + when Iir_Kind_Value_Attribute => + Put ("value_attribute"); + when Iir_Kind_Pos_Attribute => + Put ("pos_attribute"); + when Iir_Kind_Val_Attribute => + Put ("val_attribute"); + when Iir_Kind_Succ_Attribute => + Put ("succ_attribute"); + when Iir_Kind_Pred_Attribute => + Put ("pred_attribute"); + when Iir_Kind_Leftof_Attribute => + Put ("leftof_attribute"); + when Iir_Kind_Rightof_Attribute => + Put ("rightof_attribute"); + when Iir_Kind_Delayed_Attribute => + Put ("delayed_attribute"); + when Iir_Kind_Stable_Attribute => + Put ("stable_attribute"); + when Iir_Kind_Quiet_Attribute => + Put ("quiet_attribute"); + when Iir_Kind_Transaction_Attribute => + Put ("transaction_attribute"); + when Iir_Kind_Event_Attribute => + Put ("event_attribute"); + when Iir_Kind_Active_Attribute => + Put ("active_attribute"); + when Iir_Kind_Last_Event_Attribute => + Put ("last_event_attribute"); + when Iir_Kind_Last_Active_Attribute => + Put ("last_active_attribute"); + when Iir_Kind_Last_Value_Attribute => + Put ("last_value_attribute"); + when Iir_Kind_Driving_Attribute => + Put ("driving_attribute"); + when Iir_Kind_Driving_Value_Attribute => + Put ("driving_value_attribute"); + when Iir_Kind_Behavior_Attribute => + Put ("behavior_attribute"); + when Iir_Kind_Structure_Attribute => + Put ("structure_attribute"); + when Iir_Kind_Simple_Name_Attribute => + Put ("simple_name_attribute"); + when Iir_Kind_Instance_Name_Attribute => + Put ("instance_name_attribute"); + when Iir_Kind_Path_Name_Attribute => + Put ("path_name_attribute"); + when Iir_Kind_Left_Array_Attribute => + Put ("left_array_attribute"); + when Iir_Kind_Right_Array_Attribute => + Put ("right_array_attribute"); + when Iir_Kind_High_Array_Attribute => + Put ("high_array_attribute"); + when Iir_Kind_Low_Array_Attribute => + Put ("low_array_attribute"); + when Iir_Kind_Length_Array_Attribute => + Put ("length_array_attribute"); + when Iir_Kind_Ascending_Array_Attribute => + Put ("ascending_array_attribute"); + when Iir_Kind_Range_Array_Attribute => + Put ("range_array_attribute"); + when Iir_Kind_Reverse_Range_Array_Attribute => + Put ("reverse_range_array_attribute"); + when Iir_Kind_Attribute_Name => + Put ("attribute_name " & + Image_Name_Id (Get_Identifier (N))); + end case; + Put (' '); + Disp_Iir_Number (N); + New_Line; + end Disp_Header; - when Iir_Kind_Group_Template_Declaration => - Header ("entity_class_entry:"); - Disp_Tree_Chain (Get_Entity_Class_Entry_Chain (Tree), Ntab); - when Iir_Kind_Group_Declaration => - Header ("group_constituent_list:"); - Disp_Tree_List_Flat (Get_Group_Constituent_List (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + procedure Disp_Iir (N : Iir; + Indent : Natural := 1; + Flat : Boolean := False) + is + Sub_Indent : constant Natural := Indent + 1; + begin + Disp_Header (N); - when Iir_Kind_Enumeration_Type_Definition => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("type declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("literals:"); - Disp_Tree_List (Get_Enumeration_Literal_List (Tree), Ntab); - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Floating_Type_Definition => - if Flat_Decl and then not Is_Anonymous_Type_Definition (Tree) - then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("type_declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Subtype_Definition => - if Flat_Decl - and then Kind /= Iir_Kind_Subtype_Definition - and then Get_Type_Declarator (Tree) /= Null_Iir - then - return; - end if; - if Kind /= Iir_Kind_Subtype_Definition then - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("has_signal_flag: ", False); - Disp_Flag (Get_Has_Signal_Flag (Tree)); - Header ("type declarator:"); - Disp_Tree (Get_Type_Declarator (Tree), Ntab, True); - Header ("base type:"); - Disp_Tree (Get_Base_Type (Tree), Ntab, True); - end if; - Header ("type mark:"); - Disp_Tree (Get_Subtype_Type_Mark (Tree), Ntab, True); - Header ("resolution function:"); - Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); - Header ("range constraint:"); - Disp_Tree (Get_Range_Constraint (Tree), Ntab); - if Kind = Iir_Kind_Floating_Subtype_Definition - or else Kind = Iir_Kind_Subtype_Definition - then - Header ("tolerance"); - Disp_Tree (Get_Tolerance (Tree), Ntab); - end if; - when Iir_Kind_Range_Expression => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("left limit:"); - Disp_Tree (Get_Left_Limit (Tree), Ntab, True); - Header ("right limit:"); - Disp_Tree (Get_Right_Limit (Tree), Ntab, True); - Header ("direction: " - & Iir_Direction'Image (Get_Direction (Tree))); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("origin:"); - Disp_Tree (Get_Range_Origin (Tree), Ntab, True); + if Flat or else N = Null_Iir then + return; + end if; - when Iir_Kind_Array_Subtype_Definition => - if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then - return; - end if; - Header ("staticness:", false); - Disp_Type_Staticness (Tree); - Header ("index_constraint: ", False); - Disp_Flag (Get_Index_Constraint_Flag (Tree)); - Header ("constraint_state: " - & Iir_Constraint'Image (Get_Constraint_State (Tree))); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("has_signal_flag: ", False); - Disp_Flag (Get_Has_Signal_Flag (Tree)); - Header ("type declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("base type:"); - declare - Base : constant Iir := Get_Base_Type (Tree); - Fl : Boolean; - begin - if Base /= Null_Iir - and then Get_Kind (Base) = Iir_Kind_Array_Type_Definition - then - Fl := Get_Type_Declarator (Base) - /= Get_Type_Declarator (Tree); - else - Fl := False; - end if; - Disp_Tree (Base, Ntab, Fl); - end; - Header ("type mark:"); - Disp_Tree (Get_Subtype_Type_Mark (Tree), Ntab, True); - Header ("index_subtype_list:"); - Disp_Tree_List (Get_Index_Subtype_List (Tree), Ntab, True); - Header ("element_subtype_indication:"); - Disp_Tree (Get_Element_Subtype_Indication (Tree), Ntab, True); - Header ("resolution function:"); - Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); - when Iir_Kind_Array_Type_Definition => - if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("has_signal_flag: ", False); - Disp_Flag (Get_Has_Signal_Flag (Tree)); - Header ("index_subtype_list:"); - Disp_Tree_List (Get_Index_Subtype_List (Tree), Ntab, True); - Header ("element_subtype_indication:"); - Disp_Tree (Get_Element_Subtype_Indication (Tree), Ntab, True); - when Iir_Kind_Record_Type_Definition => - if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("has_signal_flag: ", False); - Disp_Flag (Get_Has_Signal_Flag (Tree)); - Header ("constraint_state: " - & Iir_Constraint'Image (Get_Constraint_State (Tree))); - Header ("elements:"); - Disp_Tree_List (Get_Elements_Declaration_List (Tree), Ntab, True); - when Iir_Kind_Record_Subtype_Definition => - if Flat_Decl and then not Is_Anonymous_Type_Definition (Tree) then - return; - end if; - Header ("type declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("base type:"); - Disp_Tree (Get_Base_Type (Tree), Ntab, True); - Header ("type mark:"); - Disp_Tree (Get_Subtype_Type_Mark (Tree), Ntab, True); - Header ("resolution function:"); - Disp_Tree_Flat (Get_Resolution_Function (Tree), Ntab); - Header ("constraint_state: " - & Iir_Constraint'Image (Get_Constraint_State (Tree))); - Header ("elements:"); - Disp_Tree_List (Get_Elements_Declaration_List (Tree), Ntab, True); - when Iir_Kind_Physical_Type_Definition => - if Flat_Decl and then Get_Type_Declarator (Tree) /= Null_Iir then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("unit chain:"); - Disp_Tree_Chain (Get_Unit_Chain (Tree), Ntab); - when Iir_Kind_Unit_Declaration => - if Flat_Decl then - return; - end if; - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("physical_literal:"); - Disp_Tree (Get_Physical_Literal (Tree), Ntab, True); - Header ("physical_Unit_Value:"); - Disp_Tree (Get_Physical_Unit_Value (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("location: ", Indent); + Put_Line (Image_Location_Type (Get_Location (N))); - when Iir_Kind_Access_Type_Definition => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("signal_type_flag: ", False); - Disp_Flag (Get_Signal_Type_Flag (Tree)); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("designated type:"); - Disp_Tree_Flat (Get_Designated_Type (Tree), Ntab); - when Iir_Kind_Access_Subtype_Definition => - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("resolved flag: ", False); - Disp_Type_Resolved_Flag (Tree); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("base type:"); - Disp_Tree (Get_Base_Type (Tree), Ntab, True); - Header ("designated subtype indication:"); - Disp_Tree (Get_Designated_Subtype_Indication (Tree), Ntab); + -- Protect against infinite recursions. + if Indent > 20 then + Put_Indent (Indent); + Put_Line ("..."); + return; + end if; + case Get_Kind (N) is + when Iir_Kind_Unused + | Iir_Kind_Entity_Aspect_Open + | Iir_Kind_Behavior_Attribute + | Iir_Kind_Structure_Attribute => + null; + when Iir_Kind_Error => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("error_origin: ", Indent); + Disp_Iir (Get_Error_Origin (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Design_File => + Header ("library: ", Indent); + Disp_Iir (Get_Library (N), Sub_Indent, True); + Header ("file_dependence_list: ", Indent); + Disp_Iir_List (Get_File_Dependence_List (N), Sub_Indent); + Header ("design_file_directory: ", Indent); + Put_Line (Image_Name_Id (Get_Design_File_Directory (N))); + Header ("design_file_filename: ", Indent); + Put_Line (Image_Name_Id (Get_Design_File_Filename (N))); + Header ("analysis_time_stamp: ", Indent); + Put_Line (Image_Time_Stamp_Id (Get_Analysis_Time_Stamp (N))); + Header ("file_time_stamp: ", Indent); + Put_Line (Image_Time_Stamp_Id (Get_File_Time_Stamp (N))); + Header ("first_design_unit: ", Indent); + Disp_Chain (Get_First_Design_Unit (N), Sub_Indent); + Header ("last_design_unit: ", Indent); + Disp_Iir (Get_Last_Design_Unit (N), Sub_Indent, True); + Header ("elab_flag: ", Indent); + Put_Line (Image_Boolean (Get_Elab_Flag (N))); + when Iir_Kind_Design_Unit => + Header ("design_file: ", Indent); + Disp_Iir (Get_Design_File (N), Sub_Indent, True); + Header ("context_items: ", Indent); + Disp_Chain (Get_Context_Items (N), Sub_Indent); + Header ("date: ", Indent); + Put_Line (Date_Type'Image (Get_Date (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("library_unit: ", Indent); + Disp_Iir (Get_Library_Unit (N), Sub_Indent); + Header ("end_location: ", Indent); + Put_Line (Image_Location_Type (Get_End_Location (N))); + Header ("hash_chain: ", Indent); + Disp_Iir (Get_Hash_Chain (N), Sub_Indent, True); + Header ("dependence_list: ", Indent); + Disp_Iir_List (Get_Dependence_List (N), Sub_Indent, True); + Header ("analysis_checks_list: ", Indent); + Disp_Iir_List (Get_Analysis_Checks_List (N), Sub_Indent); + Header ("elab_flag: ", Indent); + Put_Line (Image_Boolean (Get_Elab_Flag (N))); + Header ("date_state: ", Indent); + Put_Line (Image_Date_State_Type (Get_Date_State (N))); + when Iir_Kind_Library_Clause => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("library_declaration: ", Indent); + Disp_Iir (Get_Library_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + when Iir_Kind_Use_Clause => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("selected_name: ", Indent); + Disp_Iir (Get_Selected_Name (N), Sub_Indent); + Header ("use_clause_chain: ", Indent); + Disp_Iir (Get_Use_Clause_Chain (N), Sub_Indent); + when Iir_Kind_Integer_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("value: ", Indent); + Put_Line (Iir_Int64'Image (Get_Value (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Floating_Point_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("fp_value: ", Indent); + Put_Line (Iir_Fp64'Image (Get_Fp_Value (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Null_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_String_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("string_id: ", Indent); + Put_Line (Image_String_Id (Get_String_Id (N))); + Header ("string_length: ", Indent); + Put_Line (Int32'Image (Get_String_Length (N))); + Header ("literal_subtype: ", Indent); + Disp_Iir (Get_Literal_Subtype (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Physical_Int_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("unit_name: ", Indent); + Disp_Iir (Get_Unit_Name (N), Sub_Indent); + Header ("value: ", Indent); + Put_Line (Iir_Int64'Image (Get_Value (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Physical_Fp_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("unit_name: ", Indent); + Disp_Iir (Get_Unit_Name (N), Sub_Indent); + Header ("fp_value: ", Indent); + Put_Line (Iir_Fp64'Image (Get_Fp_Value (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Bit_String_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("string_id: ", Indent); + Put_Line (Image_String_Id (Get_String_Id (N))); + Header ("string_length: ", Indent); + Put_Line (Int32'Image (Get_String_Length (N))); + Header ("literal_subtype: ", Indent); + Disp_Iir (Get_Literal_Subtype (N), Sub_Indent); + Header ("bit_string_0: ", Indent); + Disp_Iir (Get_Bit_String_0 (N), Sub_Indent); + Header ("bit_string_1: ", Indent); + Disp_Iir (Get_Bit_String_1 (N), Sub_Indent); + Header ("bit_string_base: ", Indent); + Put_Line (Base_Type'Image (Get_Bit_String_Base (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Simple_Aggregate => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("simple_aggregate_list: ", Indent); + Disp_Iir_List (Get_Simple_Aggregate_List (N), Sub_Indent); + Header ("literal_subtype: ", Indent); + Disp_Iir (Get_Literal_Subtype (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Overflow_Literal => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Waveform_Element => + Header ("we_value: ", Indent); + Disp_Iir (Get_We_Value (N), Sub_Indent); + Header ("time: ", Indent); + Disp_Iir (Get_Time (N), Sub_Indent); + when Iir_Kind_Conditional_Waveform => + Header ("condition: ", Indent); + Disp_Iir (Get_Condition (N), Sub_Indent); + Header ("waveform_chain: ", Indent); + Disp_Chain (Get_Waveform_Chain (N), Sub_Indent); + when Iir_Kind_Association_Element_By_Expression => + Header ("formal: ", Indent); + Disp_Iir (Get_Formal (N), Sub_Indent); + Header ("actual: ", Indent); + Disp_Iir (Get_Actual (N), Sub_Indent); + Header ("in_conversion: ", Indent); + Disp_Iir (Get_In_Conversion (N), Sub_Indent); + Header ("out_conversion: ", Indent); + Disp_Iir (Get_Out_Conversion (N), Sub_Indent); + Header ("whole_association_flag: ", Indent); + Put_Line (Image_Boolean (Get_Whole_Association_Flag (N))); + Header ("collapse_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Collapse_Signal_Flag (N))); + when Iir_Kind_Association_Element_By_Individual => + Header ("formal: ", Indent); + Disp_Iir (Get_Formal (N), Sub_Indent); + Header ("actual_type: ", Indent); + Disp_Iir (Get_Actual_Type (N), Sub_Indent); + Header ("individual_association_chain: ", Indent); + Disp_Chain (Get_Individual_Association_Chain (N), Sub_Indent); + Header ("whole_association_flag: ", Indent); + Put_Line (Image_Boolean (Get_Whole_Association_Flag (N))); + Header ("collapse_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Collapse_Signal_Flag (N))); + when Iir_Kind_Association_Element_Open => + Header ("formal: ", Indent); + Disp_Iir (Get_Formal (N), Sub_Indent); + Header ("whole_association_flag: ", Indent); + Put_Line (Image_Boolean (Get_Whole_Association_Flag (N))); + Header ("collapse_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Collapse_Signal_Flag (N))); + Header ("artificial_flag: ", Indent); + Put_Line (Image_Boolean (Get_Artificial_Flag (N))); + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_None => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("associated_expr: ", Indent); + Disp_Iir (Get_Associated_Expr (N), Sub_Indent); + Header ("associated_chain: ", Indent); + Disp_Chain (Get_Associated_Chain (N), Sub_Indent); + Header ("same_alternative_flag: ", Indent); + Put_Line (Image_Boolean (Get_Same_Alternative_Flag (N))); + when Iir_Kind_Choice_By_Expression => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("associated_expr: ", Indent); + Disp_Iir (Get_Associated_Expr (N), Sub_Indent); + Header ("associated_chain: ", Indent); + Disp_Chain (Get_Associated_Chain (N), Sub_Indent); + Header ("choice_expression: ", Indent); + Disp_Iir (Get_Choice_Expression (N), Sub_Indent); + Header ("same_alternative_flag: ", Indent); + Put_Line (Image_Boolean (Get_Same_Alternative_Flag (N))); + Header ("choice_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Choice_Staticness (N))); + when Iir_Kind_Choice_By_Range => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("associated_expr: ", Indent); + Disp_Iir (Get_Associated_Expr (N), Sub_Indent); + Header ("associated_chain: ", Indent); + Disp_Chain (Get_Associated_Chain (N), Sub_Indent); + Header ("choice_range: ", Indent); + Disp_Iir (Get_Choice_Range (N), Sub_Indent); + Header ("same_alternative_flag: ", Indent); + Put_Line (Image_Boolean (Get_Same_Alternative_Flag (N))); + Header ("choice_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Choice_Staticness (N))); + when Iir_Kind_Choice_By_Name => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("associated_expr: ", Indent); + Disp_Iir (Get_Associated_Expr (N), Sub_Indent); + Header ("associated_chain: ", Indent); + Disp_Chain (Get_Associated_Chain (N), Sub_Indent); + Header ("choice_name: ", Indent); + Disp_Iir (Get_Choice_Name (N), Sub_Indent); + Header ("same_alternative_flag: ", Indent); + Put_Line (Image_Boolean (Get_Same_Alternative_Flag (N))); + when Iir_Kind_Entity_Aspect_Entity => + Header ("entity_name: ", Indent); + Disp_Iir (Get_Entity_Name (N), Sub_Indent); + Header ("architecture: ", Indent); + Disp_Iir (Get_Architecture (N), Sub_Indent); + when Iir_Kind_Entity_Aspect_Configuration => + Header ("configuration_name: ", Indent); + Disp_Iir (Get_Configuration_Name (N), Sub_Indent); + when Iir_Kind_Block_Configuration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("configuration_item_chain: ", Indent); + Disp_Iir (Get_Configuration_Item_Chain (N), Sub_Indent); + Header ("prev_block_configuration: ", Indent); + Disp_Iir (Get_Prev_Block_Configuration (N), Sub_Indent, True); + Header ("block_specification: ", Indent); + Disp_Iir (Get_Block_Specification (N), Sub_Indent); + when Iir_Kind_Block_Header => + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("port_chain: ", Indent); + Disp_Chain (Get_Port_Chain (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("port_map_aspect_chain: ", Indent); + Disp_Chain (Get_Port_Map_Aspect_Chain (N), Sub_Indent); + when Iir_Kind_Component_Configuration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("instantiation_list: ", Indent); + Disp_Iir_List (Get_Instantiation_List (N), Sub_Indent); + Header ("binding_indication: ", Indent); + Disp_Iir (Get_Binding_Indication (N), Sub_Indent); + Header ("component_name: ", Indent); + Disp_Iir (Get_Component_Name (N), Sub_Indent); + Header ("block_configuration: ", Indent); + Disp_Iir (Get_Block_Configuration (N), Sub_Indent); + when Iir_Kind_Binding_Indication => + Header ("default_entity_aspect: ", Indent); + Disp_Iir (Get_Default_Entity_Aspect (N), Sub_Indent); + Header ("entity_aspect: ", Indent); + Disp_Iir (Get_Entity_Aspect (N), Sub_Indent); + Header ("default_generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Default_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("default_port_map_aspect_chain: ", Indent); + Disp_Chain (Get_Default_Port_Map_Aspect_Chain (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("port_map_aspect_chain: ", Indent); + Disp_Chain (Get_Port_Map_Aspect_Chain (N), Sub_Indent); + when Iir_Kind_Entity_Class => + Header ("entity_class: ", Indent); + Put_Line (Image_Token_Type (Get_Entity_Class (N))); + when Iir_Kind_Attribute_Value => + Header ("spec_chain: ", Indent); + Disp_Iir (Get_Spec_Chain (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("designated_entity: ", Indent); + Disp_Iir (Get_Designated_Entity (N), Sub_Indent, True); + Header ("attribute_specification: ", Indent); + Disp_Iir (Get_Attribute_Specification (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Signature => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type_marks_list: ", Indent); + Disp_Iir_List (Get_Type_Marks_List (N), Sub_Indent); + Header ("return_type_mark: ", Indent); + Disp_Iir (Get_Return_Type_Mark (N), Sub_Indent); + when Iir_Kind_Aggregate_Info => + Header ("sub_aggregate_info: ", Indent); + Disp_Iir (Get_Sub_Aggregate_Info (N), Sub_Indent); + Header ("aggr_low_limit: ", Indent); + Disp_Iir (Get_Aggr_Low_Limit (N), Sub_Indent); + Header ("aggr_high_limit: ", Indent); + Disp_Iir (Get_Aggr_High_Limit (N), Sub_Indent); + Header ("aggr_min_length: ", Indent); + Put_Line (Iir_Int32'Image (Get_Aggr_Min_Length (N))); + Header ("aggr_others_flag: ", Indent); + Put_Line (Image_Boolean (Get_Aggr_Others_Flag (N))); + Header ("aggr_dynamic_flag: ", Indent); + Put_Line (Image_Boolean (Get_Aggr_Dynamic_Flag (N))); + Header ("aggr_named_flag: ", Indent); + Put_Line (Image_Boolean (Get_Aggr_Named_Flag (N))); + when Iir_Kind_Procedure_Call => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("parameter_association_chain: ", Indent); + Disp_Chain (Get_Parameter_Association_Chain (N), Sub_Indent); + Header ("implementation: ", Indent); + Disp_Iir (Get_Implementation (N), Sub_Indent, True); + Header ("method_object: ", Indent); + Disp_Iir (Get_Method_Object (N), Sub_Indent); + when Iir_Kind_Record_Element_Constraint => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("element_declaration: ", Indent); + Disp_Iir (Get_Element_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("element_position: ", Indent); + Put_Line (Iir_Index32'Image (Get_Element_Position (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Attribute_Specification => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("entity_name_list: ", Indent); + Disp_Iir_List (Get_Entity_Name_List (N), Sub_Indent); + Header ("entity_class: ", Indent); + Put_Line (Image_Token_Type (Get_Entity_Class (N))); + Header ("attribute_value_spec_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Spec_Chain (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("attribute_designator: ", Indent); + Disp_Iir (Get_Attribute_Designator (N), Sub_Indent); + Header ("attribute_specification_chain: ", Indent); + Disp_Iir (Get_Attribute_Specification_Chain (N), Sub_Indent); + when Iir_Kind_Disconnection_Specification => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("signal_list: ", Indent); + Disp_Iir_List (Get_Signal_List (N), Sub_Indent); + Header ("type_mark: ", Indent); + Disp_Iir (Get_Type_Mark (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + when Iir_Kind_Configuration_Specification => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("instantiation_list: ", Indent); + Disp_Iir_List (Get_Instantiation_List (N), Sub_Indent); + Header ("binding_indication: ", Indent); + Disp_Iir (Get_Binding_Indication (N), Sub_Indent); + Header ("component_name: ", Indent); + Disp_Iir (Get_Component_Name (N), Sub_Indent); + when Iir_Kind_Access_Type_Definition => + Header ("designated_type: ", Indent); + Disp_Iir (Get_Designated_Type (N), Sub_Indent, True); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("designated_subtype_indication: ", Indent); + Disp_Iir (Get_Designated_Subtype_Indication (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); when Iir_Kind_Incomplete_Type_Definition => - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("base type:"); - Disp_Tree (Get_Base_Type (Tree), Ntab, True); - + Header ("incomplete_type_list: ", Indent); + Disp_Iir_List (Get_Incomplete_Type_List (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); when Iir_Kind_File_Type_Definition => - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("file type mark:"); - Disp_Tree_Flat (Get_File_Type_Mark (Tree), Ntab); + Header ("file_type_mark: ", Indent); + Disp_Iir (Get_File_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("text_file_flag: ", Indent); + Put_Line (Image_Boolean (Get_Text_File_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); when Iir_Kind_Protected_Type_Declaration => - if Flat_Decl then - return; - end if; - Header ("staticness: ", False); - Disp_Type_Staticness (Tree); - Header ("declarator:"); - Disp_Tree_Flat (Get_Type_Declarator (Tree), Ntab); - Header ("protected_type_body:"); - Disp_Tree_Flat (Get_Protected_Type_Body (Tree), Ntab); - Header ("declarative_part:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("protected_type_body: ", Indent); + Disp_Iir (Get_Protected_Type_Body (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Record_Type_Definition => + Header ("elements_declaration_list: ", Indent); + Disp_Iir_List (Get_Elements_Declaration_List (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + Header ("constraint_state: ", Indent); + Put_Line (Image_Iir_Constraint (Get_Constraint_State (N))); + when Iir_Kind_Array_Type_Definition => + Header ("element_subtype_indication: ", Indent); + Disp_Iir (Get_Element_Subtype_Indication (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("index_subtype_list: ", Indent); + Disp_Iir_List (Get_Index_Subtype_List (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("index_constraint_flag: ", Indent); + Put_Line (Image_Boolean (Get_Index_Constraint_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + Header ("constraint_state: ", Indent); + Put_Line (Image_Iir_Constraint (Get_Constraint_State (N))); + when Iir_Kind_Array_Subtype_Definition => + Header ("element_subtype_indication: ", Indent); + Disp_Iir (Get_Element_Subtype_Indication (N), Sub_Indent); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolution_function: ", Indent); + Disp_Iir (Get_Resolution_Function (N), Sub_Indent); + Header ("index_subtype_list: ", Indent); + Disp_Iir_List (Get_Index_Subtype_List (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("index_constraint_flag: ", Indent); + Put_Line (Image_Boolean (Get_Index_Constraint_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + Header ("constraint_state: ", Indent); + Put_Line (Image_Iir_Constraint (Get_Constraint_State (N))); + when Iir_Kind_Record_Subtype_Definition => + Header ("elements_declaration_list: ", Indent); + Disp_Iir_List (Get_Elements_Declaration_List (N), Sub_Indent); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolution_function: ", Indent); + Disp_Iir (Get_Resolution_Function (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + Header ("constraint_state: ", Indent); + Put_Line (Image_Iir_Constraint (Get_Constraint_State (N))); + when Iir_Kind_Access_Subtype_Definition => + Header ("designated_type: ", Indent); + Disp_Iir (Get_Designated_Type (N), Sub_Indent, True); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("designated_subtype_indication: ", Indent); + Disp_Iir (Get_Designated_Subtype_Indication (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Header ("range_constraint: ", Indent); + Disp_Iir (Get_Range_Constraint (N), Sub_Indent); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolution_function: ", Indent); + Disp_Iir (Get_Resolution_Function (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Floating_Subtype_Definition => + Header ("range_constraint: ", Indent); + Disp_Iir (Get_Range_Constraint (N), Sub_Indent); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolution_function: ", Indent); + Disp_Iir (Get_Resolution_Function (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Enumeration_Type_Definition => + Header ("range_constraint: ", Indent); + Disp_Iir (Get_Range_Constraint (N), Sub_Indent); + Header ("enumeration_literal_list: ", Indent); + Disp_Iir_List (Get_Enumeration_Literal_List (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("only_characters_flag: ", Indent); + Put_Line (Image_Boolean (Get_Only_Characters_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Physical_Type_Definition => + Header ("unit_chain: ", Indent); + Disp_Chain (Get_Unit_Chain (N), Sub_Indent); + Header ("type_declarator: ", Indent); + Disp_Iir (Get_Type_Declarator (N), Sub_Indent, True); + Header ("base_type: ", Indent); + Disp_Iir (Get_Base_Type (N), Sub_Indent, True); + Header ("resolved_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolved_Flag (N))); + Header ("signal_type_flag: ", Indent); + Put_Line (Image_Boolean (Get_Signal_Type_Flag (N))); + Header ("has_signal_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Signal_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + Header ("type_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Type_Staticness (N))); + when Iir_Kind_Range_Expression => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("left_limit: ", Indent); + Disp_Iir (Get_Left_Limit (N), Sub_Indent); + Header ("right_limit: ", Indent); + Disp_Iir (Get_Right_Limit (N), Sub_Indent); + Header ("range_origin: ", Indent); + Disp_Iir (Get_Range_Origin (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("direction: ", Indent); + Put_Line (Image_Iir_Direction (Get_Direction (N))); when Iir_Kind_Protected_Type_Body => - Header ("protected_type_declaration:"); - Disp_Tree_Flat (Get_Protected_Type_Declaration (Tree), Ntab); - Header ("declarative_part:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("protected_type_declaration: ", Indent); + Disp_Iir (Get_Protected_Type_Declaration (N), Sub_Indent); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Subtype_Definition => + Header ("range_constraint: ", Indent); + Disp_Iir (Get_Range_Constraint (N), Sub_Indent); + Header ("subtype_type_mark: ", Indent); + Disp_Iir (Get_Subtype_Type_Mark (N), Sub_Indent); + Header ("resolution_function: ", Indent); + Disp_Iir (Get_Resolution_Function (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); when Iir_Kind_Scalar_Nature_Definition => - if Flat_Decl then - return; - end if; - Header ("across_type:"); - Disp_Tree_Flat (Get_Across_Type (Tree), Ntab); - Header ("through_type:"); - Disp_Tree_Flat (Get_Through_Type (Tree), Ntab); - Header ("reference: ", False); - Disp_Tree_Flat (Get_Reference (Tree), Ntab); - Header ("nature_declarator:"); - Disp_Tree_Flat (Get_Nature_Declarator (Tree), Ntab); - - when Iir_Kind_Block_Statement => - if Flat_Decl then - return; - end if; - Disp_Label (Tree); - Header ("guard decl:"); - Disp_Tree (Get_Guard_Decl (Tree), Ntab); - Header ("block header:"); - Disp_Tree (Get_Block_Header (Tree), Ntab); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("concurrent statements:"); - Disp_Tree_Chain (Get_Concurrent_Statement_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Generate_Statement => - if Flat_Decl then - return; - end if; - Disp_Label (Tree); - Header ("generation_scheme:"); - Disp_Tree (Get_Generation_Scheme (Tree), Ntab); - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("concurrent statements:"); - Disp_Tree_Chain (Get_Concurrent_Statement_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - - when Iir_Kind_Component_Instantiation_Statement => - Disp_Label (Tree); - Header ("instantiated unit:"); - Disp_Tree (Get_Instantiated_Unit (Tree), Ntab, True); - Header ("generic map aspect chain:"); - Disp_Tree_Chain (Get_Generic_Map_Aspect_Chain (Tree), Ntab); - Header ("port map aspect chain:"); - Disp_Tree_Chain (Get_Port_Map_Aspect_Chain (Tree), Ntab); - Header ("component_configuration:"); - Disp_Tree (Get_Component_Configuration (Tree), Ntab); - Header ("default binding indication:"); - Disp_Tree (Get_Default_Binding_Indication (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("reference: ", Indent); + Disp_Iir (Get_Reference (N), Sub_Indent); + Header ("nature_declarator: ", Indent); + Disp_Iir (Get_Nature_Declarator (N), Sub_Indent); + Header ("across_type: ", Indent); + Disp_Iir (Get_Across_Type (N), Sub_Indent); + Header ("through_type: ", Indent); + Disp_Iir (Get_Through_Type (N), Sub_Indent); + when Iir_Kind_Overload_List => + Header ("overload_list: ", Indent); + Disp_Iir_List (Get_Overload_List (N), Sub_Indent, True); + when Iir_Kind_Type_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type_definition: ", Indent); + Disp_Iir (Get_Type_Definition (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Anonymous_Type_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type_definition: ", Indent); + Disp_Iir (Get_Type_Definition (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("subtype_definition: ", Indent); + Disp_Iir (Get_Subtype_Definition (N), Sub_Indent); + when Iir_Kind_Subtype_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("nature: ", Indent); + Disp_Iir (Get_Nature (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Configuration_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("entity_name: ", Indent); + Disp_Iir (Get_Entity_Name (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("block_configuration: ", Indent); + Disp_Iir (Get_Block_Configuration (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Entity_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("concurrent_statement_chain: ", Indent); + Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("port_chain: ", Indent); + Disp_Chain (Get_Port_Chain (N), Sub_Indent); + Header ("has_begin: ", Indent); + Put_Line (Image_Boolean (Get_Has_Begin (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Package_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("package_body: ", Indent); + Disp_Iir (Get_Package_Body (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("package_header: ", Indent); + Disp_Iir (Get_Package_Header (N), Sub_Indent); + Header ("need_body: ", Indent); + Put_Line (Image_Boolean (Get_Need_Body (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Package_Body => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("package: ", Indent); + Disp_Iir (Get_Package (N), Sub_Indent); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Architecture_Body => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("entity_name: ", Indent); + Disp_Iir (Get_Entity_Name (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("concurrent_statement_chain: ", Indent); + Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("default_configuration_declaration: ", Indent); + Disp_Iir (Get_Default_Configuration_Declaration (N), Sub_Indent); + Header ("foreign_flag: ", Indent); + Put_Line (Image_Boolean (Get_Foreign_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Package_Instantiation_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("uninstantiated_name: ", Indent); + Disp_Iir (Get_Uninstantiated_Name (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Package_Header => + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + when Iir_Kind_Unit_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("physical_literal: ", Indent); + Disp_Iir (Get_Physical_Literal (N), Sub_Indent); + Header ("physical_unit_value: ", Indent); + Disp_Iir (Get_Physical_Unit_Value (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Library_Declaration => + Header ("design_file_chain: ", Indent); + Disp_Chain (Get_Design_File_Chain (N), Sub_Indent); + Header ("date: ", Indent); + Put_Line (Date_Type'Image (Get_Date (N))); + Header ("library_directory: ", Indent); + Put_Line (Image_Name_Id (Get_Library_Directory (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Component_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("port_chain: ", Indent); + Disp_Chain (Get_Port_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_is: ", Indent); + Put_Line (Image_Boolean (Get_Has_Is (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Attribute_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("type_mark: ", Indent); + Disp_Iir (Get_Type_Mark (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Group_Template_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("entity_class_entry_chain: ", Indent); + Disp_Chain (Get_Entity_Class_Entry_Chain (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Group_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("group_constituent_list: ", Indent); + Disp_Iir_List (Get_Group_Constituent_List (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("group_template_name: ", Indent); + Disp_Iir (Get_Group_Template_Name (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Element_Declaration => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("element_position: ", Indent); + Put_Line (Iir_Index32'Image (Get_Element_Position (N))); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + when Iir_Kind_Non_Object_Alias_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("name: ", Indent); + Disp_Iir (Get_Name (N), Sub_Indent); + Header ("alias_signature: ", Indent); + Disp_Iir (Get_Alias_Signature (N), Sub_Indent); + Header ("implicit_alias_flag: ", Indent); + Put_Line (Image_Boolean (Get_Implicit_Alias_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Psl_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("psl_declaration: ", Indent); + Disp_PSL_Node (Get_Psl_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("psl_clock: ", Indent); + Disp_PSL_Node (Get_PSL_Clock (N), Sub_Indent); + Header ("psl_nfa: ", Indent); + Disp_PSL_NFA (Get_PSL_NFA (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Terminal_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("nature: ", Indent); + Disp_Iir (Get_Nature (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + when Iir_Kind_Free_Quantity_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); + Header ("plus_terminal: ", Indent); + Disp_Iir (Get_Plus_Terminal (N), Sub_Indent); + Header ("minus_terminal: ", Indent); + Disp_Iir (Get_Minus_Terminal (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Enumeration_Literal => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("enum_pos: ", Indent); + Put_Line (Iir_Int32'Image (Get_Enum_Pos (N))); + Header ("subprogram_hash: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Hash (N))); + Header ("literal_origin: ", Indent); + Disp_Iir (Get_Literal_Origin (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("enumeration_decl: ", Indent); + Disp_Iir (Get_Enumeration_Decl (N), Sub_Indent, True); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Function_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("return_type: ", Indent); + Disp_Iir (Get_Return_Type (N), Sub_Indent, True); + Header ("subprogram_depth: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Depth (N))); + Header ("subprogram_hash: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Hash (N))); + Header ("overload_number: ", Indent); + Put_Line (Iir_Int32'Image (Get_Overload_Number (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("interface_declaration_chain: ", Indent); + Disp_Chain (Get_Interface_Declaration_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("return_type_mark: ", Indent); + Disp_Iir (Get_Return_Type_Mark (N), Sub_Indent); + Header ("subprogram_body: ", Indent); + Disp_Iir (Get_Subprogram_Body (N), Sub_Indent); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("pure_flag: ", Indent); + Put_Line (Image_Boolean (Get_Pure_Flag (N))); + Header ("foreign_flag: ", Indent); + Put_Line (Image_Boolean (Get_Foreign_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("resolution_function_flag: ", Indent); + Put_Line (Image_Boolean (Get_Resolution_Function_Flag (N))); + Header ("has_pure: ", Indent); + Put_Line (Image_Boolean (Get_Has_Pure (N))); + Header ("has_body: ", Indent); + Put_Line (Image_Boolean (Get_Has_Body (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); + Header ("all_sensitized_state: ", Indent); + Put_Line (Image_Iir_All_Sensitized (Get_All_Sensitized_State (N))); + when Iir_Kind_Implicit_Function_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("return_type: ", Indent); + Disp_Iir (Get_Return_Type (N), Sub_Indent, True); + Header ("type_reference: ", Indent); + Disp_Iir (Get_Type_Reference (N), Sub_Indent, True); + Header ("subprogram_hash: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Hash (N))); + Header ("overload_number: ", Indent); + Put_Line (Iir_Int32'Image (Get_Overload_Number (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("interface_declaration_chain: ", Indent); + Disp_Chain (Get_Interface_Declaration_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("implicit_definition: ", Indent); + Put_Line (Image_Iir_Predefined_Functions + (Get_Implicit_Definition (N))); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("pure_flag: ", Indent); + Put_Line (Image_Boolean (Get_Pure_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); + when Iir_Kind_Implicit_Procedure_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type_reference: ", Indent); + Disp_Iir (Get_Type_Reference (N), Sub_Indent, True); + Header ("subprogram_hash: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Hash (N))); + Header ("overload_number: ", Indent); + Put_Line (Iir_Int32'Image (Get_Overload_Number (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("interface_declaration_chain: ", Indent); + Disp_Chain (Get_Interface_Declaration_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("implicit_definition: ", Indent); + Put_Line (Image_Iir_Predefined_Functions + (Get_Implicit_Definition (N))); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); + when Iir_Kind_Procedure_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("subprogram_depth: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Depth (N))); + Header ("subprogram_hash: ", Indent); + Put_Line (Iir_Int32'Image (Get_Subprogram_Hash (N))); + Header ("overload_number: ", Indent); + Put_Line (Iir_Int32'Image (Get_Overload_Number (N))); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("interface_declaration_chain: ", Indent); + Disp_Chain (Get_Interface_Declaration_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("return_type_mark: ", Indent); + Disp_Iir (Get_Return_Type_Mark (N), Sub_Indent); + Header ("subprogram_body: ", Indent); + Disp_Iir (Get_Subprogram_Body (N), Sub_Indent); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("passive_flag: ", Indent); + Put_Line (Image_Boolean (Get_Passive_Flag (N))); + Header ("foreign_flag: ", Indent); + Put_Line (Image_Boolean (Get_Foreign_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_body: ", Indent); + Put_Line (Image_Boolean (Get_Has_Body (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); + Header ("purity_state: ", Indent); + Put_Line (Image_Iir_Pure_State (Get_Purity_State (N))); + Header ("all_sensitized_state: ", Indent); + Put_Line (Image_Iir_All_Sensitized (Get_All_Sensitized_State (N))); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("impure_depth: ", Indent); + Put_Line (Iir_Int32'Image (Get_Impure_Depth (N))); + Header ("subprogram_specification: ", Indent); + Disp_Iir (Get_Subprogram_Specification (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Object_Alias_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("name: ", Indent); + Disp_Iir (Get_Name (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("after_drivers_flag: ", Indent); + Put_Line (Image_Boolean (Get_After_Drivers_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_File_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("file_logical_name: ", Indent); + Disp_Iir (Get_File_Logical_Name (N), Sub_Indent); + Header ("file_open_kind: ", Indent); + Disp_Iir (Get_File_Open_Kind (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + Header ("has_mode: ", Indent); + Put_Line (Image_Boolean (Get_Has_Mode (N))); + Header ("mode: ", Indent); + Put_Line (Image_Iir_Mode (Get_Mode (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Guard_Signal_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("guard_expression: ", Indent); + Disp_Iir (Get_Guard_Expression (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("guard_sensitivity_list: ", Indent); + Disp_Iir_List (Get_Guard_Sensitivity_List (N), Sub_Indent); + Header ("block_statement: ", Indent); + Disp_Iir (Get_Block_Statement (N), Sub_Indent); + Header ("has_active_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Active_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + Header ("signal_kind: ", Indent); + Put_Line (Image_Iir_Signal_Kind (Get_Signal_Kind (N))); + when Iir_Kind_Signal_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("signal_driver: ", Indent); + Disp_Iir (Get_Signal_Driver (N), Sub_Indent); + Header ("has_disconnect_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Disconnect_Flag (N))); + Header ("has_active_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Active_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("after_drivers_flag: ", Indent); + Put_Line (Image_Boolean (Get_After_Drivers_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + Header ("signal_kind: ", Indent); + Put_Line (Image_Iir_Signal_Kind (Get_Signal_Kind (N))); + when Iir_Kind_Variable_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("shared_flag: ", Indent); + Put_Line (Image_Boolean (Get_Shared_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Constant_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("deferred_declaration: ", Indent); + Disp_Iir (Get_Deferred_Declaration (N), Sub_Indent); + Header ("deferred_declaration_flag: ", Indent); + Put_Line (Image_Boolean (Get_Deferred_Declaration_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Iterator_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("discrete_range: ", Indent); + Disp_Iir (Get_Discrete_Range (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("has_identifier_list: ", Indent); + Put_Line (Image_Boolean (Get_Has_Identifier_List (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("after_drivers_flag: ", Indent); + Put_Line (Image_Boolean (Get_After_Drivers_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("mode: ", Indent); + Put_Line (Image_Iir_Mode (Get_Mode (N))); + Header ("lexical_layout: ", Indent); + Put_Line (Image_Iir_Lexical_Layout_Type + (Get_Lexical_Layout (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Signal_Interface_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("default_value: ", Indent); + Disp_Iir (Get_Default_Value (N), Sub_Indent); + Header ("has_disconnect_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Disconnect_Flag (N))); + Header ("has_active_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Active_Flag (N))); + Header ("open_flag: ", Indent); + Put_Line (Image_Boolean (Get_Open_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("after_drivers_flag: ", Indent); + Put_Line (Image_Boolean (Get_After_Drivers_Flag (N))); + Header ("use_flag: ", Indent); + Put_Line (Image_Boolean (Get_Use_Flag (N))); + Header ("mode: ", Indent); + Put_Line (Image_Iir_Mode (Get_Mode (N))); + Header ("lexical_layout: ", Indent); + Put_Line (Image_Iir_Lexical_Layout_Type + (Get_Lexical_Layout (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + Header ("signal_kind: ", Indent); + Put_Line (Image_Iir_Signal_Kind (Get_Signal_Kind (N))); + when Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("operand: ", Indent); + Disp_Iir (Get_Operand (N), Sub_Indent); + Header ("implementation: ", Indent); + Disp_Iir (Get_Implementation (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("left: ", Indent); + Disp_Iir (Get_Left (N), Sub_Indent); + Header ("implementation: ", Indent); + Disp_Iir (Get_Implementation (N), Sub_Indent, True); + Header ("right: ", Indent); + Disp_Iir (Get_Right (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Function_Call => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("parameter_association_chain: ", Indent); + Disp_Chain (Get_Parameter_Association_Chain (N), Sub_Indent); + Header ("implementation: ", Indent); + Disp_Iir (Get_Implementation (N), Sub_Indent, True); + Header ("method_object: ", Indent); + Disp_Iir (Get_Method_Object (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Aggregate => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("aggregate_info: ", Indent); + Disp_Iir (Get_Aggregate_Info (N), Sub_Indent); + Header ("association_choices_chain: ", Indent); + Disp_Chain (Get_Association_Choices_Chain (N), Sub_Indent); + Header ("literal_subtype: ", Indent); + Disp_Iir (Get_Literal_Subtype (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("value_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Value_Staticness (N))); + when Iir_Kind_Parenthesis_Expression => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Qualified_Expression => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("type_mark: ", Indent); + Disp_Iir (Get_Type_Mark (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Type_Conversion => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("type_conversion_subtype: ", Indent); + Disp_Iir (Get_Type_Conversion_Subtype (N), Sub_Indent); + Header ("type_mark: ", Indent); + Disp_Iir (Get_Type_Mark (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Allocator_By_Expression => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("allocator_designated_type: ", Indent); + Disp_Iir (Get_Allocator_Designated_Type (N), Sub_Indent, True); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Allocator_By_Subtype => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("allocator_designated_type: ", Indent); + Disp_Iir (Get_Allocator_Designated_Type (N), Sub_Indent, True); + Header ("subtype_indication: ", Indent); + Disp_Iir (Get_Subtype_Indication (N), Sub_Indent); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Selected_Element => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("selected_element: ", Indent); + Disp_Iir (Get_Selected_Element (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Slice_Name => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("suffix: ", Indent); + Disp_Iir (Get_Suffix (N), Sub_Indent); + Header ("slice_subtype: ", Indent); + Disp_Iir (Get_Slice_Subtype (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Indexed_Name => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("index_list: ", Indent); + Disp_Iir_List (Get_Index_List (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Psl_Expression => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("psl_expression: ", Indent); + Disp_PSL_Node (Get_Psl_Expression (N), Sub_Indent); + when Iir_Kind_Sensitized_Process_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("sensitivity_list: ", Indent); + Disp_Iir_List (Get_Sensitivity_List (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("process_origin: ", Indent); + Disp_Iir (Get_Process_Origin (N), Sub_Indent); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("end_has_postponed: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Postponed (N))); + Header ("passive_flag: ", Indent); + Put_Line (Image_Boolean (Get_Passive_Flag (N))); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("has_is: ", Indent); + Put_Line (Image_Boolean (Get_Has_Is (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); + when Iir_Kind_Process_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("callees_list: ", Indent); + Disp_Iir_List (Get_Callees_List (N), Sub_Indent); + Header ("process_origin: ", Indent); + Disp_Iir (Get_Process_Origin (N), Sub_Indent); + Header ("seen_flag: ", Indent); + Put_Line (Image_Boolean (Get_Seen_Flag (N))); + Header ("end_has_postponed: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Postponed (N))); + Header ("passive_flag: ", Indent); + Put_Line (Image_Boolean (Get_Passive_Flag (N))); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("has_is: ", Indent); + Put_Line (Image_Boolean (Get_Has_Is (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + Header ("wait_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Wait_State (N))); when Iir_Kind_Concurrent_Conditional_Signal_Assignment => - Header ("guarded_target_flag: " - & Tri_State_Type'Image (Get_Guarded_Target_State (Tree))); - Header ("target:"); - Disp_Tree (Get_Target (Tree), Ntab, True); - if Get_Guard (Tree) = Tree then - Header ("guard: guarded"); - else - Header ("guard:"); - Disp_Tree_Flat (Get_Guard (Tree), Ntab); - end if; - Header ("conditional waveform chain:"); - Disp_Tree_Chain (Get_Conditional_Waveform_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("target: ", Indent); + Disp_Iir (Get_Target (N), Sub_Indent); + Header ("delay_mechanism: ", Indent); + Put_Line (Image_Iir_Delay_Mechanism (Get_Delay_Mechanism (N))); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("reject_time_expression: ", Indent); + Disp_Iir (Get_Reject_Time_Expression (N), Sub_Indent); + Header ("conditional_waveform_chain: ", Indent); + Disp_Chain (Get_Conditional_Waveform_Chain (N), Sub_Indent); + Header ("guard: ", Indent); + Disp_Iir (Get_Guard (N), Sub_Indent); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("guarded_target_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Guarded_Target_State (N))); when Iir_Kind_Concurrent_Selected_Signal_Assignment => - Header ("guarded_target_flag: " - & Tri_State_Type'Image (Get_Guarded_Target_State (Tree))); - Header ("target:"); - Disp_Tree (Get_Target (Tree), Ntab, True); - if Get_Guard (Tree) = Tree then - Header ("guard: guarded"); - else - Header ("guard:"); - Disp_Tree_Flat (Get_Guard (Tree), Ntab); - end if; - Header ("choices:"); - Disp_Tree_Chain (Get_Selected_Waveform_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("target: ", Indent); + Disp_Iir (Get_Target (N), Sub_Indent); + Header ("delay_mechanism: ", Indent); + Put_Line (Image_Iir_Delay_Mechanism (Get_Delay_Mechanism (N))); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("reject_time_expression: ", Indent); + Disp_Iir (Get_Reject_Time_Expression (N), Sub_Indent); + Header ("selected_waveform_chain: ", Indent); + Disp_Chain (Get_Selected_Waveform_Chain (N), Sub_Indent); + Header ("guard: ", Indent); + Disp_Iir (Get_Guard (N), Sub_Indent); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("guarded_target_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Guarded_Target_State (N))); when Iir_Kind_Concurrent_Assertion_Statement => - Header ("condition:"); - Disp_Tree (Get_Assertion_Condition (Tree), Ntab); - Header ("report expression:"); - Disp_Tree (Get_Report_Expression (Tree), Ntab); - Header ("severity expression:"); - Disp_Tree (Get_Severity_Expression (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("assertion_condition: ", Indent); + Disp_Iir (Get_Assertion_Condition (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("severity_expression: ", Indent); + Disp_Iir (Get_Severity_Expression (N), Sub_Indent); + Header ("report_expression: ", Indent); + Disp_Iir (Get_Report_Expression (N), Sub_Indent); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Psl_Default_Clock => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("psl_boolean: ", Indent); + Disp_PSL_Node (Get_Psl_Boolean (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); when Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Cover_Statement => - PSL.Dump_Tree.Dump_Tree (Get_Psl_Property (Tree), True); - Header ("report expression:"); - Disp_Tree (Get_Report_Expression (Tree), Ntab); - Header ("severity expression:"); - Disp_Tree (Get_Severity_Expression (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Psl_Default_Clock => - null; - + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("psl_property: ", Indent); + Disp_PSL_Node (Get_Psl_Property (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("severity_expression: ", Indent); + Disp_Iir (Get_Severity_Expression (N), Sub_Indent); + Header ("report_expression: ", Indent); + Disp_Iir (Get_Report_Expression (N), Sub_Indent); + Header ("psl_clock: ", Indent); + Disp_PSL_Node (Get_PSL_Clock (N), Sub_Indent); + Header ("psl_nfa: ", Indent); + Disp_PSL_NFA (Get_PSL_NFA (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("procedure_call: ", Indent); + Disp_Iir (Get_Procedure_Call (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("postponed_flag: ", Indent); + Put_Line (Image_Boolean (Get_Postponed_Flag (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Block_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("concurrent_statement_chain: ", Indent); + Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("block_block_configuration: ", Indent); + Disp_Iir (Get_Block_Block_Configuration (N), Sub_Indent); + Header ("block_header: ", Indent); + Disp_Iir (Get_Block_Header (N), Sub_Indent); + Header ("guard_decl: ", Indent); + Disp_Iir (Get_Guard_Decl (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Generate_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("concurrent_statement_chain: ", Indent); + Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("generation_scheme: ", Indent); + Disp_Iir (Get_Generation_Scheme (N), Sub_Indent); + Header ("generate_block_configuration: ", Indent); + Disp_Iir (Get_Generate_Block_Configuration (N), Sub_Indent); + Header ("has_begin: ", Indent); + Put_Line (Image_Boolean (Get_Has_Begin (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Component_Instantiation_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("instantiated_unit: ", Indent); + Disp_Iir (Get_Instantiated_Unit (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("default_binding_indication: ", Indent); + Disp_Iir (Get_Default_Binding_Indication (N), Sub_Indent); + Header ("component_configuration: ", Indent); + Disp_Iir (Get_Component_Configuration (N), Sub_Indent); + Header ("configuration_specification: ", Indent); + Disp_Iir (Get_Configuration_Specification (N), Sub_Indent); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); + Header ("port_map_aspect_chain: ", Indent); + Disp_Chain (Get_Port_Map_Aspect_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); when Iir_Kind_Simple_Simultaneous_Statement => - Header ("left:"); - Disp_Tree (Get_Simultaneous_Left (Tree), Ntab); - Header ("right:"); - Disp_Tree (Get_Simultaneous_Right (Tree), Ntab); - Header ("tolerance:"); - Disp_Tree (Get_Tolerance (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement => - Disp_Label (Tree); - Header ("passive: " & Boolean'Image (Get_Passive_Flag (Tree))); - if Kind = Iir_Kind_Sensitized_Process_Statement then - Header ("sensivity list:"); - Disp_Tree_List (Get_Sensitivity_List (Tree), Ntab, True); - end if; - Header ("declaration_chain:"); - Disp_Tree_Chain (Get_Declaration_Chain (Tree), Ntab); - Header ("process statements:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_If_Statement => - Header ("condition:"); - Disp_Tree (Get_Condition (Tree), Ntab, True); - Header ("then sequence:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); - Header ("elsif:"); - Disp_Tree (Get_Else_Clause (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Elsif => - Header ("condition:"); - Disp_Tree (Get_Condition (Tree), Ntab); - Header ("then sequence:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); - Header ("elsif:"); - Disp_Tree (Get_Else_Clause (Tree), Tab); - when Iir_Kind_For_Loop_Statement => - Header ("parameter specification:"); - Disp_Tree (Get_Parameter_Specification (Tree), Ntab); - Header ("statements:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_While_Loop_Statement => - Header ("condition:"); - Disp_Tree (Get_Condition (Tree), Ntab); - Header ("statements:"); - Disp_Tree_Chain (Get_Sequential_Statement_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Case_Statement => - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - Header ("choices chain:"); - Disp_Tree_Chain - (Get_Case_Statement_Alternative_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("simultaneous_left: ", Indent); + Disp_Iir (Get_Simultaneous_Left (N), Sub_Indent); + Header ("simultaneous_right: ", Indent); + Disp_Iir (Get_Simultaneous_Right (N), Sub_Indent); + Header ("tolerance: ", Indent); + Disp_Iir (Get_Tolerance (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); when Iir_Kind_Signal_Assignment_Statement => - Header ("guarded_target_flag: " - & Tri_State_Type'Image (Get_Guarded_Target_State (Tree))); - Header ("target:"); - Disp_Tree (Get_Target (Tree), Ntab, True); - Header ("waveform_chain:"); - Disp_Tree_Chain (Get_Waveform_Chain (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Variable_Assignment_Statement => - Header ("target:"); - Disp_Tree (Get_Target (Tree), Ntab, True); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("target: ", Indent); + Disp_Iir (Get_Target (N), Sub_Indent); + Header ("delay_mechanism: ", Indent); + Put_Line (Image_Iir_Delay_Mechanism (Get_Delay_Mechanism (N))); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("waveform_chain: ", Indent); + Disp_Chain (Get_Waveform_Chain (N), Sub_Indent); + Header ("reject_time_expression: ", Indent); + Disp_Iir (Get_Reject_Time_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("guarded_target_state: ", Indent); + Put_Line (Image_Tri_State_Type (Get_Guarded_Target_State (N))); + when Iir_Kind_Null_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); when Iir_Kind_Assertion_Statement => - Header ("condition:"); - Disp_Tree (Get_Assertion_Condition (Tree), Ntab); - Header ("report expression:"); - Disp_Tree (Get_Report_Expression (Tree), Ntab); - Header ("severity expression:"); - Disp_Tree (Get_Severity_Expression (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("assertion_condition: ", Indent); + Disp_Iir (Get_Assertion_Condition (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("severity_expression: ", Indent); + Disp_Iir (Get_Severity_Expression (N), Sub_Indent); + Header ("report_expression: ", Indent); + Disp_Iir (Get_Report_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); when Iir_Kind_Report_Statement => - Header ("report expression:"); - Disp_Tree (Get_Report_Expression (Tree), Ntab); - Header ("severity expression:"); - Disp_Tree (Get_Severity_Expression (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Return_Statement => - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("severity_expression: ", Indent); + Disp_Iir (Get_Severity_Expression (N), Sub_Indent); + Header ("report_expression: ", Indent); + Disp_Iir (Get_Report_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); when Iir_Kind_Wait_Statement => - Header ("sensitivity list:"); - Disp_Tree_List (Get_Sensitivity_List (Tree), Ntab, True); - Header ("condition:"); - Disp_Tree (Get_Condition_Clause (Tree), Ntab); - Header ("timeout:"); - Disp_Tree (Get_Timeout_Clause (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Procedure_Call_Statement - | Iir_Kind_Concurrent_Procedure_Call_Statement => - Disp_Label (Tree); - Header ("procedure_call:"); - Disp_Tree (Get_Procedure_Call (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Procedure_Call => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab); - Header ("implementation:"); - Disp_Tree (Get_Implementation (Tree), Ntab, True); - Header ("method_object:"); - Disp_Tree (Get_Method_Object (Tree), Ntab); - Header ("parameters:"); - Disp_Tree_Chain (Get_Parameter_Association_Chain (Tree), Ntab); - when Iir_Kind_Exit_Statement - | Iir_Kind_Next_Statement => - Header ("loop_label:"); - Disp_Tree (Get_Loop_Label (Tree), Ntab); - Header ("condition:"); - Disp_Tree (Get_Condition (Tree), Ntab); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - when Iir_Kind_Null_Statement => - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - - when Iir_Kinds_Dyadic_Operator => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("implementation:"); - Disp_Tree (Get_Implementation (Tree), Ntab, True); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("left:"); - Disp_Tree (Get_Left (Tree), Ntab, True); - Header ("right:"); - Disp_Tree (Get_Right (Tree), Ntab, True); - - when Iir_Kinds_Monadic_Operator => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("implementation:"); - Disp_Tree (Get_Implementation (Tree), Ntab, True); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("operand:"); - Disp_Tree (Get_Operand (Tree), Ntab, True); - - when Iir_Kind_Function_Call => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab); - Header ("implementation:"); - Disp_Tree_Flat (Get_Implementation (Tree), Ntab); - Header ("method_object:"); - Disp_Tree (Get_Method_Object (Tree), Ntab); - Header ("parameters:"); - Disp_Tree_Chain (Get_Parameter_Association_Chain (Tree), Ntab); - when Iir_Kind_Parenthesis_Expression => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - when Iir_Kind_Qualified_Expression => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("type mark:"); - Disp_Tree (Get_Type_Mark (Tree), Ntab, True); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - when Iir_Kind_Type_Conversion => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("type_mark:"); - Disp_Tree_Flat (Get_Type_Mark (Tree), Ntab); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - when Iir_Kind_Allocator_By_Expression => - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("expression:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - when Iir_Kind_Allocator_By_Subtype => - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("subtype indication:"); - Disp_Tree (Get_Expression (Tree), Ntab, True); - when Iir_Kind_Selected_Element => - Header ("staticness:", false); - Disp_Name_Staticness (Tree); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("selected element:"); - Disp_Tree (Get_Selected_Element (Tree), Ntab, True); - when Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference => - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - - when Iir_Kind_Aggregate => - Header ("staticness: value: ", false); - Disp_Staticness (Get_Value_Staticness (Tree)); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("aggregate_info:"); - Disp_Tree (Get_Aggregate_Info (Tree), Ntab); - Header ("associations:"); - Disp_Tree_Chain (Get_Association_Choices_Chain (Tree), Ntab); - when Iir_Kind_Aggregate_Info => - Header ("aggr_others_flag: ", False); - Disp_Flag (Get_Aggr_Others_Flag (Tree)); - Header ("aggr_named_flag: ", False); - Disp_Flag (Get_Aggr_Named_Flag (Tree)); - Header ("aggr_dynamic_flag: ", False); - Disp_Flag (Get_Aggr_Dynamic_Flag (Tree)); - Header ("aggr_low_limit:"); - Disp_Tree (Get_Aggr_Low_Limit (Tree), Ntab, False); - Header ("aggr_high_limit:"); - Disp_Tree (Get_Aggr_High_Limit (Tree), Ntab, False); - Header ("aggr_min_length:" & - Iir_Int32'Image (Get_Aggr_Min_Length (Tree))); - Header ("sub_aggregate_info:"); - Disp_Tree (Get_Sub_Aggregate_Info (Tree), Ntab); + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("timeout_clause: ", Indent); + Disp_Iir (Get_Timeout_Clause (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("condition_clause: ", Indent); + Disp_Iir (Get_Condition_Clause (N), Sub_Indent); + Header ("sensitivity_list: ", Indent); + Disp_Iir_List (Get_Sensitivity_List (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Variable_Assignment_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("target: ", Indent); + Disp_Iir (Get_Target (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Return_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_For_Loop_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("parameter_specification: ", Indent); + Disp_Iir (Get_Parameter_Specification (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_While_Loop_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("condition: ", Indent); + Disp_Iir (Get_Condition (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("condition: ", Indent); + Disp_Iir (Get_Condition (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("loop_label: ", Indent); + Disp_Iir (Get_Loop_Label (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_Case_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("case_statement_alternative_chain: ", Indent); + Disp_Chain (Get_Case_Statement_Alternative_Chain (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("expression: ", Indent); + Disp_Iir (Get_Expression (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Procedure_Call_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("procedure_call: ", Indent); + Disp_Iir (Get_Procedure_Call (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + when Iir_Kind_If_Statement => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("condition: ", Indent); + Disp_Iir (Get_Condition (N), Sub_Indent); + Header ("label: ", Indent); + Put_Line (Image_Name_Id (Get_Label (N))); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("else_clause: ", Indent); + Disp_Iir (Get_Else_Clause (N), Sub_Indent); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Elsif => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("condition: ", Indent); + Disp_Iir (Get_Condition (N), Sub_Indent); + Header ("sequential_statement_chain: ", Indent); + Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); + Header ("else_clause: ", Indent); + Disp_Iir (Get_Else_Clause (N), Sub_Indent); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name => + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("alias_declaration: ", Indent); + Disp_Iir (Get_Alias_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Selected_Name => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("alias_declaration: ", Indent); + Disp_Iir (Get_Alias_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); when Iir_Kind_Operator_Symbol => - null; - when Iir_Kind_Simple_Name => - Header ("staticness:", false); - Disp_Name_Staticness (Tree); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("named_entity:"); - Disp_Tree_Flat (Get_Named_Entity (Tree), Ntab); - when Iir_Kind_Indexed_Name => - Header ("staticness:", false); - Disp_Name_Staticness (Tree); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("index:"); - Disp_Tree_List (Get_Index_List (Tree), Ntab, True); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - when Iir_Kind_Slice_Name => - Header ("staticness:", false); - Disp_Name_Staticness (Tree); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("suffix:"); - Disp_Tree (Get_Suffix (Tree), Ntab); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - when Iir_Kind_Parenthesis_Name => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, Flat_Decl); - Header ("association chain:"); - Disp_Tree_Chain (Get_Association_Chain (Tree), Ntab); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("alias_declaration: ", Indent); + Disp_Iir (Get_Alias_Declaration (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); when Iir_Kind_Selected_By_All_Name => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - when Iir_Kind_Selected_Name => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("identifier: ", False); - Disp_Ident (Get_Identifier (Tree)); - Header ("named_entity:"); - Disp_Tree_Flat (Get_Named_Entity (Tree), Ntab); - - when Iir_Kind_Attribute_Name => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab, True); - Header ("signature:"); - Disp_Tree (Get_Attribute_Signature (Tree), Ntab); - + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + when Iir_Kind_Parenthesis_Name => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("association_chain: ", Indent); + Disp_Chain (Get_Association_Chain (N), Sub_Indent); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); when Iir_Kind_Base_Attribute => - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Left_Type_Attribute - | Iir_Kind_Right_Type_Attribute - | Iir_Kind_High_Type_Attribute - | Iir_Kind_Low_Type_Attribute - | Iir_Kind_Ascending_Type_Attribute => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); when Iir_Kind_Image_Attribute - | Iir_Kind_Value_Attribute => - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("parameter:"); - Disp_Tree (Get_Parameter (Tree), Ntab); - when Iir_Kind_Pos_Attribute - | Iir_Kind_Val_Attribute - | Iir_Kind_Succ_Attribute - | Iir_Kind_Pred_Attribute - | Iir_Kind_Leftof_Attribute - | Iir_Kind_Rightof_Attribute => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("prefix:"); - Disp_Tree (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("parameter:"); - Disp_Tree (Get_Parameter (Tree), Ntab); - when Iir_Kind_Left_Array_Attribute - | Iir_Kind_Right_Array_Attribute - | Iir_Kind_High_Array_Attribute - | Iir_Kind_Low_Array_Attribute - | Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute - | Iir_Kind_Length_Array_Attribute - | Iir_Kind_Ascending_Array_Attribute => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("parameter:"); - Disp_Tree (Get_Parameter (Tree), Ntab); + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("parameter: ", Indent); + Disp_Iir (Get_Parameter (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); when Iir_Kind_Delayed_Attribute | Iir_Kind_Stable_Attribute | Iir_Kind_Quiet_Attribute | Iir_Kind_Transaction_Attribute => - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - if Kind /= Iir_Kind_Transaction_Attribute then - Header ("parameter:"); - Disp_Tree (Get_Parameter (Tree), Ntab); - end if; - Header ("has_active_flag: ", False); - Disp_Flag (Get_Has_Active_Flag (Tree)); + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("parameter: ", Indent); + Disp_Iir (Get_Parameter (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("has_active_flag: ", Indent); + Put_Line (Image_Boolean (Get_Has_Active_Flag (N))); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); when Iir_Kind_Event_Attribute | Iir_Kind_Active_Attribute | Iir_Kind_Last_Event_Attribute @@ -1927,110 +3252,80 @@ package body Disp_Tree is | Iir_Kind_Last_Value_Attribute | Iir_Kind_Driving_Attribute | Iir_Kind_Driving_Value_Attribute => - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Behavior_Attribute - | Iir_Kind_Structure_Attribute => - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Simple_Name_Attribute - | Iir_Kind_Instance_Name_Attribute - | Iir_Kind_Path_Name_Attribute => - Header ("prefix:"); - Disp_Tree_Flat (Get_Prefix (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - - when Iir_Kind_Enumeration_Literal => - if Flat_Decl and then Get_Literal_Origin (Tree) = Null_Iir then - return; - end if; - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("value:" & Iir_Int32'Image (Get_Enum_Pos (Tree))); - Header ("attribute_value_chain:"); - Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - when Iir_Kind_Integer_Literal => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - when Iir_Kind_Floating_Point_Literal => - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - when Iir_Kind_String_Literal => - Header ("value: """ & Iirs_Utils.Image_String_Lit (Tree) & """"); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - when Iir_Kind_Bit_String_Literal => - Header ("base: " & Base_Type'Image (Get_Bit_String_Base (Tree))); - Header ("value: """ & Iirs_Utils.Image_String_Lit (Tree) & """"); - Header ("len:" & Int32'Image (Get_String_Length (Tree))); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Character_Literal => - Header ("value: '" & - Name_Table.Get_Character (Get_Identifier (Tree)) & - '''); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Physical_Int_Literal => - Header ("staticness:", False); - Disp_Expr_Staticness (Tree); - Header ("value: " & Iir_Int64'Image (Get_Value (Tree))); - Header ("unit_name: "); - Disp_Tree_Flat (Get_Unit_Name (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab); - when Iir_Kind_Physical_Fp_Literal => - Header ("staticness:", False); - Disp_Expr_Staticness (Tree); - Header ("fp_value: " & Iir_Fp64'Image (Get_Fp_Value (Tree))); - Header ("unit_name: "); - Disp_Tree_Flat (Get_Unit_Name (Tree), Ntab); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab); - when Iir_Kind_Null_Literal => - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - when Iir_Kind_Simple_Aggregate => - Header ("simple_aggregate_list:"); - Disp_Tree_List (Get_Simple_Aggregate_List (Tree), Ntab, True); - Header ("type:"); - Disp_Tree (Get_Type (Tree), Ntab, True); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - when Iir_Kind_Overflow_Literal => - Header ("staticness:", false); - Disp_Expr_Staticness (Tree); - Header ("type:"); - Disp_Tree_Flat (Get_Type (Tree), Ntab); - Header ("origin:"); - Disp_Tree (Get_Literal_Origin (Tree), Ntab, True); - - when Iir_Kind_Entity_Class => - null; + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Simple_Name_Attribute => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("simple_name_identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Simple_Name_Identifier (N))); + Header ("simple_name_subtype: ", Indent); + Disp_Iir (Get_Simple_Name_Subtype (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("index_subtype: ", Indent); + Disp_Iir (Get_Index_Subtype (N), Sub_Indent); + Header ("parameter: ", Indent); + Disp_Iir (Get_Parameter (N), Sub_Indent); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); + when Iir_Kind_Attribute_Name => + Header ("prefix: ", Indent); + Disp_Iir (Get_Prefix (N), Sub_Indent); + Header ("type: ", Indent); + Disp_Iir (Get_Type (N), Sub_Indent, True); + Header ("attribute_signature: ", Indent); + Disp_Iir (Get_Attribute_Signature (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("named_entity: ", Indent); + Disp_Iir (Get_Named_Entity (N), Sub_Indent, True); + Header ("base_name: ", Indent); + Disp_Iir (Get_Base_Name (N), Sub_Indent, True); + Header ("expr_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Expr_Staticness (N))); + Header ("name_staticness: ", Indent); + Put_Line (Image_Iir_Staticness (Get_Name_Staticness (N))); end case; - end Disp_Tree; + end Disp_Iir; + procedure Disp_Tree_For_Psl (N : Int32) is begin Disp_Tree_Flat (Iir (N), 1); end Disp_Tree_For_Psl; + + procedure Disp_Tree (Tree : Iir; + Flat : Boolean := false) is + begin + Disp_Iir (Tree, 1, Flat); + end Disp_Tree; end Disp_Tree; diff --git a/disp_tree.ads b/disp_tree.ads index 63720ee..94b1d29 100644 --- a/disp_tree.ads +++ b/disp_tree.ads @@ -19,14 +19,9 @@ with Types; use Types; with Iirs; use Iirs; package Disp_Tree is - -- Disp NODE as an address. The format is "[XXXXXXXX]", where each X is - -- an hexadecimal digit (quotes are not displayed). - procedure Disp_Iir_Address (Node: Iir); - -- Disp TREE recursively. - procedure Disp_Tree (Tree: Iir; - Tab: Natural := 0; - Flat_Decl: Boolean := false); + procedure Disp_Tree (Tree : Iir; + Flat : Boolean := False); procedure Disp_Tree_For_Psl (N : Int32); end Disp_Tree; diff --git a/disp_vhdl.adb b/disp_vhdl.adb index c0a4f96..1f5c893 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -1233,7 +1233,7 @@ package body Disp_Vhdl is Disp_Name (El); end loop; end if; - El := Get_Return_Type (Sig); + El := Get_Return_Type_Mark (Sig); if El /= Null_Iir then Put (" return "); Disp_Name (El); @@ -1836,7 +1836,7 @@ package body Disp_Vhdl is Put_Line (","); end if; Set_Col (Indent + Indentation); - Disp_Waveform (Get_Associated (Assoc)); + Disp_Waveform (Get_Associated_Chain (Assoc)); Put (" when "); Disp_Choice (Assoc); end loop; @@ -1959,7 +1959,7 @@ package body Disp_Vhdl is while Assoc /= Null_Iir loop Set_Col (Indent + Indentation); Put ("when "); - Sel_Stmt := Get_Associated (Assoc); + Sel_Stmt := Get_Associated_Chain (Assoc); Disp_Choice (Assoc); Put_Line (" =>"); Set_Col (Indent + 2 * Indentation); @@ -2337,11 +2337,11 @@ package body Disp_Vhdl is when Iir_Kind_Choice_By_None => null; when Iir_Kind_Choice_By_Expression => - Disp_Expression (Get_Expression (Choice)); + Disp_Expression (Get_Choice_Expression (Choice)); when Iir_Kind_Choice_By_Range => - Disp_Range (Get_Expression (Choice)); + Disp_Range (Get_Choice_Range (Choice)); when Iir_Kind_Choice_By_Name => - Disp_Name_Of (Get_Name (Choice)); + Disp_Name_Of (Get_Choice_Name (Choice)); when others => Error_Kind ("disp_choice", Choice); end case; @@ -2366,7 +2366,7 @@ package body Disp_Vhdl is Put ("("); Assoc := Get_Association_Choices_Chain (Aggr); loop - Expr := Get_Associated (Assoc); + Expr := Get_Associated_Expr (Assoc); if Get_Kind (Assoc) /= Iir_Kind_Choice_By_None then Disp_Choice (Assoc); Put (" => "); @@ -3053,6 +3053,8 @@ package body Disp_Vhdl is Put (" ("); Disp_Range (Get_Suffix (Spec)); Put (")"); + when Iir_Kind_Simple_Name => + Disp_Name (Spec); when others => Error_Kind ("disp_block_configuration", Spec); end case; diff --git a/errorout.adb b/errorout.adb index a701e1a..2a6d277 100644 --- a/errorout.adb +++ b/errorout.adb @@ -813,13 +813,10 @@ package body Errorout is when Iir_Kind_Binding_Indication => return "binding indication"; - when Iir_Kind_Error => return "error"; - --- when others => --- Error_Kind ("disp_node", Node); --- return "???"; + when Iir_Kind_Unused => + return "*unused*"; end case; end Disp_Node; diff --git a/evaluation.adb b/evaluation.adb index bd6649c..28ae739 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -167,6 +167,7 @@ package body Evaluation is Set_Type (Res, Stype); Set_Literal_Origin (Res, Origin); Set_Expr_Staticness (Res, Locally); + Set_Literal_Subtype (Res, Stype); return Res; end Build_Simple_Aggregate; @@ -206,7 +207,9 @@ package body Evaluation is Prim_Name := Get_Primary_Unit_Name (Get_Base_Type (Get_Type (Origin))); Set_Unit_Name (Res, Prim_Name); - if Get_Unit_Name (Val) = Prim_Name then + if Get_Named_Entity (Get_Unit_Name (Val)) + = Get_Named_Entity (Prim_Name) + then Set_Value (Res, Get_Value (Val)); else raise Internal_Error; @@ -235,6 +238,7 @@ package body Evaluation is when Iir_Kind_Simple_Aggregate => Res := Create_Iir (Iir_Kind_Simple_Aggregate); Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); + Set_Literal_Subtype (Res, Get_Type (Origin)); when Iir_Kind_Overflow_Literal => Res := Create_Iir (Iir_Kind_Overflow_Literal); @@ -421,6 +425,13 @@ package body Evaluation is return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc); end Create_Unidim_Array_By_Length; + procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is + begin + if Res /= Orig and then Get_Literal_Origin (Res) = Orig then + Free_Iir (Res); + end if; + end Free_Eval_Static_Expr; + function Eval_String_Literal (Str : Iir) return Iir is Ptr : String_Fat_Acc; @@ -451,17 +462,15 @@ package body Evaluation is end loop; return Build_Simple_Aggregate (List, Str, Get_Type (Str)); end; + when Iir_Kind_Bit_String_Literal => declare - Str_Type : Iir; + Str_Type : constant Iir := Get_Type (Str); List : Iir_List; - Lit_0 : Iir; - Lit_1 : Iir; + Lit_0 : constant Iir := Get_Bit_String_0 (Str); + Lit_1 : constant Iir := Get_Bit_String_1 (Str); begin - Str_Type := Get_Type (Str); List := Create_Iir_List; - Lit_0 := Get_Bit_String_0 (Str); - Lit_1 := Get_Bit_String_1 (Str); Ptr := Get_String_Fat_Acc (Str); Len := Get_String_Length (Str); @@ -478,8 +487,10 @@ package body Evaluation is end loop; return Build_Simple_Aggregate (List, Str, Str_Type); end; + when Iir_Kind_Simple_Aggregate => return Str; + when others => Error_Kind ("eval_string_literal", Str); end case; @@ -806,7 +817,9 @@ package body Evaluation is L : Natural; Res_Type : Iir; Origin_Type : Iir; + Left_Aggr, Right_Aggr : Iir; Left_List, Right_List : Iir_List; + Left_Len : Natural; begin Res_List := Create_Iir_List; -- Do the concatenation. @@ -815,14 +828,19 @@ package body Evaluation is when Iir_Predefined_Element_Array_Concat | Iir_Predefined_Element_Element_Concat => Append_Element (Res_List, Left); + Left_Len := 1; when Iir_Predefined_Array_Element_Concat | Iir_Predefined_Array_Array_Concat => - Left_List := - Get_Simple_Aggregate_List (Eval_String_Literal (Left)); - L := Get_Nbr_Elements (Left_List); - for I in 0 .. L - 1 loop + Left_Aggr := Eval_String_Literal (Left); + Left_List := Get_Simple_Aggregate_List (Left_Aggr); + Left_Len := Get_Nbr_Elements (Left_List); + for I in 0 .. Left_Len - 1 loop Append_Element (Res_List, Get_Nth_Element (Left_List, I)); end loop; + if Left_Aggr /= Left then + Destroy_Iir_List (Left_List); + Free_Iir (Left_Aggr); + end if; end case; -- Right: case Func is @@ -831,12 +849,16 @@ package body Evaluation is Append_Element (Res_List, Right); when Iir_Predefined_Element_Array_Concat | Iir_Predefined_Array_Array_Concat => - Right_List := - Get_Simple_Aggregate_List (Eval_String_Literal (Right)); + Right_Aggr := Eval_String_Literal (Right); + Right_List := Get_Simple_Aggregate_List (Right_Aggr); L := Get_Nbr_Elements (Right_List); for I in 0 .. L - 1 loop Append_Element (Res_List, Get_Nth_Element (Right_List, I)); end loop; + if Right_Aggr /= Right then + Destroy_Iir_List (Right_List); + Free_Iir (Right_Aggr); + end if; end case; L := Get_Nbr_Elements (Res_List); @@ -844,7 +866,7 @@ package body Evaluation is Origin_Type := Get_Type (Orig); Res_Type := Null_Iir; if Func = Iir_Predefined_Array_Array_Concat - and then Get_Nbr_Elements (Left_List) = 0 + and then Left_Len = 0 then if Flags.Vhdl_Std = Vhdl_87 then -- LRM87 7.2.4 @@ -912,24 +934,36 @@ package body Evaluation is function Eval_Array_Equality (Left, Right : Iir) return Boolean is + Left_Val, Right_Val : Iir; L_List : Iir_List; R_List : Iir_List; N : Natural; + Res : Boolean; begin - -- FIXME: the simple aggregates are lost. - L_List := Get_Simple_Aggregate_List (Eval_String_Literal (Left)); - R_List := Get_Simple_Aggregate_List (Eval_String_Literal (Right)); + Left_Val := Eval_String_Literal (Left); + Right_Val := Eval_String_Literal (Right); + + L_List := Get_Simple_Aggregate_List (Left_Val); + R_List := Get_Simple_Aggregate_List (Right_Val); N := Get_Nbr_Elements (L_List); if N /= Get_Nbr_Elements (R_List) then - return False; + -- Cannot be equal if not the same length. + Res := False; + else + Res := True; + for I in 0 .. N - 1 loop + -- FIXME: this is wrong: (eg: evaluated lit) + if Get_Nth_Element (L_List, I) /= Get_Nth_Element (R_List, I) then + Res := False; + exit; + end if; + end loop; end if; - for I in 0 .. N - 1 loop - -- FIXME: this is wrong: (eg: evaluated lit) - if Get_Nth_Element (L_List, I) /= Get_Nth_Element (R_List, I) then - return False; - end if; - end loop; - return True; + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; end Eval_Array_Equality; -- ORIG is either a dyadic operator or a function call. @@ -1637,24 +1671,24 @@ package body Evaluation is end if; end Build_Physical_Value; - function Eval_Incdec (Expr : Iir; N : Iir_Int64) return Iir + function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir is P : Iir_Int64; begin case Get_Kind (Expr) is when Iir_Kind_Integer_Literal => - return Build_Integer (Get_Value (Expr) + N, Expr); + return Build_Integer (Get_Value (Expr) + N, Origin); when Iir_Kind_Enumeration_Literal => P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; if P < 0 then Warning_Msg_Sem ("static constant violates bounds", Expr); - return Build_Overflow (Expr); + return Build_Overflow (Origin); else - return Build_Enumeration (Iir_Index32 (P), Expr); + return Build_Enumeration (Iir_Index32 (P), Origin); end if; when Iir_Kind_Physical_Int_Literal | Iir_Kind_Unit_Declaration => - return Build_Physical (Get_Physical_Value (Expr) + N, Expr); + return Build_Physical (Get_Physical_Value (Expr) + N, Origin); when others => Error_Kind ("eval_incdec", Expr); end case; @@ -1696,6 +1730,7 @@ package body Evaluation is Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0); Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0); Index_Type : Iir; + Res_Type : Iir; Res : Iir; Rng : Iir; begin @@ -1727,9 +1762,10 @@ package body Evaluation is Set_Base_Type (Index_Type, Get_Base_Type (Conv_Index_Type)); Set_Type_Staticness (Index_Type, Locally); end if; - Set_Type (Res, - Create_Unidim_Array_From_Index - (Get_Base_Type (Conv_Type), Index_Type, Conv)); + Res_Type := Create_Unidim_Array_From_Index + (Get_Base_Type (Conv_Type), Index_Type, Conv); + Set_Type (Res, Res_Type); + Set_Type_Conversion_Subtype (Conv, Res_Type); return Res; when others => Error_Kind ("eval_array_type_conversion", Conv_Type); @@ -1791,7 +1827,7 @@ package body Evaluation is | Iir_Kind_Overflow_Literal => return Expr; when Iir_Kind_Physical_Int_Literal => - if Get_Unit_Name (Expr) + if Get_Named_Entity (Get_Unit_Name (Expr)) = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr))) then return Expr; @@ -1820,7 +1856,7 @@ package body Evaluation is when Iir_Kind_Object_Alias_Declaration => return Eval_Static_Expr (Get_Name (Expr)); when Iir_Kind_Unit_Declaration => - return Expr; + return Get_Physical_Unit_Value (Expr); when Iir_Kind_Simple_Aggregate => return Expr; @@ -1840,33 +1876,51 @@ package body Evaluation is end; when Iir_Kinds_Dyadic_Operator => declare - Left, Right : Iir; + Left : constant Iir := Get_Left (Expr); + Right : constant Iir := Get_Right (Expr); + Left_Val, Right_Val : Iir; + Res : Iir; begin - Left := Eval_Static_Expr (Get_Left (Expr)); - Right := Eval_Static_Expr (Get_Right (Expr)); + Left_Val := Eval_Static_Expr (Left); + Right_Val := Eval_Static_Expr (Right); - return Eval_Dyadic_Operator - (Expr, Get_Implementation (Expr), Left, Right); + Res := Eval_Dyadic_Operator + (Expr, Get_Implementation (Expr), Left_Val, Right_Val); + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; end; - when Iir_Kind_Attribute_Value => - -- FIXME: see constant_declaration. - -- Currently, this avoids weird nodes, such as a string literal - -- whose type is an unconstrained array type. - Val := Get_Expression (Get_Attribute_Specification (Expr)); - Res := Build_Constant (Eval_Static_Expr (Val), Expr); - Set_Type (Res, Get_Type (Val)); - return Res; when Iir_Kind_Attribute_Name => - return Eval_Static_Expr (Get_Named_Entity (Expr)); + -- An attribute name designates an attribute value. + declare + Attr_Val : constant Iir := Get_Named_Entity (Expr); + Attr_Expr : constant Iir := + Get_Expression (Get_Attribute_Specification (Attr_Val)); + Val : Iir; + begin + Val := Eval_Static_Expr (Attr_Expr); + -- FIXME: see constant_declaration. + -- Currently, this avoids weird nodes, such as a string literal + -- whose type is an unconstrained array type. + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + end; when Iir_Kind_Pos_Attribute => declare + Param : constant Iir := Get_Parameter (Expr); Val : Iir; + Res : Iir; begin - Val := Eval_Static_Expr (Get_Parameter (Expr)); + Val := Eval_Static_Expr (Param); -- FIXME: check bounds, handle overflow. - return Build_Integer (Eval_Pos (Val), Expr); + Res := Build_Integer (Eval_Pos (Val), Expr); + Free_Eval_Static_Expr (Val, Param); + return Res; end; when Iir_Kind_Val_Attribute => declare @@ -2016,11 +2070,13 @@ package body Evaluation is end; when Iir_Kind_Pred_Attribute => - Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), -1); + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr); Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); return Res; when Iir_Kind_Succ_Attribute => - Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), +1); + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr); Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); return Res; when Iir_Kind_Leftof_Attribute @@ -2047,7 +2103,8 @@ package body Evaluation is when others => raise Internal_Error; end case; - Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), N); + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr); Eval_Check_Bound (Res, Prefix_Type); return Res; end; @@ -52,6 +52,17 @@ package body Iirs is function Get_Format (Kind : Iir_Kind) return Format_Type; + function Create_Iir (Kind : Iir_Kind) return Iir + is + Res : Iir; + Format : Format_Type; + begin + Format := Get_Format (Kind); + Res := Create_Node (Format); + Set_Nkind (Res, Iir_Kind'Pos (Kind)); + return Res; + end Create_Iir; + -- Statistics. procedure Disp_Stats is @@ -141,7 +152,7 @@ package body Iirs is procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; Pos : Source_Ptr; Line, Off: Natural) is begin - Set_Field1 (Design_Unit, Node_Type (Pos)); + Set_Field4 (Design_Unit, Node_Type (Pos)); Set_Field11 (Design_Unit, Node_Type (Off)); Set_Field12 (Design_Unit, Node_Type (Line)); end Set_Pos_Line_Off; @@ -149,7 +160,7 @@ package body Iirs is procedure Get_Pos_Line_Off (Design_Unit: Iir_Design_Unit; Pos : out Source_Ptr; Line, Off: out Natural) is begin - Pos := Source_Ptr (Get_Field1 (Design_Unit)); + Pos := Source_Ptr (Get_Field4 (Design_Unit)); Off := Natural (Get_Field11 (Design_Unit)); Line := Natural (Get_Field12 (Design_Unit)); end Get_Pos_Line_Off; @@ -250,7 +261,8 @@ package body Iirs is function Get_Format (Kind : Iir_Kind) return Format_Type is begin case Kind is - when Iir_Kind_Error + when Iir_Kind_Unused + | Iir_Kind_Error | Iir_Kind_Library_Clause | Iir_Kind_Use_Clause | Iir_Kind_Null_Literal @@ -274,7 +286,6 @@ package body Iirs is | Iir_Kind_Component_Configuration | Iir_Kind_Entity_Class | Iir_Kind_Attribute_Value - | Iir_Kind_Signature | Iir_Kind_Aggregate_Info | Iir_Kind_Procedure_Call | Iir_Kind_Record_Element_Constraint @@ -430,6 +441,7 @@ package body Iirs is | Iir_Kind_Bit_String_Literal | Iir_Kind_Block_Header | Iir_Kind_Binding_Indication + | Iir_Kind_Signature | Iir_Kind_Attribute_Specification | Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition @@ -491,17 +503,6 @@ package body Iirs is end case; end Get_Format; - function Create_Iir (Kind : Iir_Kind) return Iir - is - Res : Iir; - Format : Format_Type; - begin - Format := Get_Format (Kind); - Res := Create_Node (Format); - Set_Nkind (Res, Iir_Kind'Pos (Kind)); - return Res; - end Create_Iir; - procedure Check_Kind_For_First_Design_Unit (Target : Iir) is begin case Get_Kind (Target) is @@ -716,14 +717,13 @@ package body Iirs is end case; end Check_Kind_For_Design_File; - function Get_Design_File (Unit : Iir_Design_Unit) return Iir_Design_File is + function Get_Design_File (Unit : Iir_Design_Unit) return Iir is begin Check_Kind_For_Design_File (Unit); return Get_Field0 (Unit); end Get_Design_File; - procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir_Design_File) - is + procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir) is begin Check_Kind_For_Design_File (Unit); Set_Field0 (Unit, File); @@ -739,13 +739,13 @@ package body Iirs is end case; end Check_Kind_For_Design_File_Chain; - function Get_Design_File_Chain (Library : Iir) return Iir_Design_File is + function Get_Design_File_Chain (Library : Iir) return Iir is begin Check_Kind_For_Design_File_Chain (Library); return Get_Field1 (Library); end Get_Design_File_Chain; - procedure Set_Design_File_Chain (Library : Iir; Chain : Iir_Design_File) is + procedure Set_Design_File_Chain (Library : Iir; Chain : Iir) is begin Check_Kind_For_Design_File_Chain (Library); Set_Field1 (Library, Chain); @@ -1123,13 +1123,13 @@ package body Iirs is function Get_Bit_String_Base (Lit : Iir) return Base_Type is begin Check_Kind_For_Bit_String_Base (Lit); - return Base_Type'Val (Get_Field11 (Lit)); + return Base_Type'Val (Get_Field8 (Lit)); end Get_Bit_String_Base; procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type) is begin Check_Kind_For_Bit_String_Base (Lit); - Set_Field11 (Lit, Base_Type'Pos (Base)); + Set_Field8 (Lit, Base_Type'Pos (Base)); end Set_Bit_String_Base; procedure Check_Kind_For_Bit_String_0 (Target : Iir) is @@ -1142,16 +1142,16 @@ package body Iirs is end case; end Check_Kind_For_Bit_String_0; - function Get_Bit_String_0 (Lit : Iir) return Iir_Enumeration_Literal is + function Get_Bit_String_0 (Lit : Iir) return Iir is begin Check_Kind_For_Bit_String_0 (Lit); - return Get_Field4 (Lit); + return Get_Field6 (Lit); end Get_Bit_String_0; - procedure Set_Bit_String_0 (Lit : Iir; El : Iir_Enumeration_Literal) is + procedure Set_Bit_String_0 (Lit : Iir; El : Iir) is begin Check_Kind_For_Bit_String_0 (Lit); - Set_Field4 (Lit, El); + Set_Field6 (Lit, El); end Set_Bit_String_0; procedure Check_Kind_For_Bit_String_1 (Target : Iir) is @@ -1164,16 +1164,16 @@ package body Iirs is end case; end Check_Kind_For_Bit_String_1; - function Get_Bit_String_1 (Lit : Iir) return Iir_Enumeration_Literal is + function Get_Bit_String_1 (Lit : Iir) return Iir is begin Check_Kind_For_Bit_String_1 (Lit); - return Get_Field5 (Lit); + return Get_Field7 (Lit); end Get_Bit_String_1; - procedure Set_Bit_String_1 (Lit : Iir; El : Iir_Enumeration_Literal) is + procedure Set_Bit_String_1 (Lit : Iir; El : Iir) is begin Check_Kind_For_Bit_String_1 (Lit); - Set_Field5 (Lit, El); + Set_Field7 (Lit, El); end Set_Bit_String_1; procedure Check_Kind_For_Literal_Origin (Target : Iir) is @@ -1228,6 +1228,31 @@ package body Iirs is Set_Field4 (Lit, Orig); end Set_Range_Origin; + procedure Check_Kind_For_Literal_Subtype (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Aggregate => + null; + when others => + Failed ("Literal_Subtype", Target); + end case; + end Check_Kind_For_Literal_Subtype; + + function Get_Literal_Subtype (Lit : Iir) return Iir is + begin + Check_Kind_For_Literal_Subtype (Lit); + return Get_Field5 (Lit); + end Get_Literal_Subtype; + + procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir) is + begin + Check_Kind_For_Literal_Subtype (Lit); + Set_Field5 (Lit, Atype); + end Set_Literal_Subtype; + procedure Check_Kind_For_Entity_Class (Target : Iir) is begin case Get_Kind (Target) is @@ -1637,7 +1662,7 @@ package body Iirs is Set_Field3 (We, An_Iir); end Set_Time; - procedure Check_Kind_For_Associated (Target : Iir) is + procedure Check_Kind_For_Associated_Expr (Target : Iir) is begin case Get_Kind (Target) is when Iir_Kind_Choice_By_Others @@ -1647,21 +1672,113 @@ package body Iirs is | Iir_Kind_Choice_By_Name => null; when others => - Failed ("Associated", Target); + Failed ("Associated_Expr", Target); end case; - end Check_Kind_For_Associated; + end Check_Kind_For_Associated_Expr; - function Get_Associated (Target : Iir) return Iir is + function Get_Associated_Expr (Target : Iir) return Iir is begin - Check_Kind_For_Associated (Target); - return Get_Field1 (Target); - end Get_Associated; + Check_Kind_For_Associated_Expr (Target); + return Get_Field3 (Target); + end Get_Associated_Expr; - procedure Set_Associated (Target : Iir; Associated : Iir) is + procedure Set_Associated_Expr (Target : Iir; Associated : Iir) is begin - Check_Kind_For_Associated (Target); - Set_Field1 (Target, Associated); - end Set_Associated; + Check_Kind_For_Associated_Expr (Target); + Set_Field3 (Target, Associated); + end Set_Associated_Expr; + + procedure Check_Kind_For_Associated_Chain (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_None + | Iir_Kind_Choice_By_Name => + null; + when others => + Failed ("Associated_Chain", Target); + end case; + end Check_Kind_For_Associated_Chain; + + function Get_Associated_Chain (Target : Iir) return Iir is + begin + Check_Kind_For_Associated_Chain (Target); + return Get_Field4 (Target); + end Get_Associated_Chain; + + procedure Set_Associated_Chain (Target : Iir; Associated : Iir) is + begin + Check_Kind_For_Associated_Chain (Target); + Set_Field4 (Target, Associated); + end Set_Associated_Chain; + + procedure Check_Kind_For_Choice_Name (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Choice_By_Name => + null; + when others => + Failed ("Choice_Name", Target); + end case; + end Check_Kind_For_Choice_Name; + + function Get_Choice_Name (Choice : Iir) return Iir is + begin + Check_Kind_For_Choice_Name (Choice); + return Get_Field5 (Choice); + end Get_Choice_Name; + + procedure Set_Choice_Name (Choice : Iir; Name : Iir) is + begin + Check_Kind_For_Choice_Name (Choice); + Set_Field5 (Choice, Name); + end Set_Choice_Name; + + procedure Check_Kind_For_Choice_Expression (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Choice_By_Expression => + null; + when others => + Failed ("Choice_Expression", Target); + end case; + end Check_Kind_For_Choice_Expression; + + function Get_Choice_Expression (Choice : Iir) return Iir is + begin + Check_Kind_For_Choice_Expression (Choice); + return Get_Field5 (Choice); + end Get_Choice_Expression; + + procedure Set_Choice_Expression (Choice : Iir; Name : Iir) is + begin + Check_Kind_For_Choice_Expression (Choice); + Set_Field5 (Choice, Name); + end Set_Choice_Expression; + + procedure Check_Kind_For_Choice_Range (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Choice_By_Range => + null; + when others => + Failed ("Choice_Range", Target); + end case; + end Check_Kind_For_Choice_Range; + + function Get_Choice_Range (Choice : Iir) return Iir is + begin + Check_Kind_For_Choice_Range (Choice); + return Get_Field5 (Choice); + end Get_Choice_Range; + + procedure Set_Choice_Range (Choice : Iir; Name : Iir) is + begin + Check_Kind_For_Choice_Range (Choice); + Set_Field5 (Choice, Name); + end Set_Choice_Range; procedure Check_Kind_For_Same_Alternative_Flag (Target : Iir) is begin @@ -1932,14 +2049,13 @@ package body Iirs is end case; end Check_Kind_For_Package; - function Get_Package (Package_Body : Iir) return Iir_Package_Declaration is + function Get_Package (Package_Body : Iir) return Iir is begin Check_Kind_For_Package (Package_Body); return Get_Field4 (Package_Body); end Get_Package; - procedure Set_Package (Package_Body : Iir; Decl : Iir_Package_Declaration) - is + procedure Set_Package (Package_Body : Iir; Decl : Iir) is begin Check_Kind_For_Package (Package_Body); Set_Field4 (Package_Body, Decl); @@ -1955,13 +2071,13 @@ package body Iirs is end case; end Check_Kind_For_Package_Body; - function Get_Package_Body (Pkg : Iir) return Iir_Package_Body is + function Get_Package_Body (Pkg : Iir) return Iir is begin Check_Kind_For_Package_Body (Pkg); return Get_Field2 (Pkg); end Get_Package_Body; - procedure Set_Package_Body (Pkg : Iir; Decl : Iir_Package_Body) is + procedure Set_Package_Body (Pkg : Iir; Decl : Iir) is begin Check_Kind_For_Package_Body (Pkg); Set_Field2 (Pkg, Decl); @@ -2364,6 +2480,7 @@ package body Iirs is | Iir_Kind_Signal_Declaration | Iir_Kind_Variable_Declaration | Iir_Kind_Constant_Declaration + | Iir_Kind_Iterator_Declaration | Iir_Kind_Constant_Interface_Declaration | Iir_Kind_Variable_Interface_Declaration | Iir_Kind_Signal_Interface_Declaration @@ -2400,13 +2517,13 @@ package body Iirs is function Get_Discrete_Range (Target : Iir) return Iir is begin Check_Kind_For_Discrete_Range (Target); - return Get_Field5 (Target); + return Get_Field6 (Target); end Get_Discrete_Range; procedure Set_Discrete_Range (Target : Iir; Rng : Iir) is begin Check_Kind_For_Discrete_Range (Target); - Set_Field5 (Target, Rng); + Set_Field6 (Target, Rng); end Set_Discrete_Range; procedure Check_Kind_For_Type_Definition (Target : Iir) is @@ -2790,8 +2907,7 @@ package body Iirs is procedure Check_Kind_For_Return_Type (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Signature - | Iir_Kind_Enumeration_Literal + when Iir_Kind_Enumeration_Literal | Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration => null; @@ -2994,14 +3110,13 @@ package body Iirs is end case; end Check_Kind_For_Block_Statement; - function Get_Block_Statement (Target : Iir) return Iir_Block_Statement is + function Get_Block_Statement (Target : Iir) return Iir is begin Check_Kind_For_Block_Statement (Target); return Get_Field7 (Target); end Get_Block_Statement; - procedure Set_Block_Statement (Target : Iir; Block : Iir_Block_Statement) - is + procedure Set_Block_Statement (Target : Iir; Block : Iir) is begin Check_Kind_For_Block_Statement (Target); Set_Field7 (Target, Block); @@ -3365,6 +3480,12 @@ package body Iirs is return Get_Field1 (Target); end Get_Primary_Unit; + procedure Set_Primary_Unit (Target : Iir; Unit : Iir) is + begin + Check_Kind_For_Primary_Unit (Target); + Set_Field1 (Target, Unit); + end Set_Primary_Unit; + procedure Check_Kind_For_Identifier (Target : Iir) is begin case Get_Kind (Target) is @@ -4243,14 +4364,13 @@ package body Iirs is end case; end Check_Kind_For_Waveform_Chain; - function Get_Waveform_Chain (Target : Iir) return Iir_Waveform_Element is + function Get_Waveform_Chain (Target : Iir) return Iir is begin Check_Kind_For_Waveform_Chain (Target); return Get_Field5 (Target); end Get_Waveform_Chain; - procedure Set_Waveform_Chain (Target : Iir; Chain : Iir_Waveform_Element) - is + procedure Set_Waveform_Chain (Target : Iir; Chain : Iir) is begin Check_Kind_For_Waveform_Chain (Target); Set_Field5 (Target, Chain); @@ -5087,9 +5207,7 @@ package body Iirs is procedure Check_Kind_For_Expression (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Choice_By_Expression - | Iir_Kind_Choice_By_Range - | Iir_Kind_Attribute_Specification + when Iir_Kind_Attribute_Specification | Iir_Kind_Disconnection_Specification | Iir_Kind_Parenthesis_Expression | Iir_Kind_Qualified_Expression @@ -5282,13 +5400,13 @@ package body Iirs is end case; end Check_Kind_For_Package_Header; - function Get_Package_Header (Pkg : Iir) return Iir_Package_Body is + function Get_Package_Header (Pkg : Iir) return Iir is begin Check_Kind_For_Package_Header (Pkg); return Get_Field5 (Pkg); end Get_Package_Header; - procedure Set_Package_Header (Pkg : Iir; Header : Iir_Package_Body) is + procedure Set_Package_Header (Pkg : Iir; Header : Iir) is begin Check_Kind_For_Package_Header (Pkg); Set_Field5 (Pkg, Header); @@ -5420,13 +5538,13 @@ package body Iirs is end case; end Check_Kind_For_Else_Clause; - function Get_Else_Clause (Target : Iir) return Iir_Elsif is + function Get_Else_Clause (Target : Iir) return Iir is begin Check_Kind_For_Else_Clause (Target); return Get_Field6 (Target); end Get_Else_Clause; - procedure Set_Else_Clause (Target : Iir; Clause : Iir_Elsif) is + procedure Set_Else_Clause (Target : Iir; Clause : Iir) is begin Check_Kind_For_Else_Clause (Target); Set_Field6 (Target, Clause); @@ -5484,6 +5602,7 @@ package body Iirs is | Iir_Kind_Package_Body | Iir_Kind_Architecture_Body | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Unit_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Attribute_Declaration | Iir_Kind_Group_Template_Declaration @@ -6123,8 +6242,7 @@ package body Iirs is procedure Check_Kind_For_Name (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Choice_By_Name - | Iir_Kind_Non_Object_Alias_Declaration + when Iir_Kind_Non_Object_Alias_Declaration | Iir_Kind_Object_Alias_Declaration => null; when others => @@ -6318,6 +6436,28 @@ package body Iirs is Set_Field0 (Target, Prefix); end Set_Prefix; + procedure Check_Kind_For_Slice_Subtype (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Slice_Name => + null; + when others => + Failed ("Slice_Subtype", Target); + end case; + end Check_Kind_For_Slice_Subtype; + + function Get_Slice_Subtype (Slice : Iir) return Iir is + begin + Check_Kind_For_Slice_Subtype (Slice); + return Get_Field3 (Slice); + end Get_Slice_Subtype; + + procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir) is + begin + Check_Kind_For_Slice_Subtype (Slice); + Set_Field3 (Slice, Atype); + end Set_Slice_Subtype; + procedure Check_Kind_For_Suffix (Target : Iir) is begin case Get_Kind (Target) is @@ -6486,13 +6626,13 @@ package body Iirs is end case; end Check_Kind_For_Aggregate_Info; - function Get_Aggregate_Info (Target : Iir) return Iir_Aggregate_Info is + function Get_Aggregate_Info (Target : Iir) return Iir is begin Check_Kind_For_Aggregate_Info (Target); return Get_Field2 (Target); end Get_Aggregate_Info; - procedure Set_Aggregate_Info (Target : Iir; Info : Iir_Aggregate_Info) is + procedure Set_Aggregate_Info (Target : Iir; Info : Iir) is begin Check_Kind_For_Aggregate_Info (Target); Set_Field2 (Target, Info); @@ -6508,14 +6648,13 @@ package body Iirs is end case; end Check_Kind_For_Sub_Aggregate_Info; - function Get_Sub_Aggregate_Info (Target : Iir) return Iir_Aggregate_Info is + function Get_Sub_Aggregate_Info (Target : Iir) return Iir is begin Check_Kind_For_Sub_Aggregate_Info (Target); return Get_Field1 (Target); end Get_Sub_Aggregate_Info; - procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir_Aggregate_Info) - is + procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir) is begin Check_Kind_For_Sub_Aggregate_Info (Target); Set_Field1 (Target, Info); @@ -6915,6 +7054,28 @@ package body Iirs is Set_Field2 (Target, Mark); end Set_Subtype_Type_Mark; + procedure Check_Kind_For_Type_Conversion_Subtype (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Type_Conversion => + null; + when others => + Failed ("Type_Conversion_Subtype", Target); + end case; + end Check_Kind_For_Type_Conversion_Subtype; + + function Get_Type_Conversion_Subtype (Target : Iir) return Iir is + begin + Check_Kind_For_Type_Conversion_Subtype (Target); + return Get_Field3 (Target); + end Get_Type_Conversion_Subtype; + + procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir) is + begin + Check_Kind_For_Type_Conversion_Subtype (Target); + Set_Field3 (Target, Atype); + end Set_Type_Conversion_Subtype; + procedure Check_Kind_For_Type_Mark (Target : Iir) is begin case Get_Kind (Target) is @@ -6965,7 +7126,8 @@ package body Iirs is procedure Check_Kind_For_Return_Type_Mark (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Function_Declaration + when Iir_Kind_Signature + | Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => null; when others => @@ -7247,6 +7409,28 @@ package body Iirs is Set_Field3 (Target, Name_Id_To_Iir (Ident)); end Set_Simple_Name_Identifier; + procedure Check_Kind_For_Simple_Name_Subtype (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Simple_Name_Attribute => + null; + when others => + Failed ("Simple_Name_Subtype", Target); + end case; + end Check_Kind_For_Simple_Name_Subtype; + + function Get_Simple_Name_Subtype (Target : Iir) return Iir is + begin + Check_Kind_For_Simple_Name_Subtype (Target); + return Get_Field4 (Target); + end Get_Simple_Name_Subtype; + + procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir) is + begin + Check_Kind_For_Simple_Name_Subtype (Target); + Set_Field4 (Target, Atype); + end Set_Simple_Name_Subtype; + procedure Check_Kind_For_Protected_Type_Body (Target : Iir) is begin case Get_Kind (Target) is @@ -7350,13 +7534,13 @@ package body Iirs is function Get_String_Length (Lit : Iir) return Int32 is begin Check_Kind_For_String_Length (Lit); - return Iir_To_Int32 (Get_Field0 (Lit)); + return Iir_To_Int32 (Get_Field4 (Lit)); end Get_String_Length; procedure Set_String_Length (Lit : Iir; Len : Int32) is begin Check_Kind_For_String_Length (Lit); - Set_Field0 (Lit, Int32_To_Iir (Len)); + Set_Field4 (Lit, Int32_To_Iir (Len)); end Set_String_Length; procedure Check_Kind_For_Use_Flag (Target : Iir) is diff --git a/iirs.adb.in b/iirs.adb.in index 0ced467..2ed914d 100644 --- a/iirs.adb.in +++ b/iirs.adb.in @@ -52,6 +52,17 @@ package body Iirs is function Get_Format (Kind : Iir_Kind) return Format_Type; + function Create_Iir (Kind : Iir_Kind) return Iir + is + Res : Iir; + Format : Format_Type; + begin + Format := Get_Format (Kind); + Res := Create_Node (Format); + Set_Nkind (Res, Iir_Kind'Pos (Kind)); + return Res; + end Create_Iir; + -- Statistics. procedure Disp_Stats is @@ -141,7 +152,7 @@ package body Iirs is procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; Pos : Source_Ptr; Line, Off: Natural) is begin - Set_Field1 (Design_Unit, Node_Type (Pos)); + Set_Field4 (Design_Unit, Node_Type (Pos)); Set_Field11 (Design_Unit, Node_Type (Off)); Set_Field12 (Design_Unit, Node_Type (Line)); end Set_Pos_Line_Off; @@ -149,7 +160,7 @@ package body Iirs is procedure Get_Pos_Line_Off (Design_Unit: Iir_Design_Unit; Pos : out Source_Ptr; Line, Off: out Natural) is begin - Pos := Source_Ptr (Get_Field1 (Design_Unit)); + Pos := Source_Ptr (Get_Field4 (Design_Unit)); Off := Natural (Get_Field11 (Design_Unit)); Line := Natural (Get_Field12 (Design_Unit)); end Get_Pos_Line_Off; @@ -71,6 +71,56 @@ package Iirs is -- add an entry in disp_tree (debugging) -- handle this node in Errorout.Disp_Node + -- Meta-grammar + -- This file is processed by a tool to automatically generate the body, so + -- it must follow a meta-grammar. + -- + -- The low level representation is described in nodes.ads. + -- + -- The literals for the nodes must be declared in this file like this: + -- type Iir_Kind is + -- ( + -- Iir_Kind_AAA, + -- ... + -- Iir_Kind_ZZZ + -- ); + -- The tool doesn't check for uniqness as this is done by the compiler. + -- + -- It is possible to declare ranges of kinds like this: + -- subtype Iir_Kinds_RANGE is Iir_Kind range + -- Iir_Kind_FIRST .. + -- --Iir_Kind_MID + -- Iir_Kind_LAST; + -- Literals Iir_Kind_MID are optionnal (FIXME: make them required ?), but + -- if present all the values between FIRST and LAST must be present. + -- + -- The methods appear after the comment: ' -- General methods.' + -- They have the following format: + -- -- Field: FIELD (CONV) + -- function Get_NAME (PNAME : PTYPE) return RTYPE; + -- procedure Set_NAME (PNAME : PTYPE; RNAME : RTYPE); + -- 'FIELD' indicate which field of the node is used to store the value. + -- ' (CONV)' is required if the type of the value (indicated by RTYPE) is + -- different from the type of the field. CONV can be either 'uc' or 'pos'. + -- 'uc' indicates an unchecked conversion while 'pos' a pos/val conversion. + -- + -- Nodes content is described between ' -- Start of Iir_Kind.' and + -- ' -- End of Iir_Kind.' like this: + -- -- Iir_Kind_NODE1 (FORMAT1) + -- -- Iir_Kind_NODE2 (FORMAT2) + -- -- + -- -- Get/Set_NAME1 (FIELD1) + -- -- + -- -- Get/Set_NAME2 (FIELD2) + -- -- Get/Set_NAME3 (Alias FIELD2) + -- -- + -- -- Only for Iir_Kind_NODE1: + -- -- Get/Set_NAME4 (FIELD3) + -- Severals nodes can be described at once; at least one must be described. + -- Fields FIELD1, FIELD2, FIELD3 must be different, unless 'Alias ' is + -- present. The number of spaces is significant. The 'Only for ' lines + -- are optionnal and there may be severals of them. + ------------------------------------------------- -- General methods (can be used on all nodes): -- ------------------------------------------------- @@ -95,7 +145,6 @@ package Iirs is -- Copy a location from a node to another one. -- procedure Location_Copy (Target: in out Iir; Src: in Iir); - -- The next line marks the start of the node description. -- Start of Iir_Kind. @@ -141,7 +190,7 @@ package Iirs is -- Get/Set_Parent (Alias Field0) -- -- Get the chain of context clause. - -- Get_Context_Items (Field1) + -- Get/Set_Context_Items (Field1) -- -- Get/Set_Chain (Field2) -- @@ -171,7 +220,7 @@ package Iirs is -- Set the line and the offset in the line, only for the library manager. -- This is valid until the file is really loaded in memory. On loading, -- location will contain all this informations. - -- Get/Set_Pos_Line_Off (Field1,Field11,Field12) + -- Get/Set_Pos_Line_Off (Field4,Field11,Field12) -- -- Get/Set the date state, which indicates whether this design unit is in -- memory or not. @@ -223,19 +272,22 @@ package Iirs is -- -- As bit-strings are expanded to '0'/'1' strings, this is the number of -- characters. - -- Get/Set_String_Length (Field0) + -- Get/Set_String_Length (Field4) + -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) -- -- For bit string only: -- Enumeration literal which correspond to '0' and '1'. -- This cannot be defined only in the enumeration type definition, due to -- possible aliases. -- Only for Iir_Kind_Bit_String_Literal: - -- Get/Set_Bit_String_0 (Field4) + -- Get/Set_Bit_String_0 (Field6) -- Only for Iir_Kind_Bit_String_Literal: - -- Get/Set_Bit_String_1 (Field5) + -- Get/Set_Bit_String_1 (Field7) -- -- Only for Iir_Kind_Bit_String_Literal: - -- Get/Set_Bit_String_Base (Field11) + -- Get/Set_Bit_String_Base (Field8) -- -- Get/Set_Expr_Staticness (State1) @@ -301,6 +353,9 @@ package Iirs is -- -- List of elements -- Get/Set_Simple_Aggregate_List (Field3) + -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) -- Iir_Kind_Overflow_Literal (Short) -- This node can only be generated by evaluation to represent an error: out @@ -377,28 +432,36 @@ package Iirs is -- -- Get/Set_Parent (Field0) -- + -- For a list of choices, only the first one is associated, the following + -- associations have the same_alternative_flag set. + -- Get/Set_Chain (Field2) + -- -- These are elements of an choice chain, which is used for -- case_statement, concurrent_select_signal_assignment, aggregates. -- - -- Get/Set what is associated with the choice. This can be: - -- * a waveform_chain for a concurrent_select_signal_assignment, - -- * an expression for an aggregate, - -- * a sequential statement list for a case_statement. - -- For a list of choices, only the first one is associated, the following - -- associations have the same_alternative_flag set. - -- Get/Set_Associated (Field1) + -- Get/Set what is associated with the choice. There are two different + -- nodes, one for simple association and the other for chain association. + -- This simplifies walkers. But both nodes are never used at the same + -- time. -- - -- Get/Set_Chain (Field2) + -- For: + -- * an expression for an aggregate + -- * an individual association + -- Get/Set_Associated_Expr (Field3) + -- + -- For + -- * a waveform_chain for a concurrent_select_signal_assignment, + -- * a sequential statement chain for a case_statement. + -- Get/Set_Associated_Chain (Field4) -- -- Only for Iir_Kind_Choice_By_Name: - -- Get/Set_Name (Field4) + -- Get/Set_Choice_Name (Field5) -- -- Only for Iir_Kind_Choice_By_Expression: - -- Get/Set_Expression (Field5) + -- Get/Set_Choice_Expression (Field5) -- -- Only for Iir_Kind_Choice_By_Range: - -- Get/Set the range. - -- Get/Set_Expression (Field5) + -- Get/Set_Choice_Range (Field5) -- -- Get/Set_Same_Alternative_Flag (Flag1) -- @@ -612,13 +675,17 @@ package Iirs is -- -- Get/Set_Psl_Expression (Field3) - -- Iir_Kind_Signature (Short) + -- Iir_Kind_Signature (Medium) -- - -- Get/Set_Prefix (Field0) + -- LRM08 4.5.3 Signatures -- - -- Get/Set_Return_Type (Field1) + -- signature ::= '[' [ type_mark { , type_mark } ] [ RETURN type_mark ] ']' + -- + -- Get/Set_Prefix (Field0) -- -- Get/Set_Type_Marks_List (Field2) + -- + -- Get/Set_Return_Type_Mark (Field8) -- Iir_Kind_Overload_List (Short) -- @@ -633,7 +700,7 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Identifier (Field3) -- @@ -660,7 +727,7 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Name of the entity declaration for the architecture. -- Get/Set_Entity_Name (Field2) @@ -689,7 +756,7 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Name of the entity of a configuration. -- Get/Set_Entity_Name (Field2) @@ -717,7 +784,7 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Package_Body (Field2) -- @@ -742,7 +809,7 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Identifier (Field3) -- @@ -1070,7 +1137,6 @@ package Iirs is -- Get/Set_Parent (Field0) -- -- Only for Iir_Kind_Function_Declaration: - -- FIXME: this is a type_mark. -- Get/Set_Return_Type (Field1) -- -- Only for Iir_Kind_Function_Declaration: @@ -1082,7 +1148,7 @@ package Iirs is -- -- Get/Set_Attribute_Value_Chain (Field4) -- - -- Get_Interface_Declaration_Chain (Field5) + -- Get/Set_Interface_Declaration_Chain (Field5) -- -- Get/Set_Generic_Chain (Field6) -- @@ -1151,7 +1217,7 @@ package Iirs is -- The parse stage always puts a declaration before a body. -- Sem will remove the declaration if there is a forward declaration. -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Chain (Field2) -- @@ -1186,7 +1252,7 @@ package Iirs is -- -- Get/Set_Attribute_Value_Chain (Field4) -- - -- Get_Interface_Declaration_Chain (Field5) + -- Get/Set_Interface_Declaration_Chain (Field5) -- -- Get/Set_Generic_Chain (Field6) -- @@ -1296,11 +1362,11 @@ package Iirs is -- -- Get/Set_Attribute_Value_Chain (Field4) -- - -- Only for Iir_Kind_Constant_Declaration: + -- For iterator, this is the reconstructed subtype indication. -- Get/Set_Subtype_Indication (Field5) -- -- Only for Iir_Kind_Iterator_Declaration: - -- Get/Set_Discrete_Range (Field5) + -- Get/Set_Discrete_Range (Field6) -- -- Only for Iir_Kind_Constant_Declaration: -- Default value of a deferred constant points to the full constant @@ -1618,7 +1684,7 @@ package Iirs is -- type definitions -- ----------------------- - -- For Iir_Kinds_Type_And_Subtype_Definition: + -- For Iir_Kinds_Type_And_Subtype_Definition: -- -- Type_Declarator: -- Points to the type declaration or subtype declaration that has created @@ -1715,7 +1781,7 @@ package Iirs is -- Iir_Kind_Physical_Type_Definition (Short) -- -- Get/Set_Unit_Chain (Field1) - -- Get_Primary_Unit (Alias Field1) + -- Get/Set_Primary_Unit (Alias Field1) -- -- Get/Set_Type_Declarator (Field3) -- @@ -1743,6 +1809,8 @@ package Iirs is -- -- physical_literal ::= [ abstract_literal ] /unit/_name -- + -- Get/Set_Parent (Field0) + -- -- Get/Set_Type (Field1) -- -- Get/Set_Chain (Field2) @@ -2229,14 +2297,14 @@ package Iirs is -- Get/Set_Visible_Flag (Flag4) -- -- True if the target of the assignment is guarded - -- Get_Guarded_Target_State (State3) + -- Get/Set_Guarded_Target_State (State3) -- Iir_Kind_Sensitized_Process_Statement (Medium) -- Iir_Kind_Process_Statement (Medium) -- -- Get/Set_Parent (Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Chain (Field2) -- @@ -2248,7 +2316,7 @@ package Iirs is -- Get/Set_Sequential_Statement_Chain (Field5) -- -- Only for Iir_Kind_Sensitized_Process_Statement: - -- Get_Sensitivity_List (Field6) + -- Get/Set_Sensitivity_List (Field6) -- -- Get/Set_Callees_List (Field7) -- @@ -2385,7 +2453,7 @@ package Iirs is -- -- Get/Set_Parent (Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Chain (Field2) -- @@ -2416,7 +2484,7 @@ package Iirs is -- -- Get/Set_Parent (Field0) -- - -- Get_Declaration_Chain (Field1) + -- Get/Set_Declaration_Chain (Field1) -- -- Get/Set_Chain (Field2) -- @@ -2607,7 +2675,7 @@ package Iirs is -- Get/Set_Visible_Flag (Flag4) -- -- True if the target of the assignment is guarded - -- Get_Guarded_Target_State (State3) + -- Get/Set_Guarded_Target_State (State3) -- Iir_Kind_Variable_Assignment_Statement (Short) -- @@ -2819,6 +2887,9 @@ package Iirs is -- -- Get/Set_Association_Choices_Chain (Field4) -- + -- Same as Type, but marked as property of that node. + -- Get/Set_Literal_Subtype (Field5) + -- -- Get/Set_Expr_Staticness (State1) -- -- Get/Set_Value_Staticness (State2) @@ -2888,6 +2959,12 @@ package Iirs is -- -- Get/Set_Type (Field1) -- + -- If the type mark denotes an unconstrained array and the expression is + -- locally static, the result should be locally static according to vhdl93 + -- (which is not clear on that point). As a subtype is created, it is + -- referenced by this field. + -- Get/Set_Type_Conversion_Subtype (Field3) + -- -- Get/Set_Type_Mark (Field4) -- -- Get/Set_Expression (Field5) @@ -3020,6 +3097,8 @@ package Iirs is -- -- Get/Set_Suffix (Field2) -- + -- Get/Set_Slice_Subtype (Field3) + -- -- Get/Set_Base_Name (Field5) -- -- Get/Set_Expr_Staticness (State1) @@ -3220,6 +3299,9 @@ package Iirs is -- Only for Iir_Kind_Simple_Name_Attribute: -- Get/Set_Simple_Name_Identifier (Field3) -- + -- Only for Iir_Kind_Simple_Name_Attribute: + -- Get/Set_Simple_Name_Subtype (Field4) + -- -- Get/Set_Base_Name (Field5) -- -- Get/Set_Expr_Staticness (State1) @@ -3250,12 +3332,14 @@ package Iirs is -- -- Get/Set_Has_Signal_Flag (Flag3) + -- Iir_Kind_Unused (Short) + -- End of Iir_Kind. type Iir_Kind is ( - -- Erroneous IIR. + Iir_Kind_Unused, Iir_Kind_Error, Iir_Kind_Design_File, @@ -4762,11 +4846,11 @@ package Iirs is procedure Disp_Stats; -- Design units contained in a design file. - -- Field: Field5 + -- Field: Field5 Chain function Get_First_Design_Unit (Design : Iir) return Iir; procedure Set_First_Design_Unit (Design : Iir; Chain : Iir); - -- Field: Field6 + -- Field: Field6 Ref function Get_Last_Design_Unit (Design : Iir) return Iir; procedure Set_Last_Design_Unit (Design : Iir; Chain : Iir); @@ -4786,7 +4870,7 @@ package Iirs is procedure Set_Analysis_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id); -- The library which FILE belongs to. - -- Field: Field0 + -- Field: Field0 Ref function Get_Library (File : Iir_Design_File) return Iir; procedure Set_Library (File : Iir_Design_File; Lib : Iir); @@ -4806,14 +4890,14 @@ package Iirs is procedure Set_Design_File_Directory (File : Iir_Design_File; Dir : Name_Id); -- The parent of a design unit is a design file. - -- Field: Field0 - function Get_Design_File (Unit : Iir_Design_Unit) return Iir_Design_File; - procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir_Design_File); + -- Field: Field0 Ref + function Get_Design_File (Unit : Iir_Design_Unit) return Iir; + procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir); -- Design files of a library. - -- Field: Field1 - function Get_Design_File_Chain (Library : Iir) return Iir_Design_File; - procedure Set_Design_File_Chain (Library : Iir; Chain : Iir_Design_File); + -- Field: Field1 Chain + function Get_Design_File_Chain (Library : Iir) return Iir; + procedure Set_Design_File_Chain (Library : Iir; Chain : Iir); -- System directory where the library is stored. -- Field: Field11 (pos) @@ -4821,12 +4905,13 @@ package Iirs is procedure Set_Library_Directory (Library : Iir; Dir : Name_Id); -- Symbolic date, used to order design units in a library. + -- Display: Image -- Field: Field10 (pos) function Get_Date (Target : Iir) return Date_Type; procedure Set_Date (Target : Iir; Date : Date_Type); -- Chain of context clauses. - -- Field: Field1 + -- Field: Field1 Chain function Get_Context_Items (Design_Unit : Iir) return Iir; procedure Set_Context_Items (Design_Unit : Iir; Items_Chain : Iir); @@ -4834,7 +4919,7 @@ package Iirs is -- exception: the architecture of an entity aspect (of a component -- instantiation) may not have been analyzed. The Entity_Aspect_Entity -- is added to this list (instead of the non-existing design unit). - -- Field: Field8 (uc) + -- Field: Field8 Ref (uc) function Get_Dependence_List (Unit : Iir) return Iir_List; procedure Set_Dependence_List (Unit : Iir; List : Iir_List); @@ -4870,14 +4955,14 @@ package Iirs is -- Every design unit is put in an hash table to find quickly found by its -- name. This field is a single chain for collisions. - -- Field: Field7 + -- Field: Field7 Ref function Get_Hash_Chain (Design_Unit : Iir_Design_Unit) return Iir; procedure Set_Hash_Chain (Design_Unit : Iir_Design_Unit; Chain : Iir); -- Set the line and the offset in the line, only for the library manager. -- This is valid until the file is really loaded in memory. On loading, -- location will contain all this informations. - -- Field: Field1 + -- Field: Field4 -- Field: Field6 -- Field: Field7 procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; @@ -4889,11 +4974,13 @@ package Iirs is -- literals. -- Value of an integer/physical literal. + -- Display: Image -- Field: Int64 function Get_Value (Lit : Iir) return Iir_Int64; procedure Set_Value (Lit : Iir; Val : Iir_Int64); -- Position (same as lit_type'pos) of an enumeration literal. + -- Display: Image -- Field: Field10 (pos) function Get_Enum_Pos (Lit : Iir) return Iir_Int32; procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32); @@ -4908,6 +4995,7 @@ package Iirs is procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir); -- Value of a floating point literal. + -- Display: Image -- Field: Fp64 function Get_Fp_Value (Lit : Iir) return Iir_Fp64; procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64); @@ -4915,7 +5003,7 @@ package Iirs is -- Declaration of the literal. -- This is used to retrieve the genuine enumeration literal for literals -- created from static expression. - -- Field: Field6 + -- Field: Field6 Ref function Get_Enumeration_Decl (Target : Iir) return Iir; procedure Set_Enumeration_Decl (Target : Iir; Lit : Iir); @@ -4925,18 +5013,19 @@ package Iirs is procedure Set_Simple_Aggregate_List (Target : Iir; List : Iir_List); -- The logarithm of the base (1, 3 or 4) of a bit string. - -- Field: Field11 (pos) + -- Display: Image + -- Field: Field8 (pos) function Get_Bit_String_Base (Lit : Iir) return Base_Type; procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type); -- The enumeration literal which defines the '0' and '1' value. - -- Field: Field4 - function Get_Bit_String_0 (Lit : Iir) return Iir_Enumeration_Literal; - procedure Set_Bit_String_0 (Lit : Iir; El : Iir_Enumeration_Literal); + -- Field: Field6 + function Get_Bit_String_0 (Lit : Iir) return Iir; + procedure Set_Bit_String_0 (Lit : Iir; El : Iir); - -- Field: Field5 - function Get_Bit_String_1 (Lit : Iir) return Iir_Enumeration_Literal; - procedure Set_Bit_String_1 (Lit : Iir; El : Iir_Enumeration_Literal); + -- Field: Field7 + function Get_Bit_String_1 (Lit : Iir) return Iir; + procedure Set_Bit_String_1 (Lit : Iir; El : Iir); -- The origin of a literal can be null_iir for a literal generated by the -- parser, or a node which was statically evaluated to this literal. @@ -4949,6 +5038,13 @@ package Iirs is function Get_Range_Origin (Lit : Iir) return Iir; procedure Set_Range_Origin (Lit : Iir; Orig : Iir); + -- Same as Type, but not marked as Ref. This is when a literal has a + -- subtype (such as string or bit_string) created specially for the + -- literal. + -- Field: Field5 + function Get_Literal_Subtype (Lit : Iir) return Iir; + procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir); + -- Field: Field3 (uc) function Get_Entity_Class (Target : Iir) return Token_Type; procedure Set_Entity_Class (Target : Iir; Kind : Token_Type); @@ -4968,7 +5064,7 @@ package Iirs is function Get_Attribute_Specification_Chain (Target : Iir) return Iir; procedure Set_Attribute_Specification_Chain (Target : Iir; Chain : Iir); - -- Field: Field4 + -- Field: Field4 Ref function Get_Attribute_Specification (Val : Iir) return Iir; procedure Set_Attribute_Specification (Val : Iir; Attr : Iir); @@ -4976,7 +5072,7 @@ package Iirs is function Get_Signal_List (Target : Iir) return Iir_List; procedure Set_Signal_List (Target : Iir; List : Iir_List); - -- Field: Field3 + -- Field: Field3 Ref function Get_Designated_Entity (Val : Iir_Attribute_Value) return Iir; procedure Set_Designated_Entity (Val : Iir_Attribute_Value; Entity : Iir); @@ -5036,9 +5132,26 @@ package Iirs is procedure Set_Time (We : Iir_Waveform_Element; An_Iir : Iir); -- Node associated with a choice. - -- Field: Field1 - function Get_Associated (Target : Iir) return Iir; - procedure Set_Associated (Target : Iir; Associated : Iir); + -- Field: Field3 + function Get_Associated_Expr (Target : Iir) return Iir; + procedure Set_Associated_Expr (Target : Iir; Associated : Iir); + + -- Chain associated with a choice. + -- Field: Field4 Chain + function Get_Associated_Chain (Target : Iir) return Iir; + procedure Set_Associated_Chain (Target : Iir; Associated : Iir); + + -- Field: Field5 + function Get_Choice_Name (Choice : Iir) return Iir; + procedure Set_Choice_Name (Choice : Iir; Name : Iir); + + -- Field: Field5 + function Get_Choice_Expression (Choice : Iir) return Iir; + procedure Set_Choice_Expression (Choice : Iir; Name : Iir); + + -- Field: Field5 + function Get_Choice_Range (Choice : Iir) return Iir; + procedure Set_Choice_Range (Choice : Iir; Name : Iir); -- Set when a choice belongs to the same alternative as the previous one. -- Field: Flag1 @@ -5060,7 +5173,7 @@ package Iirs is -- statement). -- All elements of this list must belong to the same block configuration. -- The order is not important. - -- Field: Field4 + -- Field: Field4 Ref function Get_Prev_Block_Configuration (Target : Iir) return Iir; procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir); @@ -5095,13 +5208,13 @@ package Iirs is -- The package declaration corresponding to the body. -- Field: Field4 - function Get_Package (Package_Body : Iir) return Iir_Package_Declaration; - procedure Set_Package (Package_Body : Iir; Decl : Iir_Package_Declaration); + function Get_Package (Package_Body : Iir) return Iir; + procedure Set_Package (Package_Body : Iir; Decl : Iir); -- The package body corresponding to the package declaration. -- Field: Field2 - function Get_Package_Body (Pkg : Iir) return Iir_Package_Body; - procedure Set_Package_Body (Pkg : Iir; Decl : Iir_Package_Body); + function Get_Package_Body (Pkg : Iir) return Iir; + procedure Set_Package_Body (Pkg : Iir; Decl : Iir); -- If true, the package need a body. -- Field: Flag1 @@ -5112,24 +5225,24 @@ package Iirs is function Get_Block_Configuration (Target : Iir) return Iir; procedure Set_Block_Configuration (Target : Iir; Block : Iir); - -- Field: Field5 + -- Field: Field5 Chain function Get_Concurrent_Statement_Chain (Target : Iir) return Iir; procedure Set_Concurrent_Statement_Chain (Target : Iir; First : Iir); - -- Field: Field2 + -- Field: Field2 Chain_Next function Get_Chain (Target : Iir) return Iir; procedure Set_Chain (Target : Iir; Chain : Iir); pragma Inline (Get_Chain); - -- Field: Field7 + -- Field: Field7 Chain function Get_Port_Chain (Target : Iir) return Iir; procedure Set_Port_Chain (Target : Iir; Chain : Iir); - -- Field: Field6 + -- Field: Field6 Chain function Get_Generic_Chain (Target : Iir) return Iir; procedure Set_Generic_Chain (Target : Iir; Generics : Iir); - -- Field: Field1 + -- Field: Field1 Ref function Get_Type (Target : Iir) return Iir; procedure Set_Type (Target : Iir; Atype : Iir); pragma Inline (Get_Type); @@ -5138,7 +5251,7 @@ package Iirs is function Get_Subtype_Indication (Target : Iir) return Iir; procedure Set_Subtype_Indication (Target : Iir; Atype : Iir); - -- Field: Field5 + -- Field: Field6 function Get_Discrete_Range (Target : Iir) return Iir; procedure Set_Discrete_Range (Target : Iir; Rng : Iir); @@ -5167,12 +5280,12 @@ package Iirs is -- The base name of a name is the node at the origin of the name. -- The base name is a declaration (signal, object, constant or interface), -- a selected_by_all name, an implicit_dereference name. - -- Field: Field5 + -- Field: Field5 Ref function Get_Base_Name (Target : Iir) return Iir; procedure Set_Base_Name (Target : Iir; Name : Iir); pragma Inline (Get_Base_Name); - -- Field: Field5 + -- Field: Field5 Chain function Get_Interface_Declaration_Chain (Target : Iir) return Iir; procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir); pragma Inline (Get_Interface_Declaration_Chain); @@ -5181,7 +5294,7 @@ package Iirs is function Get_Subprogram_Specification (Target : Iir) return Iir; procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir); - -- Field: Field5 + -- Field: Field5 Chain function Get_Sequential_Statement_Chain (Target : Iir) return Iir; procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir); @@ -5193,6 +5306,7 @@ package Iirs is -- identifier. If the overload number is not 0, it is the rank of the -- subprogram. If the overload number is 0, then the identifier is not -- overloaded in the declarative region. + -- Display: Image -- Field: Field12 (pos) function Get_Overload_Number (Target : Iir) return Iir_Int32; procedure Set_Overload_Number (Target : Iir; Val : Iir_Int32); @@ -5203,6 +5317,7 @@ package Iirs is -- For a subprogram declared immediatly within a subprogram of level N, -- the depth is N + 1. -- Depth is used with depth of impure objects to check purity rules. + -- Display: Image -- Field: Field10 (pos) function Get_Subprogram_Depth (Target : Iir) return Iir_Int32; procedure Set_Subprogram_Depth (Target : Iir; Depth : Iir_Int32); @@ -5210,17 +5325,19 @@ package Iirs is -- Hash of a subprogram profile. -- This is used to speed up subprogram profile comparaison, which is very -- often used by overload. + -- Display: Image -- Field: Field11 (pos) function Get_Subprogram_Hash (Target : Iir) return Iir_Int32; procedure Set_Subprogram_Hash (Target : Iir; Val : Iir_Int32); pragma Inline (Get_Subprogram_Hash); -- Depth of the deepest impure object. + -- Display: Image -- Field: Field3 (uc) function Get_Impure_Depth (Target : Iir) return Iir_Int32; procedure Set_Impure_Depth (Target : Iir; Depth : Iir_Int32); - -- Field: Field1 + -- Field: Field1 Ref function Get_Return_Type (Target : Iir) return Iir; procedure Set_Return_Type (Target : Iir; Decl : Iir); pragma Inline (Get_Return_Type); @@ -5232,7 +5349,7 @@ package Iirs is -- For an implicit subprogram, the type_reference is the type declaration -- for which the implicit subprogram was defined. - -- Field: Field10 + -- Field: Field10 Ref function Get_Type_Reference (Target : Iir) return Iir; procedure Set_Type_Reference (Target : Iir; Decl : Iir); @@ -5269,8 +5386,8 @@ package Iirs is procedure Set_Design_Unit (Target : Iir; Unit : Iir_Design_Unit); -- Field: Field7 - function Get_Block_Statement (Target : Iir) return Iir_Block_Statement; - procedure Set_Block_Statement (Target : Iir; Block : Iir_Block_Statement); + function Get_Block_Statement (Target : Iir) return Iir; + procedure Set_Block_Statement (Target : Iir; Block : Iir); -- For a non-resolved signal: null_iir if the signal has no driver, or -- a process/concurrent_statement for which the signal should have a @@ -5280,7 +5397,7 @@ package Iirs is function Get_Signal_Driver (Target : Iir_Signal_Declaration) return Iir; procedure Set_Signal_Driver (Target : Iir_Signal_Declaration; Driver : Iir); - -- Field: Field1 + -- Field: Field1 Chain function Get_Declaration_Chain (Target : Iir) return Iir; procedure Set_Declaration_Chain (Target : Iir; Decls : Iir); @@ -5292,6 +5409,7 @@ package Iirs is function Get_File_Open_Kind (Target : Iir_File_Declaration) return Iir; procedure Set_File_Open_Kind (Target : Iir_File_Declaration; Kind : Iir); + -- Display: Image -- Field: Field4 (pos) function Get_Element_Position (Target : Iir) return Iir_Index32; procedure Set_Element_Position (Target : Iir; Pos : Iir_Index32); @@ -5315,7 +5433,7 @@ package Iirs is procedure Set_Selected_Name (Target : Iir_Use_Clause; Name : Iir); -- The type declarator which declares the type definition DEF. - -- Field: Field3 + -- Field: Field3 Ref function Get_Type_Declarator (Def : Iir) return Iir; procedure Set_Type_Declarator (Def : Iir; Decl : Iir); @@ -5323,7 +5441,7 @@ package Iirs is function Get_Enumeration_Literal_List (Target : Iir) return Iir_List; procedure Set_Enumeration_Literal_List (Target : Iir; List : Iir_List); - -- Field: Field1 + -- Field: Field1 Chain function Get_Entity_Class_Entry_Chain (Target : Iir) return Iir; procedure Set_Entity_Class_Entry_Chain (Target : Iir; Chain : Iir); @@ -5334,17 +5452,19 @@ package Iirs is -- Chain of physical type units. -- The first unit is the primary unit. If you really need the primary -- unit (and not the chain), you'd better to use Get_Primary_Unit. - -- Field: Field1 + -- Field: Field1 Chain function Get_Unit_Chain (Target : Iir) return Iir; procedure Set_Unit_Chain (Target : Iir; Chain : Iir); -- Alias of Get_Unit_Chain. -- Return the primary unit of a physical type. - -- Field: Field1 + -- Field: Field1 Ref function Get_Primary_Unit (Target : Iir) return Iir; + procedure Set_Primary_Unit (Target : Iir; Unit : Iir); -- Get/Set the identifier of a declaration. -- Can also be used instead of get/set_label. + -- Display: Inline -- Field: Field3 (uc) function Get_Identifier (Target : Iir) return Name_Id; procedure Set_Identifier (Target : Iir; Identifier : Name_Id); @@ -5378,7 +5498,7 @@ package Iirs is function Get_Right_Limit (Decl : Iir_Range_Expression) return Iir; procedure Set_Right_Limit (Decl : Iir_Range_Expression; Limit : Iir); - -- Field: Field4 + -- Field: Field4 Ref function Get_Base_Type (Decl : Iir) return Iir; procedure Set_Base_Type (Decl : Iir; Base_Type : Iir); pragma Inline (Get_Base_Type); @@ -5442,7 +5562,7 @@ package Iirs is function Get_Elements_Declaration_List (Decl : Iir) return Iir_List; procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List); - -- Field: Field1 + -- Field: Field1 Ref function Get_Designated_Type (Target : Iir) return Iir; procedure Set_Designated_Type (Target : Iir; Dtype : Iir); @@ -5471,9 +5591,9 @@ package Iirs is function Get_Target (Target : Iir) return Iir; procedure Set_Target (Target : Iir; Atarget : Iir); - -- Field: Field5 - function Get_Waveform_Chain (Target : Iir) return Iir_Waveform_Element; - procedure Set_Waveform_Chain (Target : Iir; Chain : Iir_Waveform_Element); + -- Field: Field5 Chain + function Get_Waveform_Chain (Target : Iir) return Iir; + procedure Set_Waveform_Chain (Target : Iir; Chain : Iir); -- Field: Field8 function Get_Guard (Target : Iir) return Iir; @@ -5630,12 +5750,12 @@ package Iirs is procedure Set_Instantiated_Unit (Target : Iir; Unit : Iir); -- Generic map aspect list. - -- Field: Field8 + -- Field: Field8 Chain function Get_Generic_Map_Aspect_Chain (Target : Iir) return Iir; procedure Set_Generic_Map_Aspect_Chain (Target : Iir; Generics : Iir); -- Port map aspect list. - -- Field: Field9 + -- Field: Field9 Chain function Get_Port_Map_Aspect_Chain (Target : Iir) return Iir; procedure Set_Port_Map_Aspect_Chain (Target : Iir; Port : Iir); @@ -5672,15 +5792,15 @@ package Iirs is -- Set to the designated type (either the type of the expression or the -- subtype) when the expression is analyzed. - -- Field: Field2 + -- Field: Field2 Ref function Get_Allocator_Designated_Type (Target : Iir) return Iir; procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir); - -- Field: Field7 + -- Field: Field7 Chain function Get_Selected_Waveform_Chain (Target : Iir) return Iir; procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir); - -- Field: Field7 + -- Field: Field7 Chain function Get_Conditional_Waveform_Chain (Target : Iir) return Iir; procedure Set_Conditional_Waveform_Chain (Target : Iir; Chain : Iir); @@ -5706,8 +5826,8 @@ package Iirs is procedure Set_Block_Block_Configuration (Block : Iir; Conf : Iir); -- Field: Field5 - function Get_Package_Header (Pkg : Iir) return Iir_Package_Body; - procedure Set_Package_Header (Pkg : Iir; Header : Iir_Package_Body); + function Get_Package_Header (Pkg : Iir) return Iir; + procedure Set_Package_Header (Pkg : Iir; Header : Iir); -- Field: Field7 function Get_Block_Header (Target : Iir) return Iir; @@ -5735,8 +5855,8 @@ package Iirs is procedure Set_Condition (Target : Iir; Condition : Iir); -- Field: Field6 - function Get_Else_Clause (Target : Iir) return Iir_Elsif; - procedure Set_Else_Clause (Target : Iir; Clause : Iir_Elsif); + function Get_Else_Clause (Target : Iir) return Iir; + procedure Set_Else_Clause (Target : Iir; Clause : Iir); -- Iterator of a for_loop_statement. -- Field: Field1 @@ -5745,7 +5865,7 @@ package Iirs is -- Get/Set the statement in which TARGET appears. This is used to check -- if next/exit is in a loop. - -- Field: Field0 + -- Field: Field0 Ref function Get_Parent (Target : Iir) return Iir; procedure Set_Parent (Target : Iir; Parent : Iir); @@ -5772,11 +5892,11 @@ package Iirs is function Get_Default_Entity_Aspect (Target : Iir) return Iir; procedure Set_Default_Entity_Aspect (Target : Iir; Aspect : Iir); - -- Field: Field6 + -- Field: Field6 Chain function Get_Default_Generic_Map_Aspect_Chain (Target : Iir) return Iir; procedure Set_Default_Generic_Map_Aspect_Chain (Target : Iir; Chain : Iir); - -- Field: Field7 + -- Field: Field7 Chain function Get_Default_Port_Map_Aspect_Chain (Target : Iir) return Iir; procedure Set_Default_Port_Map_Aspect_Chain (Target : Iir; Chain : Iir); @@ -5785,7 +5905,7 @@ package Iirs is procedure Set_Binding_Indication (Target : Iir; Binding : Iir); -- The named entity designated by a name. - -- Field: Field4 + -- Field: Field4 Ref function Get_Named_Entity (Name : Iir) return Iir; procedure Set_Named_Entity (Name : Iir; Val : Iir); @@ -5842,6 +5962,12 @@ package Iirs is function Get_Prefix (Target : Iir) return Iir; procedure Set_Prefix (Target : Iir; Prefix : Iir); + -- The subtype of a slice. Contrary to the Type field, this is not a + -- reference. + -- Field: Field3 + function Get_Slice_Subtype (Slice : Iir) return Iir; + procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir); + -- Suffix of a slice or attribute. -- Field: Field2 function Get_Suffix (Target : Iir) return Iir; @@ -5866,25 +5992,25 @@ package Iirs is -- List of individual associations for association_element_by_individual. -- Associations for parenthesis_name. - -- Field: Field2 + -- Field: Field2 Chain function Get_Association_Chain (Target : Iir) return Iir; procedure Set_Association_Chain (Target : Iir; Chain : Iir); -- List of individual associations for association_element_by_individual. - -- Field: Field4 + -- Field: Field4 Chain function Get_Individual_Association_Chain (Target : Iir) return Iir; procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir); -- Get/Set info for the aggregate. -- There is one aggregate_info for for each dimension. -- Field: Field2 - function Get_Aggregate_Info (Target : Iir) return Iir_Aggregate_Info; - procedure Set_Aggregate_Info (Target : Iir; Info : Iir_Aggregate_Info); + function Get_Aggregate_Info (Target : Iir) return Iir; + procedure Set_Aggregate_Info (Target : Iir; Info : Iir); -- Get/Set the info node for the next dimension. -- Field: Field1 - function Get_Sub_Aggregate_Info (Target : Iir) return Iir_Aggregate_Info; - procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir_Aggregate_Info); + function Get_Sub_Aggregate_Info (Target : Iir) return Iir; + procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir); -- TRUE when the length of the aggregate is not locally static. -- Field: Flag3 @@ -5895,6 +6021,7 @@ package Iirs is -- the aggregate or for the current dimension of a sub-aggregate. -- The real number of elements may be greater than this number if there -- is an 'other' choice. + -- Display: Image -- Field: Field4 (uc) function Get_Aggr_Min_Length (Info : Iir_Aggregate_Info) return Iir_Int32; procedure Set_Aggr_Min_Length (Info : Iir_Aggregate_Info; Nbr : Iir_Int32); @@ -5927,12 +6054,12 @@ package Iirs is procedure Set_Value_Staticness (Target : Iir; Staticness : Iir_Staticness); -- Chain of choices. - -- Field: Field4 + -- Field: Field4 Chain function Get_Association_Choices_Chain (Target : Iir) return Iir; procedure Set_Association_Choices_Chain (Target : Iir; Chain : Iir); -- Chain of choices. - -- Field: Field1 + -- Field: Field1 Chain function Get_Case_Statement_Alternative_Chain (Target : Iir) return Iir; procedure Set_Case_Statement_Alternative_Chain (Target : Iir; Chain : Iir); @@ -5946,12 +6073,12 @@ package Iirs is procedure Set_Procedure_Call (Stmt : Iir; Call : Iir); -- Subprogram to be called by a procedure, function call or operator. - -- Field: Field3 + -- Field: Field3 Ref function Get_Implementation (Target : Iir) return Iir; procedure Set_Implementation (Target : Iir; Decl : Iir); -- Paramater associations for procedure and function call. - -- Field: Field2 + -- Field: Field2 Chain function Get_Parameter_Association_Chain (Target : Iir) return Iir; procedure Set_Parameter_Association_Chain (Target : Iir; Chain : Iir); @@ -5966,6 +6093,10 @@ package Iirs is function Get_Subtype_Type_Mark (Target : Iir) return Iir; procedure Set_Subtype_Type_Mark (Target : Iir; Mark : Iir); + -- Field: Field3 + function Get_Type_Conversion_Subtype (Target : Iir) return Iir; + procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir); + -- The type_mark that appeared in qualified expressions or type -- conversions. -- Field: Field4 @@ -6029,7 +6160,7 @@ package Iirs is function Get_Attribute_Signature (Attr : Iir) return Iir; procedure Set_Attribute_Signature (Attr : Iir; Signature : Iir); - -- Field: Field1 (uc) + -- Field: Field1 Ref (uc) function Get_Overload_List (Target : Iir) return Iir_List; procedure Set_Overload_List (Target : Iir; List : Iir_List); @@ -6038,6 +6169,11 @@ package Iirs is function Get_Simple_Name_Identifier (Target : Iir) return Name_Id; procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id); + -- Subtype for Simple_Name attribute. + -- Field: Field4 + function Get_Simple_Name_Subtype (Target : Iir) return Iir; + procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir); + -- Body of a protected type declaration. -- Field: Field2 function Get_Protected_Type_Body (Target : Iir) return Iir; @@ -6059,7 +6195,8 @@ package Iirs is procedure Set_String_Id (Lit : Iir; Id : String_Id); -- For a string literal: the string length. - -- Field: Field0 (uc) + -- Display: Image + -- Field: Field4 (uc) function Get_String_Length (Lit : Iir) return Int32; procedure Set_String_Length (Lit : Iir; Len : Int32); diff --git a/iirs_utils.adb b/iirs_utils.adb index 9dc3c6e..515ae06 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -426,14 +426,6 @@ package body Iirs_Utils is Set_Range_Constraint (Def, Range_Expr); end Create_Range_Constraint_For_Enumeration_Type; - procedure Free_Old_Iir (Node: in Iir) - is - N : Iir; - begin - N := Node; - Free_Iir (N); - end Free_Old_Iir; - procedure Free_Name (Node : Iir) is N : Iir; @@ -525,7 +517,7 @@ package body Iirs_Utils is | Iir_Kind_Physical_Subtype_Definition => return; when Iir_Kind_Architecture_Body => - Free_Recursive (Get_Entity (N)); + Free_Recursive (Get_Entity_Name (N)); when Iir_Kind_Overload_List => Free_Recursive_List (Get_Overload_List (N)); if not Free_List then @@ -760,7 +752,9 @@ package body Iirs_Utils is when Iir_Kind_Indexed_Name | Iir_Kind_Selected_Name | Iir_Kind_Slice_Name => - return Get_Prefix (Block_Spec); + return Get_Named_Entity (Get_Prefix (Block_Spec)); + when Iir_Kind_Simple_Name => + return Get_Named_Entity (Block_Spec); when others => Error_Kind ("get_block_from_block_specification", Block_Spec); return Null_Iir; diff --git a/iirs_utils.ads b/iirs_utils.ads index 3b06e27..b638d1b 100644 --- a/iirs_utils.ads +++ b/iirs_utils.ads @@ -77,9 +77,6 @@ package Iirs_Utils is -- Free NODE and its sub-nodes. procedure Free_Recursive (Node : Iir; Free_List : Boolean := False); - -- Free NODE. - procedure Free_Old_Iir (Node: in Iir); - -- Name of FUNC. function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions) return String; diff --git a/iirs_walk.adb b/iirs_walk.adb index 1af0e66..3998329 100644 --- a/iirs_walk.adb +++ b/iirs_walk.adb @@ -76,7 +76,7 @@ package body Iirs_Walk is Chain := Get_Case_Statement_Alternative_Chain (Stmt); while Chain /= Null_Iir loop Status := Walk_Sequential_Stmt_Chain - (Get_Associated (Chain), Cb); + (Get_Associated_Chain (Chain), Cb); exit when Status /= Walk_Continue; Chain := Get_Chain (Chain); end loop; @@ -102,7 +102,8 @@ package body Iirs_Walk is when Iir_Kind_Aggregate => Chain := Get_Association_Choices_Chain (Target); while Chain /= Null_Iir loop - Status := Walk_Assignment_Target (Get_Associated (Chain), Cb); + Status := + Walk_Assignment_Target (Get_Associated_Expr (Chain), Cb); exit when Status /= Walk_Continue; Chain := Get_Chain (Chain); end loop; diff --git a/libraries.adb b/libraries.adb index 3120d72..4696008 100644 --- a/libraries.adb +++ b/libraries.adb @@ -784,24 +784,37 @@ package body Libraries is end if; end Free_Dependence_List; + -- This procedure is called when the DESIGN_UNIT (either the stub created + -- when a library is read or created from a previous unit in a source + -- file) has been replaced by a new unit. Free everything but DESIGN_UNIT, + -- has it may be referenced in other units (dependence...) + -- FIXME: Isn't the library unit also referenced too ? procedure Free_Design_Unit (Design_Unit : Iir_Design_Unit) is Lib : Iir; Unit : Iir_Design_Unit; Dep_List : Iir_List; begin + -- Free dependence list. Dep_List := Get_Dependence_List (Design_Unit); Destroy_Iir_List (Dep_List); + Set_Dependence_List (Design_Unit, Null_Iir_List); + + -- Free default configuration of architecture (if any). Lib := Get_Library_Unit (Design_Unit); if Lib /= Null_Iir and then Get_Kind (Lib) = Iir_Kind_Architecture_Body then + Free_Iir (Get_Entity_Name (Lib)); Unit := Get_Default_Configuration_Declaration (Lib); if Unit /= Null_Iir then Free_Design_Unit (Unit); end if; end if; - Iirs_Utils.Free_Old_Iir (Lib); + + -- Free library unit. + Free_Iir (Lib); + Set_Library_Unit (Design_Unit, Null_Iir); end Free_Design_Unit; procedure Remove_Unit_From_File @@ -931,6 +944,9 @@ package body Libraries is or else Get_Date_State (Design_Unit) = Date_Disk then Remove_Unit_From_File (Design_Unit, Design_File); + + Set_Chain (Design_Unit, Obsoleted_Design_Units); + Obsoleted_Design_Units := Design_Unit; end if; end; @@ -1024,7 +1040,11 @@ package body Libraries is else raise Internal_Error; end if; + Prev_Design_Unit := Design_Unit; Design_Unit := Get_Chain (Design_Unit); + + Set_Chain (Prev_Design_Unit, Obsoleted_Design_Units); + Obsoleted_Design_Units := Prev_Design_Unit; end loop; Set_First_Design_Unit (Design_File, Null_Iir); Set_Last_Design_Unit (Design_File, Null_Iir); @@ -1422,9 +1442,8 @@ package body Libraries is Design_File : Iir_Design_File; Fe : Source_File_Entry; begin - if Get_Date_State (Design_Unit) /= Date_Disk then - raise Internal_Error; - end if; + -- The unit must not be loaded. + pragma Assert (Get_Date_State (Design_Unit) = Date_Disk); -- Load and parse the unit. Design_File := Get_Design_File (Design_Unit); diff --git a/libraries.ads b/libraries.ads index 3a89c47..ecb048c 100644 --- a/libraries.ads +++ b/libraries.ads @@ -59,6 +59,9 @@ package Libraries is -- for library directories. Name_Nil : Name_Id; + -- Chain of obsoleted design units. + Obsoleted_Design_Units : Iir := Null_Iir; + -- Initialize library pathes table. -- Set the local path. procedure Init_Pathes; @@ -109,6 +109,18 @@ package body Nodes is end if; end Free_Node; + function Next_Node (N : Node_Type) return Node_Type is + begin + case Nodet.Table (N).Format is + when Format_Medium => + return N + 2; + when Format_Short + | Format_Int + | Format_Fp => + return N + 1; + end case; + end Next_Node; + function Get_Nkind (N : Node_Type) return Kind_Type is begin return Nodet.Table (N).Kind; @@ -101,6 +101,7 @@ package Nodes is function Create_Node (Format : Format_Type) return Node_Type; procedure Free_Node (N : Node_Type); + function Next_Node (N : Node_Type) return Node_Type; function Get_Nkind (N : Node_Type) return Kind_Type; pragma Inline (Get_Nkind); diff --git a/nodes_gc.adb b/nodes_gc.adb new file mode 100644 index 0000000..dfb23b4 --- /dev/null +++ b/nodes_gc.adb @@ -0,0 +1,807 @@ +-- Node garbage collector (for debugging). +-- Copyright (C) 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 GHDL; 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 Types; use Types; +with Nodes; +with Iirs; use Iirs; +with Libraries; +with Disp_Tree; +with Std_Package; + +package body Nodes_GC is + + type Marker_Array is array (Iir range <>) of Boolean; + type Marker_Array_Acc is access Marker_Array; + + Markers : Marker_Array_Acc; + + procedure Mark_Iir (N : Iir); + + procedure Mark_Iir_List (N : Iir_List) + is + El : Iir; + begin + case N is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + null; + when others => + for I in Natural loop + El := Get_Nth_Element (N, I); + exit when El = Null_Iir; + Mark_Iir (El); + end loop; + end case; + end Mark_Iir_List; + + procedure Mark_PSL_Node (N : PSL_Node) is + begin + null; + end Mark_PSL_Node; + + procedure Mark_PSL_NFA (N : PSL_NFA) is + begin + null; + end Mark_PSL_NFA; + + procedure Report_Already_Marked (N : Iir) + is + use Ada.Text_IO; + begin + Disp_Tree.Disp_Tree (N, True); + return; + end Report_Already_Marked; + + procedure Already_Marked (N : Iir) is + begin + -- An unused node mustn't be referenced. + if Get_Kind (N) = Iir_Kind_Unused then + raise Internal_Error; + end if; + + if not Flag_Disp_Multiref then + return; + end if; + + case Get_Kind (N) is + when Iir_Kind_Constant_Interface_Declaration => + if Get_Identifier (N) = Null_Identifier then + -- Anonymous interfaces are shared by predefined functions. + return; + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (N) = 0 + or else N = Get_Right_Limit (Get_Range_Constraint + (Get_Type (N))) + then + return; + end if; + when others => + null; + end case; + + Report_Already_Marked (N); + end Already_Marked; + + procedure Mark_Chain (Head : Iir) + is + El : Iir; + begin + El := Head; + while El /= Null_Iir loop + Mark_Iir (El); + El := Get_Chain (El); + end loop; + end Mark_Chain; + + procedure Report_Unreferenced_Node (N : Iir) is + begin + Disp_Tree.Disp_Tree (N, True); + end Report_Unreferenced_Node; + + -- Subprograms + procedure Mark_Iir (N : Iir) is + begin + if N = Null_Iir then + return; + elsif Markers (N) then + Already_Marked (N); + return; + else + Markers (N) := True; + end if; + + case Get_Kind (N) is + when Iir_Kind_Unused + | Iir_Kind_Entity_Aspect_Open + | Iir_Kind_Behavior_Attribute + | Iir_Kind_Structure_Attribute => + null; + when Iir_Kind_Error => + Mark_Iir (Get_Error_Origin (N)); + when Iir_Kind_Design_File => + Mark_Iir_List (Get_File_Dependence_List (N)); + Mark_Chain (Get_First_Design_Unit (N)); + when Iir_Kind_Design_Unit => + Mark_Chain (Get_Context_Items (N)); + Mark_Iir (Get_Library_Unit (N)); + Mark_Iir_List (Get_Analysis_Checks_List (N)); + when Iir_Kind_Library_Clause => + Mark_Iir (Get_Library_Declaration (N)); + when Iir_Kind_Use_Clause => + Mark_Iir (Get_Selected_Name (N)); + Mark_Iir (Get_Use_Clause_Chain (N)); + when Iir_Kind_Integer_Literal => + Mark_Iir (Get_Literal_Origin (N)); + when Iir_Kind_Floating_Point_Literal => + Mark_Iir (Get_Literal_Origin (N)); + when Iir_Kind_Null_Literal => + null; + when Iir_Kind_String_Literal => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir (Get_Literal_Subtype (N)); + when Iir_Kind_Physical_Int_Literal => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir (Get_Unit_Name (N)); + when Iir_Kind_Physical_Fp_Literal => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir (Get_Unit_Name (N)); + when Iir_Kind_Bit_String_Literal => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir (Get_Literal_Subtype (N)); + Mark_Iir (Get_Bit_String_0 (N)); + Mark_Iir (Get_Bit_String_1 (N)); + when Iir_Kind_Simple_Aggregate => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir_List (Get_Simple_Aggregate_List (N)); + Mark_Iir (Get_Literal_Subtype (N)); + when Iir_Kind_Overflow_Literal => + Mark_Iir (Get_Literal_Origin (N)); + when Iir_Kind_Waveform_Element => + Mark_Iir (Get_We_Value (N)); + Mark_Iir (Get_Time (N)); + when Iir_Kind_Conditional_Waveform => + Mark_Iir (Get_Condition (N)); + Mark_Chain (Get_Waveform_Chain (N)); + when Iir_Kind_Association_Element_By_Expression => + Mark_Iir (Get_Formal (N)); + Mark_Iir (Get_Actual (N)); + Mark_Iir (Get_In_Conversion (N)); + Mark_Iir (Get_Out_Conversion (N)); + when Iir_Kind_Association_Element_By_Individual => + Mark_Iir (Get_Formal (N)); + Mark_Iir (Get_Actual_Type (N)); + Mark_Chain (Get_Individual_Association_Chain (N)); + when Iir_Kind_Association_Element_Open => + Mark_Iir (Get_Formal (N)); + when Iir_Kind_Choice_By_Others + | Iir_Kind_Choice_By_None => + Mark_Iir (Get_Associated_Expr (N)); + Mark_Chain (Get_Associated_Chain (N)); + when Iir_Kind_Choice_By_Expression => + Mark_Iir (Get_Associated_Expr (N)); + Mark_Chain (Get_Associated_Chain (N)); + Mark_Iir (Get_Choice_Expression (N)); + when Iir_Kind_Choice_By_Range => + Mark_Iir (Get_Associated_Expr (N)); + Mark_Chain (Get_Associated_Chain (N)); + Mark_Iir (Get_Choice_Range (N)); + when Iir_Kind_Choice_By_Name => + Mark_Iir (Get_Associated_Expr (N)); + Mark_Chain (Get_Associated_Chain (N)); + Mark_Iir (Get_Choice_Name (N)); + when Iir_Kind_Entity_Aspect_Entity => + Mark_Iir (Get_Entity_Name (N)); + Mark_Iir (Get_Architecture (N)); + when Iir_Kind_Entity_Aspect_Configuration => + Mark_Iir (Get_Configuration_Name (N)); + when Iir_Kind_Block_Configuration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Configuration_Item_Chain (N)); + Mark_Iir (Get_Block_Specification (N)); + when Iir_Kind_Block_Header => + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Port_Chain (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + Mark_Chain (Get_Port_Map_Aspect_Chain (N)); + when Iir_Kind_Component_Configuration => + Mark_Iir_List (Get_Instantiation_List (N)); + Mark_Iir (Get_Binding_Indication (N)); + Mark_Iir (Get_Component_Name (N)); + Mark_Iir (Get_Block_Configuration (N)); + when Iir_Kind_Binding_Indication => + Mark_Iir (Get_Default_Entity_Aspect (N)); + Mark_Iir (Get_Entity_Aspect (N)); + Mark_Chain (Get_Default_Generic_Map_Aspect_Chain (N)); + Mark_Chain (Get_Default_Port_Map_Aspect_Chain (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + Mark_Chain (Get_Port_Map_Aspect_Chain (N)); + when Iir_Kind_Entity_Class => + null; + when Iir_Kind_Attribute_Value => + Mark_Iir (Get_Spec_Chain (N)); + when Iir_Kind_Signature => + Mark_Iir (Get_Prefix (N)); + Mark_Iir_List (Get_Type_Marks_List (N)); + Mark_Iir (Get_Return_Type_Mark (N)); + when Iir_Kind_Aggregate_Info => + Mark_Iir (Get_Sub_Aggregate_Info (N)); + Mark_Iir (Get_Aggr_Low_Limit (N)); + Mark_Iir (Get_Aggr_High_Limit (N)); + when Iir_Kind_Procedure_Call => + Mark_Iir (Get_Prefix (N)); + Mark_Chain (Get_Parameter_Association_Chain (N)); + Mark_Iir (Get_Method_Object (N)); + when Iir_Kind_Record_Element_Constraint => + Mark_Iir (Get_Element_Declaration (N)); + when Iir_Kind_Attribute_Specification => + Mark_Iir_List (Get_Entity_Name_List (N)); + Mark_Iir (Get_Attribute_Value_Spec_Chain (N)); + Mark_Iir (Get_Expression (N)); + Mark_Iir (Get_Attribute_Designator (N)); + Mark_Iir (Get_Attribute_Specification_Chain (N)); + when Iir_Kind_Disconnection_Specification => + Mark_Iir_List (Get_Signal_List (N)); + Mark_Iir (Get_Type_Mark (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Configuration_Specification => + Mark_Iir_List (Get_Instantiation_List (N)); + Mark_Iir (Get_Binding_Indication (N)); + Mark_Iir (Get_Component_Name (N)); + when Iir_Kind_Access_Type_Definition => + Mark_Iir (Get_Designated_Subtype_Indication (N)); + when Iir_Kind_Incomplete_Type_Definition => + Mark_Iir_List (Get_Incomplete_Type_List (N)); + when Iir_Kind_File_Type_Definition => + Mark_Iir (Get_File_Type_Mark (N)); + when Iir_Kind_Protected_Type_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Protected_Type_Body (N)); + when Iir_Kind_Record_Type_Definition => + Mark_Iir_List (Get_Elements_Declaration_List (N)); + when Iir_Kind_Array_Type_Definition => + Mark_Iir (Get_Element_Subtype_Indication (N)); + Mark_Iir_List (Get_Index_Subtype_List (N)); + when Iir_Kind_Array_Subtype_Definition => + Mark_Iir (Get_Element_Subtype_Indication (N)); + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Resolution_Function (N)); + Mark_Iir_List (Get_Index_Subtype_List (N)); + Mark_Iir (Get_Tolerance (N)); + when Iir_Kind_Record_Subtype_Definition => + Mark_Iir_List (Get_Elements_Declaration_List (N)); + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Resolution_Function (N)); + Mark_Iir (Get_Tolerance (N)); + when Iir_Kind_Access_Subtype_Definition => + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Designated_Subtype_Indication (N)); + when Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Mark_Iir (Get_Range_Constraint (N)); + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Resolution_Function (N)); + when Iir_Kind_Floating_Subtype_Definition => + Mark_Iir (Get_Range_Constraint (N)); + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Resolution_Function (N)); + Mark_Iir (Get_Tolerance (N)); + when Iir_Kind_Enumeration_Type_Definition => + Mark_Iir (Get_Range_Constraint (N)); + Mark_Iir_List (Get_Enumeration_Literal_List (N)); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + null; + when Iir_Kind_Physical_Type_Definition => + Mark_Chain (Get_Unit_Chain (N)); + when Iir_Kind_Range_Expression => + Mark_Iir (Get_Left_Limit (N)); + Mark_Iir (Get_Right_Limit (N)); + Mark_Iir (Get_Range_Origin (N)); + when Iir_Kind_Protected_Type_Body => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Protected_Type_Declaration (N)); + when Iir_Kind_Subtype_Definition => + Mark_Iir (Get_Range_Constraint (N)); + Mark_Iir (Get_Subtype_Type_Mark (N)); + Mark_Iir (Get_Resolution_Function (N)); + Mark_Iir (Get_Tolerance (N)); + when Iir_Kind_Scalar_Nature_Definition => + Mark_Iir (Get_Reference (N)); + Mark_Iir (Get_Nature_Declarator (N)); + Mark_Iir (Get_Across_Type (N)); + Mark_Iir (Get_Through_Type (N)); + when Iir_Kind_Overload_List => + null; + when Iir_Kind_Type_Declaration => + Mark_Iir (Get_Type_Definition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Anonymous_Type_Declaration => + Mark_Iir (Get_Type_Definition (N)); + Mark_Iir (Get_Subtype_Definition (N)); + when Iir_Kind_Subtype_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + when Iir_Kind_Nature_Declaration + | Iir_Kind_Subnature_Declaration => + Mark_Iir (Get_Nature (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Configuration_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Entity_Name (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Block_Configuration (N)); + when Iir_Kind_Entity_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Concurrent_Statement_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Port_Chain (N)); + when Iir_Kind_Package_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Package_Body (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Package_Header (N)); + when Iir_Kind_Package_Body => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Package (N)); + when Iir_Kind_Architecture_Body => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Entity_Name (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Concurrent_Statement_Chain (N)); + Mark_Iir (Get_Default_Configuration_Declaration (N)); + when Iir_Kind_Package_Instantiation_Declaration => + Mark_Iir (Get_Uninstantiated_Name (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + when Iir_Kind_Package_Header => + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + when Iir_Kind_Unit_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Physical_Literal (N)); + Mark_Iir (Get_Physical_Unit_Value (N)); + when Iir_Kind_Library_Declaration => + Mark_Chain (Get_Design_File_Chain (N)); + when Iir_Kind_Component_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Port_Chain (N)); + when Iir_Kind_Attribute_Declaration => + Mark_Iir (Get_Type_Mark (N)); + when Iir_Kind_Group_Template_Declaration => + Mark_Chain (Get_Entity_Class_Entry_Chain (N)); + when Iir_Kind_Group_Declaration => + Mark_Iir_List (Get_Group_Constituent_List (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Group_Template_Name (N)); + when Iir_Kind_Element_Declaration => + Mark_Iir (Get_Subtype_Indication (N)); + when Iir_Kind_Non_Object_Alias_Declaration => + Mark_Iir (Get_Name (N)); + Mark_Iir (Get_Alias_Signature (N)); + when Iir_Kind_Psl_Declaration => + Mark_PSL_Node (Get_Psl_Declaration (N)); + Mark_PSL_Node (Get_PSL_Clock (N)); + Mark_PSL_NFA (Get_PSL_NFA (N)); + when Iir_Kind_Terminal_Declaration => + Mark_Iir (Get_Nature (N)); + when Iir_Kind_Free_Quantity_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Default_Value (N)); + when Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Default_Value (N)); + Mark_Iir (Get_Tolerance (N)); + Mark_Iir (Get_Plus_Terminal (N)); + Mark_Iir (Get_Minus_Terminal (N)); + when Iir_Kind_Enumeration_Literal => + Mark_Iir (Get_Literal_Origin (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Function_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Interface_Declaration_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Iir (Get_Return_Type_Mark (N)); + Mark_Iir (Get_Subprogram_Body (N)); + when Iir_Kind_Implicit_Function_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Interface_Declaration_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + when Iir_Kind_Implicit_Procedure_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Interface_Declaration_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + when Iir_Kind_Procedure_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Interface_Declaration_Chain (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Iir (Get_Return_Type_Mark (N)); + Mark_Iir (Get_Subprogram_Body (N)); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Subprogram_Specification (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + when Iir_Kind_Object_Alias_Declaration => + Mark_Iir (Get_Name (N)); + Mark_Iir (Get_Subtype_Indication (N)); + when Iir_Kind_File_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_File_Logical_Name (N)); + Mark_Iir (Get_File_Open_Kind (N)); + when Iir_Kind_Guard_Signal_Declaration => + Mark_Iir (Get_Guard_Expression (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir_List (Get_Guard_Sensitivity_List (N)); + Mark_Iir (Get_Block_Statement (N)); + when Iir_Kind_Signal_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Default_Value (N)); + Mark_Iir (Get_Signal_Driver (N)); + when Iir_Kind_Variable_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Default_Value (N)); + when Iir_Kind_Constant_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Default_Value (N)); + Mark_Iir (Get_Deferred_Declaration (N)); + when Iir_Kind_Iterator_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Discrete_Range (N)); + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Default_Value (N)); + when Iir_Kind_Signal_Interface_Declaration => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Subtype_Indication (N)); + Mark_Iir (Get_Default_Value (N)); + when Iir_Kind_Identity_Operator + | Iir_Kind_Negation_Operator + | Iir_Kind_Absolute_Operator + | Iir_Kind_Not_Operator + | Iir_Kind_Condition_Operator + | Iir_Kind_Reduction_And_Operator + | Iir_Kind_Reduction_Or_Operator + | Iir_Kind_Reduction_Nand_Operator + | Iir_Kind_Reduction_Nor_Operator + | Iir_Kind_Reduction_Xor_Operator + | Iir_Kind_Reduction_Xnor_Operator => + Mark_Iir (Get_Operand (N)); + when Iir_Kind_And_Operator + | Iir_Kind_Or_Operator + | Iir_Kind_Nand_Operator + | Iir_Kind_Nor_Operator + | Iir_Kind_Xor_Operator + | Iir_Kind_Xnor_Operator + | Iir_Kind_Equality_Operator + | Iir_Kind_Inequality_Operator + | Iir_Kind_Less_Than_Operator + | Iir_Kind_Less_Than_Or_Equal_Operator + | Iir_Kind_Greater_Than_Operator + | Iir_Kind_Greater_Than_Or_Equal_Operator + | Iir_Kind_Match_Equality_Operator + | Iir_Kind_Match_Inequality_Operator + | Iir_Kind_Match_Less_Than_Operator + | Iir_Kind_Match_Less_Than_Or_Equal_Operator + | Iir_Kind_Match_Greater_Than_Operator + | Iir_Kind_Match_Greater_Than_Or_Equal_Operator + | Iir_Kind_Sll_Operator + | Iir_Kind_Sla_Operator + | Iir_Kind_Srl_Operator + | Iir_Kind_Sra_Operator + | Iir_Kind_Rol_Operator + | Iir_Kind_Ror_Operator + | Iir_Kind_Addition_Operator + | Iir_Kind_Substraction_Operator + | Iir_Kind_Concatenation_Operator + | Iir_Kind_Multiplication_Operator + | Iir_Kind_Division_Operator + | Iir_Kind_Modulus_Operator + | Iir_Kind_Remainder_Operator + | Iir_Kind_Exponentiation_Operator => + Mark_Iir (Get_Left (N)); + Mark_Iir (Get_Right (N)); + when Iir_Kind_Function_Call => + Mark_Iir (Get_Prefix (N)); + Mark_Chain (Get_Parameter_Association_Chain (N)); + Mark_Iir (Get_Method_Object (N)); + when Iir_Kind_Aggregate => + Mark_Iir (Get_Aggregate_Info (N)); + Mark_Chain (Get_Association_Choices_Chain (N)); + Mark_Iir (Get_Literal_Subtype (N)); + when Iir_Kind_Parenthesis_Expression => + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Qualified_Expression => + Mark_Iir (Get_Type_Mark (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Type_Conversion => + Mark_Iir (Get_Type_Conversion_Subtype (N)); + Mark_Iir (Get_Type_Mark (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Allocator_By_Expression => + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Allocator_By_Subtype => + Mark_Iir (Get_Subtype_Indication (N)); + when Iir_Kind_Selected_Element => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Selected_Element (N)); + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Left_Type_Attribute + | Iir_Kind_Right_Type_Attribute + | Iir_Kind_High_Type_Attribute + | Iir_Kind_Low_Type_Attribute + | Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Instance_Name_Attribute + | Iir_Kind_Path_Name_Attribute => + Mark_Iir (Get_Prefix (N)); + when Iir_Kind_Slice_Name => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Suffix (N)); + Mark_Iir (Get_Slice_Subtype (N)); + when Iir_Kind_Indexed_Name => + Mark_Iir (Get_Prefix (N)); + Mark_Iir_List (Get_Index_List (N)); + when Iir_Kind_Psl_Expression => + Mark_PSL_Node (Get_Psl_Expression (N)); + when Iir_Kind_Sensitized_Process_Statement => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + Mark_Iir_List (Get_Sensitivity_List (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Iir (Get_Process_Origin (N)); + when Iir_Kind_Process_Statement => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + Mark_Iir_List (Get_Callees_List (N)); + Mark_Iir (Get_Process_Origin (N)); + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + Mark_Iir (Get_Target (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Reject_Time_Expression (N)); + Mark_Chain (Get_Conditional_Waveform_Chain (N)); + Mark_Iir (Get_Guard (N)); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + Mark_Iir (Get_Target (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Expression (N)); + Mark_Iir (Get_Reject_Time_Expression (N)); + Mark_Chain (Get_Selected_Waveform_Chain (N)); + Mark_Iir (Get_Guard (N)); + when Iir_Kind_Concurrent_Assertion_Statement => + Mark_Iir (Get_Assertion_Condition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Severity_Expression (N)); + Mark_Iir (Get_Report_Expression (N)); + when Iir_Kind_Psl_Default_Clock => + Mark_PSL_Node (Get_Psl_Boolean (N)); + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Mark_PSL_Node (Get_Psl_Property (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Severity_Expression (N)); + Mark_Iir (Get_Report_Expression (N)); + Mark_PSL_Node (Get_PSL_Clock (N)); + Mark_PSL_NFA (Get_PSL_NFA (N)); + when Iir_Kind_Concurrent_Procedure_Call_Statement => + Mark_Iir (Get_Procedure_Call (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Block_Statement => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Concurrent_Statement_Chain (N)); + Mark_Iir (Get_Block_Block_Configuration (N)); + Mark_Iir (Get_Block_Header (N)); + Mark_Iir (Get_Guard_Decl (N)); + when Iir_Kind_Generate_Statement => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Concurrent_Statement_Chain (N)); + Mark_Iir (Get_Generation_Scheme (N)); + Mark_Iir (Get_Generate_Block_Configuration (N)); + when Iir_Kind_Component_Instantiation_Statement => + Mark_Iir (Get_Instantiated_Unit (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Default_Binding_Indication (N)); + Mark_Iir (Get_Component_Configuration (N)); + Mark_Iir (Get_Configuration_Specification (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + Mark_Chain (Get_Port_Map_Aspect_Chain (N)); + when Iir_Kind_Simple_Simultaneous_Statement => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Simultaneous_Left (N)); + Mark_Iir (Get_Simultaneous_Right (N)); + Mark_Iir (Get_Tolerance (N)); + when Iir_Kind_Signal_Assignment_Statement => + Mark_Iir (Get_Target (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Waveform_Chain (N)); + Mark_Iir (Get_Reject_Time_Expression (N)); + when Iir_Kind_Null_Statement => + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Assertion_Statement => + Mark_Iir (Get_Assertion_Condition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Severity_Expression (N)); + Mark_Iir (Get_Report_Expression (N)); + when Iir_Kind_Report_Statement => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Severity_Expression (N)); + Mark_Iir (Get_Report_Expression (N)); + when Iir_Kind_Wait_Statement => + Mark_Iir (Get_Timeout_Clause (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Condition_Clause (N)); + Mark_Iir_List (Get_Sensitivity_List (N)); + when Iir_Kind_Variable_Assignment_Statement => + Mark_Iir (Get_Target (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Return_Statement => + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_For_Loop_Statement => + Mark_Iir (Get_Parameter_Specification (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + when Iir_Kind_While_Loop_Statement => + Mark_Iir (Get_Condition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Mark_Iir (Get_Condition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Loop_Label (N)); + when Iir_Kind_Case_Statement => + Mark_Chain (Get_Case_Statement_Alternative_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Expression (N)); + when Iir_Kind_Procedure_Call_Statement => + Mark_Iir (Get_Procedure_Call (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_If_Statement => + Mark_Iir (Get_Condition (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + Mark_Iir (Get_Else_Clause (N)); + when Iir_Kind_Elsif => + Mark_Iir (Get_Condition (N)); + Mark_Chain (Get_Sequential_Statement_Chain (N)); + Mark_Iir (Get_Else_Clause (N)); + when Iir_Kind_Character_Literal + | Iir_Kind_Simple_Name => + Mark_Iir (Get_Alias_Declaration (N)); + when Iir_Kind_Selected_Name => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Alias_Declaration (N)); + when Iir_Kind_Operator_Symbol => + Mark_Iir (Get_Alias_Declaration (N)); + when Iir_Kind_Selected_By_All_Name => + Mark_Iir (Get_Prefix (N)); + when Iir_Kind_Parenthesis_Name => + Mark_Iir (Get_Prefix (N)); + Mark_Chain (Get_Association_Chain (N)); + when Iir_Kind_Base_Attribute => + Mark_Iir (Get_Prefix (N)); + when Iir_Kind_Image_Attribute + | Iir_Kind_Value_Attribute + | Iir_Kind_Pos_Attribute + | Iir_Kind_Val_Attribute + | Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute + | Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Parameter (N)); + when Iir_Kind_Delayed_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Parameter (N)); + when Iir_Kind_Event_Attribute + | Iir_Kind_Active_Attribute + | Iir_Kind_Last_Event_Attribute + | Iir_Kind_Last_Active_Attribute + | Iir_Kind_Last_Value_Attribute + | Iir_Kind_Driving_Attribute + | Iir_Kind_Driving_Value_Attribute => + Mark_Iir (Get_Prefix (N)); + when Iir_Kind_Simple_Name_Attribute => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Simple_Name_Subtype (N)); + when Iir_Kind_Left_Array_Attribute + | Iir_Kind_Right_Array_Attribute + | Iir_Kind_High_Array_Attribute + | Iir_Kind_Low_Array_Attribute + | Iir_Kind_Length_Array_Attribute + | Iir_Kind_Ascending_Array_Attribute + | Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Index_Subtype (N)); + Mark_Iir (Get_Parameter (N)); + when Iir_Kind_Attribute_Name => + Mark_Iir (Get_Prefix (N)); + Mark_Iir (Get_Attribute_Signature (N)); + end case; + end Mark_Iir; + + + procedure Report_Unreferenced + is + use Ada.Text_IO; + use Std_Package; + El : Iir; + Nbr_Unreferenced : Natural; + begin + Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False); + + if Flag_Disp_Multiref then + Put_Line ("** nodes already marked:"); + end if; + + Mark_Chain (Libraries.Get_Libraries_Chain); + Mark_Chain (Libraries.Obsoleted_Design_Units); + Mark_Iir (Convertible_Integer_Type_Declaration); + Mark_Iir (Convertible_Integer_Subtype_Declaration); + Mark_Iir (Convertible_Real_Type_Declaration); + Mark_Iir (Universal_Integer_One); + Mark_Iir (Error_Mark); + + El := Error_Mark; + Nbr_Unreferenced := 0; + while El in Markers'Range loop + if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then + if Nbr_Unreferenced = 0 then + Put_Line ("** unreferenced nodes:"); + end if; + Nbr_Unreferenced := Nbr_Unreferenced + 1; + Report_Unreferenced_Node (El); + end if; + El := Iir (Nodes.Next_Node (Nodes.Node_Type (El))); + end loop; + + if Nbr_Unreferenced /= 0 then + raise Internal_Error; + end if; + end Report_Unreferenced; +end Nodes_GC; diff --git a/nodes_gc.adb.in b/nodes_gc.adb.in new file mode 100644 index 0000000..7c4303b --- /dev/null +++ b/nodes_gc.adb.in @@ -0,0 +1,159 @@ +-- Node garbage collector (for debugging). +-- Copyright (C) 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 GHDL; 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 Types; use Types; +with Nodes; +with Iirs; use Iirs; +with Libraries; +with Disp_Tree; +with Std_Package; + +package body Nodes_GC is + + type Marker_Array is array (Iir range <>) of Boolean; + type Marker_Array_Acc is access Marker_Array; + + Markers : Marker_Array_Acc; + + procedure Mark_Iir (N : Iir); + + procedure Mark_Iir_List (N : Iir_List) + is + El : Iir; + begin + case N is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + null; + when others => + for I in Natural loop + El := Get_Nth_Element (N, I); + exit when El = Null_Iir; + Mark_Iir (El); + end loop; + end case; + end Mark_Iir_List; + + procedure Mark_PSL_Node (N : PSL_Node) is + begin + null; + end Mark_PSL_Node; + + procedure Mark_PSL_NFA (N : PSL_NFA) is + begin + null; + end Mark_PSL_NFA; + + procedure Report_Already_Marked (N : Iir) + is + use Ada.Text_IO; + begin + Disp_Tree.Disp_Tree (N, True); + return; + end Report_Already_Marked; + + procedure Already_Marked (N : Iir) is + begin + -- An unused node mustn't be referenced. + if Get_Kind (N) = Iir_Kind_Unused then + raise Internal_Error; + end if; + + if not Flag_Disp_Multiref then + return; + end if; + + case Get_Kind (N) is + when Iir_Kind_Constant_Interface_Declaration => + if Get_Identifier (N) = Null_Identifier then + -- Anonymous interfaces are shared by predefined functions. + return; + end if; + when Iir_Kind_Enumeration_Literal => + if Get_Enum_Pos (N) = 0 + or else N = Get_Right_Limit (Get_Range_Constraint + (Get_Type (N))) + then + return; + end if; + when others => + null; + end case; + + Report_Already_Marked (N); + end Already_Marked; + + procedure Mark_Chain (Head : Iir) + is + El : Iir; + begin + El := Head; + while El /= Null_Iir loop + Mark_Iir (El); + El := Get_Chain (El); + end loop; + end Mark_Chain; + + procedure Report_Unreferenced_Node (N : Iir) is + begin + Disp_Tree.Disp_Tree (N, True); + end Report_Unreferenced_Node; + + -- Subprograms + + procedure Report_Unreferenced + is + use Ada.Text_IO; + use Std_Package; + El : Iir; + Nbr_Unreferenced : Natural; + begin + Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False); + + if Flag_Disp_Multiref then + Put_Line ("** nodes already marked:"); + end if; + + Mark_Chain (Libraries.Get_Libraries_Chain); + Mark_Chain (Libraries.Obsoleted_Design_Units); + Mark_Iir (Convertible_Integer_Type_Declaration); + Mark_Iir (Convertible_Integer_Subtype_Declaration); + Mark_Iir (Convertible_Real_Type_Declaration); + Mark_Iir (Universal_Integer_One); + Mark_Iir (Error_Mark); + + El := Error_Mark; + Nbr_Unreferenced := 0; + while El in Markers'Range loop + if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then + if Nbr_Unreferenced = 0 then + Put_Line ("** unreferenced nodes:"); + end if; + Nbr_Unreferenced := Nbr_Unreferenced + 1; + Report_Unreferenced_Node (El); + end if; + El := Iir (Nodes.Next_Node (Nodes.Node_Type (El))); + end loop; + + if Nbr_Unreferenced /= 0 then + raise Internal_Error; + end if; + end Report_Unreferenced; +end Nodes_GC; diff --git a/xtools/check_iirs_pkg.ads b/nodes_gc.ads index e03abab..ef8e647 100644 --- a/xtools/check_iirs_pkg.ads +++ b/nodes_gc.ads @@ -1,5 +1,5 @@ --- Tool to check the coherence of the iirs package. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- Node garbage collector (for debugging). +-- Copyright (C) 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 @@ -12,27 +12,13 @@ -- 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 +-- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -package Check_Iirs_Pkg is - -- If set, disp all Iir kind. - Flag_Disp_Iir : Boolean := False; +package Nodes_GC is + Flag_Disp_Multiref : Boolean := False; - -- If set, disp Iir_Kinds subtype. - Flag_Disp_Subtype : Boolean := False; - - -- If set, generate checks. - Flag_Checks : Boolean := True; - - procedure Read_Fields; - - procedure Check_Iirs; - - procedure Read_Desc; - - procedure Gen_Func; - - procedure List_Free_Fields; -end Check_Iirs_Pkg; + procedure Report_Unreferenced; + -- Display nodes that aren't referenced. +end Nodes_GC; @@ -1508,7 +1508,7 @@ package body Parse is -- -- [ LRM93 3.1.3 ] -- secondary_unit_declaration ::= identifier = physical_literal ; - function Parse_Physical_Type_Definition + function Parse_Physical_Type_Definition (Parent : Iir) return Iir_Physical_Type_Definition is use Iir_Chains.Unit_Chain_Handling; @@ -1528,6 +1528,7 @@ package body Parse is Expect (Tok_Identifier); Unit := Create_Iir (Iir_Kind_Unit_Declaration); Set_Location (Unit); + Set_Parent (Unit, Parent); Set_Identifier (Unit, Current_Identifier); -- Skip identifier @@ -1786,29 +1787,29 @@ package body Parse is -- precond : TYPE -- postcond: a token -- - -- [ §4.1 ] + -- [ LRM93 4.1 ] -- type_definition ::= scalar_type_definition -- | composite_type_definition -- | access_type_definition -- | file_type_definition -- | protected_type_definition -- - -- [ §3.1 ] + -- [ LRM93 3.1 ] -- scalar_type_definition ::= enumeration_type_definition -- | integer_type_definition -- | floating_type_definition -- | physical_type_definition -- - -- [ §3.2 ] + -- [ LRM93 3.2 ] -- composite_type_definition ::= array_type_definition -- | record_type_definition -- - -- [ §3.1.2 ] + -- [ LRM93 3.1.2 ] -- integer_type_definition ::= range_constraint -- - -- [ 3.1.4 ] + -- [ LRM93 3.1.4 ] -- floating_type_definition ::= range_constraint - function Parse_Type_Declaration return Iir + function Parse_Type_Declaration (Parent : Iir) return Iir is Def : Iir; Loc : Location_Type; @@ -1867,7 +1868,7 @@ package body Parse is declare Unit_Def : Iir; begin - Unit_Def := Parse_Physical_Type_Definition; + Unit_Def := Parse_Physical_Type_Definition (Parent); if Current_Token = Tok_Identifier then if Flags.Vhdl_Std = Vhdl_87 then Error_Msg_Parse @@ -2855,7 +2856,10 @@ package body Parse is Expect (Tok_Left_Bracket); Res := Create_Iir (Iir_Kind_Signature); Set_Location (Res); + + -- Skip '[' Scan; + -- List of type_marks. if Current_Token = Tok_Identifier then List := Create_Iir_List; @@ -2866,12 +2870,18 @@ package body Parse is Scan; end loop; end if; + if Current_Token = Tok_Return then + -- Skip 'return' Scan; - Set_Return_Type (Res, Parse_Name); + + Set_Return_Type_Mark (Res, Parse_Name); end if; + + -- Skip ']' Expect (Tok_Right_Bracket); Scan; + return Res; end Parse_Signature; @@ -3313,7 +3323,7 @@ package body Parse is when Tok_Invalid => raise Internal_Error; when Tok_Type => - Decl := Parse_Type_Declaration; + Decl := Parse_Type_Declaration (Parent); -- LRM 2.5 Package declarations -- If a package declarative item is a type declaration that is @@ -3519,7 +3529,10 @@ package body Parse is if Current_Token = Tok_Others then A_Choice := Create_Iir (Iir_Kind_Choice_By_Others); Set_Location (A_Choice); + + -- Skip 'others' Scan; + return A_Choice; else Expr1 := Parse_Expression; @@ -3538,22 +3551,22 @@ package body Parse is if Is_Range_Attribute_Name (Expr1) then A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); Location_Copy (A_Choice, Expr1); - Set_Expression (A_Choice, Expr1); + Set_Choice_Range (A_Choice, Expr1); return A_Choice; elsif Current_Token = Tok_To or else Current_Token = Tok_Downto then A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); Location_Copy (A_Choice, Expr1); - Set_Expression (A_Choice, Parse_Range_Right (Expr1)); + Set_Choice_Range (A_Choice, Parse_Range_Right (Expr1)); return A_Choice; else A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); Location_Copy (A_Choice, Expr1); - Set_Expression (A_Choice, Expr1); + Set_Choice_Expression (A_Choice, Expr1); return A_Choice; end if; end Parse_A_Choice; - -- [ §7.3.2 ] + -- [ LRM93 7.3.2 ] -- choices ::= choice { | choice } -- -- Leave tok_double_arrow as current token. @@ -3677,7 +3690,7 @@ package body Parse is Expr := Parse_Expression; end case; end if; - Set_Associated (Assoc, Expr); + Set_Associated_Expr (Assoc, Expr); Append_Subchain (Last, Res, Assoc); exit when Current_Token = Tok_Right_Paren; Expect (Tok_Comma); @@ -4428,7 +4441,7 @@ package body Parse is Expect (Tok_When, "'when' expected after waveform"); Scan; Assoc := Parse_Choices (Null_Iir); - Set_Associated (Assoc, Wf_Chain); + Set_Associated_Chain (Assoc, Wf_Chain); Append_Subchain (Last, Res, Assoc); exit when Current_Token = Tok_Semi_Colon; Expect (Tok_Comma, "',' (comma) expected after choice"); @@ -5019,7 +5032,7 @@ package body Parse is Expect (Tok_Double_Arrow); Scan; - Set_Associated + Set_Associated_Chain (Assoc, Parse_Sequential_Statements (Stmt)); Append_Subchain (Last_Assoc, Stmt, Assoc); end loop; @@ -847,7 +847,7 @@ package body Sem is Block_Spec := Sem_Index_Specification (Block_Spec, Get_Type (Get_Generation_Scheme (Block))); if Block_Spec /= Null_Iir then - Set_Prefix (Block_Spec, Block); + Set_Prefix (Block_Spec, Block_Name); Set_Block_Specification (Block_Conf, Block_Spec); Block_Spec_Kind := Get_Kind (Block_Spec); end if; @@ -855,7 +855,7 @@ package body Sem is case Block_Spec_Kind is when Iir_Kind_Simple_Name => - Set_Block_Specification (Block_Conf, Block); + Set_Block_Specification (Block_Conf, Block_Name); when Iir_Kind_Indexed_Name | Iir_Kind_Slice_Name => null; @@ -1369,22 +1369,30 @@ package body Sem is when Iir_Kind_Choice_By_None | Iir_Kind_Choice_By_Others => - return Are_Trees_Equal (Get_Associated (Left), - Get_Associated (Right)); + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); when Iir_Kind_Choice_By_Name => - if not Are_Trees_Equal (Get_Name (Left), Get_Name (Right)) then + if not Are_Trees_Equal (Get_Choice_Name (Left), + Get_Choice_Name (Right)) + then + return False; + end if; + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Expression => + if not Are_Trees_Equal (Get_Choice_Expression (Left), + Get_Choice_Expression (Right)) then return False; end if; - return Are_Trees_Equal (Get_Associated (Left), - Get_Associated (Right)); - when Iir_Kind_Choice_By_Expression - | Iir_Kind_Choice_By_Range => - if not Are_Trees_Equal (Get_Expression (Left), - Get_Expression (Right)) then + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); + when Iir_Kind_Choice_By_Range => + if not Are_Trees_Equal (Get_Choice_Range (Left), + Get_Choice_Range (Right)) then return False; end if; - return Are_Trees_Equal (Get_Associated (Left), - Get_Associated (Right)); + return Are_Trees_Equal (Get_Associated_Expr (Left), + Get_Associated_Expr (Right)); when Iir_Kind_Character_Literal => return Are_Trees_Equal (Get_Named_Entity (Left), Get_Named_Entity (Right)); diff --git a/sem_assocs.adb b/sem_assocs.adb index 80fd246..2149007 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -307,14 +307,11 @@ package body Sem_Assocs is Assoc : Iir) return Boolean is - Fmode : Iir_Mode; - Amode : Iir_Mode; + Fmode : constant Iir_Mode := Get_Mode (Formal); + Amode : constant Iir_Mode := Get_Mode (Actual); begin - Fmode := Get_Mode (Formal); - Amode := Get_Mode (Actual); - if Fmode = Iir_Unknown_Mode or Amode = Iir_Unknown_Mode then - raise Internal_Error; - end if; + pragma Assert (Fmode /= Iir_Unknown_Mode); + pragma Assert (Amode /= Iir_Unknown_Mode); if Flags.Vhdl_Std < Vhdl_02 then if Vhdl93_Assocs_Map (Fmode, Amode) then @@ -365,12 +362,14 @@ package body Sem_Assocs is while Choice /= Null_Iir loop case Get_Kind (Choice) is when Iir_Kind_Choice_By_Expression => - if Eval_Pos (Get_Expression (Choice)) = Eval_Pos (Index) then + if Eval_Pos (Get_Choice_Expression (Choice)) + = Eval_Pos (Index) + then goto Found; end if; when Iir_Kind_Choice_By_Range => if Eval_Int_In_Range (Eval_Pos (Index), - Get_Expression (Choice)) + Get_Choice_Range (Choice)) then -- FIXME: overlap. raise Internal_Error; @@ -384,7 +383,7 @@ package body Sem_Assocs is -- If not found, append it. Choice := Create_Iir (Iir_Kind_Choice_By_Expression); - Set_Expression (Choice, Index); + Set_Choice_Expression (Choice, Index); Location_Copy (Choice, Formal); if Last_Choice = Null_Iir then Set_Individual_Association_Chain (Sub_Assoc, Choice); @@ -395,12 +394,12 @@ package body Sem_Assocs is << Found >> null; if I < Nbr - 1 then - Sub_Assoc := Get_Associated (Choice); + Sub_Assoc := Get_Associated_Expr (Choice); if Sub_Assoc = Null_Iir then Sub_Assoc := Create_Iir (Iir_Kind_Association_Element_By_Individual); Location_Copy (Sub_Assoc, Index); - Set_Associated (Choice, Sub_Assoc); + Set_Associated_Expr (Choice, Sub_Assoc); end if; else Sub_Assoc := Choice; @@ -425,7 +424,7 @@ package body Sem_Assocs is Choice := Create_Iir (Iir_Kind_Choice_By_Range); Location_Copy (Choice, Formal); - Set_Expression (Choice, Index); + Set_Choice_Range (Choice, Index); Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); Set_Individual_Association_Chain (Sub_Assoc, Choice); @@ -439,7 +438,7 @@ package body Sem_Assocs is begin Choice := Create_Iir (Iir_Kind_Choice_By_Name); Location_Copy (Choice, Formal); - Set_Name (Choice, Get_Selected_Element (Formal)); + Set_Choice_Name (Choice, Get_Selected_Element (Formal)); Set_Chain (Choice, Get_Individual_Association_Chain (Sub_Assoc)); Set_Individual_Association_Chain (Sub_Assoc, Choice); @@ -468,12 +467,12 @@ package body Sem_Assocs is when Iir_Kind_Association_Element_By_Individual => null; when Iir_Kind_Choice_By_Expression => - Sub := Get_Associated (Iassoc); + Sub := Get_Associated_Expr (Iassoc); if Sub = Null_Iir then Sub := Create_Iir (Iir_Kind_Association_Element_By_Individual); Location_Copy (Sub, Formal); Set_Formal (Sub, Iassoc); - Set_Associated (Iassoc, Sub); + Set_Associated_Expr (Iassoc, Sub); Iassoc := Sub; else case Get_Kind (Sub) is @@ -514,14 +513,14 @@ package body Sem_Assocs is Formal := Get_Formal (Assoc); Iass := Iassoc; Add_Individual_Association_1 (Iass, Formal); - Prev := Get_Associated (Iass); + Prev := Get_Associated_Expr (Iass); if Prev /= Null_Iir then Error_Msg_Sem ("individual association of " & Disp_Node (Get_Association_Interface (Assoc)) & " conflicts with that at " & Disp_Location (Prev), Assoc); else - Set_Associated (Iass, Assoc); + Set_Associated_Expr (Iass, Assoc); end if; end Add_Individual_Association; @@ -545,7 +544,7 @@ package body Sem_Assocs is while El /= Null_Iir loop pragma Assert (Get_Kind (El) = Iir_Kind_Choice_By_Expression); Finish_Individual_Assoc_Array_Subtype - (Get_Associated (El), Atype, Dim + 1); + (Get_Associated_Expr (El), Atype, Dim + 1); El := Get_Chain (El); end loop; end if; @@ -642,7 +641,7 @@ package body Sem_Assocs is Matches := (others => Null_Iir); Ch := Get_Individual_Association_Chain (Assoc); while Ch /= Null_Iir loop - Rec_El := Get_Name (Ch); + Rec_El := Get_Choice_Name (Ch); Pos := Natural (Get_Element_Position (Rec_El)); if Matches (Pos) /= Null_Iir then Error_Msg_Sem ("individual " & Disp_Node (Rec_El) @@ -837,16 +836,15 @@ package body Sem_Assocs is -- return NULL_IIR. function Sem_Formal_Conversion (Assoc : Iir) return Iir is - Formal : Iir; - Assoc_Chain : Iir; + Formal : constant Iir := Get_Formal (Assoc); + Assoc_Chain : constant Iir := Get_Association_Chain (Formal); Res : Iir; Conv : Iir; Name : Iir; Conv_Func : Iir; Conv_Type : Iir; begin - Formal := Get_Formal (Assoc); - Assoc_Chain := Get_Association_Chain (Formal); + -- Nothing to do if the formal isn't a conversion. if not Is_Conversion_Function (Assoc_Chain) then return Null_Iir; end if; @@ -1159,6 +1157,7 @@ package body Sem_Assocs is Res := Create_Iir (Iir_Kind_Function_Call); Location_Copy (Res, Conv); Set_Implementation (Res, Conv); + Set_Prefix (Res, Conv); Set_Base_Name (Res, Res); Set_Parameter_Association_Chain (Res, Null_Iir); Set_Type (Res, Get_Return_Type (Func)); @@ -1179,9 +1178,8 @@ package body Sem_Assocs is return Res; end Extract_Out_Conversion; - -- Associate ASSOC with interface INTERFACE - -- This sets RES. + -- This sets MATCH. procedure Sem_Association (Assoc : Iir; Inter : Iir; @@ -1312,6 +1310,8 @@ package body Sem_Assocs is return; end if; + -- At that point, the analysis is being finished. + if Out_Conv = Null_Iir and then In_Conv = Null_Iir then Res_Type := Formal_Type; else @@ -1519,6 +1519,8 @@ package body Sem_Assocs is if Assoc_1 /= Null_Iir then Inter := Interface_1; Pos := Pos_1; + Free_Parenthesis_Name + (Get_Formal (Assoc), Get_Out_Conversion (Assoc_1)); Set_Formal (Assoc, Get_Formal (Assoc_1)); Set_Out_Conversion (Assoc, Get_Out_Conversion (Assoc_1)); diff --git a/sem_decls.adb b/sem_decls.adb index 8f4a8b7..abc51ea 100644 --- a/sem_decls.adb +++ b/sem_decls.adb @@ -1437,7 +1437,7 @@ package body Sem_Decls is procedure Sem_Subtype_Declaration (Decl: Iir; Is_Global : Boolean) is Def: Iir; - Atype : Iir; + Ind : Iir; begin -- Real hack to skip subtype declarations of anonymous type decls. if Get_Visible_Flag (Decl) then @@ -1447,21 +1447,23 @@ package body Sem_Decls is Sem_Scopes.Add_Name (Decl); Xref_Decl (Decl); - -- Check the definition of the type. - Atype := Get_Subtype_Indication (Decl); - Def := Sem_Subtype_Indication (Atype); - Set_Subtype_Indication (Decl, Def); - Def := Get_Type_Of_Subtype_Indication (Def); + -- Analyze the definition of the type. + Ind := Get_Subtype_Indication (Decl); + Ind := Sem_Subtype_Indication (Ind); + Set_Subtype_Indication (Decl, Ind); + Def := Get_Type_Of_Subtype_Indication (Ind); if Def = Null_Iir then return; end if; if not Is_Anonymous_Type_Definition (Def) then - -- There is no added constraints and therefore the subtype - -- declaration is in fact an alias of the type. + -- There is no added constraints and therefore the subtype + -- declaration is in fact an alias of the type. Create a copy so + -- that it has its own type declarator. Def := Copy_Subtype_Indication (Def); Location_Copy (Def, Decl); - Set_Subtype_Type_Mark (Def, Atype); + Set_Subtype_Type_Mark (Def, Ind); + Set_Subtype_Indication (Decl, Def); end if; Set_Type (Decl, Def); @@ -2028,7 +2030,8 @@ package body Sem_Decls is -- of the subprogram equivalent to the enumeration literal, -- defined in Section 3.1.1 return List = Null_Iir_List - and then Get_Type (N_Entity) = Get_Type (Get_Return_Type (Sig)); + and then Get_Type (N_Entity) + = Get_Type (Get_Return_Type_Mark (Sig)); when Iir_Kind_Function_Declaration | Iir_Kind_Implicit_Function_Declaration => -- LRM93 2.3.2 Signatures @@ -2036,7 +2039,7 @@ package body Sem_Decls is -- a function and the base type of the type mark following -- the reserved word in the signature is the same as the base -- type of the return type of the function, [...] - if Get_Type (Get_Return_Type (Sig)) /= + if Get_Type (Get_Return_Type_Mark (Sig)) /= Get_Base_Type (Get_Return_Type (N_Entity)) then return False; @@ -2046,7 +2049,7 @@ package body Sem_Decls is -- LRM93 2.3.2 Signatures -- * [...] or the reserved word RETURN is absent and the -- subprogram is a procedure. - if Get_Return_Type (Sig) /= Null_Iir then + if Get_Return_Type_Mark (Sig) /= Null_Iir then return False; end if; when others => @@ -2107,10 +2110,10 @@ package body Sem_Decls is Set_Type (El, Get_Base_Type (Get_Type (El))); end loop; end if; - El := Get_Return_Type (Sig); + El := Get_Return_Type_Mark (Sig); if El /= Null_Iir then El := Sem_Type_Mark (El); - Set_Return_Type (Sig, El); + Set_Return_Type_Mark (Sig, El); -- Likewise. Set_Type (El, Get_Base_Type (Get_Type (El))); end if; @@ -2137,6 +2140,15 @@ package body Sem_Decls is end if; end if; end loop; + + -- Free the overload list (with a workaround as only variables can + -- be free). + declare + Name_Ov : Iir; + begin + Name_Ov := Name; + Free_Overload_List (Name_Ov); + end; else if Signature_Match (Name, Sig) then Res := Name; @@ -2420,7 +2432,6 @@ package body Sem_Decls is if Sig /= Null_Iir then Error_Msg_Sem ("signature not allowed for object alias", Sig); end if; - Set_Name (Alias, N_Entity); Sem_Object_Alias_Declaration (Alias); return Alias; else @@ -2952,22 +2963,24 @@ package body Sem_Decls is procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; Staticness : Iir_Staticness) is - It_Type: constant Iir := Get_Discrete_Range (Iterator); + It_Range: constant Iir := Get_Discrete_Range (Iterator); + It_Type : Iir; A_Range: Iir; begin Xref_Decl (Iterator); - A_Range := Sem_Discrete_Range_Integer (It_Type); + A_Range := Sem_Discrete_Range_Integer (It_Range); if A_Range = Null_Iir then - Set_Type (Iterator, Create_Error_Type (It_Type)); + Set_Type (Iterator, Create_Error_Type (It_Range)); return; end if; Set_Discrete_Range (Iterator, A_Range); - Set_Type (Iterator, - Get_Type_Of_Subtype_Indication - (Range_To_Subtype_Indication (A_Range))); + It_Type := Range_To_Subtype_Indication (A_Range); + Set_Subtype_Indication (Iterator, It_Type); + Set_Type (Iterator, Get_Type_Of_Subtype_Indication (It_Type)); + Set_Expr_Staticness (Iterator, Staticness); end Sem_Iterator; end Sem_Decls; diff --git a/sem_decls.ads b/sem_decls.ads index dcc114b..5ff2b8b 100644 --- a/sem_decls.ads +++ b/sem_decls.ads @@ -51,7 +51,8 @@ package Sem_Decls is procedure Sem_Iterator (Iterator : Iir_Iterator_Declaration; Staticness : Iir_Staticness); - -- Extract from NAME the named entity whose profile matches SIG. + -- Extract from NAME the named entity whose profile matches SIG. If NAME + -- is an overload list, it is destroyed. function Sem_Signature (Name : Iir; Sig : Iir_Signature) return Iir; end Sem_Decls; diff --git a/sem_expr.adb b/sem_expr.adb index 42d6580..e84fecc 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -1623,6 +1623,7 @@ package body Sem_Expr is Interpretation : Name_Interpretation_Type; Decl : Iir; Overload_List : Iir_List; + Overload : Iir; Res_Type_List : Iir; Full_Compat : Iir; @@ -1853,7 +1854,8 @@ package body Sem_Expr is else -- Second pass -- Find the uniq implementation for this call. - Overload_List := Get_Overload_List (Get_Implementation (Expr)); + Overload := Get_Implementation (Expr); + Overload_List := Get_Overload_List (Overload); Full_Compat := Null_Iir; for I in Natural loop Decl := Get_Nth_Element (Overload_List, I); @@ -1868,7 +1870,9 @@ package body Sem_Expr is end if; end if; end loop; - Free_Iir (Get_Type (Expr)); + Free_Iir (Overload); + Overload := Get_Type (Expr); + Free_Overload_List (Overload); return Set_Uniq_Interpretation (Full_Compat); end if; end Sem_Operator; @@ -1939,9 +1943,10 @@ package body Sem_Expr is return Natural (Len); end Sem_String_Literal; - procedure Sem_String_Literal (Lit: Iir) is - Lit_Type: Iir; - Lit_Base_Type : Iir; + procedure Sem_String_Literal (Lit: Iir) + is + Lit_Type : constant Iir := Get_Type (Lit); + Lit_Base_Type : constant Iir := Get_Base_Type (Lit_Type); -- The subtype created for the literal. N_Type: Iir; @@ -1950,9 +1955,6 @@ package body Sem_Expr is Len : Natural; El_Type : Iir; begin - Lit_Type := Get_Type (Lit); - Lit_Base_Type := Get_Base_Type (Lit_Type); - El_Type := Get_Base_Type (Get_Element_Subtype (Lit_Base_Type)); Len := Sem_String_Literal (Lit, El_Type); @@ -1975,6 +1977,7 @@ package body Sem_Expr is N_Type := Create_Unidim_Array_By_Length (Lit_Base_Type, Iir_Int64 (Len), Lit); Set_Type (Lit, N_Type); + Set_Literal_Subtype (Lit, N_Type); end if; end Sem_String_Literal; @@ -2061,15 +2064,15 @@ package body Sem_Expr is -- Return true iff OP1 < OP2. function Lt (Op1, Op2 : Natural) return Boolean is begin - return Compare_String_Literals (Get_Expression (Arr (Op1)), - Get_Expression (Arr (Op2))) + return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)), + Get_Choice_Expression (Arr (Op2))) = Compare_Lt; end Lt; function Eq (Op1, Op2 : Natural) return Boolean is begin - return Compare_String_Literals (Get_Expression (Arr (Op1)), - Get_Expression (Arr (Op2))) + return Compare_String_Literals (Get_Choice_Expression (Arr (Op1)), + Get_Choice_Expression (Arr (Op2))) = Compare_Eq; end Eq; @@ -2092,19 +2095,19 @@ package body Sem_Expr is -- In such case, each choice appearing in any of the case statement -- alternative must be a locally static expression whose value is of -- the same length as that of the case expression. - Expr := Sem_Expression (Get_Expression (Choice), Sel_Type); + Expr := Sem_Expression (Get_Choice_Expression (Choice), Sel_Type); if Expr = Null_Iir then Has_Length_Error := True; return; end if; - Set_Expression (Choice, Expr); + Set_Choice_Expression (Choice, Expr); if Get_Expr_Staticness (Expr) < Locally then Error_Msg_Sem ("choice must be locally static expression", Expr); Has_Length_Error := True; return; end if; Expr := Eval_Expr (Expr); - Set_Expression (Choice, Expr); + Set_Choice_Expression (Choice, Expr); if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then Error_Msg_Sem ("bound error during evaluation of choice expression", Expr); @@ -2276,9 +2279,10 @@ package body Sem_Expr is N_Choice := Create_Iir (Iir_Kind_Choice_By_Range); Location_Copy (N_Choice, El); Set_Chain (N_Choice, Get_Chain (El)); - Set_Associated (N_Choice, Get_Associated (El)); + Set_Associated_Expr (N_Choice, Get_Associated_Expr (El)); + Set_Associated_Chain (N_Choice, Get_Associated_Chain (El)); Set_Same_Alternative_Flag (N_Choice, Get_Same_Alternative_Flag (El)); - Set_Expression (N_Choice, Eval_Range_If_Static (Name1)); + Set_Choice_Range (N_Choice, Eval_Range_If_Static (Name1)); Set_Choice_Staticness (N_Choice, Get_Type_Staticness (Range_Type)); Free_Iir (El); @@ -2299,14 +2303,16 @@ package body Sem_Expr is Expr : Iir; Ent : Iir; begin - Expr := Get_Expression (El); if Get_Kind (El) = Iir_Kind_Choice_By_Range then + Expr := Get_Choice_Range (El); Expr := Sem_Discrete_Range_Expression (Expr, Sub_Type, True); if Expr = Null_Iir then return False; end if; Expr := Eval_Range_If_Static (Expr); + Set_Choice_Range (El, Expr); else + Expr := Get_Choice_Expression (El); case Get_Kind (Expr) is when Iir_Kind_Selected_Name | Iir_Kind_Simple_Name @@ -2343,8 +2349,8 @@ package body Sem_Expr is return False; end if; Expr := Eval_Expr_If_Static (Expr); + Set_Choice_Expression (El, Expr); end if; - Set_Expression (El, Expr); Set_Choice_Staticness (El, Get_Expr_Staticness (Expr)); return True; end Sem_Simple_Choice; @@ -2358,17 +2364,24 @@ package body Sem_Expr is is Expr : Iir; begin - Expr := Get_Expression (Assoc); - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - case Get_Direction (Expr) is - when Iir_To => - return Get_Left_Limit (Expr); - when Iir_Downto => - return Get_Right_Limit (Expr); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + case Get_Direction (Expr) is + when Iir_To => + return Get_Left_Limit (Expr); + when Iir_Downto => + return Get_Right_Limit (Expr); + end case; + when others => + return Expr; end case; when others => - return Expr; + Error_Kind ("get_low", Assoc); end case; end Get_Low; @@ -2376,17 +2389,24 @@ package body Sem_Expr is is Expr : Iir; begin - Expr := Get_Expression (Assoc); - case Get_Kind (Expr) is - when Iir_Kind_Range_Expression => - case Get_Direction (Expr) is - when Iir_To => - return Get_Right_Limit (Expr); - when Iir_Downto => - return Get_Left_Limit (Expr); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_Expression => + return Get_Choice_Expression (Assoc); + when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Assoc); + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + case Get_Direction (Expr) is + when Iir_To => + return Get_Right_Limit (Expr); + when Iir_Downto => + return Get_Left_Limit (Expr); + end case; + when others => + return Expr; end case; when others => - return Expr; + Error_Kind ("get_high", Assoc); end case; end Get_High; @@ -2540,22 +2560,25 @@ package body Sem_Expr is Ok : Boolean; Expr : Iir; begin - Expr := Get_Expression (Choice); + Ok := True; if Type_Has_Bounds - and then Get_Expr_Staticness (Expr) = Locally and then Get_Type_Staticness (A_Type) = Locally then if Get_Kind (Choice) = Iir_Kind_Choice_By_Range then - Ok := Eval_Is_Range_In_Bound (Expr, A_Type, True); + Expr := Get_Choice_Range (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_Range_In_Bound (Expr, A_Type, True); + end if; else - Ok := Eval_Is_In_Bound (Expr, A_Type); + Expr := Get_Choice_Expression (Choice); + if Get_Expr_Staticness (Expr) = Locally then + Ok := Eval_Is_In_Bound (Expr, A_Type); + end if; end if; if not Ok then Error_Msg_Sem (Disp_Node (Expr) & " out of index range", Choice); end if; - else - Ok := True; end if; if Ok then Index := Index + 1; @@ -2802,7 +2825,7 @@ package body Sem_Expr is Expr : Iir; Aggr_El : Iir_Element_Declaration; begin - Expr := Get_Expression (Ass); + Expr := Get_Choice_Expression (Ass); if Get_Kind (Expr) /= Iir_Kind_Simple_Name then Error_Msg_Sem ("element association must be a simple name", Ass); Ok := False; @@ -2819,13 +2842,15 @@ package body Sem_Expr is N_El := Create_Iir (Iir_Kind_Choice_By_Name); Location_Copy (N_El, Ass); - Set_Name (N_El, Aggr_El); - Set_Associated (N_El, Get_Associated (Ass)); + Set_Choice_Name (N_El, Aggr_El); + Set_Associated_Expr (N_El, Get_Associated_Expr (Ass)); + Set_Associated_Chain (N_El, Get_Associated_Chain (Ass)); Set_Chain (N_El, Get_Chain (Ass)); Set_Same_Alternative_Flag (N_El, Get_Same_Alternative_Flag (Ass)); Xref_Ref (Expr, Aggr_El); - Free_Old_Iir (Ass); + Free_Iir (Ass); + Free_Iir (Expr); Add_Match (N_El, Aggr_El); return N_El; end Sem_Simple_Choice; @@ -2848,7 +2873,7 @@ package body Sem_Expr is Prev_El := Null_Iir; El := Assoc_Chain; while El /= Null_Iir loop - Expr := Get_Associated (El); + Expr := Get_Associated_Expr (El); -- If there is an associated expression with the choice, then the -- choice is a new alternative, and has no expected type. @@ -2907,7 +2932,7 @@ package body Sem_Expr is if El_Type /= Null_Iir then Expr := Sem_Expression (Expr, El_Type); if Expr /= Null_Iir then - Set_Associated (El, Eval_Expr_If_Static (Expr)); + Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); Value_Staticness := Min (Value_Staticness, Get_Expr_Staticness (Expr)); else @@ -3197,14 +3222,15 @@ package body Sem_Expr is Choice : Iir; begin Choice := Assoc_Chain; - Expr := Get_Expression (Choice); case Get_Kind (Choice) is when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); Set_Direction (Index_Subtype_Constraint, Get_Direction (Index_Constraint)); Set_Left_Limit (Index_Subtype_Constraint, Expr); Set_Right_Limit (Index_Subtype_Constraint, Expr); when Iir_Kind_Choice_By_Range => + Expr := Get_Choice_Range (Choice); Set_Range_Constraint (Info.Index_Subtype, Expr); -- FIXME: avoid allocation-free. Free_Iir (Index_Subtype_Constraint); @@ -3269,7 +3295,7 @@ package body Sem_Expr is El := Assoc_Chain; Value_Staticness := Locally; while El /= Null_Iir loop - Expr := Get_Associated (El); + Expr := Get_Associated_Expr (El); if Expr /= Null_Iir then Expr := Sem_Expression (Expr, Element_Type); if Expr /= Null_Iir then @@ -3277,7 +3303,7 @@ package body Sem_Expr is Set_Expr_Staticness (Aggr, Min (Get_Expr_Staticness (Aggr), Expr_Staticness)); - Set_Associated (El, Eval_Expr_If_Static (Expr)); + Set_Associated_Expr (El, Eval_Expr_If_Static (Expr)); -- FIXME: handle name/others in translate. -- if Get_Kind (Expr) = Iir_Kind_Aggregate then @@ -3303,8 +3329,8 @@ package body Sem_Expr is Choice := Assoc_Chain; Value_Staticness := Locally; while Choice /= Null_Iir loop - if Get_Associated (Choice) /= Null_Iir then - Assoc := Get_Associated (Choice); + if Get_Associated_Expr (Choice) /= Null_Iir then + Assoc := Get_Associated_Expr (Choice); end if; case Get_Kind (Assoc) is when Iir_Kind_Aggregate => @@ -3381,6 +3407,7 @@ package body Sem_Expr is Set_Index_Constraint_Flag (A_Subtype, True); Set_Constraint_State (A_Subtype, Fully_Constrained); Set_Type (Aggr, A_Subtype); + Set_Literal_Subtype (Aggr, A_Subtype); end if; Prev_Info := Null_Iir; diff --git a/sem_names.adb b/sem_names.adb index 113a7cd..17353cd 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -73,16 +73,19 @@ package body Sem_Names is -- Create an overload list. -- must be destroyed with free_iir. - function Get_Overload_List return Iir_Overload_List is + function Get_Overload_List return Iir_Overload_List + is + Res : Iir; begin - return Create_Iir (Iir_Kind_Overload_List); + Res := Create_Iir (Iir_Kind_Overload_List); + return Res; end Get_Overload_List; function Create_Overload_List (List : Iir_List) return Iir_Overload_List is Res : Iir_Overload_List; begin - Res := Create_Iir (Iir_Kind_Overload_List); + Res := Get_Overload_List; Set_Overload_List (Res, List); return Res; end Create_Overload_List; @@ -218,12 +221,16 @@ package body Sem_Names is when Iir_Kind_Function_Call | Iir_Kind_Indexed_Name | Iir_Kind_Selected_Element => - -- FIXME: recursion ? + Sem_Name_Free (Get_Prefix (El)); + Free_Iir (El); + when Iir_Kind_Attribute_Name => Free_Iir (El); when Iir_Kinds_Function_Declaration | Iir_Kinds_Procedure_Declaration | Iir_Kind_Enumeration_Literal => null; + when Iir_Kinds_Denoting_Name => + null; when others => Error_Kind ("sem_name_free", El); end case; @@ -251,6 +258,20 @@ package body Sem_Names is end if; end Sem_Name_Free_Result; + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir) + is + Chain, Next_Chain : Iir; + begin + pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call); + Chain := Get_Association_Chain (Name); + while Chain /= Null_Iir loop + Next_Chain := Get_Chain (Chain); + Free_Iir (Chain); + Chain := Next_Chain; + end loop; + Free_Iir (Name); + end Free_Parenthesis_Name; + -- Find all named declaration whose identifier is ID in DECL_LIST and -- return it. -- The result can be NULL (if no such declaration exist), @@ -576,7 +597,6 @@ package body Sem_Names is Staticness : Iir_Staticness; Prefix_Rng : Iir; begin - -- Set a type to the prefix. Set_Base_Name (Name, Get_Base_Name (Prefix)); -- LRM93 §6.5: the prefix of an indexed name must be appropriate @@ -696,6 +716,7 @@ package body Sem_Names is (Expr_Type, Min (Get_Type_Staticness (Prefix_Type), Get_Type_Staticness (Slice_Type))); Set_Type (Name, Expr_Type); + Set_Slice_Subtype (Name, Expr_Type); Set_Index_Constraint_Flag (Expr_Type, True); Set_Constraint_State (Expr_Type, Fully_Constrained); if Is_Signal_Object (Prefix) then @@ -891,7 +912,8 @@ package body Sem_Names is Set_Expr_Staticness (Attr, Staticness); end Finish_Sem_Array_Attribute; - procedure Finish_Sem_Scalar_Type_Attribute (Attr : Iir; Param : Iir) + procedure Finish_Sem_Scalar_Type_Attribute + (Attr_Name : Iir; Attr : Iir; Param : Iir) is Prefix : Iir; Prefix_Type : Iir; @@ -913,6 +935,7 @@ package body Sem_Names is Prefix := Sem_Type_Mark (Prefix); end if; Set_Prefix (Attr, Prefix); + Free_Iir (Attr_Name); Prefix_Type := Get_Type (Prefix); Prefix_Bt := Get_Base_Type (Prefix_Type); @@ -978,6 +1001,7 @@ package body Sem_Names is Prefix_Name := Get_Prefix (Attr_Name); Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr)); Set_Prefix (Attr, Prefix); + Free_Iir (Attr_Name); if Parameter = Null_Iir then return; @@ -1074,6 +1098,7 @@ package body Sem_Names is function Sem_Type_Conversion (Loc : Iir; Type_Mark : Iir; Actual : Iir) return Iir is + Conv_Type : constant Iir := Get_Type (Type_Mark); Conv: Iir_Type_Conversion; Expr: Iir; Staticness : Iir_Staticness; @@ -1081,7 +1106,7 @@ package body Sem_Names is Conv := Create_Iir (Iir_Kind_Type_Conversion); Location_Copy (Conv, Loc); Set_Type_Mark (Conv, Type_Mark); - Set_Type (Conv, Get_Type (Type_Mark)); + Set_Type (Conv, Conv_Type); Set_Expression (Conv, Actual); -- Default staticness in case of error. @@ -1128,12 +1153,25 @@ package body Sem_Names is -- expression. if Expr /= Null_Iir then Staticness := Get_Expr_Staticness (Expr); + + -- If the type mark is not locally static, the expression cannot + -- be locally static. This was clarified in VHDL 08, but a type + -- mark that denotes an unconstrained array type, does not prevent + -- the expression from being static. + if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition + or else Get_Constraint_State (Conv_Type) = Fully_Constrained + then + Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type)); + end if; + + -- LRM87 7.4 Static Expressions + -- A type conversion is not a locally static expression. if Flags.Vhdl_Std = Vhdl_87 then Staticness := Min (Globally, Staticness); end if; Set_Expr_Staticness (Conv, Staticness); - if not Are_Types_Closely_Related (Get_Type (Conv), Get_Type (Expr)) + if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr)) then -- FIXME: should explain why the types are not closely related. Error_Msg_Sem @@ -1380,7 +1418,7 @@ package body Sem_Names is when Iir_Kind_Type_Conversion => pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name); Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name))); - -- FIXME: free name + Free_Parenthesis_Name (Name, Res); return Res; when Iir_Kind_Indexed_Name | Iir_Kind_Selected_Element @@ -1400,7 +1438,7 @@ package body Sem_Names is Prefix := Finish_Sem_Name (Get_Prefix (Name), Get_Implementation (Res)); Finish_Sem_Function_Call (Res, Prefix); - -- FIXME: free name + Free_Iir (Name); when Iir_Kinds_Denoting_Name => Prefix := Finish_Sem_Name (Name, Get_Implementation (Res)); Finish_Sem_Function_Call (Res, Prefix); @@ -1412,12 +1450,20 @@ package body Sem_Names is if Get_Parameter (Res) = Null_Iir then Finish_Sem_Array_Attribute (Name, Res, Null_Iir); end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Res); + end if; return Res; when Iir_Kinds_Scalar_Type_Attribute | Iir_Kind_Image_Attribute | Iir_Kind_Value_Attribute => if Get_Parameter (Res) = Null_Iir then - Finish_Sem_Scalar_Type_Attribute (Res, Null_Iir); + Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); end if; return Res; when Iir_Kinds_Signal_Value_Attribute => @@ -1425,15 +1471,19 @@ package body Sem_Names is when Iir_Kinds_Signal_Attribute => if Get_Parameter (Res) = Null_Iir then Finish_Sem_Signal_Attribute (Name, Res, Null_Iir); + else + Free_Parenthesis_Name (Name, Res); end if; return Res; when Iir_Kinds_Type_Attribute => + Free_Iir (Name); return Res; when Iir_Kind_Base_Attribute => return Res; when Iir_Kind_Simple_Name_Attribute | Iir_Kind_Path_Name_Attribute | Iir_Kind_Instance_Name_Attribute => + Free_Iir (Name); return Res; when Iir_Kind_Psl_Expression => return Res; @@ -1456,17 +1506,22 @@ package body Sem_Names is case Get_Kind (Res) is when Iir_Kind_Indexed_Name => Finish_Sem_Indexed_Name (Res); + Free_Parenthesis_Name (Name, Res); when Iir_Kind_Slice_Name => Finish_Sem_Slice_Name (Res); + Free_Parenthesis_Name (Name, Res); when Iir_Kind_Selected_Element => Xref_Ref (Res, Get_Selected_Element (Res)); Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); Set_Base_Name (Res, Get_Base_Name (Prefix)); + Free_Iir (Name); when Iir_Kind_Dereference => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name); Finish_Sem_Dereference (Res); + Free_Iir (Name); when Iir_Kinds_Signal_Value_Attribute => - null; + Sem_Name_Free_Result (Name, Res); when others => Error_Kind ("finish_sem_name(2)", Res); end case; @@ -1995,6 +2050,7 @@ package body Sem_Names is when others => raise Internal_Error; end case; + Free_Parenthesis_Name (Name, Res); return Res; end Sem_Index_Specification; @@ -2038,8 +2094,7 @@ package body Sem_Names is -- Extract type of prefix, handle possible implicit deference. Base_Type := Get_Base_Type (Get_Type (Sub_Name)); - if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition - then + if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then Ptr_Type := Base_Type; Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type)); else @@ -2267,7 +2322,7 @@ package body Sem_Names is Add_Result (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True)); elsif Actual /= Null_Iir then - Finish_Sem_Scalar_Type_Attribute (Prefix, Actual); + Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual); Set_Named_Entity (Name, Prefix); return; else @@ -2445,7 +2500,7 @@ package body Sem_Names is -- attributes 'simple_name, 'path_name, or 'instance_name. if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then -- GHDL: according to 4.3.3, the name cannot be an alias. - Prefix := Get_Name (Prefix); + Prefix := Strip_Denoting_Name (Get_Name (Prefix)); end if; -- LRM93 6.6 @@ -2746,7 +2801,7 @@ package body Sem_Names is when Iir_Kind_Range_Array_Attribute | Iir_Kind_Reverse_Range_Array_Attribute => -- For names such as pfx'Range'Left. - Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir); + -- Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir); Prefix_Type := Get_Type (Prefix); when Iir_Kind_Process_Statement => Error_Msg_Sem @@ -2775,7 +2830,12 @@ package body Sem_Names is return Error_Mark; end case; - Res_Type := Prefix_Type; + -- Type of the attribute. This is correct unless there is a parameter, + -- and furthermore 'range and 'reverse_range has to be handled + -- specially because the result is a range and not a value. + Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0); + + -- Create the node for the attribute. case Get_Identifier (Attr) is when Name_Left => Res := Create_Iir (Iir_Kind_Left_Array_Attribute); @@ -3032,6 +3092,7 @@ package body Sem_Names is Prefix_Name : constant Iir := Get_Prefix (Attr); Prefix: Iir; Res : Iir; + Attr_Type : Iir; begin Prefix := Get_Named_Entity (Prefix_Name); Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix)); @@ -3088,21 +3149,22 @@ package body Sem_Names is Res := Create_Iir (Iir_Kind_Simple_Name_Attribute); Eval_Simple_Name (Get_Identifier (Prefix)); Set_Simple_Name_Identifier (Res, Name_Table.Get_Identifier); - Set_Type (Res, Create_Unidim_Array_By_Length - (String_Type_Definition, - Iir_Int64 (Name_Table.Name_Length), - Attr)); + Attr_Type := Create_Unidim_Array_By_Length + (String_Type_Definition, + Iir_Int64 (Name_Table.Name_Length), + Attr); + Set_Simple_Name_Subtype (Res, Attr_Type); Set_Expr_Staticness (Res, Locally); when Name_Path_Name => Res := Create_Iir (Iir_Kind_Path_Name_Attribute); Set_Expr_Staticness (Res, Globally); - Set_Type (Res, String_Type_Definition); + Attr_Type := String_Type_Definition; when Name_Instance_Name => Res := Create_Iir (Iir_Kind_Instance_Name_Attribute); Set_Expr_Staticness (Res, Globally); - Set_Type (Res, String_Type_Definition); + Attr_Type := String_Type_Definition; when others => raise Internal_Error; @@ -3110,6 +3172,7 @@ package body Sem_Names is Location_Copy (Res, Attr); Set_Prefix (Res, Prefix_Name); + Set_Type (Res, Attr_Type); return Res; end Sem_Name_Attribute; @@ -3441,10 +3504,17 @@ package body Sem_Names is Disp_Overload_List (Get_Overload_List (Res), Name); return Null_Iir; else + -- Free results Sem_Name_Free_Result (Expr, Res); + + Ret_Type := Get_Type (Name); + if Ret_Type /= Null_Iir then + pragma Assert (Is_Overload_List (Ret_Type)); + Free_Overload_List (Ret_Type); + end if; + Set_Named_Entity (Name, Res); Res := Finish_Sem_Name (Name); - Expr := Get_Named_Entity (Name); -- Fall through. end if; else @@ -3463,7 +3533,7 @@ package body Sem_Names is end if; end if; - -- NAME has only one meaning, which is EXPR. + -- NAME has only one meaning, which is RES. case Get_Kind (Res) is when Iir_Kind_Simple_Name | Iir_Kind_Character_Literal @@ -3548,6 +3618,12 @@ package body Sem_Names is if Get_Parameter (Expr) = Null_Iir then Finish_Sem_Array_Attribute (Name, Expr, Null_Iir); end if; + if Get_Kind (Name) = Iir_Kind_Attribute_Name then + Free_Iir (Name); + else + Free_Iir (Get_Prefix (Name)); + Free_Parenthesis_Name (Name, Expr); + end if; return Expr; when others => Error_Msg_Sem ("name " & Disp_Node (Name) @@ -3556,8 +3632,7 @@ package body Sem_Names is end case; end Name_To_Range; - function Is_Object_Name (Name : Iir) return Boolean - is + function Is_Object_Name (Name : Iir) return Boolean is begin case Get_Kind (Name) is when Iir_Kind_Object_Alias_Declaration @@ -3588,8 +3663,7 @@ package body Sem_Names is end case; end Is_Object_Name; - function Name_To_Object (Name : Iir) return Iir - is + function Name_To_Object (Name : Iir) return Iir is begin case Get_Kind (Name) is when Iir_Kind_Object_Alias_Declaration diff --git a/sem_names.ads b/sem_names.ads index a777741..3bc8530 100644 --- a/sem_names.ads +++ b/sem_names.ads @@ -111,7 +111,6 @@ package Sem_Names is -- Free the list node (and the list itself). procedure Free_Overload_List (N : in out Iir_Overload_List); - pragma Unreferenced (Free_Overload_List); -- Display an error message if the overload resolution for EXPR find more -- than one interpretation. @@ -128,6 +127,10 @@ package Sem_Names is -- Before the first call, RES should be set to NULL_IIR. procedure Add_Result (Res : in out Iir; Decl : Iir); + -- Free a Parenthesis_Name. This is a special case as in general the + -- Association_Chain field must be freed too. + procedure Free_Parenthesis_Name (Name : Iir; Res : Iir); + -- Return TRUE iff TYPE1 and TYPE2 are closely related. function Are_Types_Closely_Related (Type1, Type2 : Iir) return Boolean; diff --git a/sem_specs.adb b/sem_specs.adb index 5100716..ed41875 100644 --- a/sem_specs.adb +++ b/sem_specs.adb @@ -359,7 +359,9 @@ package body Sem_Specs is begin Applied := Sem_Named_Entity1 (Ent, Base); -- FIXME: check the alias denotes a local entity... - if Applied and then Base /= Decl then + if Applied + and then Base /= Strip_Denoting_Name (Decl) + then Error_Msg_Sem (Disp_Node (Ent) & " does not denote the entire object", Attr); @@ -442,7 +444,7 @@ package body Sem_Specs is begin El1 := Get_Case_Statement_Alternative_Chain (El); while El1 /= Null_Iir loop - Sem_Named_Entity_Chain (Get_Associated (El1)); + Sem_Named_Entity_Chain (Get_Associated_Chain (El1)); El1 := Get_Chain (El1); end loop; end; @@ -574,7 +576,6 @@ package body Sem_Specs is Prefix : Iir; Inter : Name_Interpretation_Type; List : Iir_List; - Ov_List : Iir_Overload_List; Name : Iir; begin List := Create_Iir_List; @@ -606,10 +607,7 @@ package body Sem_Specs is Inter := Get_Next_Interpretation (Inter); end loop; - Ov_List := Create_Overload_List (List); - Name := Sem_Decls.Sem_Signature (Ov_List, Sig); - Destroy_Iir_List (List); - Free_Iir (Ov_List); + Name := Sem_Decls.Sem_Signature (Create_Overload_List (List), Sig); if Name = Null_Iir then return; end if; diff --git a/sem_stmts.adb b/sem_stmts.adb index b4d84f0..d707992 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -37,7 +37,7 @@ package body Sem_Stmts is -- be created. -- Note: FIRST_STMT is the first statement, which can be get by: -- get_sequential_statement_chain (usual) - -- get_associated (for case statement). + -- get_associated_chain (for case statement). procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir); -- Access to the current subprogram or process. @@ -137,7 +137,7 @@ package body Sem_Stmts is begin El := Get_Case_Statement_Alternative_Chain (Stmt); while El /= Null_Iir loop - Sem_Sequential_Labels (Get_Associated (El)); + Sem_Sequential_Labels (Get_Associated_Chain (El)); El := Get_Chain (El); end loop; end; @@ -156,7 +156,7 @@ package body Sem_Stmts is begin El := Chain; while El /= Null_Iir loop - Ass := Get_Associated (El); + Ass := Get_Associated_Expr (El); if Get_Kind (Ass) = Iir_Kind_Aggregate then Fill_Array_From_Aggregate_Associated (Get_Association_Choices_Chain (Ass), Nbr, Arr); @@ -308,7 +308,7 @@ package body Sem_Stmts is -- LRM93 9.4 -- Such a target may not only contain locally static signal -- names [...] - Ass := Get_Associated (Choice); + Ass := Get_Associated_Expr (Choice); if Get_Kind (Ass) = Iir_Kind_Aggregate then Check_Aggregate_Target (Stmt, Ass, Nbr); else @@ -565,8 +565,17 @@ package body Sem_Stmts is -- in ascending order with repect to time. -- GHDL: this must be checked at run-time, but this is also -- checked now for static expressions. - Expr := Eval_Static_Expr (Expr); - Time := Get_Value (Expr); + if Get_Expr_Staticness (Expr) = Locally then + -- The expression is static, and therefore may be + -- evaluated. + Expr := Eval_Expr (Expr); + Set_Time (We, Expr); + Time := Get_Value (Expr); + else + -- The expression is a physical literal (common case). + -- Extract its value. + Time := Get_Physical_Value (Expr); + end if; if Time < 0 then Error_Msg_Sem ("waveform time expression must be >= 0", Expr); @@ -978,7 +987,7 @@ package body Sem_Stmts is -- Sem on associated. El := Chain; while El /= Null_Iir loop - Sem_Sequential_Statements_Internal (Get_Associated (El)); + Sem_Sequential_Statements_Internal (Get_Associated_Chain (El)); El := Get_Chain (El); end loop; end Sem_Case_Statement; @@ -1698,7 +1707,7 @@ package body Sem_Stmts is El := Chain; while El /= Null_Iir loop - Assoc_El := Get_Associated (El); + Assoc_El := Get_Associated_Expr (El); exit when Assoc_El /= Null_Iir; El := Get_Chain (El); end loop; @@ -1725,8 +1734,9 @@ package body Sem_Stmts is if Waveform_Type /= Null_Iir then El := Chain; while El /= Null_Iir loop - Sem_Waveform_Chain (Stmt, Get_Associated (El), Waveform_Type); - Sem_Check_Waveform_Chain (Stmt, Get_Associated (El)); + Sem_Waveform_Chain + (Stmt, Get_Associated_Chain (El), Waveform_Type); + Sem_Check_Waveform_Chain (Stmt, Get_Associated_Chain (El)); El := Get_Chain (El); end loop; end if; diff --git a/sem_types.adb b/sem_types.adb index 7a2cb68..8c4c5a4 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -373,6 +373,9 @@ package body Sem_Types is Set_Range_Constraint (Sub_Type, Phys_Range); -- This must be locally... Set_Type_Staticness (Sub_Type, Get_Expr_Staticness (Range_Expr1)); + + -- FIXME: the original range is not used. Reuse it ? + Free_Iir (Range_Expr); end; end if; Set_Resolved_Flag (Sub_Type, False); diff --git a/simulate/annotations.adb b/simulate/annotations.adb index 4377ffd..d07a998 100644 --- a/simulate/annotations.adb +++ b/simulate/annotations.adb @@ -761,7 +761,7 @@ package body Annotations is Assoc := Get_Case_Statement_Alternative_Chain (El); loop Annotate_Sequential_Statement_Chain - (Block_Info, Get_Associated (Assoc)); + (Block_Info, Get_Associated_Chain (Assoc)); Assoc := Get_Chain (Assoc); exit when Assoc = Null_Iir; Save_Nbr_Objects; diff --git a/simulate/elaboration.adb b/simulate/elaboration.adb index 391798f..0abe811 100644 --- a/simulate/elaboration.adb +++ b/simulate/elaboration.adb @@ -633,10 +633,9 @@ package body Elaboration is return Iir_Value_Literal_Acc is Value : Iir_Value_Literal_Acc; - Ref : Iir; + Ref : constant Iir := Get_Type (Bound); Res : Iir_Value_Literal_Acc; begin - Ref := Get_Type (Bound); Res := Create_Value_For_Type (Instance, Ref, False); Res := Unshare (Res, Instance_Pool); Value := Execute_Expression (Instance, Bound); @@ -647,10 +646,9 @@ package body Elaboration is procedure Elaborate_Range_Expression (Instance : Block_Instance_Acc; Rc: Iir_Range_Expression) is - Range_Info : Sim_Info_Acc; + Range_Info : constant Sim_Info_Acc := Get_Info (Rc); Val : Iir_Value_Literal_Acc; begin - Range_Info := Get_Info (Rc); if Range_Info.Scope_Level /= Instance.Scope_Level or else Instance.Objects (Range_Info.Slot) /= null then @@ -1850,6 +1848,9 @@ package body Elaboration is Item := Conf_Chain; while Item /= Null_Iir loop Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; Prev_Item := Get_Prev_Block_Configuration (Item); case Get_Kind (Spec) is @@ -1923,12 +1924,15 @@ package body Elaboration is Info : Sim_Info_Acc; begin Spec := Get_Block_Specification (Item); + if Get_Kind (Spec) = Iir_Kind_Simple_Name then + Spec := Get_Named_Entity (Spec); + end if; case Get_Kind (Spec) is when Iir_Kind_Slice_Name | Iir_Kind_Indexed_Name | Iir_Kind_Selected_Name => -- Block configuration for a generate statement. - Gen := Get_Prefix (Spec); + Gen := Get_Named_Entity (Get_Prefix (Spec)); Info := Get_Info (Gen); Set_Prev_Block_Configuration (Item, Sub_Conf (Info.Inst_Slot)); @@ -2180,7 +2184,9 @@ package body Elaboration is case Get_Kind (Decl) is when Iir_Kind_Function_Declaration | Iir_Kind_Procedure_Declaration => - Elaborate_Subprogram_Declaration (Instance, Decl); + if not Is_Second_Subprogram_Specification (Decl) then + Elaborate_Subprogram_Declaration (Instance, Decl); + end if; when Iir_Kind_Implicit_Function_Declaration | Iir_Kind_Implicit_Procedure_Declaration => null; diff --git a/simulate/execution.adb b/simulate/execution.adb index 304f3bb..ef4cccc 100644 --- a/simulate/execution.adb +++ b/simulate/execution.adb @@ -1801,7 +1801,7 @@ package body Execution is Assoc := Get_Association_Choices_Chain (Aggregate); Pos := 0; while Assoc /= Null_Iir loop - Value := Get_Associated (Assoc); + Value := Get_Associated_Expr (Assoc); loop case Get_Kind (Assoc) is when Iir_Kind_Choice_By_None => @@ -1811,9 +1811,9 @@ package body Execution is Set_Elem (Pos); Pos := Pos + 1; when Iir_Kind_Choice_By_Expression => - Set_Elem_By_Expr (Get_Expression (Assoc)); + Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); when Iir_Kind_Choice_By_Range => - Set_Elem_By_Range (Get_Expression (Assoc)); + Set_Elem_By_Range (Get_Choice_Range (Assoc)); when Iir_Kind_Choice_By_Others => for J in 1 .. Length loop if Res.Val_Array.V (Orig + J * Step) = null then @@ -1884,7 +1884,7 @@ package body Execution is Assoc := Get_Association_Choices_Chain (Aggregate); Pos := 1; loop - N_Expr := Get_Associated (Assoc); + N_Expr := Get_Associated_Expr (Assoc); if N_Expr /= Null_Iir then Expr := N_Expr; end if; @@ -1893,7 +1893,7 @@ package body Execution is Set_Expr (Pos); Pos := Pos + 1; when Iir_Kind_Choice_By_Name => - Set_Expr (1 + Get_Element_Position (Get_Name (Assoc))); + Set_Expr (1 + Get_Element_Position (Get_Choice_Name (Assoc))); when Iir_Kind_Choice_By_Others => for I in Res.Val_Record.V'Range loop if Res.Val_Record.V (I) = null then @@ -1993,7 +1993,7 @@ package body Execution is Bound := Res.Bounds.D (Dim); Pos := 0; while Assoc /= Null_Iir loop - Value := Get_Associated (Assoc); + Value := Get_Associated_Expr (Assoc); case Get_Kind (Assoc) is when Iir_Kind_Choice_By_None => null; @@ -2033,7 +2033,7 @@ package body Execution is Assoc := Get_Association_Choices_Chain (Aggregate); Pos := 0; loop - Expr := Get_Associated (Assoc); + Expr := Get_Associated_Expr (Assoc); if Expr = Null_Iir then -- List of choices is not allowed. raise Internal_Error; @@ -4216,7 +4216,8 @@ package body Execution is declare Expr1: Iir_Value_Literal_Acc; begin - Expr1 := Execute_Expression (Instance, Get_Expression (Choice)); + Expr1 := Execute_Expression + (Instance, Get_Choice_Expression (Choice)); Res := Is_Equal (Expr, Expr1); return Res; end; @@ -4225,7 +4226,7 @@ package body Execution is A_Range : Iir_Value_Literal_Acc; begin A_Range := Execute_Bounds - (Instance, Get_Expression (Choice)); + (Instance, Get_Choice_Range (Choice)); Res := Is_In_Range (Expr, A_Range); end; return Res; @@ -4514,7 +4515,7 @@ package body Execution is while Assoc /= Null_Iir loop if not Get_Same_Alternative_Flag (Assoc) then - Stmt_Chain := Get_Associated (Assoc); + Stmt_Chain := Get_Associated_Chain (Assoc); end if; if Is_In_Choice (Instance, Assoc, Value) then diff --git a/simulate/grt_interface.ads b/simulate/grt_interface.ads index 1098024..05f7abb 100644 --- a/simulate/grt_interface.ads +++ b/simulate/grt_interface.ads @@ -16,17 +16,10 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with System; -with Ada.Unchecked_Conversion; with Grt.Types; use Grt.Types; with Iir_Values; use Iir_Values; package Grt_Interface is - function To_Std_String_Basep is new Ada.Unchecked_Conversion - (System.Address, Std_String_Basep); - function To_Std_String_Boundp is new Ada.Unchecked_Conversion - (System.Address, Std_String_Boundp); - procedure Set_Std_String_From_Iir_Value (Str : Std_String; Val : Iir_Value_Literal_Acc); diff --git a/simulate/simulation.adb b/simulate/simulation.adb index d951324..3f3f871 100644 --- a/simulate/simulation.adb +++ b/simulate/simulation.adb @@ -1246,7 +1246,7 @@ package body Simulation is is pragma Unreferenced (Formal_Instance); Formal : constant Iir := Get_Formal (Assoc); - Inter : constant Iir := Get_Base_Name (Formal); + Inter : constant Iir := Get_Association_Interface (Assoc); begin if False and Trace_Elaboration then Put ("connect formal "); diff --git a/std_package.adb b/std_package.adb index 153c84b..5fedc8b 100644 --- a/std_package.adb +++ b/std_package.adb @@ -245,7 +245,7 @@ package body Std_Package is Set_Has_Signal_Flag (Subtype_Definition, not Flags.Flag_Whole_Analyze); - -- type is + -- subtype is Subtype_Decl := Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Subtype_Decl, Get_Identifier (Type_Decl)); Set_Type (Subtype_Decl, Subtype_Definition); @@ -730,7 +730,7 @@ package body Std_Package is Lit: Iir_Physical_Int_Literal; Mul_Name : Iir; begin - Unit := Create_Std_Iir (Iir_Kind_Unit_Declaration); + Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration); Set_Std_Identifier (Unit, Name); Set_Type (Unit, Time_Type_Definition); @@ -777,7 +777,7 @@ package body Std_Package is Build_Init (Last_Unit); - Time_Fs_Unit := Create_Std_Iir (Iir_Kind_Unit_Declaration); + Time_Fs_Unit := Create_Std_Decl (Iir_Kind_Unit_Declaration); Set_Std_Identifier (Time_Fs_Unit, Name_Fs); Set_Type (Time_Fs_Unit, Time_Type_Definition); Set_Expr_Staticness (Time_Fs_Unit, Time_Staticness); @@ -823,7 +823,7 @@ package body Std_Package is Set_Has_Signal_Flag (Time_Subtype_Definition, not Flags.Flag_Whole_Analyze); - -- subtype + -- subtype time is Time_Subtype_Declaration := Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Time_Subtype_Declaration, Name_Time); @@ -878,6 +878,7 @@ package body Std_Package is Set_Has_Signal_Flag (Delay_Length_Subtype_Definition, not Flags.Flag_Whole_Analyze); + -- subtype delay_length is ... Delay_Length_Subtype_Declaration := Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Delay_Length_Subtype_Declaration, @@ -886,6 +887,8 @@ package body Std_Package is Delay_Length_Subtype_Definition); Set_Type_Declarator (Delay_Length_Subtype_Definition, Delay_Length_Subtype_Declaration); + Set_Subtype_Indication (Delay_Length_Subtype_Declaration, + Delay_Length_Subtype_Definition); Add_Decl (Delay_Length_Subtype_Declaration); else Delay_Length_Subtype_Definition := Null_Iir; @@ -925,6 +928,9 @@ package body Std_Package is Natural_Subtype_Definition := Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition); Set_Base_Type (Natural_Subtype_Definition, Integer_Type_Definition); + Set_Subtype_Type_Mark + (Natural_Subtype_Definition, + Create_Std_Type_Mark (Integer_Subtype_Declaration)); Constraint := Create_Std_Range_Expr (Create_Std_Integer (0, Integer_Type_Definition), Create_Std_Integer (High_Bound (Flags.Flag_Integer_64), @@ -940,6 +946,8 @@ package body Std_Package is Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Natural_Subtype_Declaration, Name_Natural); Set_Type (Natural_Subtype_Declaration, Natural_Subtype_Definition); + Set_Subtype_Indication (Natural_Subtype_Declaration, + Natural_Subtype_Definition); Add_Decl (Natural_Subtype_Declaration); Set_Type_Declarator (Natural_Subtype_Definition, Natural_Subtype_Declaration); @@ -953,6 +961,9 @@ package body Std_Package is Create_Std_Iir (Iir_Kind_Integer_Subtype_Definition); Set_Base_Type (Positive_Subtype_Definition, Integer_Type_Definition); + Set_Subtype_Type_Mark + (Positive_Subtype_Definition, + Create_Std_Type_Mark (Integer_Subtype_Declaration)); Constraint := Create_Std_Range_Expr (Create_Std_Integer (1, Integer_Type_Definition), Create_Std_Integer (High_Bound (Flags.Flag_Integer_64), @@ -968,6 +979,8 @@ package body Std_Package is Create_Std_Decl (Iir_Kind_Subtype_Declaration); Set_Std_Identifier (Positive_Subtype_Declaration, Name_Positive); Set_Type (Positive_Subtype_Declaration, Positive_Subtype_Definition); + Set_Subtype_Indication (Positive_Subtype_Declaration, + Positive_Subtype_Definition); Add_Decl (Positive_Subtype_Declaration); Set_Type_Declarator (Positive_Subtype_Definition, Positive_Subtype_Declaration); diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh index ceef80d..d7a4970 100644 --- a/translate/gcc/dist-common.sh +++ b/translate/gcc/dist-common.sh @@ -39,6 +39,8 @@ configuration.adb configuration.ads nodes.ads nodes.adb +nodes_gc.ads +nodes_gc.adb options.ads options.adb psl-errors.ads diff --git a/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb index 1d72394..ba755af 100644 --- a/translate/ghdldrv/ghdlcomp.adb +++ b/translate/ghdldrv/ghdlcomp.adb @@ -24,6 +24,7 @@ with Ada.Text_IO; with Types; with Iirs; use Iirs; +with Nodes_GC; with Flags; with Back_End; with Sem; @@ -39,6 +40,9 @@ package body Ghdlcomp is Flag_Expect_Failure : Boolean := False; + Flag_Debug_Nodes_Leak : Boolean := False; + -- If True, detect unreferenced nodes at the end of analysis. + -- Commands which use the mcode compiler. type Command_Comp is abstract new Command_Lib with null record; procedure Decode_Option (Cmd : in out Command_Comp; @@ -56,6 +60,9 @@ package body Ghdlcomp is if Option = "--expect-failure" then Flag_Expect_Failure := True; Res := Option_Ok; + elsif Option = "--debug-nodes-leak" then + Flag_Debug_Nodes_Leak := True; + Res := Option_Ok; elsif Hooks.Decode_Option.all (Option) then Res := Option_Ok; else @@ -318,6 +325,8 @@ package body Ghdlcomp is raise Compilation_Error; end if; + Free_Iir (Design_File); + -- Do late analysis checks. Unit := Get_First_Design_Unit (New_Design_File); while Unit /= Null_Iir loop @@ -335,7 +344,12 @@ package body Ghdlcomp is raise Compilation_Error; end if; + if Flag_Debug_Nodes_Leak then + Nodes_GC.Report_Unreferenced; + end if; + Libraries.Save_Work_Library; + exception when Compilation_Error => if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then diff --git a/translate/ghdldrv/ghdldrv.adb b/translate/ghdldrv/ghdldrv.adb index 72500ef..50fd6d7 100644 --- a/translate/ghdldrv/ghdldrv.adb +++ b/translate/ghdldrv/ghdldrv.adb @@ -113,6 +113,9 @@ package body Ghdldrv is elsif Status = 1 then Error ("compilation error"); raise Compile_Error; + elsif Status > 127 then + Error ("executable killed by a signal"); + raise Exec_Error; else Error ("exec error"); raise Exec_Error; diff --git a/translate/translation.adb b/translate/translation.adb index a68c787..fda2c2f 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -4443,6 +4443,7 @@ package body Translation is Type_Info := Get_Info (Get_Base_Type (Iter_Type)); case Get_Kind (Spec) is when Iir_Kind_Generate_Statement + | Iir_Kind_Simple_Name | Iir_Kind_Selected_Name => -- Apply for all/remaining blocks. declare @@ -4618,6 +4619,9 @@ package body Translation is Block_Info : Block_Info_Acc; begin Block := Get_Block_Specification (El); + if Get_Kind (Block) = Iir_Kind_Simple_Name then + Block := Get_Named_Entity (Block); + end if; if Get_Kind (Block) = Iir_Kind_Block_Statement then Block_Info := Get_Info (Block); Push_Scope (Block_Info.Block_Decls_Type, @@ -12190,7 +12194,7 @@ package body Translation is | Iir_Kind_Choice_By_Name => El := Assoc; while El /= Null_Iir loop - if Inherit_Collapse_Flag (Get_Associated (Assoc)) = False + if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc)) then return False; end if; @@ -13563,7 +13567,7 @@ package body Translation is when Iir_Kind_Aggregate => Assoc := Get_Association_Choices_Chain (Aggr); while Assoc /= Null_Iir loop - Sub := Get_Associated (Assoc); + Sub := Get_Associated_Expr (Assoc); case Get_Kind (Assoc) is when Iir_Kind_Choice_By_None => if N_Info = Null_Iir then @@ -15781,7 +15785,7 @@ package body Translation is if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then return Null_Iir; end if; - Aggr1 := Get_Associated (Chain); + Aggr1 := Get_Associated_Expr (Chain); case Get_Kind (Aggr1) is when Iir_Kind_Aggregate => if Get_Type (Aggr1) /= Null_Iir then @@ -15967,7 +15971,7 @@ package body Translation is return; end if; exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; - Do_Assign (Get_Associated (El)); + Do_Assign (Get_Associated_Expr (El)); P := P + 1; El := Get_Chain (El); end loop; @@ -15980,7 +15984,7 @@ package body Translation is -- falltrough... null; when Iir_Kind_Choice_By_Expression => - Do_Assign (Get_Associated (El)); + Do_Assign (Get_Associated_Expr (El)); return; when Iir_Kind_Choice_By_Range => declare @@ -15991,7 +15995,7 @@ package body Translation is Open_Temp; Var_Length := Create_Temp_Init (Ghdl_Index_Type, - Chap7.Translate_Range_Length (Get_Expression (El))); + Chap7.Translate_Range_Length (Get_Choice_Range (El))); Var_I := Create_Temp (Ghdl_Index_Type); Init_Var (Var_I); Start_Loop_Stmt (Label); @@ -16000,7 +16004,7 @@ package body Translation is New_Obj_Value (Var_I), New_Obj_Value (Var_Length), Ghdl_Bool_Type)); - Do_Assign (Get_Associated (El)); + Do_Assign (Get_Associated_Expr (El)); Inc_Var (Var_I); Finish_Loop_Stmt (Label); Close_Temp; @@ -16077,8 +16081,8 @@ package body Translation is while El /= Null_Iir loop Start_Choice (Case_Blk); Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); - if Get_Associated (El) /= Null_Iir then - El_Assoc := Get_Associated (El); + if Get_Associated_Expr (El) /= Null_Iir then + El_Assoc := Get_Associated_Expr (El); end if; Finish_Choice (Case_Blk); Do_Assign (El_Assoc); @@ -16145,7 +16149,7 @@ package body Translation is El_Index := 0; Assoc := Get_Association_Choices_Chain (Aggr); while Assoc /= Null_Iir loop - N_El_Expr := Get_Associated (Assoc); + N_El_Expr := Get_Associated_Expr (Assoc); if N_El_Expr /= Null_Iir then El_Expr := N_El_Expr; end if; @@ -16154,7 +16158,7 @@ package body Translation is Set_El (Get_Nth_Element (El_List, El_Index)); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => - Set_El (Get_Name (Assoc)); + Set_El (Get_Choice_Name (Assoc)); El_Index := Natural'Last; when Iir_Kind_Choice_By_Others => for J in Set_Array'Range loop @@ -19679,7 +19683,7 @@ package body Translation is when Iir_Kind_Choice_By_None => if Final then Translate_Variable_Aggregate_Assignment - (Get_Associated (El), El_Type, + (Get_Associated_Expr (El), El_Type, Chap3.Index_Base (Val, Targ_Type, New_Lit (New_Unsigned_Literal @@ -19687,7 +19691,8 @@ package body Translation is Index := Index + 1; else Translate_Variable_Array_Aggr - (Get_Associated (El), Targ_Type, Val, Index, Dim + 1); + (Get_Associated_Expr (El), + Targ_Type, Val, Index, Dim + 1); end if; when others => Error_Kind ("translate_variable_array_aggr", El); @@ -19713,12 +19718,12 @@ package body Translation is Elem := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => - Elem := Get_Name (Aggr_El); + Elem := Get_Choice_Name (Aggr_El); when others => Error_Kind ("translate_variable_rec_aggr", Aggr_El); end case; Translate_Variable_Aggregate_Assignment - (Get_Associated (Aggr_El), Get_Type (Elem), + (Get_Associated_Expr (Aggr_El), Get_Type (Elem), Chap6.Translate_Selected_Element (Val, Elem)); Aggr_El := Get_Chain (Aggr_El); end loop; @@ -20010,7 +20015,7 @@ package body Translation is Info.Choice_Chain := null; Info.Choice_Assoc := Nbr_Assocs - 1; Info.Choice_Parent := Choice; - Info.Choice_Expr := Get_Expression (Choice); + Info.Choice_Expr := Get_Choice_Expression (Choice); Nbr_Choices := Nbr_Choices + 1; Choice := Get_Chain (Choice); @@ -20252,7 +20257,8 @@ package body Translation is Start_Choice (Case_Blk); New_Expr_Choice (Case_Blk, Others_Lit); Finish_Choice (Case_Blk); - Translate_Statements_Chain (Get_Associated (Choice)); + 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); @@ -20262,7 +20268,8 @@ package body Translation is (Ghdl_Index_Type, Unsigned_64 (Get_Info (Choice).Choice_Assoc))); Finish_Choice (Case_Blk); - Translate_Statements_Chain (Get_Associated (Choice)); + Translate_Statements_Chain + (Get_Associated_Chain (Choice)); end if; Free_Info (Choice); when others => @@ -20310,12 +20317,12 @@ package body Translation is end if; First := True; - Stmt_Chain := Get_Associated (Choice); + Stmt_Chain := Get_Associated_Chain (Choice); Ch := Choice; loop case Get_Kind (Ch) is when Iir_Kind_Choice_By_Expression => - Ch_Expr := Get_Expression (Ch); + Ch_Expr := Get_Choice_Expression (Ch); Cond := Translate_Simple_String_Choice (Expr_Node, Chap7.Translate_Expression (Ch_Expr, @@ -20335,7 +20342,7 @@ package body Translation is Ch := Get_Chain (Ch); exit when Ch = Null_Iir; exit when not Get_Same_Alternative_Flag (Ch); - exit when Get_Associated (Ch) /= Null_Iir; + exit when Get_Associated_Chain (Ch) /= Null_Iir; if First then New_Assign_Stmt (New_Obj (Cond_Var), Cond); First := False; @@ -20371,14 +20378,14 @@ package body Translation is when Iir_Kind_Choice_By_Others => New_Default_Choice (Blk); when Iir_Kind_Choice_By_Expression => - Expr := Get_Expression (Choice); + 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_Expression (Choice); + Expr := Get_Choice_Range (Choice); Get_Low_High_Limit (Expr, L, H); New_Range_Choice (Blk, @@ -20431,15 +20438,13 @@ package body Translation is Choice := Get_Case_Statement_Alternative_Chain (Stmt); while Choice /= Null_Iir loop Start_Choice (Case_Blk); - Stmt_Chain := Get_Associated (Choice); + 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); - if Get_Associated (Choice) /= Null_Iir then - raise Internal_Error; - end if; + pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); end loop; Finish_Choice (Case_Blk); Translate_Statements_Chain (Stmt_Chain); @@ -21628,7 +21633,7 @@ package body Translation is when others => Error_Kind ("translate_signal_target_array_aggr", El); end case; - Expr := Get_Associated (El); + Expr := Get_Associated_Expr (El); if Dim = Nbr_Dim then Translate_Signal_Target_Aggr (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); @@ -21663,14 +21668,14 @@ package body Translation is Element := Get_Nth_Element (El_List, El_Index); El_Index := El_Index + 1; when Iir_Kind_Choice_By_Name => - Element := Get_Name (Aggr_El); + 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 (Aggr_El), Get_Type (Element)); + Get_Associated_Expr (Aggr_El), Get_Type (Element)); Aggr_El := Get_Chain (Aggr_El); end loop; end Translate_Signal_Target_Record_Aggr; diff --git a/xtools/Makefile b/xtools/Makefile index e1546ec..599e0da 100644 --- a/xtools/Makefile +++ b/xtools/Makefile @@ -14,21 +14,22 @@ # 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. -all: ../iirs.adb -check_iirs: force - gnatmake -g -gnatwa check_iirs +DEPS=../iirs.ads ../nodes.ads ./pnodes.py -MODE=--generate +all: ../iirs.adb ../disp_tree.adb ../nodes_gc.adb -../iirs.adb: ../iirs.adb.in ../iirs.ads ../nodes.ads ./check_iirs +../iirs.adb: ../iirs.adb.in $(DEPS) $(RM) $@ - ./check_iirs $(MODE) > subprg.ada - sed -e "/^ -- Subprograms/r subprg.ada" \ - < ../iirs.adb.in > $@ + ./pnodes.py body > $@ chmod -w $@ -force: +../disp_tree.adb: ../disp_tree.adb.in $(DEPS) + $(RM) $@ + ./pnodes.py disp_tree > $@ + chmod -w $@ -clean: - $(RM) *.o *.ali *~ check_iirs +../nodes_gc.adb: ../nodes_gc.adb.in $(DEPS) + $(RM) $@ + ./pnodes.py mark_tree > $@ + chmod -w $@ diff --git a/xtools/check_iirs.adb b/xtools/check_iirs.adb deleted file mode 100644 index 3b28dfe..0000000 --- a/xtools/check_iirs.adb +++ /dev/null @@ -1,64 +0,0 @@ --- Tool to check the coherence of the iirs package. --- Copyright (C) 2002, 2003, 2004, 2005 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 Check_Iirs_Pkg; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; - -procedure Check_Iirs -is - type Prg_Mode is (Mode_Generate, Mode_Genfast, Mode_Free); - Mode : Prg_Mode; - procedure Usage is - begin - Put_Line ("usage: " & Command_Name & " MODE"); - Put_Line ("MODE is one of:"); - Put_Line (" --generate"); - Put_Line (" --genfast"); - Put_Line (" --list-free-fields"); - end Usage; -begin - if Argument_Count /= 1 then - Usage; - Set_Exit_Status (Failure); - return; - end if; - if Argument (1) = "--generate" then - Mode := Mode_Generate; - elsif Argument (1) = "--genfast" then - Mode := Mode_Genfast; - elsif Argument (1) = "--list-free-fields" then - Mode := Mode_Free; - else - Usage; - Set_Exit_Status (Failure); - return; - end if; - - Check_Iirs_Pkg.Read_Fields; - Check_Iirs_Pkg.Check_Iirs; - Check_Iirs_Pkg.Read_Desc; - case Mode is - when Mode_Generate => - Check_Iirs_Pkg.Gen_Func; - when Mode_Genfast => - Check_Iirs_Pkg.Flag_Checks := False; - Check_Iirs_Pkg.Gen_Func; - when Mode_Free => - Check_Iirs_Pkg.List_Free_Fields; - end case; -end Check_Iirs; diff --git a/xtools/check_iirs_pkg.adb b/xtools/check_iirs_pkg.adb deleted file mode 100644 index 219c132..0000000 --- a/xtools/check_iirs_pkg.adb +++ /dev/null @@ -1,1234 +0,0 @@ --- Tool to check the coherence of the iirs package. --- Copyright (C) 2002, 2003, 2004, 2005 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 GNAT.Spitbol; use GNAT.Spitbol; -with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; -with GNAT.Spitbol.Table_Integer; use GNAT.Spitbol.Table_Integer; -with GNAT.Table; - -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; -with Ada.Command_Line; use Ada.Command_Line; - -package body Check_Iirs_Pkg is - -- Exception raise in case of error. - Err : exception; - - -- Identifier get by getident_pat. - Ident : VString := Nul; - Ident_2 : VString := Nul; - Ident_3 : VString := Nul; - Ident_4 : VString := Nul; - Ident_5 : VString := Nul; - - -- Enumel_Pat set this variable to the position of the comma. - -- Used to detect the absence of a comma. - Comma_Pos : aliased Natural; - - -- Patterns - -- Space. - Wsp : constant Pattern := Span (' '); - - -- "type Iir_Kind is". - Type_Iir_Kind_Pat : constant Pattern := - Wsp & "type" & Wsp & "Iir_Kind" & Wsp & "is" & Rpos (0); - - -- "(" - Lparen_Pat : constant Pattern := Wsp & '(' & Rpos (0); - - -- Comment. - Comment_Pat : constant Pattern := Wsp & "--"; - - -- End of ada line - Eol_Pat : constant Pattern := Comment_Pat or Rpos (0); - - -- A-Za-z - Basic_Pat : constant Pattern := Span (Basic_Set); - - -- A-Za-z0-9 - Alnum_Pat : constant Pattern := Span (Alphanumeric_Set); - - -- Ada identifier. - Ident_Pat : constant Pattern := Basic_Pat & Arbno (('_' or "") & Alnum_Pat); - -- Basic_Pat & Arbno (Alnum_Pat) & Arbno ('_' & Alnum_Pat); - - -- Eat the ada identifier. - Getident_Pat : constant Pattern := Ident_Pat * Ident; - Getident2_Pat : constant Pattern := Ident_Pat * Ident_2; - Getident3_Pat : constant Pattern := Ident_Pat * Ident_3; - Getident4_Pat : constant Pattern := Ident_Pat * Ident_4; - Getident5_Pat : constant Pattern := Ident_Pat * Ident_5; - - -- Get an enumeration elements. - Enumel_Pat : constant Pattern := Wsp & Getident_Pat - & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat; - - -- End of an enumeration declaration. - End_Enum_Pat : constant Pattern := Wsp & ");" & Eol_Pat; - - Format_Pat : constant Pattern := " Format_" & Getident_Pat - & ((',' & Setcur (Comma_Pos'Access)) or "") & Eol_Pat; - - Fields_Of_Format_Pat : constant Pattern := - " -- Fields of Format_" & Getident_Pat & ":" & Rpos (0); - - -- "subtype XX is Iir_Kind range". - Iir_Kind_Subtype_Pat : constant Pattern := - Wsp & "subtype" & Wsp & Getident_Pat & Wsp & "is" & Wsp & "Iir_Kind" - & Wsp & "range" & Eol_Pat; - - -- Pattern for a range. - Start_Range_Pat : constant Pattern := - Wsp & Getident_Pat & Wsp & ".." & Eol_Pat; - Comment_Range_Pat : constant Pattern := - Wsp & "--" & Getident_Pat & Rpos (0); - End_Range_Pat : constant Pattern := Wsp & Getident_Pat & ";" & Eol_Pat; - - -- End of public package part. - End_Pat : constant Pattern := "end Iirs;" & Rpos (0); - - -- Pattern for a function field. - Func_Decl_Pat : constant Pattern := " -- Field: " & Getident_Pat - & ( "" or (" (" & Getident2_Pat & ")")) & Rpos (0); - - -- function Get_XXX. - Function_Get_Pat : constant Pattern := " function Get_" & Getident_Pat - & " (" & Getident2_Pat & " : " & Getident3_Pat & ") return " - & Getident4_Pat & ";" & Rpos (0); - - -- procedure Set_XXX. - Procedure_Set_Pat : constant Pattern := " procedure Set_" & Getident_Pat - & " (" & Getident2_Pat & " : " & Getident3_Pat - & "; " & Getident4_Pat & " : " & Getident5_Pat & ");" & Rpos (0); - - Field_Decl_Pat : constant Pattern := " -- " & Getident_Pat & " : "; - Field_Type_Pat : constant Pattern := " -- " & Ident_Pat & " : " - & Getident_Pat & ("" or (" (" & Arb & ")")) & Rpos (0); - - -- Formats of nodes. - type Format_Type is range 0 .. 7; - No_Format : constant Format_Type := 0; - Format_Pos : Format_Type := No_Format; - - Format2pos : GNAT.Spitbol.Table_Integer.Table (8); - - type Format_Info is record - Name : String_Access; - end record; - - Formats : array (Format_Type) of Format_Info := (others => (Name => null)); - - type Format_Mask_Type is array (Format_Type) of Boolean; - pragma Pack (Format_Mask_Type); - - -- Type of a IIR name. - type Iir_Type is new Natural range 0 .. 255; - No_Iir : constant Iir_Type := 0; - - -- Table to convert an Iir name to its position. - Iir_Kind2pos : GNAT.Spitbol.Table_Integer.Table (256); - -- Last iir used during table construction. - Iir_Pos : Iir_Type := No_Iir; - - -- Table of Get_ functions. - Function2pos : GNAT.Spitbol.Table_Integer.Table (256); - - -- Table of field. - Field2pos : GNAT.Spitbol.Table_Integer.Table (32); - - type Range_Type is record - L : Iir_Type; - H : Iir_Type; - end record; - - Null_Range : constant Range_Type := (No_Iir, No_Iir); - - function Img (Rng : Range_Type) return String is - begin - return "(" & Iir_Type'Image (Rng.L) & ", " - & Iir_Type'Image (Rng.H) & ")"; - end Img; - - package Table_Range is new GNAT.Spitbol.Table (Range_Type, Null_Range, Img); - use Table_Range; - - Iir_Kinds2pos : Table_Range.Table (32); - - -- Field type. They represent a raw field. - type Field_Type is new Integer range 0 .. 64; - No_Field : constant Field_Type := 0; - -- Position of the last field. - Field_Pos : Field_Type := No_Field; - - type Field_Info is record - -- Name of the field. - Name : String_Access; - -- Type of the field. - Ftype : String_Access; - -- Formats in which the field is valid. - Formats : Format_Mask_Type; - end record; - - package Field_Table is new GNAT.Table - (Table_Component_Type => Field_Info, - Table_Index_Type => Field_Type, - Table_Low_Bound => 1, - Table_Initial => 32, - Table_Increment => 100); - - -- Function type. They represent a field name. - type Func_Type is new Natural; - No_Func : constant Func_Type := 0; - -- Last function known; used during the construction of the func_table. - Function_Pos : Func_Type := No_Func; - - type Field2Func_Array is array (Field_Type) of Func_Type; - - -- Information for each Iir node. - type Iir_Info is record - -- Name of the Kind. - Name : String_Access; - - -- If TRUE, the node was described. - Described : Boolean; - - -- Format used by the node. - Format : Format_Type; - - -- Function used to get the value of each field. - Func : Field2Func_Array; - end record; - - -- Table of IIr. - package Iir_Table is new GNAT.Table - (Table_Component_Type => Iir_Info, - Table_Index_Type => Iir_Type, - Table_Low_Bound => 1, - Table_Initial => 256, - Table_Increment => 100); - - -- Table of functions. - type Iir_Bool_Array is array (Iir_Type) of Boolean; - pragma Pack (Iir_Bool_Array); - - type Conversion_Type is (None, Via_Pos_Attr, Via_Unchecked); - - type Func_Info is record - -- Name of the function. - Name : String_Access; - -- Field get/set by the function. - Field : Field_Type; - -- If true, the iir use this function. - Uses : Iir_Bool_Array; - -- Name of the target. - Target_Name : String_Access; - -- Type of the target. - Target_Type : String_Access; - -- Name of the value. - Value_Name : String_Access; - -- Type of the value. - Value_Type : String_Access; - -- Conversion; - Conv : Conversion_Type; - end record; - - package Func_Table is new GNAT.Table - (Table_Component_Type => Func_Info, - Table_Index_Type => Func_Type, - Table_Low_Bound => 1, - Table_Initial => 256, - Table_Increment => 100); - - -- Get the position of IIR V. - function Get_Iir_Pos (V : VString) return Iir_Type - is - P : Integer; - begin - P := Get (Iir_Kind2pos, V); - - if P < 0 then - -- Identifier unknown. - raise Err; - end if; - return Iir_Type (P); - end Get_Iir_Pos; - - Flag_Disp_Format : constant Boolean := False; - Flag_Disp_Field : constant Boolean := False; - - procedure Read_Fields - is - In_Node : File_Type; - Line : VString := Nul; - - Format_Mask : Format_Mask_Type; - - procedure Parse_Field - is - P : Integer; - Name : constant Vstring := Ident; - begin - if not Match (Line, Field_Type_Pat) then - Put_Line ("** field declaration without type"); - raise Err; - end if; - - -- Check if the field is not already known. - P := Get (Field2pos, Name); - if P > 0 then - if Ident /= Field_Table.Table (Field_Type (P)).Ftype.all then - Put_Line ("*** field type mismatch"); - raise Err; - end if; - for I in Format_Mask'Range loop - if Format_Mask (I) then - Field_Table.Table (Field_Type (P)).Formats (I) := True; - end if; - end loop; - return; - end if; - - Field_Pos := Field_Pos + 1; - Set (Field2pos, Name, Natural (Field_Pos)); - Field_Table.Set_Last (Field_Pos); - Field_Table.Table (Field_Pos) := - (Name => new String'(To_String (Name)), - Ftype => new String'(To_String (Ident)), - Formats => Format_Mask); - if Flag_Disp_Field then - Put_Line ("found field '" - & Field_Table.Table (Field_Pos).Name.all & "'"); - end if; - end Parse_Field; - begin - Open (In_Node, In_File, "../nodes.ads"); - - Anchored_Mode := True; - - -- Read lines until "type format_type is": - loop - Line := Get_Line (In_Node); - exit when Match (Line, " type Format_Type is" & Rpos (0)); - end loop; - -- Expect '('. - Line := Get_Line (In_Node); - if not Match (Line, " (" & Rpos (0)) then - raise Err; - end if; - - -- Read all formats. - loop - Line := Get_Line (In_Node); - - -- Read the identifier. - Comma_Pos := 0; - if not Match (Line, Format_Pat) then - raise Err; - end if; - - -- Put it into the table. - Format_Pos := Format_Pos + 1; - Set (Format2Pos, Ident, Natural (Format_Pos)); - Formats (Format_Pos) := (Name => new String'(To_String (Ident))); - if Flag_Disp_Format then - Put_Line ("found format " & S (Ident)); - end if; - - -- If there is no comma, then this is the end of enumeration. - exit when Comma_Pos = 0; - end loop; - - -- Read ");" - Line := Get_Line (In_Node); - if not Match (Line, " );" & Rpos (0)) then - raise Err; - end if; - - -- Read fields. - - loop - Line := Get_Line (In_Node); - exit when Match (Line, " -- Common fields are:" & Rpos (0)); - end loop; - Format_Mask := (others => True); - loop - Line := Get_Line (In_Node); - if Match (Line, Field_Decl_Pat) then - Parse_Field; - elsif Match (Line, Rpos (0)) then - Line := Get_Line (In_Node); - exit when not Match (Line, Fields_Of_Format_Pat); - declare - P : Integer; - begin - P := Get (Format2pos, Ident); - if P < 0 then - Put_Line ("*** unknown format"); - raise Err; - end if; - Format_Mask := (others => False); - Format_Mask (Format_Type (P)) := True; - end; - else - Put_Line ("** bad line in field declarations"); - raise Err; - end if; - end loop; - Close (In_Node); - - if False then - Put_Line ("Fields:"); - for I in 1 .. Field_Pos loop - Put (Field_Table.Table (I).Name.all); - Put (": "); - Put (Field_Table.Table (I).Ftype.all); - Put (" "); - for J in Format_Mask_Type'Range loop - if Field_Table.Table (I).Formats (J) - and then Formats (J).Name /= null - then - Put (" "); - Put (Formats (J).Name.all); - end if; - end loop; - New_Line; - end loop; - end if; - end Read_Fields; - - -- Read all Iir_Kind_* names and put them into Iir_Table. - -- Fill Iir_Kinds2pos - -- Fill Func_Table. - procedure Check_Iirs - is - -- iirs.ads file. - In_Iirs : File_Type; - - -- Line read from In_Iirs. - Line : VString := Nul; - begin - -- Open the file. - Open (In_Iirs, In_File, "../iirs.ads"); - - Anchored_Mode := True; - - -- Read lines until "type Iir_Kind is" - loop - Line := Get_Line (In_Iirs); - exit when Match (Line, Type_Iir_Kind_Pat); - end loop; - - if Flag_Disp_Iir then - Put_Line ("found iir_kind at line" - & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs))); - end if; - - --Debug_Mode := True; - - -- Read '(' - Line := Get_Line (In_Iirs); - if not Match (Line, Lparen_Pat) then - raise Err; - end if; - - -- Read all kind. - loop - Line := Get_Line (In_Iirs); - - -- Skip comments and empty lines. - if Match (Line, Eol_Pat) then - goto Continue; - end if; - - -- Read the identifier. - Comma_Pos := 0; - if not Match (Line, Enumel_Pat) then - raise Err; - end if; - - -- Put it into the table. - Iir_Pos := Iir_Pos + 1; - Set (Iir_Kind2pos, Ident, Natural (Iir_Pos)); - Iir_Table.Set_Last (Iir_Pos); - Iir_Table.Table (Iir_Pos) := (Name => new String'(To_String (Ident)), - Described => False, - Format => No_Format, - Func => (others => No_Func)); - if Flag_Disp_Iir then - Put_Line ("found " & S (Ident) & Iir_Type'Image (Iir_Pos)); - end if; - - -- If there is no comma, then this is the end of enumeration. - exit when Comma_Pos = 0; - << Continue >> null; - end loop; - - -- Read ");" - Line := Get_Line (In_Iirs); - if not Match (Line, End_Enum_Pat) then - raise Err; - end if; - - -- Look for iir_kind subtype. - loop - Line := Get_Line (In_Iirs); - exit when Match (Line, End_Pat); - - Ident_2 := Null_Unbounded_String; - - if Match (Line, Iir_Kind_Subtype_Pat) then - declare - Start : Iir_Type; - Pos : Iir_Type; - P : Iir_Type; - Rng_Ident : constant VString := Ident; - begin - Line := Get_Line (In_Iirs); - if not Match (Line, Start_Range_Pat) then - -- Bad pattern for left bound. - Put_Line (Standard_Error, "bad pattern"); - raise Err; - end if; - Start := Get_Iir_Pos (Ident); - Pos := Start; - if Flag_Disp_Subtype then - Put_Line ("found subtype " & S (Rng_Ident)); - Put_Line (" " & S (Ident) & " .." - & Iir_Type'Image (Pos)); - end if; - - loop - Line := Get_Line (In_Iirs); - if Match (Line, End_Range_Pat) then - P := Get_Iir_Pos (Ident); - if P /= Pos + 1 and then Flag_Disp_Subtype Then - Put_Line (Standard_Error, "** missing comments"); - for I in Pos + 1 .. P - 1 loop - Put_Line (" --" & Iir_Table.Table (I).Name.all); - end loop; - end if; - Set (Iir_Kinds2pos, Rng_Ident, Range_Type'(Start, P)); - if Flag_Disp_Subtype then - Put_Line (" " & S (Ident) & Iir_Type'Image (P)); - end if; - exit; - elsif Match (Line, Comment_Range_Pat) then - P := Get_Iir_Pos (Ident); - if P /= Pos + 1 then - -- Bad order. - Put_Line (Standard_Error, "** missing node in range"); - raise Err; - else - Pos := Pos + 1; - end if; - else - -- Comment (with identifier) or end of range expected. - raise Err; - end if; - end loop; - end; - elsif Match (Line, Func_Decl_Pat) then - declare - Field_Pos : Integer; - F : Func_Type; - Conv : Conversion_Type; - begin - Field_Pos := Get (Field2pos, Ident); - if Field_Pos < 0 then - Put_Line (Standard_Error, - "*** field not found: '" & S (Ident) & "'"); - raise Err; - end if; - - if Ident_2 /= Null_Unbounded_String then - if Ident_2 = "pos" then - Conv := Via_Pos_Attr; - elsif Ident_2 = "uc" then - Conv := Via_Unchecked; - else - Put_Line (Standard_Error, "*** bad conversion"); - raise Err; - end if; - else - Conv := None; - end if; - - Line := Get_Line (In_Iirs); - if not Match (Line, Function_Get_Pat) then - Put_Line (Standard_Error, "*** function expected"); - raise Err; - end if; - - if False then - Put_Line ("found function " & S (Ident)); - end if; - Function_Pos := Function_Pos + 1; - F := Function_Pos; - Set (Function2pos, Ident, Integer (Function_Pos)); - Func_Table.Set_Last (Function_Pos); - Func_Table.Table (Function_Pos) := - (Name => new String'(To_String (Ident)), - Field => Field_Type (Field_Pos), - Uses => (others => False), - Target_Name => new String'(To_String (Ident_2)), - Target_Type => new String'(To_String (Ident_3)), - Value_Name => null, - Value_Type => new String'(To_String (Ident_4)), - Conv => Conv); - - Line := Get_Line (In_Iirs); - if Match (Line, Procedure_Set_Pat) then - if Func_Table.Table (F).Target_Name.all /= Ident_2 then - Put_Line (Standard_Error, - "*** procedure target name mismatch (" - & Func_Table.Table (F).Target_Name.all - & " vs " & S (Ident_2) &")"); - raise Err; - end if; - if Func_Table.Table (F).Target_Type.all /= Ident_3 then - Put_Line (Standard_Error, - "*** procedure target type name mismatch"); - raise Err; - end if; - if Func_Table.Table (F).Value_Type.all /= Ident_5 then - Put_Line (Standard_Error, - "*** procedure target type name mismatch"); - raise Err; - end if; - Func_Table.Table (F).Value_Name := - new String'(To_String (Ident_4)); - else - if not Match (Line, Rpos (0)) then - Put_Line (Standard_Error, - "*** procedure or empty line expected"); - raise Err; - end if; - end if; - end; - end if; - end loop; - Close (In_Iirs); - Set_Exit_Status (Success); - exception - when Err => - Put_Line (Standard_Error, - "*** Fatal error at line" - & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs))); - Set_Exit_Status (Failure); - raise; - end Check_Iirs; - - -- Start of node description. - Start_Of_Iir_Kind_Pat : constant Pattern := - " -- Start of Iir_Kind." & Rpos (0); - End_Of_Iir_Kind_Pat : constant Pattern := - " -- End of Iir_Kind." & Rpos (0); - - -- Box ("----------") delimiters. - Desc_Box_Comment_Pat : constant Pattern := " --" & Span ('-') & Rpos (0); - - -- A comment ("-- XXXX") - Desc_Comment_Pat : constant Pattern := " -- " & Arb & Rpos (0); - Desc_Empty_Comment_Pat : constant Pattern := " --" & Rpos (0); - - -- Get a iir_kind identifier. - Desc_Iir_Kind_Pat : constant Pattern := - " -- " & Getident_Pat - & ("" or ( " (" & Getident2_Pat & ")")) - & Rpos (0); - - Subprogram_Pat : constant Pattern := - " -- Get" & ("_" or "/Set_") & Getident_Pat - & ((" " & Arb) or "") & Rpos (0); - - Desc_Only_For_Pat : constant Pattern := - " -- Only for " & Getident_Pat & ":" & Rpos (0); - Desc_Subprogram_Pat : constant Pattern := - " -- " & ("function" or "procedure"); - - Field_Pat : constant Pattern := Arb & "(" & Getident_Pat & ")"; - Alias_Field_Pat : constant Pattern := Arb & "(Alias " & Getident_Pat & ")"; - - Disp_Desc : constant Boolean := False; - - -- Check descriptions. - procedure Read_Desc - is - -- iirs.ads file. - In_Iirs : File_Type; - - -- Current line. - Line : VString; - - -- IIR being described. - type Iir_Array is array (Natural range <>) of Iir_Type; - Iir_Desc : Iir_Array (1 .. 32); - Nbr_Desc : Natural := 0; - - Only_For : Iir_Array (1 .. 16) := (others => No_Iir); - Nbr_Only_For : Natural := 0; - - -- Just say IIR N is being described. - procedure Add_Desc (N : Iir_Type; Format : Format_Type) is - begin - if Iir_Table.Table (N).Described then - Put_Line ("*** iir already described"); - raise Err; - end if; - - Iir_Table.Table (N).Described := True; - Iir_Table.Table (N).Format := Format; - Nbr_Desc := Nbr_Desc + 1; - Iir_Desc (Nbr_Desc) := N; - end Add_Desc; - - begin - -- Open the file. - Open (In_Iirs, In_File, "../iirs.ads"); - - Anchored_Mode := True; - - if False then - -- List of fields. - Set (Field2pos, "Field1", 1); - Set (Field2pos, "Field2", 2); - Set (Field2pos, "Field3", 3); - Set (Field2pos, "Field4", 4); - Set (Field2pos, "Field5", 5); - Set (Field2pos, "Field6", 6); - Set (Field2pos, "Field7", 7); - Set (Field2pos, "Nbr2", 6); - Set (Field2pos, "Nbr3", 7); - - Set (Field2pos, "Ident", 8); - Set (Field2pos, "Field0", 9); - Set (Field2pos, "Attr", 10); - Set (Field2pos, "Chain", 11); - - Set (Field2pos, "Flag1", 12); - Set (Field2pos, "Flag2", 13); - Set (Field2pos, "Flag3", 14); - Set (Field2pos, "Flag4", 15); - Set (Field2pos, "Flag5", 16); - Set (Field2pos, "Odigit_1", 17); - Set (Field2pos, "Odigit_2", 18); - Set (Field2pos, "State1", 19); - Set (Field2pos, "Staticness_1", 20); - Set (Field2pos, "Staticness_2", 21); - end if; - - -- Read lines until "-- Start of Iir_Kind." - loop - Line := Get_Line (In_Iirs); - exit when Match (Line, Start_Of_Iir_Kind_Pat); - end loop; - - --Debug_Mode := True; - - -- Read descriptions. - L1 : loop - - -- Look for a description - - loop - Line := Get_Line (In_Iirs); - - -- The description - exit when Match (Line, " -- Iir_Kind"); - - -- End of descriptions - exit L1 when Match (Line, End_Of_Iir_Kind_Pat); - - -- Skip over comments - if Match (Line, Desc_Box_Comment_Pat) - or else Match (Line, Desc_Comment_Pat) - then - loop - Line := Get_Line (In_Iirs); - exit when Match (Line, Rpos (0)); - if Match (Line, Desc_Comment_Pat) - or else Match (Line, Desc_Empty_Comment_Pat) - or else Match (Line, Desc_Box_Comment_Pat) - then - null; - else - raise Err; - end if; - end loop; - end if; - end loop; - - -- Get iir_kind. - declare - P_Num : Integer; - Rng : Range_Type; - Format : Format_Type; - begin - -- No iir being described. - Nbr_Desc := 0; - loop - Ident_2 := Nul; - exit when not Match (Line, Desc_Iir_Kind_Pat); - - -- Check format. - if Ident_2 = Nul then - Put_Line (Standard_Error, - "*** no format for " & S (Ident)); - raise Err; - end if; - P_Num := Get (Format2pos, Ident_2); - if P_Num < 0 then - Put_Line (Standard_Error, "*** unknown format"); - raise Err; - end if; - Format := Format_Type (P_Num); - - -- Handle nodes. - P_Num := Get (Iir_Kind2pos, Ident); - if P_Num >= 0 then - Add_Desc (Iir_Type (P_Num), Format); - else - Rng := Get (Iir_Kinds2pos, Ident); - if Rng = Null_Range then - Put_Line (Standard_Error, "*** " & S (Ident)); - raise Err; - end if; - for I in Rng.L .. Rng.H loop - Add_Desc (I, Format); - end loop; - end if; - - if Disp_Desc then - Put_Line ("desc for " & S (Ident)); - end if; - - Line := Get_Line (In_Iirs); - end loop; - end; - - --Debug_Mode := True; - - -- Read the functions. - loop - if not Match (Line, Comment_Pat) then - if Match (Line, Rpos (0)) then - exit; - else - raise Err; - end if; - end if; - declare - Func : Func_Type; - Func_Num : Integer; - Field : Field_Type; - Field_Num : Integer; - Is_Alias : Boolean; - - procedure Add_Field (N : Iir_Type) is - begin - if not Field_Table.Table (Field). - Formats (Iir_Table.Table (N).Format) - then - Put_Line (Standard_Error, "** no field for format"); - raise Err; - end if; - if Is_Alias then - if Iir_Table.Table (N).Func (Field) = No_Func - then - Put_Line (Standard_Error, - "** aliased field not yet used"); - raise Err; - end if; - else - if Iir_Table.Table (N).Func (Field) /= No_Func - --and then - --Iir_Table.Table (N).Func (Field) /= Func - then - Put_Line (Standard_Error, - "** Field already used"); - raise Err; - end if; - Iir_Table.Table (N).Func (Field) := Func; - end if; - Func_Table.Table (Func).Uses (N) := True; - end Add_Field; - begin - if Match (Line, Subprogram_Pat) then - if Disp_Desc then - Put ("subprg: " & S (Ident)); - end if; - Func_Num := Get (Function2pos, Ident); - if Func_Num < 0 then - Put_Line (Standard_Error, - "*** function not found: " & S (Ident)); - raise Err; - end if; - Func := Func_Type (Func_Num); - if Match (Line, Field_Pat) then - Is_Alias := False; - elsif Match (Line, Alias_Field_Pat) then - Is_Alias := True; - else - raise Err; - end if; - if Disp_Desc then - Put_Line (" (" & S (Ident) & ")"); - end if; - Field_Num := Get (Field2pos, Ident); - if Field_Num < 0 then - Put_Line (Standard_Error, - "*** unknown field: " & S (Ident)); - raise Err; - end if; - Field := Field_Type (Field_Num); - if Func_Table.Table (Func).Field /= Field then - if Func_Table.Table (Func).Field = No_Field then - Func_Table.Table (Func).Field := Field; - else - -- Field redefined for the function. - Put_Line (Standard_Error, - "** field redefined for function " - & Func_Table.Table (Func).Name.all); - raise Err; - end if; - end if; - - -- Check the field is not already used by another func. - if Nbr_Only_For > 0 then - for I in 1 .. Nbr_Only_For loop - Add_Field (Only_For (I)); - end loop; - Nbr_Only_For := 0; - else - for I in 1 .. Nbr_Desc loop - Add_Field (Iir_Desc (I)); - end loop; - end if; - elsif Match (Line, Desc_Only_For_Pat) then - declare - P_Num : Integer; - Rng : Range_Type; - - procedure Add_Only_For (N : Iir_Type) is - begin - for I in 1 .. Nbr_Desc loop - if Iir_Desc (I) = N then - Nbr_Only_For := Nbr_Only_For + 1; - Only_For (Nbr_Only_For) := N; - return; - end if; - end loop; - Put_Line (Standard_Error, - "** not currently described"); - raise Err; - end Add_Only_For; - begin - P_Num := Get (Iir_Kind2pos, Ident); - if P_Num >= 0 then - Add_Only_For (Iir_Type (P_Num)); - else - Rng := Get (Iir_Kinds2pos, Ident); - if Rng = Null_Range then - Put_Line (Standard_Error, "*** " & S (Ident)); - raise Err; - end if; - for I in Rng.L .. Rng.H loop - Add_Only_For (I); - end loop; - end if; - end; - elsif Match (Line, " -- Only") then - Put_Line (Standard_Error, "** bad 'Only' for line"); - raise Err; - elsif Match (Line, Desc_Comment_Pat) then - null; - elsif Match (Line, Desc_Empty_Comment_Pat) then - null; - elsif Match (Line, Desc_Subprogram_Pat) then - null; - else - raise Err; - end if; - end; - Line := Get_Line (In_Iirs); - end loop; - end loop L1; - - -- Check each Iir was described. - for I in Iir_Table.First .. Iir_Table.Last loop - if not Iir_Table.Table (I).Described then - Put_Line (Standard_Error, - "*** not described: " & Iir_Table.Table (I).Name.all); - raise Err; - end if; - end loop; - - Close (In_Iirs); - exception - when Err => - Put_Line (Standard_Error, - "*** Fatal error (2) at line" - & Positive_Count'Image (Ada.Text_IO.Line (In_Iirs) - 1)); - Put_Line (Standard_Error, "*** Line is " & S (Line)); - Set_Exit_Status (Failure); - raise; - end Read_Desc; - - procedure Gen_Func - is - function Is_Used (F : Func_Type) return Boolean - is - begin - for I in Func_Table.Table (F).Uses'Range loop - if Func_Table.Table (F).Uses (I) then - return True; - end if; - end loop; - return False; - end Is_Used; - Is_First : Boolean; - Same_Name : Boolean; - begin - Put_Line (" function Get_Format (Kind : Iir_Kind) " - & "return Format_Type is"); - Put_Line (" begin"); - Put_Line (" case Kind is"); - for I in 1 .. Format_Pos loop - Is_First := True; - Put (" when "); - for J in Iir_Table.First .. Iir_Table.Last loop - if Iir_Table.Table (J).Format = I then - if not Is_First then - New_Line; - Put (" | "); - end if; - Is_First := False; - Put (Iir_Table.Table (J).Name.all); - end if; - end loop; - Put_Line (" =>"); - Put (" return Format_"); - Put (Formats (I).Name.all); - Put_Line (";"); - end loop; - Put_Line (" end case;"); - Put_Line (" end Get_Format;"); - New_Line; - - -- Builder. - Put_Line (" function Create_Iir (Kind : Iir_Kind) return Iir"); - Put_Line (" is"); - Put_Line (" Res : Iir;"); - Put_Line (" Format : Format_Type;"); - Put_Line (" begin"); - Put_Line (" Format := Get_Format (Kind);"); - Put_Line (" Res := Create_Node (Format);"); - Put_Line (" Set_Nkind (Res, Iir_Kind'Pos (Kind));"); - Put_Line (" return Res;"); - Put_Line (" end Create_Iir;"); - New_Line; - - for I in Func_Table.First .. Func_Table.Last loop - declare - F : Func_Info renames Func_Table.Table (I); - begin - -- Avoid bug get_parent. - if Is_Used (I) then - Same_Name := F.Name.all = Field_Table.Table (F.Field).Name.all; - if Flag_Checks then - Put (" procedure Check_Kind_For_"); - Put (F.Name.all); - Put (" (Target : Iir) is"); - New_Line; - Put_Line (" begin"); - Put_Line (" case Get_Kind (Target) is"); - Put (" when "); - Is_First := True; - for J in F.Uses'Range loop - if F.Uses (J) then - if not Is_First then - New_Line; - Put (" | "); - else - Is_First := False; - end if; - Put (Iir_Table.Table (J).Name.all); - end if; - end loop; - Put_Line (" =>"); - Put_Line (" null;"); - Put_Line (" when others =>"); - Put (" Failed ("""); - Put (F.Name.all); - Put_Line (""", Target);"); - Put_Line (" end case;"); - Put (" end Check_Kind_For_"); - Put (F.Name.all); - Put_Line (";"); - New_Line; - end if; - - Put (" function Get_"); - Put (F.Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (" : "); - Put (F.Target_Type.all); - Put (") return "); - Put (F.Value_Type.all); - if Col > 76 then - New_Line; - Put (" "); - end if; - Put (" is"); - New_Line; - Put_Line (" begin"); - if Flag_Checks then - Put (" Check_Kind_For_"); - Put (F.Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (");"); - New_Line; - end if; - Put (" return "); - case F.Conv is - when None => - null; - when Via_Pos_Attr => - Put (F.Value_Type.all); - Put ("'Val ("); - when Via_Unchecked => - Put (Field_Table.Table (F.Field).Ftype.all); - Put ("_To_"); - Put (F.Value_Type.all); - Put (" ("); - end case; - if Same_Name then - Put ("Nodes."); - end if; - Put ("Get_"); - Put (Field_Table.Table (F.Field).Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (")"); - case F.Conv is - when None => - null; - when Via_Pos_Attr - | Via_Unchecked => - Put (")"); - end case; - Put (";"); - New_Line; - Put (" end Get_"); - Put (F.Name.all); - Put (";"); - New_Line; - New_Line; - - if F.Value_Name /= null then - Put (" procedure Set_"); - Put (F.Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (" : "); - Put (F.Target_Type.all); - Put ("; "); - Put (F.Value_Name.all); - Put (" : "); - Put (F.Value_Type.all); - Put (")"); - if Col > 76 then - New_Line; - Put (" "); - end if; - Put (" is"); - New_Line; - Put_Line (" begin"); - if Flag_Checks then - Put (" Check_Kind_For_"); - Put (F.Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (");"); - New_Line; - end if; - Put (" "); - if Same_Name then - Put ("Nodes."); - end if; - Put ("Set_"); - Put (Field_Table.Table (F.Field).Name.all); - Put (" ("); - Put (F.Target_Name.all); - Put (", "); - case F.Conv is - when None => - null; - when Via_Pos_Attr => - Put (F.Value_Type.all); - Put ("'Pos ("); - when Via_Unchecked => - Put (F.Value_Type.all); - Put ("_To_"); - Put (Field_Table.Table (F.Field).Ftype.all); - Put (" ("); - end case; - Put (F.Value_Name.all); - case F.Conv is - when None => - null; - when Via_Pos_Attr - | Via_Unchecked => - Put (")"); - end case; - Put (");"); - New_Line; - Put (" end Set_"); - Put (F.Name.all); - Put (";"); - New_Line; - New_Line; - end if; - end if; - end; - end loop; - end Gen_Func; - - procedure List_Free_Fields - is - begin - for I in Iir_Table.First .. Iir_Table.Last loop - declare - Info : Iir_Info renames Iir_Table.Table (I); - begin - Put_Line (Info.Name.all); - for J in 1 .. Field_Pos loop - if Info.Func (J) = No_Func - and then Field_Table.Table (J).Formats (Info.Format) - then - Put (" "); - Put_Line (Field_Table.Table (J).Name.all); - end if; - end loop; - end; - end loop; - end List_Free_Fields; -end Check_Iirs_Pkg; diff --git a/xtools/pnodes.py b/xtools/pnodes.py new file mode 100755 index 0000000..a9fbc21 --- /dev/null +++ b/xtools/pnodes.py @@ -0,0 +1,718 @@ +#!/usr/bin/env python + +import re +import sys +import argparse + +field_file = "../nodes.ads" +spec_file = "../iirs.ads" +template_file = "../iirs.adb.in" +template_disp_file = "../disp_tree.adb.in" +template_mark_file = "../nodes_gc.adb.in" +prefix_name = "Iir_Kind_" +prefix_range_name = "Iir_Kinds_" +type_name = "Iir_Kind" +conversions = ['uc', 'pos'] + +class FuncDesc: + def __init__(self, name, field, conv, acc, display, + pname, ptype, rname, rtype): + self.name = name + self.field = field + self.conv = conv + self.acc = acc + self.display = display # List of display attributes + self.pname = pname # Parameter mame + self.ptype = ptype # Parameter type + self.rname = rname # value name (for procedure) + self.rtype = rtype # value type + +class NodeDesc: + def __init__(self, name, format, fields, attrs): + self.name = name + self.format = format + self.fields = fields # {field: FuncDesc} dict, defined for all fields + self.attrs = attrs # A {attr: FuncDesc} dict + +class line: + def __init__(self, string, no): + self.l = string + self.n = no + +class EndOfFile(Exception): + def __init__(self,filename): + self.filename = filename + + def __str__(self): + return "end of file " + self.filename + +class linereader: + def __init__(self, filename): + self.filename = filename + self.f = open (filename) + self.lineno = 0 + self.l = '' + + def get(self): + self.l = self.f.readline() + if not self.l: + raise EndOfFile(self.filename) + self.lineno = self.lineno + 1 + return self.l + +class ParseError(Exception): + def __init__(self, lr, msg): + self.lr = lr; + self.msg = msg + + def __str__(self): + return 'Error: ' + self.msg + return 'Parse error at ' + self.lr.filname + ':' + self.lr.lineno + \ + ': ' + self.msg + +# Return fields description. +# This is a dictionary. The keys represent the possible format of a node. +# The values are dictionnaries representing fields. Keys are fields name, and +# values are fields type. +def read_fields(file): + fields = {} + formats = [] + lr = linereader(file) + + # Search for 'type Format_Type is' + while lr.get() != ' type Format_Type is\n': + pass + + # Skip '(' + if lr.get() != ' (\n': + raise 'no open parenthesis after Format_Type'; + + # Read formats + l = lr.get() + pat_field_name = re.compile(' Format_(\w+),?\n') + while l != ' );\n': + m = pat_field_name.match(l) + if m == None: + print l + raise 'bad literal within Format_Type' + name = m.group(1) + formats.append(name) + fields[name] = {} + l = lr.get() + + # Read fields + l = lr.get() + pat_fields = re.compile(' -- Fields of Format_(\w+):\n') + pat_field_desc = re.compile(' -- (\w+) : (\w+).*\n') + format_name = '' + common_desc = {} + try: + while True: + # 1) Search for description + while True: + # The common one + if l == ' -- Common fields are:\n': + format_name = 'Common' + break + # One for a format + m = pat_fields.match(l) + if m != None: + format_name = m.group(1) + if not format_name in fields: + raise ParseError( + lr, 'Format ' + format_name + ' is unknown'); + break + l = lr.get() + + # 2) Read field description + l = lr.get() + desc = common_desc + while True: + m = pat_field_desc.match(l) + if m == None: + break + desc[m.group(1)] = m.group(2) + l = lr.get() + + # 3) Disp + if format_name == 'Common': + common_desc = desc + else: + fields[format_name] = desc + except EndOfFile: + pass + + return (formats, fields) + +# Read kinds, kinds ranges and methods +def read_kinds(filename): + lr = linereader(filename) + kinds = [] + # Search for 'type Iir_Kind is' + while lr.get() != ' type ' + type_name + ' is\n': + pass + # Skip '(' + if lr.get() != ' (\n': + raise ParseError(lr, + 'no open parenthesis after "type ' + type_name +'"') + + # Read literals + pat_node = re.compile(' ' + prefix_name + '(\w+),?( +-- .*)?\n') + pat_comment = re.compile('( +-- .*)?\n') + while True: + l = lr.get() + if l == ' );\n': + break + m = pat_node.match(l) + if m: + kinds.append(m.group(1)) + continue + m = pat_comment.match(l) + if not m: + raise ParseError(lr, 'Unknow line within kind declaration') + + # Check subtypes + pat_subtype = re.compile(' subtype ' + prefix_range_name \ + + '(\w+) is ' + type_name + ' range\n') + pat_first = re.compile(' ' + prefix_name + '(\w+) ..\n') + pat_last = re.compile(' ' + prefix_name + '(\w+);\n') + pat_middle = re.compile(' --' + prefix_name + '(\w+)\n') + kinds_ranges={} + while True: + l = lr.get() + # Start of methods is also end of subtypes. + if l == ' -- General methods.\n': + break + # Found a subtype. + m = pat_subtype.match(l) + if m: + # Check first bound + name = m.group(1) + l = lr.get() + mf = pat_first.match(l) + if not mf: + raise ParseError(lr, 'badly formated first bound of subtype') + first = kinds.index(mf.group(1)) + idx = first + has_middle = None + # Read until last bound + while True: + l = lr.get() + ml = pat_middle.match(l) + if ml: + # Check element in the middle + if kinds.index(ml.group(1)) != idx + 1: + raise ParseError(lr, + "missing " + kinds[idx] + " in subtype") + has_middle = True + idx = idx + 1 + else: + # Check last bound + ml = pat_last.match(l) + if ml: + last = kinds.index(ml.group(1)) + if last != idx + 1 and has_middle: + raise ParseError(lr, + "missing " + kinds[idx] + " in subtype") + break + raise ParseError(lr, + "unhandled line in subtype") + kinds_ranges[name] = kinds[first:last+1] + + # Read functions + funcs = [] + pat_display = re.compile(' -- Display:(.*)\n') + pat_field = re.compile(' -- Field: (\w+)' + + '( Ref| Chain_Next| Chain)?( .*)?\n') + pat_conv = re.compile(' \((\w+)\)') + pat_func = \ + re.compile(' function Get_(\w+) \((\w+) : (\w+)\) return (\w+);\n') + pat_proc = \ + re.compile(' procedure Set_(\w+) \((\w+) : (\w+); (\w+) : (\w+)\);\n') + while True: + l = lr.get() + if l == 'end Iirs;\n': + break + md = pat_display.match(l) + if md: + display = md.group(1).split() + l = lr.get() + m = pat_field.match(l) + if not m: + raise ParseError(lr, 'Field: expected after Display:') + else: + display = [] + m = pat_field.match(l) + if m: + # Extract conversion + acc = m.group(2) + if acc: + acc = acc.strip() + conv = m.group(3) + if conv: + mc = pat_conv.match(conv) + if not mc: + raise ParseError(lr, 'conversion ill formed') + conv = mc.group(1) + if conv not in conversions: + raise ParseError(lr, 'unknown conversion ' + conv) + else: + conv = None + + # Read function + l = lr.get() + mf = pat_func.match(l) + if not mf: + raise ParseError(lr, + 'function declaration expected after Field') + # Read procedure + l = lr.get() + mp = pat_proc.match(l) + if not mp: + raise ParseError(lr, + 'procedure declaration expected after function') + # Consistency check between function and procedure + if mf.group(1) != mp.group(1): + raise ParseError(lr, 'function and procedure name mismatch') + if mf.group(2) != mp.group(2): + raise ParseError(lr, 'parameter name mismatch with function') + if mf.group(3) != mp.group(3): + raise ParseError(lr, 'parameter type mismatch with function') + if mf.group(4) != mp.group(5): + raise ParseError(lr, 'result type mismatch with function') + funcs.append(FuncDesc(mf.group(1), m.group(1), conv, acc, display, + mp.group(2), mp.group(3), + mp.group(4), mp.group(5))) + + return (kinds, kinds_ranges, funcs) + +# Read description for one node +def read_nodes_fields(lr, names, fields, nodes, funcs_dict): + pat_only = re.compile(' -- Only for ' + prefix_name + '(\w+):\n') + pat_field = re.compile(' -- Get/Set_(\w+) \((Alias )?(\w+)\)\n') + pat_comment = re.compile(' --.*\n') + pat_start = re.compile (' -- \w.*\n') + + # Create nodes + cur_nodes = [] + for (nm, fmt) in names: + if fmt not in fields: + raise ParseError(lr, 'unknown format') + n = NodeDesc(nm, fmt, {x: None for x in fields[fmt]}, {}) + nodes[nm] = n + cur_nodes.append(n) + + # Look for fields + only_nodes = cur_nodes + l = lr.l + while l != '\n': + # Handle 'Only ...' + while True: + m = pat_only.match(l) + if not m: + break + name = m.group(1) + if name not in [x.name for x in cur_nodes]: + raise ParseError(lr, 'node not currently described') + if only_nodes == cur_nodes: + only_nodes = [] + only_nodes.append(nodes[name]) + l = lr.get() + # Handle field + m = pat_field.match(l) + if m: + # 1) Check the function exists + func = m.group(1) + alias = m.group(2) + field = m.group(3) + if func not in funcs_dict: + raise ParseError(lr, 'unknown function') + func = funcs_dict[func] + if func.field != field: + raise ParseError(lr, 'field mismatch') + for c in only_nodes: + if field not in c.fields: + raise ParseError(lr, 'field does not exist in node') + if not alias: + if c.fields[field]: + raise ParseError(lr, 'field already used') + c.fields[field] = func + c.attrs[func.name] = func + only_nodes = cur_nodes + elif pat_start.match(l): + raise ParseError(lr, 'bad line in node description') + elif not pat_comment.match(l): + raise ParseError(lr, 'bad line in node description') + l = lr.get() + +# Read description for all nodes +def read_nodes(filename, kinds_ranges, fields, funcs): + lr = linereader(filename) + funcs_dict = {x.name:x for x in funcs} + nodes = {} + + # Skip until start + while lr.get() != ' -- Start of ' + type_name + '.\n': + pass + + pat_decl = re.compile(' -- ' + prefix_name + '(\w+) \((\w+)\)\n') + pat_decls = re.compile(' -- ' + prefix_range_name + '(\w+) \((\w+)\)\n') + pat_comment_line = re.compile(' --+\n') + pat_comment_box = re.compile(' --( .*)?\n') + while True: + l = lr.get() + if l == ' -- End of ' + type_name + '.\n': + return nodes + if l == '\n': + continue + m = pat_decl.match(l) + if m: + # List of nodes being described by the current description. + names = [] + + # Declaration of the first node + while True: + name=m.group(1) + fmt=m.group(2) + names.append((name,fmt)) + # There might be several nodes described at once. + l = lr.get() + m = pat_decl.match(l) + if not m: + break + read_nodes_fields(lr, names, fields, nodes, funcs_dict) + continue + m = pat_decls.match(l) + if m: + # List of nodes being described by the current description. + name=m.group(1) + fmt=m.group(2) + names = [(k,fmt) for k in kinds_ranges[name]] + l = lr.get() + read_nodes_fields(lr, names, fields, nodes, funcs_dict) + continue + if pat_comment_line.match(l) or pat_comment_box.match(l): + continue + raise ParseError(lr, 'bad line in node description') + return nodes + +# Generate a choice 'when A | B ... Z =>' using elements of CHOICES. +def gen_choices(choices): + is_first=True + for c in choices: + if is_first: + print ' ', + print 'when', + else: + print + print ' ', + print ' |', + print prefix_name + c, + is_first=None + print '=>' + +# Generate the Get_Format function. +def gen_get_format(formats, nodes, kinds): + print ' function Get_Format (Kind : ' + type_name + ') ' + \ + 'return Format_Type is' + print ' begin' + print ' case Kind is' + for f in formats: + choices = [k for k in kinds if nodes[k].format == f] + gen_choices(choices) + print ' return Format_' + f + ';' + print ' end case;' + print ' end Get_Format;' + +# Generate the Check_Kind_For_XXX function +def gen_check_kind(func, nodes, kinds): + pname = 'Target' + ptype = 'Iir' + print ' procedure Check_Kind_For_' + func.name + ' (' + pname \ + + ' : ' + ptype + ') is' + print ' begin' + print ' case Get_Kind (' + pname + ') is' + choices = [k for k in kinds if func.name in nodes[k].attrs] + gen_choices(choices) + print ' null;' + print ' when others =>' + print ' Failed ("' + func.name + '", ' + pname + ');' + print ' end case;' + print ' end Check_Kind_For_' + func.name + ';' + print + +def gen_subprg_header(decl): + if len(decl) < 76: + print decl + ' is' + else: + print decl + print ' is' + print ' begin' + +# Generate Get_XXX/Set_XXX subprograms for FUNC. +def gen_get_set(func, nodes, fields): + g = 'Get_' + func.field + ' (' + func.pname + ')' + s = func.rname + if func.conv: + field_type = None + for fld in fields.values(): + if func.field in fld: + field_type = fld[func.field] + break + if func.conv == 'uc': + g = field_type + '_To_' + func.rtype + ' (' + g + ')' + s = func.rtype + '_To_' + field_type + ' (' + s + ')' + elif func.conv == 'pos': + g = func.rtype + "'Val (" + g + ')' + s = func.rtype + "'Pos (" + s + ')' + + subprg = ' function Get_' + func.name + ' (' + func.pname \ + + ' : ' + func.ptype + ') return ' + func.rtype + gen_subprg_header(subprg) + print ' Check_Kind_For_' + func.name + ' (' + func.pname + ');' + print ' return ' + g + ';' + print ' end Get_' + func.name + ';' + print + subprg = ' procedure Set_' + func.name + ' (' \ + + func.pname + ' : ' + func.ptype + '; ' \ + + func.rname + ' : ' + func.rtype + ')' + gen_subprg_header(subprg) + print ' Check_Kind_For_' + func.name + ' (' + func.pname + ');' + print ' Set_' + func.field + ' (' + func.pname + ', ' \ + + s + ');' + print ' end Set_' + func.name + ';' + print + +def gen_image_field(func, param): + getter = 'Get_' + func.name + ' (' + param + ')' + if 'Image' in func.display: + return func.rtype + '\'Image (' + getter + ')' + else: + return 'Image_' + func.rtype + ' (' + getter + ')' + +def gen_disp_header(kinds, nodes): + print ' procedure Disp_Header (N : Iir) is' + print ' begin' + print ' if N = Null_Iir then' + print ' Put_Line ("*null*");' + print ' return;' + print ' end if;' + print + print ' case Get_Kind (N) is' + for k in kinds: + inlines = [f for f in nodes[k].attrs.values() if 'Inline' in f.display] + if len(inlines) > 1: + raise Error + print ' when ' + prefix_name + k + ' =>' + if inlines: + print ' Put ("' + k.lower() + ' " &' + print ' ' + \ + gen_image_field(inlines[0], 'N') + ');' + else: + print ' Put ("' + k.lower() + '");' + print ' end case;' + print ' Put (\' \');' + print ' Disp_Iir_Number (N);' + print ' New_Line;' + print ' end Disp_Header;' + print + +def funcs_of_node(n): + return sorted([fv.name for fv in n.fields.values() if fv]) + +def gen_disp(kinds, nodes): + print ' procedure Disp_Iir (N : Iir;' + print ' Indent : Natural := 1;' + print ' Flat : Boolean := False)' + print ' is' + print ' Sub_Indent : constant Natural := Indent + 1;' + print ' begin' + print ' Disp_Header (N);' + print + print ' if Flat or else N = Null_Iir then' + print ' return;' + print ' end if;' + print + print ' Header ("location: ", Indent);' + print ' Put_Line (Image_Location_Type (Get_Location (N)));' + print + print ' -- Protect against infinite recursions.' + print ' if Indent > 20 then' + print ' Put_Indent (Indent);' + print ' Put_Line ("...");' + print ' return;' + print ' end if;' + print + print ' case Get_Kind (N) is' + done = [] + for k in kinds: + if k in done: + continue + v = nodes[k] + # Find other kinds with the same set of functions. + vfuncs = funcs_of_node(v) + ks = [k1 for k1 in kinds if \ + k1 not in done and funcs_of_node(nodes[k1]) == vfuncs] + gen_choices(ks) + done += ks + flds = [fk for fk, fv in v.fields.items() if fv] + if flds: + for fk in sorted(flds): + func = v.fields[fk] + if func.acc == 'Chain_Next': + continue + print ' ' + \ + 'Header ("' + func.name.lower() + ': ", Indent);' + str = ' ' + if func.acc == 'Chain': + str += 'Disp_Chain (Get_' + func.name \ + + ' (N), Sub_Indent);' + print str + elif func.rtype in [ 'Iir', 'Iir_List', 'PSL_Node', 'PSL_NFA' ]: + str += 'Disp_' + func.rtype + \ + ' (Get_' + func.name + ' (N), Sub_Indent' + if func.acc == 'Ref': + str += ', True' + str += ');' + print str + else: + str += 'Put_Line (' + if len(func.rtype) <= 20: + str += gen_image_field(func, 'N') + print str + ');' + else: + # Inline version due to length + str += 'Image_' + func.rtype + print str + print ' (' + \ + 'Get_' + func.name + ' (N)));' + else: + print ' null;' + print ' end case;' + print ' end Disp_Iir;' + print + +def gen_mark(kinds, nodes): + print ' procedure Mark_Iir (N : Iir) is' + print ' begin' + print ' if N = Null_Iir then' + print ' return;' + print ' elsif Markers (N) then' + print ' Already_Marked (N);' + print ' return;' + print ' else' + print ' Markers (N) := True;' + print ' end if;' + print + print ' case Get_Kind (N) is' + done = [] + for k in kinds: + if k in done: + continue + v = nodes[k] + # Find other kinds with the same set of functions. + vfuncs = funcs_of_node(v) + ks = [k1 for k1 in kinds if \ + k1 not in done and funcs_of_node(nodes[k1]) == vfuncs] + gen_choices(ks) + done += ks + flds = [fk for fk, fv in v.fields.items() if fv] + empty = True + for fk in sorted(flds): + func = v.fields[fk] + if func.acc in ['Ref', 'Chain_Next']: + continue + elif func.acc in [ 'Chain' ]: + print ' ' + \ + 'Mark_Chain (Get_' + func.name + ' (N));' + empty = False + elif func.rtype in [ 'Iir', 'Iir_List', 'PSL_Node', 'PSL_NFA' ]: + print ' ' + \ + 'Mark_' + func.rtype + ' (Get_' + func.name + ' (N));' + empty = False + if empty: + print ' null;' + print ' end case;' + print ' end Mark_Iir;' + print + +parser = argparse.ArgumentParser(description='Meta-grammar processor') +parser.add_argument('action', choices=['disp-nodes', 'disp-kinds', + 'disp-fields', 'disp-funcs', + 'disp_tree', 'mark_tree', + 'get_format', 'body'], + default='disp-nodes') +args = parser.parse_args() + +try: + (formats, fields) = read_fields(field_file) + (kinds, kinds_ranges, funcs) = read_kinds(spec_file) + nodes = read_nodes(spec_file,kinds_ranges,fields,funcs) + +except ParseError as e: + print >> sys.stderr, e + print >> sys.stderr, \ + "in {0}:{1}:{2}".format(e.lr.filename, e.lr.lineno, e.lr.l) + sys.exit(1) + +if args.action == 'disp-fields': + for fmt in fields: + print "Fields of Format_"+fmt + fld=fields[fmt] + for k in fld: + print ' ' + k + ' (' + fld[k] + ')' +elif args.action == 'disp-kinds': + print "Kinds are:" + for k in kinds: + print ' ' + prefix_name + k +elif args.action == 'disp-funcs': + print "Functions are:" + for f in funcs: + s = '{0} ({1}'.format(f.name, f.field) + if f.acc: + s += ' acc:' + f.acc + if f.conv: + s += ' conv:' + f.conv + s += ')' + print s +elif args.action == 'disp-nodes': + for k in kinds: + v = nodes[k] + print prefix_name + k + ' (' + v.format + ')' + flds = [fk for fk, fv in v.fields.items() if fv] + for fk in sorted(flds): + print ' ' + fk + ': '+ v.fields[fk].name +elif args.action == 'get_format': + gen_get_format(formats, nodes) +elif args.action == 'body': + lr = linereader(template_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_get_format(formats, nodes, kinds) + print + for f in funcs: + gen_check_kind(f, nodes, kinds) + gen_get_set(f, nodes, fields) + if l[0:3] == 'end': + break +elif args.action == 'disp_tree': + lr = linereader(template_disp_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_disp_header(kinds, nodes) + gen_disp(kinds, nodes) + if l[0:3] == 'end': + break +elif args.action == 'mark_tree': + lr = linereader(template_mark_file) + while True: + l = lr.get().rstrip() + print l + if l == ' -- Subprograms': + gen_mark(kinds,nodes) + if l[0:3] == 'end': + break |