---------------------------------------- ---------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- OCARINA.GENERATORS.ADA_TREE.GENERATOR -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2007, GET-Telecom Paris. -- -- -- -- Ocarina is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. Ocarina 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 distributed with Ocarina; see file COPYING. -- -- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- Ocarina is maintained by the Ocarina team -- -- (ocarina-users@listes.enst.fr) -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Output; use Output; with Utils; use Utils; with GNAT.OS_Lib; use GNAT.OS_Lib; with Ocarina.Generators.Utils; with Ocarina.Generators.Ada_Tree.Nodes; with Ocarina.Generators.Ada_Tree.Nutils; with Ocarina.Generators.Ada_Values; package body Ocarina.Generators.Ada_Tree.Generator is use Ocarina.Generators.Utils; use Ocarina.Generators.Ada_Tree.Nodes; use Ocarina.Generators.Ada_Tree.Nutils; use Ocarina.Generators.Ada_Values; procedure Generate_Access_Type_Definition (N : node_id); procedure Generate_Ada_Comment (N : node_id); procedure Generate_QoS_Distributed_Application (N : node_id); procedure Generate_QoS_Node (N : node_id); procedure Generate_HI_Distributed_Application (N : node_id); procedure Generate_HI_Node (N : node_id); procedure Generate_Unit_Packages (N : node_id); procedure Generate_Array_Aggregate (N : node_id); procedure Generate_Array_Type_Definition (N : node_id); procedure Generate_Assignment_Statement (N : node_id); procedure Generate_Attribute_Designator (N : node_id); procedure Generate_Attribute_Definition_Clause (N : node_id); procedure Generate_Block_Statement (N : node_id); procedure Generate_Case_Label (N : node_id); procedure Generate_Case_Statement (N : node_id); procedure Generate_Component_Association (N : node_id); procedure Generate_Component_Declaration (N : node_id); procedure Generate_Decimal_Type_Definition (N : node_id); procedure Generate_Defining_Identifier (N : node_id); procedure Generate_Delay_Statement (N : node_id); procedure Generate_Derived_Type_Definition (N : node_id); procedure Generate_Designator (N : node_id); procedure Generate_Element_Association (N : node_id); procedure Generate_Elsif_Statement (N : node_id); procedure Generate_Enumeration_Type_Definition (N : node_id); procedure Generate_Enumeration_Representation_Clause (N : node_id); procedure Generate_Exception_Declaration (N : node_id); procedure Generate_Explicit_Dereference (N : node_id); procedure Generate_Expression (N : node_id); procedure Generate_For_Statement (N : node_id); procedure Generate_Full_Type_Declaration (N : node_id); procedure Generate_If_Statement (N : node_id); procedure Generate_Literal (N : node_id); procedure Generate_Loop_Statement (N : node_id); procedure Generate_Main_Subprogram_Implementation (N : node_id); procedure Generate_Null_Statement; procedure Generate_Object_Declaration (N : node_id); procedure Generate_Object_Instantiation (N : node_id); procedure Generate_Package_Declaration (N : node_id); procedure Generate_Package_Implementation (N : node_id); procedure Generate_Package_Instantiation (N : node_id); procedure Generate_Package_Specification (N : node_id); procedure Generate_Parameter (N : node_id); procedure Generate_Parameter_Association (N : node_id); procedure Generate_Parameter_List (L : list_id); procedure Generate_Pragma_Statement (N : node_id); procedure Generate_Protected_Object_Spec (N : node_id); procedure Generate_Protected_Object_Body (N : node_id); procedure Generate_Qualified_Expression (N : node_id); procedure Generate_Range_Constraint (N : node_id); procedure Generate_Raise_Statement (N : node_id); procedure Generate_Record_Aggregate (N : node_id); procedure Generate_Record_Definition (N : node_id); procedure Generate_Record_Type_Definition (N : node_id); procedure Generate_Private_Type_Definition (N : node_id); procedure Generate_Return_Statement (N : node_id); procedure Generate_Selected_Component (N : node_id); procedure Generate_Subprogram_Call (N : node_id); procedure Generate_Subprogram_Implementation (N : node_id); procedure Generate_Subprogram_Specification (N : node_id); procedure Generate_Used_Type (N : node_id); procedure Generate_Used_Package (N : node_id); procedure Generate_Type_Conversion (N : node_id); procedure Generate_Variant_Part (N : node_id); procedure Generate_Withed_Package (N : node_id); procedure Write (T : token_type); procedure Write_Line (T : token_type); procedure Generate_Statement_Delimiter (N : node_id); procedure Generate_Comment_Box (M : name_id); type pragma_w is (w_on, w_off); procedure Generate_Pragma_Warnings (W : pragma_w); -- Generate pragma Warnings (Off|On); -- The entities declared below are relared to the package -- generation in different files function Get_File_Name (N : node_id) return name_id; -- Generate an Ada file name from the package node given as -- parameter procedure Release_Output (Fd : File_Descriptor); -- Releases the output by closing the opened files function Set_Output (N : node_id) return File_Descriptor; -- Adjust the output depending on the command line options and -- return a file descriptor in order to be able to close it. ------------------- -- Get_File_Name -- ------------------- function Get_File_Name (N : node_id) return name_id is pragma assert (Kind (N) = k_package_specification or else Kind (N) = k_package_implementation or else Kind (N) = k_subprogram_specification or else Kind (N) = k_subprogram_implementation); Package_Spec_Suffix : constant String := ".ads"; Package_Body_Suffix : constant String := ".adb"; begin -- The File name corresponding to a package is the lowerd filly -- qualified name of the package. All '.' separators are -- replaced by '-'. if Kind (N) = k_subprogram_implementation or else Kind (N) = k_subprogram_specification then -- If the user supplied a custom file name, we use it if Has_Custom_File_Name (Main_Subprogram_Unit (N)) then Get_Name_String (File_Name (Main_Subprogram_Unit (N))); else Get_Name_String (Conventional_Base_Name (Fully_Qualified_Name (Defining_Identifier (Main_Subprogram_Unit (N))))); end if; else if Has_Custom_File_Name (Package_Declaration (N)) then Get_Name_String (File_Name (Package_Declaration (N))); else Get_Name_String (Conventional_Base_Name (Fully_Qualified_Name (Defining_Identifier (Package_Declaration (N))))); end if; end if; -- Adding file suffix if Kind (N) = k_package_specification or else Kind (N) = k_subprogram_specification then Add_Str_To_Name_Buffer (Package_Spec_Suffix); else Add_Str_To_Name_Buffer (Package_Body_Suffix); end if; return Name_Find; end Get_File_Name; ---------------- -- Set_Output -- ---------------- function Set_Output (N : node_id) return File_Descriptor is begin if not Print_On_Stdout then declare File_Name : constant name_id := Get_File_Name (N); Fd : File_Descriptor; begin Get_Name_String (File_Name); -- Create a new file and overwrites existing file with -- the same name Fd := Create_File (Name_Buffer (1 .. Name_Len), Text); if Fd = Invalid_FD then raise Program_Error; end if; -- Setting the output Set_Output (Fd); return Fd; end; end if; return Invalid_FD; end Set_Output; -------------------- -- Release_Output -- -------------------- procedure Release_Output (Fd : File_Descriptor) is begin if not Print_On_Stdout and then Fd /= Invalid_FD then Close (Fd); Set_Standard_Output; end if; end Release_Output; -------------- -- Generate -- -------------- procedure Generate (N : node_id) is begin case Kind (N) is when k_private_type_definition => Generate_Private_Type_Definition (N); when k_access_type_definition => Generate_Access_Type_Definition (N); when k_ada_comment => Generate_Ada_Comment (N); when k_qos_distributed_application => Generate_QoS_Distributed_Application (N); when k_qos_node => Generate_QoS_Node (N); when k_hi_distributed_application => Generate_HI_Distributed_Application (N); when k_hi_node => Generate_HI_Node (N); when k_qos_unit | k_hi_unit => Generate_Unit_Packages (N); when k_array_aggregate => Generate_Array_Aggregate (N); when k_array_type_definition => Generate_Array_Type_Definition (N); when k_assignment_statement => Generate_Assignment_Statement (N); when k_attribute_definition_clause => Generate_Attribute_Definition_Clause (N); when k_attribute_designator => Generate_Attribute_Designator (N); when k_block_statement => Generate_Block_Statement (N); when k_case_label => Generate_Case_Label (N); when k_case_statement => Generate_Case_Statement (N); when k_component_association => Generate_Component_Association (N); when k_component_declaration => Generate_Component_Declaration (N); when k_decimal_type_definition => Generate_Decimal_Type_Definition (N); when k_defining_identifier => Generate_Defining_Identifier (N); when k_delay_statement => Generate_Delay_Statement (N); when k_derived_type_definition => Generate_Derived_Type_Definition (N); when k_designator => Generate_Designator (N); when k_element_association => Generate_Element_Association (N); when k_elsif_statement => Generate_Elsif_Statement (N); when k_enumeration_type_definition => Generate_Enumeration_Type_Definition (N); when k_enumeration_representation_clause => Generate_Enumeration_Representation_Clause (N); when k_exception_declaration => Generate_Exception_Declaration (N); when k_explicit_dereference => Generate_Explicit_Dereference (N); when k_expression => Generate_Expression (N); when k_for_statement => Generate_For_Statement (N); when k_full_type_declaration => Generate_Full_Type_Declaration (N); when k_if_statement => Generate_If_Statement (N); when k_literal => Generate_Literal (N); when k_loop_statement => Generate_Loop_Statement (N); when k_main_subprogram_implementation => Generate_Main_Subprogram_Implementation (N); when k_null_statement => Generate_Null_Statement; when k_object_declaration => Generate_Object_Declaration (N); when k_object_instantiation => Generate_Object_Instantiation (N); when k_package_declaration => Generate_Package_Declaration (N); when k_package_implementation => Generate_Package_Implementation (N); when k_package_instantiation => Generate_Package_Instantiation (N); when k_package_specification => Generate_Package_Specification (N); when k_parameter_association => Generate_Parameter_Association (N); when k_pragma_statement => Generate_Pragma_Statement (N); when k_protected_object_spec => Generate_Protected_Object_Spec (N); when k_protected_object_body => Generate_Protected_Object_Body (N); when k_qualified_expression => Generate_Qualified_Expression (N); when k_range_constraint => Generate_Range_Constraint (N); when k_raise_statement => Generate_Raise_Statement (N); when k_record_aggregate => Generate_Record_Aggregate (N); when k_record_definition => Generate_Record_Definition (N); when k_record_type_definition => Generate_Record_Type_Definition (N); when k_return_statement => Generate_Return_Statement (N); when k_selected_component => Generate_Selected_Component (N); when k_subprogram_call => Generate_Subprogram_Call (N); when k_subprogram_specification => Generate_Subprogram_Specification (N); when k_subprogram_implementation => Generate_Subprogram_Implementation (N); when k_type_conversion => Generate_Type_Conversion (N); when k_used_type => Generate_Used_Type (N); when k_used_package => Generate_Used_Package (N); when k_variant_part => Generate_Variant_Part (N); when k_withed_package => Generate_Withed_Package (N); when k_boolean .. k_string => Write_Name (Image (base_type (N))); when others => null; end case; end Generate; -------------------------------------- -- Generate_Private_Type_Definition -- -------------------------------------- procedure Generate_Private_Type_Definition (N : node_id) is pragma unreferenced (N); begin Write (tok_private); end Generate_Private_Type_Definition; ------------------------------------- -- Generate_Access_Type_Definition -- ------------------------------------- procedure Generate_Access_Type_Definition (N : node_id) is begin if Is_Not_Null (N) then Write (tok_not); Write_Space; Write (tok_null); Write_Space; end if; Write (tok_access); Write_Space; if Is_All (N) then Write (tok_all); Write_Space; end if; if Is_Constant (N) then Write (tok_constant); Write_Space; end if; Generate (Subtype_Indication (N)); end Generate_Access_Type_Definition; -------------------------- -- Generate_Ada_Comment -- -------------------------- procedure Generate_Ada_Comment (N : node_id) is -- This procedure does the following: -- * It generates an ada comment basing on the name of node N -- * If the name it too long, and depending on the location of -- the comment in the source code, the procedure splits the -- comment into more than a line. -- The comment is assumed to be a sequence of caracters, -- beginning and ending with a NON-SPACE caracter. -- A word is: -- a space character, or else a sequence of non space -- characters located between two spaces. -- The maximum length of a line, in colums Max_Line_Length : constant Natural := 78; function Are_There_More_Words return Boolean; -- This function returns True if there are words in the buffer function Next_Word_Length return Natural; -- This function returns the size of the next word to be -- got. It returns zero when the buffer is empty. function Get_Next_Word return String; -- This function extracts the next word from the buffer procedure Skip_Next_Word; -- Skips the next word -------------------------- -- Are_There_More_Words -- -------------------------- function Are_There_More_Words return Boolean is begin return (Name_Len /= 0); end Are_There_More_Words; ---------------------- -- Next_Word_Length -- ---------------------- function Next_Word_Length return Natural is L : Natural; begin if not Are_There_More_Words then L := 0; elsif Name_Buffer (1) = ' ' then L := 1; else L := 0; while L + 1 <= Name_Len and then Name_Buffer (L + 1) /= ' ' loop L := L + 1; end loop; end if; return L; end Next_Word_Length; ------------------- -- Get_Next_Word -- ------------------- function Get_Next_Word return String is L : constant Natural := Next_Word_Length; begin if L = 0 then return ""; else declare Next_Word : constant String := Name_Buffer (1 .. L); begin if Name_Len = L then Name_Len := 0; else Set_Str_To_Name_Buffer (Name_Buffer (L + 1 .. Name_Len)); end if; return Next_Word; end; end if; end Get_Next_Word; -------------------- -- Skip_Next_Word -- -------------------- procedure Skip_Next_Word is begin if Name_Len = Next_Word_Length then Name_Len := 0; elsif Next_Word_Length > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Next_Word_Length + 1 .. Name_Len)); end if; end Skip_Next_Word; First_Line : Boolean := True; Used_Columns : Natural; begin Get_Name_String (Name (Defining_Identifier (N))); while Are_There_More_Words loop Used_Columns := N_Space; if First_Line then First_Line := False; else Write_Indentation; end if; -- We consume 4 colums Used_Columns := Used_Columns + 2; Write_Str ("--"); if Has_Header_Spaces (N) then Used_Columns := Used_Columns + 2; Write_Str (" "); end if; -- If the first word of the line, would be a space, skip it if Next_Word_Length = 1 and then Name_Buffer (1) = ' ' then Skip_Next_Word; end if; Used_Columns := Used_Columns + Next_Word_Length; Write_Str (Get_Next_Word); while Are_There_More_Words and then (Used_Columns + Next_Word_Length < Max_Line_Length) loop Used_Columns := Used_Columns + Next_Word_Length; Write_Str (Get_Next_Word); end loop; if Are_There_More_Words then Write_Eol; end if; end loop; end Generate_Ada_Comment; ------------------------------------------ -- Generate_QoS_Distributed_Application -- ------------------------------------------ procedure Generate_QoS_Distributed_Application (N : node_id) is P : node_id := First_Node (QoS_Nodes (N)); Application_Directory : name_id; begin -- Create the application directory (a lower case string) Get_Name_String (Name (N)); Application_Directory := To_Lower (Name_Find); Create_Directory (Application_Directory); -- Process the application nodes Enter_Directory (Application_Directory); while Present (P) loop Generate (P); P := Next_Node (P); end loop; Leave_Directory; end Generate_QoS_Distributed_Application; ----------------------- -- Generate_QoS_Node -- ----------------------- procedure Generate_QoS_Node (N : node_id) is U : node_id := First_Node (Units (N)); Partition_Directory : constant name_id := To_Lower (Name (N)); begin -- Create the partition directory Create_Directory (Partition_Directory); Enter_Directory (Partition_Directory); while Present (U) loop Generate (U); U := Next_Node (U); end loop; Leave_Directory; end Generate_QoS_Node; ---------------------------- -- Generate_Unit_Packages -- ---------------------------- procedure Generate_Unit_Packages (N : node_id) is P : node_id := First_Node (Packages (N)); begin while Present (P) loop Generate (P); P := Next_Node (P); end loop; end Generate_Unit_Packages; ------------------------------ -- Generate_Array_Aggregate -- ------------------------------ procedure Generate_Array_Aggregate (N : node_id) is E : node_id; begin Write (tok_left_paren); E := First_Node (Elements (N)); loop Generate (E); E := Next_Node (E); exit when No (E); Write (tok_comma); Write_Eol; Write_Indentation; end loop; Write (tok_right_paren); end Generate_Array_Aggregate; ------------------------------------ -- Generate_Array_Type_Definition -- ------------------------------------ procedure Generate_Array_Type_Definition (N : node_id) is R : node_id; begin Write (tok_array); Write_Space; Write (tok_left_paren); R := First_Node (Range_Constraints (N)); loop Generate (R); R := Next_Node (R); exit when No (R); Write (tok_comma); Write_Space; end loop; Write (tok_right_paren); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_of); Write_Space; if Aliased_Present (N) then Write (tok_aliased); Write_Space; end if; Generate (Component_Definition (N)); Decrement_Indentation; end Generate_Array_Type_Definition; ----------------------------------- -- Generate_Assignment_Statement -- ----------------------------------- procedure Generate_Assignment_Statement (N : node_id) is begin Generate (Defining_Identifier (N)); Write_Space; Write (tok_colon_equal); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Expression (N)); Decrement_Indentation; end Generate_Assignment_Statement; ------------------------------------------ -- Generate_Attribute_Definition_Clause -- ------------------------------------------ procedure Generate_Attribute_Definition_Clause (N : node_id) is begin Write (tok_for); Write_Space; Write_Name (Name (Defining_Identifier (N))); Write (tok_apostrophe); Write_Name (Attribute_Designator (N)); Write_Space; Write (tok_use); Write_Space; Generate (Expression (N)); end Generate_Attribute_Definition_Clause; ----------------------------------- -- Generate_Attribute_Designator -- ----------------------------------- procedure Generate_Attribute_Designator (N : node_id) is begin Generate (Prefix (N)); Write (tok_apostrophe); Write_Name (Name (N)); end Generate_Attribute_Designator; ------------------------------ -- Generate_Block_Statement -- ------------------------------ procedure Generate_Block_Statement (N : node_id) is D : node_id; begin if Present (Defining_Identifier (N)) then Write_Eol; Decrement_Indentation; Write_Indentation (-1); Increment_Indentation; Generate (Defining_Identifier (N)); Write_Line (tok_colon); Write_Indentation; end if; if not Is_Empty (Declarative_Part (N)) then Write (tok_declare); Write_Eol; Increment_Indentation; D := First_Node (Declarative_Part (N)); loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); exit when No (D); end loop; Decrement_Indentation; Write_Indentation; end if; Write (tok_begin); Write_Eol; Increment_Indentation; D := First_Node (Statements (N)); loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); exit when No (D); end loop; Decrement_Indentation; Write_Indentation; if not Is_Empty (Exception_Handler (N)) then declare Excp_Handler_Alternative : node_id; begin Write (tok_exception); Write_Eol; Increment_Indentation; -- Generation of the exception handler Write_Indentation; Excp_Handler_Alternative := First_Node (Exception_Handler (N)); while Present (Excp_Handler_Alternative) loop Write (tok_when); Write_Space; -- Generate the different part of the component -- association but add a new line after "=>" Generate (Defining_Identifier (Excp_Handler_Alternative)); Write_Space; Write (tok_arrow); Write_Eol; Increment_Indentation; Write_Indentation; Generate (Expression (Excp_Handler_Alternative)); Generate_Statement_Delimiter (Expression (Excp_Handler_Alternative)); Decrement_Indentation; Excp_Handler_Alternative := Next_Node (Excp_Handler_Alternative); end loop; Decrement_Indentation; Write_Indentation; end; end if; Write (tok_end); end Generate_Block_Statement; ------------------------- -- Generate_Case_Label -- ------------------------- procedure Generate_Case_Label (N : node_id) is begin Write_Str (Image (Value (N))); end Generate_Case_Label; ----------------------------- -- Generate_Case_Statement -- ----------------------------- procedure Generate_Case_Statement (N : node_id) is D : node_id; M : node_id; begin Write (tok_case); Write_Space; Generate (Expression (N)); Write_Space; Write_Line (tok_is); D := First_Node (Case_Statement_Alternatives (N)); Increment_Indentation; while Present (D) loop if Is_Empty (Discret_Choice_List (D)) then Write_Indentation; Generate_Pragma_Warnings (w_off); Write_Line (tok_semicolon); end if; Write_Indentation; Write (tok_when); Write_Space; if not Is_Empty (Discret_Choice_List (D)) then M := First_Node (Discret_Choice_List (D)); loop Generate (M); M := Next_Node (M); exit when No (M); Write_Space; Write (tok_vertical_bar); Write_Space; end loop; Write_Space; Write_Line (tok_arrow); else Write (tok_others); Write_Space; Write_Line (tok_arrow); end if; Increment_Indentation; if Is_Empty (Statements (D)) then Write_Indentation; Write (tok_null); Write_Line (tok_semicolon); else M := First_Node (Statements (D)); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); M := Next_Node (M); end loop; end if; Decrement_Indentation; if Is_Empty (Discret_Choice_List (D)) then Write_Indentation; Generate_Pragma_Warnings (w_on); Write_Line (tok_semicolon); end if; Write_Eol; D := Next_Node (D); end loop; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write (tok_case); end Generate_Case_Statement; ------------------------------------ -- Generate_Component_Association -- ------------------------------------ procedure Generate_Component_Association (N : node_id) is begin -- If the developer gives a defining identifier, we generate -- it, else we assume that the developer wants to generate a -- "others => XXXX" statement. if Present (Defining_Identifier (N)) then Generate (Defining_Identifier (N)); else Write (tok_others); end if; Write_Space; Write (tok_arrow); Write_Space; Generate (Expression (N)); end Generate_Component_Association; ------------------------------------ -- Generate_Component_Declaration -- ------------------------------------ procedure Generate_Component_Declaration (N : node_id) is E : constant node_id := Expression (N); begin Generate (Defining_Identifier (N)); Write_Space; Write (tok_colon); Write_Space; if Aliased_Present (N) then Write (tok_aliased); Write_Space; end if; Generate (Subtype_Indication (N)); if Present (E) then Write_Space; Write (tok_colon_equal); Write_Space; Generate (E); end if; end Generate_Component_Declaration; -------------------------------------- -- Generate_Decimal_Type_Definition -- -------------------------------------- procedure Generate_Decimal_Type_Definition (N : node_id) is begin Write (tok_delta); Write_Space; Generate (Scale (N)); Write_Space; Write (tok_digits); Write_Space; Write_Str (Image (Total (N))); end Generate_Decimal_Type_Definition; ---------------------------------- -- Generate_Defining_Identifier -- ---------------------------------- procedure Generate_Defining_Identifier (N : node_id) is P : node_id; begin P := Parent_Unit_Name (N); if Present (P) then Generate (P); Write (tok_dot); end if; Write_Name (Name (N)); end Generate_Defining_Identifier; ------------------------------ -- Generate_Delay_Statement -- ------------------------------ procedure Generate_Delay_Statement (N : node_id) is begin Write (tok_delay); Write_Space; if Is_Until (N) then Write (tok_until); Write_Space; end if; Generate (Expression (N)); end Generate_Delay_Statement; -------------------------------------- -- Generate_Derived_Type_Definition -- -------------------------------------- procedure Generate_Derived_Type_Definition (N : node_id) is R : node_id; begin if Is_Abstract_Type (N) then Write (tok_abstract); Write_Space; end if; if not Is_Subtype (N) then Write (tok_new); Write_Space; end if; Generate (Subtype_Indication (N)); if Is_Private_Extention (N) then Write_Space; Write (tok_with); Write_Space; Write (tok_private); else R := Record_Extension_Part (N); if Present (R) then Write_Space; Write (tok_with); Write_Space; Generate (Record_Extension_Part (N)); end if; end if; end Generate_Derived_Type_Definition; ------------------------- -- Generate_Designator -- ------------------------- procedure Generate_Designator (N : node_id) is P : node_id; begin P := Parent_Unit_Name (N); if Present (P) then Generate (P); Write (tok_dot); end if; Write_Name (Name (Defining_Identifier (N))); if Is_All (N) then Write (tok_dot); Write (tok_all); end if; end Generate_Designator; ---------------------------------- -- Generate_Element_Association -- ---------------------------------- procedure Generate_Element_Association (N : node_id) is begin if Present (Index (N)) then Generate (Index (N)); else Write (tok_others); end if; Write_Space; Write (tok_arrow); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Expression (N)); Decrement_Indentation; end Generate_Element_Association; ------------------------------ -- Generate_Elsif_Statement -- ------------------------------ procedure Generate_Elsif_Statement (N : node_id) is D : node_id; begin Write (tok_elsif); Write_Space; Generate (Condition (N)); Write_Eol; Write_Indentation; Write_Line (tok_then); Increment_Indentation; D := First_Node (Then_Statements (N)); loop Write_Indentation; Generate (D); exit when No (Next_Node (D)); Generate_Statement_Delimiter (D); D := Next_Node (D); end loop; Decrement_Indentation; end Generate_Elsif_Statement; ------------------------------------------ -- Generate_Enumeration_Type_Definition -- ------------------------------------------ procedure Generate_Enumeration_Type_Definition (N : node_id) is E : node_id; begin Write (tok_left_paren); E := First_Node (Enumeration_Literals (N)); while Present (E) loop Generate (E); E := Next_Node (E); exit when No (E); Write_Line (tok_comma); Write_Indentation; end loop; Write (tok_right_paren); end Generate_Enumeration_Type_Definition; ------------------------------------------------ -- Generate_Enumeration_Representation_Clause -- ------------------------------------------------ procedure Generate_Enumeration_Representation_Clause (N : node_id) is begin Write (tok_for); Write_Space; Generate (Defining_Identifier (N)); Write_Space; Write (tok_use); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Array_Aggregate (N)); Decrement_Indentation; end Generate_Enumeration_Representation_Clause; ------------------------------------ -- Generate_Exception_Declaration -- ------------------------------------ procedure Generate_Exception_Declaration (N : node_id) is begin Write_Name (Name (Defining_Identifier (N))); Write_Space; Write (tok_colon); Write_Space; Write (tok_exception); if Present (Renamed_Entity (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_renames); Write_Space; Generate (Renamed_Entity (N)); Decrement_Indentation; end if; end Generate_Exception_Declaration; ----------------------------------- -- Generate_Explicit_Dereference -- ----------------------------------- procedure Generate_Explicit_Dereference (N : node_id) is begin Generate (Prefix (N)); Write (tok_dot); Write (tok_all); end Generate_Explicit_Dereference; ------------------------- -- Generate_Expression -- ------------------------- procedure Generate_Expression (N : node_id) is L_Expr : constant node_id := Left_Expr (N); Op : constant operator_id := Operator (N); R_Expr : constant node_id := Right_Expr (N); begin -- Each expression having a right part and a left part is -- systematically put between two parentheses. if No (R_Expr) then if Op = operator_type'pos (op_not) then Write (tok_not); Write_Space; elsif Op /= operator_type'pos (op_none) then Write_Name (Operator_Image (Standard.Integer (Op))); -- Do not generate space after a unary operator end if; else -- Expressions having "|" as operator (case switches -- alternatives) and expressions having "&" as operator -- (array concatenation) do not require parentheses. if Op /= operator_type'pos (op_vertical_bar) and then Op /= operator_type'pos (op_and_symbol) then Write (tok_left_paren); end if; end if; Generate (L_Expr); if Present (R_Expr) then Write_Eol; Increment_Indentation; Write_Indentation; Write_Name (Operator_Image (Standard.Integer (Op))); Write_Space; Generate (R_Expr); if Op /= operator_type'pos (op_vertical_bar) and then Op /= operator_type'pos (op_and_symbol) then Write (tok_right_paren); end if; Decrement_Indentation; end if; end Generate_Expression; ---------------------------- -- Generate_For_Statement -- ---------------------------- procedure Generate_For_Statement (N : node_id) is D : node_id := First_Node (Statements (N)); begin Write (tok_for); Write_Space; Write_Name (Name (Defining_Identifier (N))); Write_Space; Write (tok_in); Write_Space; Generate (First (Range_Constraint (N))); Write_Space; Write (tok_dot); Write (tok_dot); Write_Space; Generate (Last (Range_Constraint (N))); Write_Space; Write (tok_loop); Write_Eol; Increment_Indentation; while Present (D) loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); end loop; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write (tok_loop); end Generate_For_Statement; ------------------------------------ -- Generate_Full_Type_Declaration -- ------------------------------------ procedure Generate_Full_Type_Declaration (N : node_id) is D : constant node_id := Discriminant_Spec (N); begin if Is_Subtype (N) then Write (tok_subtype); else Write (tok_type); end if; Write_Space; Write_Name (Name (Defining_Identifier (N))); Write_Space; if Present (D) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); Generate (D); Write (tok_right_paren); Decrement_Indentation; Write_Eol; Write_Indentation; end if; if Type_Definition (N) /= No_Node then Write (tok_is); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Type_Definition (N)); Decrement_Indentation; else Write_Eol; end if; end Generate_Full_Type_Declaration; --------------------------- -- Generate_If_Statement -- --------------------------- procedure Generate_If_Statement (N : node_id) is T : constant list_id := Then_Statements (N); E : constant list_id := Else_Statements (N); I : node_id; begin -- Enter If_Statement Write (tok_if); Write_Space; Generate (Condition (N)); Write_Eol; Write_Indentation; Write (tok_then); Write_Eol; -- If_Statement cannot be empty. A null statement is always -- there if needed. Increment_Indentation; I := First_Node (T); while Present (I) loop Write_Indentation; Generate (I); Generate_Statement_Delimiter (I); I := Next_Node (I); end loop; Decrement_Indentation; -- Elsif_Statements if not Is_Empty (Elsif_Statements (N)) then I := First_Node (Elsif_Statements (N)); loop Write_Indentation; Generate (I); Generate_Statement_Delimiter (I); I := Next_Node (I); exit when No (I); end loop; end if; -- Else_Statement can be empty if not Is_Empty (E) then Write_Indentation; Write (tok_else); Write_Eol; Increment_Indentation; I := First_Node (E); while Present (I) loop Write_Indentation; Generate (I); Generate_Statement_Delimiter (I); I := Next_Node (I); end loop; Decrement_Indentation; end if; -- Leave If_Statement Write_Indentation; Write (tok_end); Write_Space; Write (tok_if); end Generate_If_Statement; ---------------------- -- Generate_Literal -- ---------------------- procedure Generate_Literal (N : node_id) is begin if Present (Parent_Designator (N)) then Generate (Parent_Designator (N)); Write (tok_dot); end if; Write_Str (Image (Value (N))); end Generate_Literal; ----------------------------- -- Generate_Loop_Statement -- ----------------------------- procedure Generate_Loop_Statement (N : node_id) is D : node_id := First_Node (Statements (N)); begin Write (tok_loop); Write_Eol; Increment_Indentation; while Present (D) loop Write_Indentation; Generate (D); Generate_Statement_Delimiter (D); D := Next_Node (D); end loop; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write (tok_loop); end Generate_Loop_Statement; --------------------------------------------- -- Generate_Main_Subprogram_Implementation -- --------------------------------------------- procedure Generate_Main_Subprogram_Implementation (N : node_id) is Fd : File_Descriptor; begin if Present (Subprogram_Specification (N)) then Fd := Set_Output (Subprogram_Specification (N)); Generate (Subprogram_Specification (N)); Generate_Statement_Delimiter (Subprogram_Specification (N)); Release_Output (Fd); end if; if Present (Subprogram_Implementation (N)) then Fd := Set_Output (Subprogram_Implementation (N)); Generate (Subprogram_Implementation (N)); Generate_Statement_Delimiter (Subprogram_Implementation (N)); Release_Output (Fd); end if; end Generate_Main_Subprogram_Implementation; ----------------------------- -- Generate_Null_Statement -- ----------------------------- procedure Generate_Null_Statement is begin Write (tok_null); end Generate_Null_Statement; --------------------------------- -- Generate_Object_Declaration -- --------------------------------- procedure Generate_Object_Declaration (N : node_id) is begin Name_Buffer (1 .. Var_Name_Len) := (others => ' '); Get_Name_String (Name (Defining_Identifier (N))); if Var_Name_Len > Name_Len then Name_Len := Var_Name_Len; end if; Write_Str (Name_Buffer (1 .. Name_Len)); Write_Space; Write (tok_colon); if Constant_Present (N) then Write_Space; Write (tok_constant); end if; if Aliased_Present (N) then Write_Space; Write (tok_aliased); end if; Write_Space; if Present (Object_Definition (N)) then Generate (Object_Definition (N)); else -- This workaround doesn't affect the classic object -- declaration because we must give a type. However it makes -- the generation of case statement and exception handlers -- simpler. Write (tok_others); end if; if Present (Discriminant_Spec (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Discriminant_Spec (N)); Decrement_Indentation; end if; if Present (Renamed_Entity (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_renames); Write_Space; Generate (Renamed_Entity (N)); Decrement_Indentation; -- If an object renames another object, it cannot be -- initialized, else if Present (Expression (N)) then Write_Space; Write (tok_colon_equal); Write_Eol; Increment_Indentation; Write_Indentation (-1); Generate (Expression (N)); Decrement_Indentation; end if; end if; end Generate_Object_Declaration; ----------------------------------- -- Generate_Object_Instantiation -- ----------------------------------- procedure Generate_Object_Instantiation (N : node_id) is begin Write (tok_new); Write_Space; Generate (Qualified_Expression (N)); end Generate_Object_Instantiation; ---------------------------------- -- Generate_Package_Declaration -- ---------------------------------- procedure Generate_Package_Declaration (N : node_id) is begin Generate (Package_Specification (N)); Generate (Package_Implementation (N)); end Generate_Package_Declaration; ------------------------------------- -- Generate_Package_Implementation -- ------------------------------------- procedure Generate_Package_Implementation (N : node_id) is P : node_id; Fd : File_Descriptor; begin -- If the user wants to generates only the spec, or if the -- package body is empty, we don't generate it. if Disable_Pkg_Body_Gen or else Is_Empty (Statements (N)) then return; end if; Fd := Set_Output (N); P := First_Node (Withed_Packages (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; Write_Eol; Write_Indentation; Write (tok_package); Write_Space; Write (tok_body); Write_Space; Generate (Defining_Identifier (Package_Declaration (N))); Write_Space; Write (tok_is); Write_Eol (2); Increment_Indentation; P := First_Node (Statements (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; Write_Indentation; if not Is_Empty (Package_Initialization (N)) then Write_Line (tok_begin); Increment_Indentation; P := First_Node (Package_Initialization (N)); loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); exit when No (P); end loop; Decrement_Indentation; Write_Indentation; end if; Write (tok_end); Write_Space; Generate (Defining_Identifier (Package_Declaration (N))); Generate_Statement_Delimiter (Defining_Identifier (Package_Declaration (N))); Release_Output (Fd); end Generate_Package_Implementation; ------------------------------------ -- Generate_Package_Instantiation -- ------------------------------------ procedure Generate_Package_Instantiation (N : node_id) is Param : node_id; begin Write (tok_package); Write_Space; Generate (Defining_Identifier (N)); Write_Space; Write (tok_is); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_new); Write_Space; Generate (Generic_Package (N)); if not Is_Empty (Parameter_List (N)) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); Param := First_Node (Parameter_List (N)); loop Generate (Param); Param := Next_Node (Param); exit when No (Param); Write_Line (tok_comma); Write_Indentation; end loop; Write (tok_right_paren); Decrement_Indentation; end if; Decrement_Indentation; end Generate_Package_Instantiation; ------------------------------------ -- Generate_Package_Specification -- ------------------------------------ procedure Generate_Package_Specification (N : node_id) is P : node_id; Fd : File_Descriptor; begin -- If the user wants to generates only the body, or if the -- package spec is empty, we don't generate it. if Disable_Pkg_Spec_Gen then return; end if; -- Do not generate empty non instanciated specs if not Is_Instantiated_Package (N) and then Is_Empty (Visible_Part (N)) and then Is_Empty (Private_Part (N)) then return; end if; Fd := Set_Output (N); P := First_Node (Withed_Packages (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; Write_Eol; if Is_Instantiated_Package (N) then Generate (Package_Instantiation (N)); Generate_Statement_Delimiter (Package_Instantiation (N)); else Write_Indentation; Write (tok_package); Write_Space; Generate (Defining_Identifier (Package_Declaration (N))); Write_Space; Write (tok_is); Write_Eol (2); Increment_Indentation; P := First_Node (Visible_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; if not Is_Empty (Private_Part (N)) then Write_Indentation; Write (tok_private); Write_Eol; Increment_Indentation; P := First_Node (Private_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; end if; Write_Indentation; Write (tok_end); Write_Space; Generate (Defining_Identifier (Package_Declaration (N))); Generate_Statement_Delimiter (Defining_Identifier (Package_Declaration (N))); end if; Release_Output (Fd); end Generate_Package_Specification; ------------------------ -- Generate_Parameter -- ------------------------ procedure Generate_Parameter (N : node_id) is begin Name_Buffer (1 .. Var_Name_Len) := (others => ' '); Get_Name_String (Name (Defining_Identifier (N))); if Var_Name_Len > Name_Len then Name_Len := Var_Name_Len; end if; Write_Str (Name_Buffer (1 .. Name_Len)); Write_Space; Write (tok_colon); Write_Space; if Kind (Parameter_Type (N)) /= k_access_type_definition then case Parameter_Mode (N) is when mode_in => null; when mode_out => Write (tok_out); Write_Space; when mode_inout => Write (tok_in); Write_Space; Write (tok_out); Write_Space; end case; end if; Generate (Parameter_Type (N)); if Present (Expression (N)) then Write_Space; Write_Line (tok_colon_equal); Increment_Indentation; Write_Indentation; Generate (Expression (N)); Decrement_Indentation; end if; end Generate_Parameter; ------------------------------------ -- Generate_Parameter_Association -- ------------------------------------ procedure Generate_Parameter_Association (N : node_id) is begin Generate (Selector_Name (N)); Write_Space; Write (tok_arrow); Write_Space; Generate (Actual_Parameter (N)); end Generate_Parameter_Association; ----------------------------- -- Generate_Parameter_List -- ----------------------------- procedure Generate_Parameter_List (L : list_id) is N : node_id; begin -- If we got there, then L is not empty. Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); N := First_Node (L); loop Generate_Parameter (N); exit when No (Next_Node (N)); Generate_Statement_Delimiter (N); Write_Indentation; N := Next_Node (N); end loop; Write (tok_right_paren); Decrement_Indentation; end Generate_Parameter_List; ------------------------------- -- Generate_Pragma_Statement -- ------------------------------- procedure Generate_Pragma_Statement (N : node_id) is Args : constant list_id := Nodes.Argument_List (N); Arg : node_id; begin Write (tok_pragma); Write_Space; Generate (Defining_Identifier (N)); if not Is_Empty (Args) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); Arg := First_Node (Args); loop Generate (Arg); Arg := Next_Node (Arg); exit when No (Arg); Write_Line (tok_comma); Write_Indentation; end loop; Write (tok_right_paren); Decrement_Indentation; end if; end Generate_Pragma_Statement; ------------------------------ -- Generate_Pragma_Warnings -- ------------------------------ procedure Generate_Pragma_Warnings (W : pragma_w) is begin Write (tok_pragma); Write_Space; Write_Name (GN (pragma_warnings)); Write_Space; Write (tok_left_paren); if W = w_on then Write_Str ("On"); else Write_Str ("Off"); end if; Write (tok_right_paren); end Generate_Pragma_Warnings; ------------------------------------ -- Generate_Protected_Object_Spec -- ------------------------------------ procedure Generate_Protected_Object_Spec (N : node_id) is P : node_id; begin Write (tok_protected); Write_Space; if Is_Type (N) then Write (tok_type); Write_Space; end if; Generate (Defining_Identifier (N)); Write_Space; Write (tok_is); Write_Eol; Increment_Indentation; P := First_Node (Visible_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; Decrement_Indentation; if not Is_Empty (Private_Part (N)) then Write_Indentation; Write (tok_private); Write_Eol; Increment_Indentation; P := First_Node (Private_Part (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); P := Next_Node (P); end loop; Decrement_Indentation; end if; Write_Indentation; Write (tok_end); Write_Space; Generate (Defining_Identifier (N)); end Generate_Protected_Object_Spec; ------------------------------------ -- Generate_Protected_Object_Body -- ------------------------------------ procedure Generate_Protected_Object_Body (N : node_id) is P : node_id; begin Write (tok_protected); Write_Space; Write (tok_body); Write_Space; Generate (Defining_Identifier (N)); Write_Space; Write (tok_is); Write_Eol; Increment_Indentation; P := First_Node (Statements (N)); while Present (P) loop Write_Indentation; Generate (P); Generate_Statement_Delimiter (P); Write_Eol; P := Next_Node (P); end loop; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Generate (Defining_Identifier (N)); end Generate_Protected_Object_Body; ----------------------------------- -- Generate_Qualified_Expression -- ----------------------------------- procedure Generate_Qualified_Expression (N : node_id) is begin Generate (Subtype_Mark (N)); Write_Line (tok_apostrophe); Increment_Indentation; Write_Indentation (-1); Generate (Aggregate (N)); Decrement_Indentation; end Generate_Qualified_Expression; ------------------------------- -- Generate_Range_Constraint -- ------------------------------- procedure Generate_Range_Constraint (N : node_id) is May_Be_Unconstrained : Boolean := False; begin if Present (Index_Type (N)) then Generate (Index_Type (N)); if Kind (Index_Type (N)) /= k_attribute_designator then May_Be_Unconstrained := True; Write_Space; Write (tok_range); Write_Space; end if; end if; if Present (First (N)) and then Present (Last (N)) then Generate (First (N)); Write_Space; Write (tok_dot); Write (tok_dot); Write_Space; Generate (Last (N)); elsif May_Be_Unconstrained then Write (tok_box); end if; end Generate_Range_Constraint; ------------------------------ -- Generate_Raise_Statement -- ------------------------------ procedure Generate_Raise_Statement (N : node_id) is E : constant node_id := Raised_Error (N); begin Write (tok_raise); if Present (E) then Write_Space; Generate (E); end if; end Generate_Raise_Statement; ------------------------------- -- Generate_Record_Aggregate -- ------------------------------- procedure Generate_Record_Aggregate (N : node_id) is L : list_id; M : node_id; begin L := Component_Association_List (N); Write (tok_left_paren); if not Is_Empty (L) then M := First_Node (L); loop Generate (M); M := Next_Node (M); exit when No (M); Write_Line (tok_comma); Write_Indentation; end loop; end if; Write (tok_right_paren); end Generate_Record_Aggregate; -------------------------------- -- Generate_Record_Definition -- -------------------------------- procedure Generate_Record_Definition (N : node_id) is L : constant list_id := Component_List (N); C : node_id; begin if Is_Empty (L) then Write (tok_null); Write_Space; Write (tok_record); else Write_Space; Write (tok_record); Write_Eol; Increment_Indentation; C := First_Node (L); while Present (C) loop Write_Indentation; Generate (C); Generate_Statement_Delimiter (C); C := Next_Node (C); end loop; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write (tok_record); end if; end Generate_Record_Definition; ------------------------------------- -- Generate_Record_Type_Definition -- ------------------------------------- procedure Generate_Record_Type_Definition (N : node_id) is R : node_id; begin if Is_Abstract_Type (N) then Write (tok_abstract); Write_Space; end if; if Is_Tagged_Type (N) then Write (tok_tagged); Write_Space; end if; if Is_Limited_Type (N) then Write (tok_limited); Write_Space; end if; R := Record_Definition (N); if Present (R) then Generate (R); end if; end Generate_Record_Type_Definition; ------------------------------- -- Generate_Return_Statement -- ------------------------------- procedure Generate_Return_Statement (N : node_id) is E : constant node_id := Expression (N); begin Write (tok_return); if Present (E) then Write_Space; Generate (E); end if; end Generate_Return_Statement; --------------------------------- -- Generate_Selected_Component -- --------------------------------- procedure Generate_Selected_Component (N : node_id) is begin Generate (Prefix (N)); Write (tok_dot); Generate (Selector_Name (N)); end Generate_Selected_Component; ------------------------------ -- Generate_Subprogram_Call -- ------------------------------ procedure Generate_Subprogram_Call (N : node_id) is L : constant list_id := Actual_Parameter_Part (N); P : node_id; begin Generate (Defining_Identifier (N)); if not Is_Empty (L) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); P := First_Node (L); loop Generate (P); P := Next_Node (P); exit when No (P); Write_Line (tok_comma); Write_Indentation; end loop; Write (tok_right_paren); Decrement_Indentation; end if; end Generate_Subprogram_Call; ---------------------------------------- -- Generate_Subprogram_Implementation -- ---------------------------------------- procedure Generate_Subprogram_Implementation (N : node_id) is D : constant list_id := Declarations (N); S : constant list_id := Statements (N); P : constant node_id := Specification (N); M : node_id; W : node_id; begin -- If we deal with a main subprogram, then we generate its -- withed packages if not Is_Empty (Withed_Packages (N)) then W := First_Node (Withed_Packages (N)); while Present (W) loop Generate (W); Generate_Statement_Delimiter (W); Write_Indentation; W := Next_Node (W); end loop; Write_Eol; Write_Indentation; end if; Generate_Comment_Box (Name (Defining_Identifier (P))); Write_Eol; Write_Indentation; Generate (P); if not Is_Empty (Parameter_Profile (P)) then Write_Eol; Write_Indentation; else Write_Space; end if; Write (tok_is); Write_Eol; if not Is_Empty (D) then Increment_Indentation; M := First_Node (D); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); M := Next_Node (M); end loop; Decrement_Indentation; end if; Write_Indentation; Write (tok_begin); Write_Eol; Increment_Indentation; if not Is_Empty (S) then M := First_Node (S); while Present (M) loop Write_Indentation; Generate (M); Generate_Statement_Delimiter (M); M := Next_Node (M); end loop; else Write_Indentation; Write (tok_null); Write_Line (tok_semicolon); end if; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write_Name (Name (Defining_Identifier (P))); end Generate_Subprogram_Implementation; --------------------------------------- -- Generate_Subprogram_Specification -- --------------------------------------- procedure Generate_Subprogram_Specification (N : node_id) is P : constant list_id := Parameter_Profile (N); T : constant node_id := Return_Type (N); R : constant node_id := Renamed_Entity (N); G : constant node_id := Instantiated_Entity (N); W : node_id; begin -- If we deal with a main subprogram, then we generate its -- withed packages if not Is_Empty (Withed_Packages (N)) then W := First_Node (Withed_Packages (N)); while Present (W) loop Generate (W); Generate_Statement_Delimiter (W); Write_Indentation; W := Next_Node (W); end loop; Write_Eol; Write_Indentation; end if; if Present (T) then Write (tok_function); else Write (tok_procedure); end if; -- This work around is used to define access subprogram types if Present (Defining_Identifier (N)) then Write_Space; Write_Name (Name (Defining_Identifier (N))); end if; if not Is_Empty (P) then Write_Eol; Generate_Parameter_List (P); end if; if Present (T) then if not Is_Empty (P) then Write_Eol; Increment_Indentation; Write_Indentation (-1); else Write_Space; end if; Write (tok_return); Write_Space; Generate (T); Decrement_Indentation; end if; if Present (R) then Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_renames); Write_Space; Generate (R); Decrement_Indentation; end if; if Present (G) then Write_Space; Write (tok_is); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_new); Write_Space; Generate (G); Decrement_Indentation; end if; end Generate_Subprogram_Specification; ------------------------------ -- Generate_Type_Conversion -- ------------------------------ procedure Generate_Type_Conversion (N : node_id) is begin Generate (Subtype_Mark (N)); Write_Eol; Increment_Indentation; Write_Indentation (-1); Write (tok_left_paren); Generate (Expression (N)); Write (tok_right_paren); Decrement_Indentation; end Generate_Type_Conversion; ------------------------ -- Generate_Used_Type -- ------------------------ procedure Generate_Used_Type (N : node_id) is begin Write (tok_use); Write_Space; Write (tok_type); Write_Space; Generate (The_Used_Entity (N)); end Generate_Used_Type; --------------------------- -- Generate_Used_Package -- --------------------------- procedure Generate_Used_Package (N : node_id) is begin Write (tok_use); Write_Space; Generate (The_Used_Entity (N)); end Generate_Used_Package; --------------------------- -- Generate_Variant_Part -- --------------------------- procedure Generate_Variant_Part (N : node_id) is V : node_id; C : node_id; O : node_id := No_Node; R : node_id; begin Write (tok_case); Write_Space; Generate (Discriminant (N)); Write_Space; Write (tok_is); Write_Eol; V := First_Node (Variants (N)); Increment_Indentation; while Present (V) loop C := First_Node (Discrete_Choices (V)); if No (C) or else (Kind (C) = k_literal and then Value (C) = No_Value) then O := V; else Write_Indentation; Write (tok_when); Write_Space; Increment_Indentation; loop Generate (C); C := Next_Node (C); if No (C) then Write_Space; Write (tok_arrow); Write_Eol; exit; end if; Write_Eol; Write_Indentation (-1); Write (tok_vertical_bar); Write_Space; end loop; Write_Indentation; if not Is_Empty (Component_List (V)) then R := First_Node (Component_List (V)); while Present (R) loop Generate (R); Generate_Statement_Delimiter (R); R := Next_Node (R); exit when No (R); Write_Indentation; end loop; else Write (tok_null); Write_Line (tok_semicolon); end if; Decrement_Indentation; end if; V := Next_Node (V); end loop; -- Add a "when others" clause either based on the "default" -- label or a null one. In case of null statement, add two -- pragmas to disable warnings and enable them after the -- addition of the null statement if No (O) then Write_Indentation; Generate_Pragma_Warnings (w_off); Write_Line (tok_semicolon); end if; Write_Indentation; Write (tok_when); Write_Space; Write (tok_others); Write_Space; Write (tok_arrow); Write_Eol; Increment_Indentation; Write_Indentation; if Present (O) then if not Is_Empty (Component_List (O)) then R := First_Node (Component_List (O)); while Present (R) loop Generate (R); Generate_Statement_Delimiter (R); R := Next_Node (R); end loop; else Write (tok_null); Write_Line (tok_semicolon); end if; else Write (tok_null); Generate_Statement_Delimiter (O); end if; Decrement_Indentation; if No (O) then Write_Indentation; Generate_Pragma_Warnings (w_on); Write_Line (tok_semicolon); end if; Decrement_Indentation; Write_Indentation; Write (tok_end); Write_Space; Write (tok_case); end Generate_Variant_Part; ----------------------------------------- -- Generate_HI_Distributed_Application -- ----------------------------------------- procedure Generate_HI_Distributed_Application (N : node_id) is P : node_id := First_Node (HI_Nodes (N)); Application_Directory : name_id; begin -- Create the application directory (a lower case string) Get_Name_String (Name (N)); Application_Directory := To_Lower (Name_Find); Create_Directory (Application_Directory); -- Process the application nodes Enter_Directory (Application_Directory); while Present (P) loop Generate (P); P := Next_Node (P); end loop; Leave_Directory; end Generate_HI_Distributed_Application; ---------------------- -- Generate_HI_Node -- ---------------------- procedure Generate_HI_Node (N : node_id) is U : node_id := First_Node (Units (N)); Partition_Directory : constant name_id := To_Lower (Name (N)); begin -- Create the node directory Create_Directory (Partition_Directory); Enter_Directory (Partition_Directory); while Present (U) loop Generate (U); U := Next_Node (U); end loop; Leave_Directory; end Generate_HI_Node; ----------------------------- -- Generate_Withed_Package -- ----------------------------- procedure Generate_Withed_Package (N : node_id) is begin Write (tok_with); Write_Space; Generate (Defining_Identifier (N)); if Used (N) then Write (tok_semicolon); Write_Eol; Write_Indentation; Write (tok_use); Write_Space; Generate (Defining_Identifier (N)); end if; if Warnings_Off (N) then Write (tok_semicolon); Write_Eol; Write_Indentation; Write (tok_pragma); Write_Space; Write_Str ("Warnings"); Write_Space; Write (tok_left_paren); Write_Str ("Off"); Write (tok_comma); Write_Space; Generate (Defining_Identifier (N)); Write (tok_right_paren); end if; if Elaborated (N) then Write (tok_semicolon); Write_Eol; Write_Indentation; Write (tok_pragma); Write_Space; Write_Str ("Elaborate_All"); Write_Space; Write (tok_left_paren); Generate (Defining_Identifier (N)); Write (tok_right_paren); end if; end Generate_Withed_Package; ----------- -- Write -- ----------- procedure Write (T : token_type) is begin Write_Name (Token_Image (T)); end Write; ---------------- -- Write_Line -- ---------------- procedure Write_Line (T : token_type) is begin Write (T); Write_Eol; end Write_Line; ---------------------------------- -- Generate_Statement_Delimiter -- ---------------------------------- procedure Generate_Statement_Delimiter (N : node_id) is begin if No (N) or else Kind (N) /= k_ada_comment then Write_Line (tok_semicolon); else Write_Eol; end if; end Generate_Statement_Delimiter; -------------------------- -- Generate_Comment_Box -- -------------------------- procedure Generate_Comment_Box (M : name_id) is begin Get_Name_String (M); for I in 1 .. Name_Len + 6 loop Write_Char ('-'); end loop; Write_Eol; Write_Indentation; Write_Str ("-- "); Write_Name (M); Write_Str (" -- "); Write_Eol; Write_Indentation; for I in 1 .. Name_Len + 6 loop Write_Char ('-'); end loop; Write_Eol; end Generate_Comment_Box; end Ocarina.Generators.Ada_Tree.Generator;