URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-pp.adb] - Rev 706
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . P P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT 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 GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Output; use Output; with Snames; package body Prj.PP is use Prj.Tree; Not_Tested : array (Project_Node_Kind) of Boolean := (others => True); procedure Indicate_Tested (Kind : Project_Node_Kind); -- Set the corresponding component of array Not_Tested to False. -- Only called by pragmas Debug. --------------------- -- Indicate_Tested -- --------------------- procedure Indicate_Tested (Kind : Project_Node_Kind) is begin Not_Tested (Kind) := False; end Indicate_Tested; ------------------ -- Pretty_Print -- ------------------ procedure Pretty_Print (Project : Prj.Tree.Project_Node_Id; In_Tree : Prj.Tree.Project_Node_Tree_Ref; Increment : Positive := 3; Eliminate_Empty_Case_Constructions : Boolean := False; Minimize_Empty_Lines : Boolean := False; W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; Backward_Compatibility : Boolean; Id : Prj.Project_Id := Prj.No_Project; Max_Line_Length : Max_Length_Of_Line := Max_Length_Of_Line'Last) is procedure Print (Node : Project_Node_Id; Indent : Natural); -- A recursive procedure that traverses a project file tree and outputs -- its source. Current_Prj is the project that we are printing. This -- is used when printing attributes, since in nested packages they -- need to use a fully qualified name. procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural); -- Outputs an attribute name, taking into account the value of -- Backward_Compatibility. procedure Output_Name (Name : Name_Id; Indent : Natural; Capitalize : Boolean := True); -- Outputs a name procedure Start_Line (Indent : Natural); -- Outputs the indentation at the beginning of the line procedure Output_String (S : Name_Id; Indent : Natural); procedure Output_String (S : Path_Name_Type; Indent : Natural); -- Outputs a string using the default output procedures procedure Write_Empty_Line (Always : Boolean := False); -- Outputs an empty line, only if the previous line was not empty -- already and either Always is True or Minimize_Empty_Lines is -- False. procedure Write_Line (S : String); -- Outputs S followed by a new line procedure Write_String (S : String; Indent : Natural; Truncated : Boolean := False); -- Outputs S using Write_Str, starting a new line if line would -- become too long, when Truncated = False. -- When Truncated = True, only the part of the string that can fit on -- the line is output. procedure Write_End_Of_Line_Comment (Node : Project_Node_Id); Write_Char : Write_Char_Ap := Output.Write_Char'Access; Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access; Write_Str : Write_Str_Ap := Output.Write_Str'Access; -- These three access to procedure values are used for the output Last_Line_Is_Empty : Boolean := False; -- Used to avoid two consecutive empty lines Column : Natural := 0; -- Column number of the last character in the line. Used to avoid -- outputting lines longer than Max_Line_Length. First_With_In_List : Boolean := True; -- Indicate that the next with clause is first in a list such as -- with "A", "B"; -- First_With_In_List will be True for "A", but not for "B". --------------------------- -- Output_Attribute_Name -- --------------------------- procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is begin if Backward_Compatibility then case Name is when Snames.Name_Spec => Output_Name (Snames.Name_Specification, Indent); when Snames.Name_Spec_Suffix => Output_Name (Snames.Name_Specification_Suffix, Indent); when Snames.Name_Body => Output_Name (Snames.Name_Implementation, Indent); when Snames.Name_Body_Suffix => Output_Name (Snames.Name_Implementation_Suffix, Indent); when others => Output_Name (Name, Indent); end case; else Output_Name (Name, Indent); end if; end Output_Attribute_Name; ----------------- -- Output_Name -- ----------------- procedure Output_Name (Name : Name_Id; Indent : Natural; Capitalize : Boolean := True) is Capital : Boolean := Capitalize; begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; Get_Name_String (Name); -- If line would become too long, create new line if Column + Name_Len > Max_Line_Length then Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; for J in 1 .. Name_Len loop if Capital then Write_Char (To_Upper (Name_Buffer (J))); else Write_Char (Name_Buffer (J)); end if; if Capitalize then Capital := Name_Buffer (J) = '_' or else Is_Digit (Name_Buffer (J)); end if; end loop; Column := Column + Name_Len; end Output_Name; ------------------- -- Output_String -- ------------------- procedure Output_String (S : Name_Id; Indent : Natural) is begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; Get_Name_String (S); -- If line could become too long, create new line. Note that the -- number of characters on the line could be twice the number of -- character in the string (if every character is a '"') plus two -- (the initial and final '"'). if Column + Name_Len + Name_Len + 2 > Max_Line_Length then Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; Write_Char ('"'); Column := Column + 1; Get_Name_String (S); for J in 1 .. Name_Len loop if Name_Buffer (J) = '"' then Write_Char ('"'); Write_Char ('"'); Column := Column + 2; else Write_Char (Name_Buffer (J)); Column := Column + 1; end if; -- If the string does not fit on one line, cut it in parts and -- concatenate. if J < Name_Len and then Column >= Max_Line_Length then Write_Str (""" &"); Write_Eol.all; Column := 0; Start_Line (Indent + Increment); Write_Char ('"'); Column := Column + 1; end if; end loop; Write_Char ('"'); Column := Column + 1; end Output_String; procedure Output_String (S : Path_Name_Type; Indent : Natural) is begin Output_String (Name_Id (S), Indent); end Output_String; ---------------- -- Start_Line -- ---------------- procedure Start_Line (Indent : Natural) is begin if not Minimize_Empty_Lines then Write_Str ((1 .. Indent => ' ')); Column := Column + Indent; end if; end Start_Line; ---------------------- -- Write_Empty_Line -- ---------------------- procedure Write_Empty_Line (Always : Boolean := False) is begin if (Always or else not Minimize_Empty_Lines) and then not Last_Line_Is_Empty then Write_Eol.all; Column := 0; Last_Line_Is_Empty := True; end if; end Write_Empty_Line; ------------------------------- -- Write_End_Of_Line_Comment -- ------------------------------- procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree); begin if Value /= No_Name then Write_String (" --", 0); Write_String (Get_Name_String (Value), 0, Truncated => True); end if; Write_Line (""); end Write_End_Of_Line_Comment; ---------------- -- Write_Line -- ---------------- procedure Write_Line (S : String) is begin Write_String (S, 0); Last_Line_Is_Empty := False; Write_Eol.all; Column := 0; end Write_Line; ------------------ -- Write_String -- ------------------ procedure Write_String (S : String; Indent : Natural; Truncated : Boolean := False) is Length : Natural := S'Length; begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; -- If the string would not fit on the line, -- start a new line. if Column + Length > Max_Line_Length then if Truncated then Length := Max_Line_Length - Column; else Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; end if; Write_Str (S (S'First .. S'First + Length - 1)); Column := Column + Length; end Write_String; ----------- -- Print -- ----------- procedure Print (Node : Project_Node_Id; Indent : Natural) is begin if Present (Node) then case Kind_Of (Node, In_Tree) is when N_Project => pragma Debug (Indicate_Tested (N_Project)); if Present (First_With_Clause_Of (Node, In_Tree)) then -- with clause(s) First_With_In_List := True; Print (First_With_Clause_Of (Node, In_Tree), Indent); Write_Empty_Line (Always => True); end if; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); case Project_Qualifier_Of (Node, In_Tree) is when Unspecified | Standard => null; when Aggregate => Write_String ("aggregate ", Indent); when Aggregate_Library => Write_String ("aggregate library ", Indent); when Library => Write_String ("library ", Indent); when Configuration => Write_String ("configuration ", Indent); when Dry => Write_String ("abstract ", Indent); end case; Write_String ("project ", Indent); if Id /= Prj.No_Project then Output_Name (Id.Display_Name, Indent); else Output_Name (Name_Of (Node, In_Tree), Indent); end if; -- Check if this project extends another project if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then Write_String (" extends ", Indent); if Is_Extending_All (Node, In_Tree) then Write_String ("all ", Indent); end if; Output_String (Extended_Project_Path_Of (Node, In_Tree), Indent); end if; Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); Write_Empty_Line (Always => True); -- Output all of the declarations in the project Print (Project_Declaration_Of (Node, In_Tree), Indent); Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_String ("end ", Indent); if Id /= Prj.No_Project then Output_Name (Id.Display_Name, Indent); else Output_Name (Name_Of (Node, In_Tree), Indent); end if; Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); when N_With_Clause => pragma Debug (Indicate_Tested (N_With_Clause)); -- The with clause will sometimes contain an invalid name -- when we are importing a virtual project from an -- extending all project. Do not output anything in this -- case if Name_Of (Node, In_Tree) /= No_Name and then String_Value_Of (Node, In_Tree) /= No_Name then if First_With_In_List then Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); if Non_Limited_Project_Node_Of (Node, In_Tree) = Empty_Node then Write_String ("limited ", Indent); end if; Write_String ("with ", Indent); end if; Output_String (String_Value_Of (Node, In_Tree), Indent); if Is_Not_Last_In_List (Node, In_Tree) then Write_String (", ", Indent); First_With_In_List := False; else Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); First_With_In_List := True; end if; end if; Print (Next_With_Clause_Of (Node, In_Tree), Indent); when N_Project_Declaration => pragma Debug (Indicate_Tested (N_Project_Declaration)); if Present (First_Declarative_Item_Of (Node, In_Tree)) then Print (First_Declarative_Item_Of (Node, In_Tree), Indent + Increment); Write_Empty_Line (Always => True); end if; when N_Declarative_Item => pragma Debug (Indicate_Tested (N_Declarative_Item)); Print (Current_Item_Node (Node, In_Tree), Indent); Print (Next_Declarative_Item (Node, In_Tree), Indent); when N_Package_Declaration => pragma Debug (Indicate_Tested (N_Package_Declaration)); Write_Empty_Line (Always => True); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("package ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); if Project_Of_Renamed_Package_Of (Node, In_Tree) /= Empty_Node then Write_String (" renames ", Indent); Output_Name (Name_Of (Project_Of_Renamed_Package_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After_End (Node, In_Tree), Indent); else Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node then Print (First_Declarative_Item_Of (Node, In_Tree), Indent + Increment); end if; Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_String ("end ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); Write_Empty_Line; end if; when N_String_Type_Declaration => pragma Debug (Indicate_Tested (N_String_Type_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("type ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_Line (" is"); Start_Line (Indent + Increment); Write_String ("(", Indent); declare String_Node : Project_Node_Id := First_Literal_String (Node, In_Tree); begin while Present (String_Node) loop Output_String (String_Value_Of (String_Node, In_Tree), Indent); String_Node := Next_Literal_String (String_Node, In_Tree); if Present (String_Node) then Write_String (", ", Indent); end if; end loop; end; Write_String (");", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Literal_String => pragma Debug (Indicate_Tested (N_Literal_String)); Output_String (String_Value_Of (Node, In_Tree), Indent); if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; when N_Attribute_Declaration => pragma Debug (Indicate_Tested (N_Attribute_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("for ", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then Write_String (" (", Indent); Output_String (Associative_Array_Index_Of (Node, In_Tree), Indent); if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; Write_String (")", Indent); end if; Write_String (" use ", Indent); if Present (Expression_Of (Node, In_Tree)) then Print (Expression_Of (Node, In_Tree), Indent); else -- Full associative array declaration if Present (Associative_Project_Of (Node, In_Tree)) then Output_Name (Name_Of (Associative_Project_Of (Node, In_Tree), In_Tree), Indent); if Present (Associative_Package_Of (Node, In_Tree)) then Write_String (".", Indent); Output_Name (Name_Of (Associative_Package_Of (Node, In_Tree), In_Tree), Indent); end if; elsif Present (Associative_Package_Of (Node, In_Tree)) then Output_Name (Name_Of (Associative_Package_Of (Node, In_Tree), In_Tree), Indent); end if; Write_String ("'", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); end if; Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Typed_Variable_Declaration => pragma Debug (Indicate_Tested (N_Typed_Variable_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_String (" : ", Indent); Output_Name (Name_Of (String_Type_Of (Node, In_Tree), In_Tree), Indent); Write_String (" := ", Indent); Print (Expression_Of (Node, In_Tree), Indent); Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Variable_Declaration => pragma Debug (Indicate_Tested (N_Variable_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_String (" := ", Indent); Print (Expression_Of (Node, In_Tree), Indent); Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Expression => pragma Debug (Indicate_Tested (N_Expression)); declare Term : Project_Node_Id := First_Term (Node, In_Tree); begin while Present (Term) loop Print (Term, Indent); Term := Next_Term (Term, In_Tree); if Present (Term) then Write_String (" & ", Indent); end if; end loop; end; when N_Term => pragma Debug (Indicate_Tested (N_Term)); Print (Current_Term (Node, In_Tree), Indent); when N_Literal_String_List => pragma Debug (Indicate_Tested (N_Literal_String_List)); Write_String ("(", Indent); declare Expression : Project_Node_Id := First_Expression_In_List (Node, In_Tree); begin while Present (Expression) loop Print (Expression, Indent); Expression := Next_Expression_In_List (Expression, In_Tree); if Present (Expression) then Write_String (", ", Indent); end if; end loop; end; Write_String (")", Indent); when N_Variable_Reference => pragma Debug (Indicate_Tested (N_Variable_Reference)); if Present (Project_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); end if; if Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); end if; Output_Name (Name_Of (Node, In_Tree), Indent); when N_External_Value => pragma Debug (Indicate_Tested (N_External_Value)); Write_String ("external (", Indent); Print (External_Reference_Of (Node, In_Tree), Indent); if Present (External_Default_Of (Node, In_Tree)) then Write_String (", ", Indent); Print (External_Default_Of (Node, In_Tree), Indent); end if; Write_String (")", Indent); when N_Attribute_Reference => pragma Debug (Indicate_Tested (N_Attribute_Reference)); if Present (Project_Node_Of (Node, In_Tree)) and then Project_Node_Of (Node, In_Tree) /= Project then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), Indent); if Present (Package_Node_Of (Node, In_Tree)) then Write_String (".", Indent); Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); end if; elsif Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); else Write_String ("project", Indent); end if; Write_String ("'", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); declare Index : constant Name_Id := Associative_Array_Index_Of (Node, In_Tree); begin if Index /= No_Name then Write_String (" (", Indent); Output_String (Index, Indent); Write_String (")", Indent); end if; end; when N_Case_Construction => pragma Debug (Indicate_Tested (N_Case_Construction)); declare Case_Item : Project_Node_Id; Is_Non_Empty : Boolean := False; begin Case_Item := First_Case_Item_Of (Node, In_Tree); while Present (Case_Item) loop if Present (First_Declarative_Item_Of (Case_Item, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; end if; Case_Item := Next_Case_Item (Case_Item, In_Tree); end loop; if Is_Non_Empty then Write_Empty_Line; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("case ", Indent); Print (Case_Variable_Reference_Of (Node, In_Tree), Indent); Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); declare Case_Item : Project_Node_Id := First_Case_Item_Of (Node, In_Tree); begin while Present (Case_Item) loop pragma Assert (Kind_Of (Case_Item, In_Tree) = N_Case_Item); Print (Case_Item, Indent + Increment); Case_Item := Next_Case_Item (Case_Item, In_Tree); end loop; end; Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_Line ("end case;"); Print (First_Comment_After_End (Node, In_Tree), Indent); end if; end; when N_Case_Item => pragma Debug (Indicate_Tested (N_Case_Item)); if Present (First_Declarative_Item_Of (Node, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Write_Empty_Line; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("when ", Indent); if No (First_Choice_Of (Node, In_Tree)) then Write_String ("others", Indent); else declare Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); begin while Present (Label) loop Print (Label, Indent); Label := Next_Literal_String (Label, In_Tree); if Present (Label) then Write_String (" | ", Indent); end if; end loop; end; end if; Write_String (" =>", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); declare First : constant Project_Node_Id := First_Declarative_Item_Of (Node, In_Tree); begin if No (First) then Write_Empty_Line; else Print (First, Indent + Increment); end if; end; end if; when N_Comment_Zones => -- Nothing to do, because it will not be processed directly null; when N_Comment => pragma Debug (Indicate_Tested (N_Comment)); if Follows_Empty_Line (Node, In_Tree) then Write_Empty_Line; end if; Start_Line (Indent); Write_String ("--", Indent); Write_String (Get_Name_String (String_Value_Of (Node, In_Tree)), Indent, Truncated => True); Write_Line (""); if Is_Followed_By_Empty_Line (Node, In_Tree) then Write_Empty_Line; end if; Print (Next_Comment (Node, In_Tree), Indent); end case; end if; end Print; -- Start of processing for Pretty_Print begin if W_Char = null then Write_Char := Output.Write_Char'Access; else Write_Char := W_Char; end if; if W_Eol = null then Write_Eol := Output.Write_Eol'Access; else Write_Eol := W_Eol; end if; if W_Str = null then Write_Str := Output.Write_Str'Access; else Write_Str := W_Str; end if; Print (Project, 0); end Pretty_Print; ----------------------- -- Output_Statistics -- ----------------------- procedure Output_Statistics is begin Output.Write_Line ("Project_Node_Kinds not tested:"); for Kind in Project_Node_Kind loop if Kind /= N_Comment_Zones and then Not_Tested (Kind) then Output.Write_Str (" "); Output.Write_Line (Project_Node_Kind'Image (Kind)); end if; end loop; Output.Write_Eol; end Output_Statistics; --------- -- wpr -- --------- procedure wpr (Project : Prj.Tree.Project_Node_Id; In_Tree : Prj.Tree.Project_Node_Tree_Ref) is begin Pretty_Print (Project, In_Tree, Backward_Compatibility => False); end wpr; end Prj.PP;