with Ada.Characters.Handling; use Ada.Characters.Handling;
with Hostparm;
with Namet; use Namet;
with Output; use Output;
with Snames;
package body Prj.PP is
use Prj.Tree;
Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
Column : Natural := 0;
procedure Indicate_Tested (Kind : Project_Node_Kind);
procedure Indicate_Tested (Kind : Project_Node_Kind) is
begin
Not_Tested (Kind) := False;
end Indicate_Tested;
procedure Pretty_Print
(Project : Prj.Tree.Project_Node_Id;
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)
is
procedure Print (Node : Project_Node_Id; Indent : Natural);
procedure Output_Attribute_Name (Name : Name_Id);
procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
procedure Start_Line (Indent : Natural);
procedure Output_String (S : Name_Id);
procedure Write_Empty_Line (Always : Boolean := False);
procedure Write_Line (S : String);
procedure Write_String (S : String; Truncated : Boolean := False);
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;
Last_Line_Is_Empty : Boolean := False;
procedure Output_Attribute_Name (Name : Name_Id) is
begin
if Backward_Compatibility then
case Name is
when Snames.Name_Spec =>
Output_Name (Snames.Name_Specification);
when Snames.Name_Spec_Suffix =>
Output_Name (Snames.Name_Specification_Suffix);
when Snames.Name_Body =>
Output_Name (Snames.Name_Implementation);
when Snames.Name_Body_Suffix =>
Output_Name (Snames.Name_Implementation_Suffix);
when others =>
Output_Name (Name);
end case;
else
Output_Name (Name);
end if;
end Output_Attribute_Name;
procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
Capital : Boolean := Capitalize;
begin
Get_Name_String (Name);
if Column + Name_Len > Max_Line_Length then
Write_Eol.all;
Column := 0;
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;
procedure Output_String (S : Name_Id) is
begin
Get_Name_String (S);
if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
Write_Eol.all;
Column := 0;
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 J < Name_Len and then Column >= Max_Line_Length then
Write_Str (""" &");
Write_Eol.all;
Write_Char ('"');
Column := 1;
end if;
end loop;
Write_Char ('"');
Column := Column + 1;
end Output_String;
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;
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;
procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
Value : constant Name_Id := End_Of_Line_Comment (Node);
begin
if Value /= No_Name then
Write_String (" --");
Write_String (Get_Name_String (Value), Truncated => True);
end if;
Write_Line ("");
end Write_End_Of_Line_Comment;
procedure Write_Line (S : String) is
begin
Write_String (S);
Last_Line_Is_Empty := False;
Write_Eol.all;
Column := 0;
end Write_Line;
procedure Write_String (S : String; Truncated : Boolean := False) is
Length : Natural := S'Length;
begin
if Column + Length > Max_Line_Length then
if Truncated then
Length := Max_Line_Length - Column;
else
Write_Eol.all;
Column := 0;
end if;
end if;
Write_Str (S (S'First .. S'First + Length - 1));
Column := Column + Length;
end Write_String;
procedure Print (Node : Project_Node_Id; Indent : Natural) is
begin
if Node /= Empty_Node then
case Kind_Of (Node) is
when N_Project =>
pragma Debug (Indicate_Tested (N_Project));
if First_With_Clause_Of (Node) /= Empty_Node then
Print (First_With_Clause_Of (Node), Indent);
Write_Empty_Line (Always => True);
end if;
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("project ");
Output_Name (Name_Of (Node));
if Extended_Project_Path_Of (Node) /= No_Name then
Write_String (" extends ");
Output_String (Extended_Project_Path_Of (Node));
end if;
Write_String (" is");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent + Increment);
Write_Empty_Line (Always => True);
Print (Project_Declaration_Of (Node), Indent);
Print (First_Comment_Before_End (Node), Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
Print (First_Comment_After_End (Node), Indent);
when N_With_Clause =>
pragma Debug (Indicate_Tested (N_With_Clause));
if Name_Of (Node) /= No_Name then
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
if Non_Limited_Project_Node_Of (Node) = Empty_Node then
Write_String ("limited ");
end if;
Write_String ("with ");
Output_String (String_Value_Of (Node));
Write_String (";");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent);
end if;
Print (Next_With_Clause_Of (Node), Indent);
when N_Project_Declaration =>
pragma Debug (Indicate_Tested (N_Project_Declaration));
if First_Declarative_Item_Of (Node) /= Empty_Node then
Print
(First_Declarative_Item_Of (Node), 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), Indent);
Print (Next_Declarative_Item (Node), Indent);
when N_Package_Declaration =>
pragma Debug (Indicate_Tested (N_Package_Declaration));
Write_Empty_Line (Always => True);
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("package ");
Output_Name (Name_Of (Node));
if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
Write_String (" renames ");
Output_Name
(Name_Of (Project_Of_Renamed_Package_Of (Node)));
Write_String (".");
Output_Name (Name_Of (Node));
Write_String (";");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After_End (Node), Indent);
else
Write_String (" is");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent + Increment);
if First_Declarative_Item_Of (Node) /= Empty_Node then
Print
(First_Declarative_Item_Of (Node),
Indent + Increment);
end if;
Print (First_Comment_Before_End (Node),
Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
Print (First_Comment_After_End (Node), Indent);
Write_Empty_Line;
end if;
when N_String_Type_Declaration =>
pragma Debug (Indicate_Tested (N_String_Type_Declaration));
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("type ");
Output_Name (Name_Of (Node));
Write_Line (" is");
Start_Line (Indent + Increment);
Write_String ("(");
declare
String_Node : Project_Node_Id :=
First_Literal_String (Node);
begin
while String_Node /= Empty_Node loop
Output_String (String_Value_Of (String_Node));
String_Node := Next_Literal_String (String_Node);
if String_Node /= Empty_Node then
Write_String (", ");
end if;
end loop;
end;
Write_String (");");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent);
when N_Literal_String =>
pragma Debug (Indicate_Tested (N_Literal_String));
Output_String (String_Value_Of (Node));
if Source_Index_Of (Node) /= 0 then
Write_String (" at ");
Write_String (Source_Index_Of (Node)'Img);
end if;
when N_Attribute_Declaration =>
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("for ");
Output_Attribute_Name (Name_Of (Node));
if Associative_Array_Index_Of (Node) /= No_Name then
Write_String (" (");
Output_String (Associative_Array_Index_Of (Node));
if Source_Index_Of (Node) /= 0 then
Write_String (" at ");
Write_String (Source_Index_Of (Node)'Img);
end if;
Write_String (")");
end if;
Write_String (" use ");
Print (Expression_Of (Node), Indent);
Write_String (";");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent);
when N_Typed_Variable_Declaration =>
pragma Debug
(Indicate_Tested (N_Typed_Variable_Declaration));
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" : ");
Output_Name (Name_Of (String_Type_Of (Node)));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
Write_String (";");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent);
when N_Variable_Declaration =>
pragma Debug (Indicate_Tested (N_Variable_Declaration));
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
Write_String (";");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent);
when N_Expression =>
pragma Debug (Indicate_Tested (N_Expression));
declare
Term : Project_Node_Id := First_Term (Node);
begin
while Term /= Empty_Node loop
Print (Term, Indent);
Term := Next_Term (Term);
if Term /= Empty_Node then
Write_String (" & ");
end if;
end loop;
end;
when N_Term =>
pragma Debug (Indicate_Tested (N_Term));
Print (Current_Term (Node), Indent);
when N_Literal_String_List =>
pragma Debug (Indicate_Tested (N_Literal_String_List));
Write_String ("(");
declare
Expression : Project_Node_Id :=
First_Expression_In_List (Node);
begin
while Expression /= Empty_Node loop
Print (Expression, Indent);
Expression := Next_Expression_In_List (Expression);
if Expression /= Empty_Node then
Write_String (", ");
end if;
end loop;
end;
Write_String (")");
when N_Variable_Reference =>
pragma Debug (Indicate_Tested (N_Variable_Reference));
if Project_Node_Of (Node) /= Empty_Node then
Output_Name (Name_Of (Project_Node_Of (Node)));
Write_String (".");
end if;
if Package_Node_Of (Node) /= Empty_Node then
Output_Name (Name_Of (Package_Node_Of (Node)));
Write_String (".");
end if;
Output_Name (Name_Of (Node));
when N_External_Value =>
pragma Debug (Indicate_Tested (N_External_Value));
Write_String ("external (");
Print (External_Reference_Of (Node), Indent);
if External_Default_Of (Node) /= Empty_Node then
Write_String (", ");
Print (External_Default_Of (Node), Indent);
end if;
Write_String (")");
when N_Attribute_Reference =>
pragma Debug (Indicate_Tested (N_Attribute_Reference));
if Project_Node_Of (Node) /= Empty_Node
and then Project_Node_Of (Node) /= Project
then
Output_Name (Name_Of (Project_Node_Of (Node)));
if Package_Node_Of (Node) /= Empty_Node then
Write_String (".");
Output_Name (Name_Of (Package_Node_Of (Node)));
end if;
elsif Package_Node_Of (Node) /= Empty_Node then
Output_Name (Name_Of (Package_Node_Of (Node)));
else
Write_String ("project");
end if;
Write_String ("'");
Output_Attribute_Name (Name_Of (Node));
declare
Index : constant Name_Id :=
Associative_Array_Index_Of (Node);
begin
if Index /= No_Name then
Write_String (" (");
Output_String (Index);
Write_String (")");
end if;
end;
when N_Case_Construction =>
pragma Debug (Indicate_Tested (N_Case_Construction));
declare
Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
Is_Non_Empty : Boolean := False;
begin
while Case_Item /= Empty_Node loop
if First_Declarative_Item_Of (Case_Item) /= Empty_Node
or else not Eliminate_Empty_Case_Constructions
then
Is_Non_Empty := True;
exit;
end if;
Case_Item := Next_Case_Item (Case_Item);
end loop;
if Is_Non_Empty then
Write_Empty_Line;
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("case ");
Print (Case_Variable_Reference_Of (Node), Indent);
Write_String (" is");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent + Increment);
declare
Case_Item : Project_Node_Id :=
First_Case_Item_Of (Node);
begin
while Case_Item /= Empty_Node loop
pragma Assert
(Kind_Of (Case_Item) = N_Case_Item);
Print (Case_Item, Indent + Increment);
Case_Item := Next_Case_Item (Case_Item);
end loop;
end;
Print (First_Comment_Before_End (Node),
Indent + Increment);
Start_Line (Indent);
Write_Line ("end case;");
Print (First_Comment_After_End (Node), Indent);
end if;
end;
when N_Case_Item =>
pragma Debug (Indicate_Tested (N_Case_Item));
if First_Declarative_Item_Of (Node) /= Empty_Node
or else not Eliminate_Empty_Case_Constructions
then
Write_Empty_Line;
Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("when ");
if First_Choice_Of (Node) = Empty_Node then
Write_String ("others");
else
declare
Label : Project_Node_Id := First_Choice_Of (Node);
begin
while Label /= Empty_Node loop
Print (Label, Indent);
Label := Next_Literal_String (Label);
if Label /= Empty_Node then
Write_String (" | ");
end if;
end loop;
end;
end if;
Write_String (" =>");
Write_End_Of_Line_Comment (Node);
Print (First_Comment_After (Node), Indent + Increment);
declare
First : constant Project_Node_Id :=
First_Declarative_Item_Of (Node);
begin
if First = Empty_Node then
Write_Empty_Line;
else
Print (First, Indent + Increment);
end if;
end;
end if;
when N_Comment_Zones =>
null;
when N_Comment =>
pragma Debug (Indicate_Tested (N_Comment));
if Follows_Empty_Line (Node) then
Write_Empty_Line;
end if;
Start_Line (Indent);
Write_String ("--");
Write_String
(Get_Name_String (String_Value_Of (Node)),
Truncated => True);
Write_Line ("");
if Is_Followed_By_Empty_Line (Node) then
Write_Empty_Line;
end if;
Print (Next_Comment (Node), Indent);
end case;
end if;
end 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);
if W_Char = null or else W_Str = null then
Output.Write_Eol;
end if;
end Pretty_Print;
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;
end Prj.PP;