1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Ada.Characters.Handling; use Ada.Characters.Handling;
31 with Namet; use Namet;
32 with Output; use Output;
33 with Stringt; use Stringt;
35 package body Prj.PP is
39 Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
41 Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
42 -- Maximum length of a line.
44 Column : Natural := 0;
45 -- Column number of the last character in the line. Used to avoid
46 -- outputing lines longer than Max_Line_Length.
48 procedure Indicate_Tested (Kind : Project_Node_Kind);
49 -- Set the corresponding component of array Not_Tested to False.
50 -- Only called by pragmas Debug.
57 procedure Indicate_Tested (Kind : Project_Node_Kind) is
59 Not_Tested (Kind) := False;
66 procedure Pretty_Print
67 (Project : Prj.Tree.Project_Node_Id;
68 Increment : Positive := 3;
69 Eliminate_Empty_Case_Constructions : Boolean := False;
70 Minimize_Empty_Lines : Boolean := False;
71 W_Char : Write_Char_Ap := null;
72 W_Eol : Write_Eol_Ap := null;
73 W_Str : Write_Str_Ap := null) is
75 procedure Print (Node : Project_Node_Id; Indent : Natural);
76 -- A recursive procedure that traverses a project file tree
77 -- and outputs its source.
78 -- Current_Prj is the project that we are printing. This
79 -- is used when printing attributes, since in nested packages they need
80 -- to use a fully qualified name.
82 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
85 procedure Start_Line (Indent : Natural);
86 -- Outputs the indentation at the beginning of the line.
88 procedure Output_String (S : String_Id);
89 -- Outputs a string using the default output procedures
91 procedure Write_Empty_Line (Always : Boolean := False);
92 -- Outputs an empty line, only if the previous line was not
93 -- empty already and either Always is True or Minimize_Empty_Lines
96 procedure Write_Line (S : String);
97 -- Outputs S followed by a new line
99 procedure Write_String (S : String);
100 -- Outputs S using Write_Str, starting a new line if line would
103 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
104 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
105 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
106 -- These two access to procedure values are used for the output.
108 Last_Line_Is_Empty : Boolean := False;
109 -- Used to avoid two consecutive empty lines.
115 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
116 Capital : Boolean := Capitalize;
119 Get_Name_String (Name);
121 -- If line would become too long, create new line
123 if Column + Name_Len > Max_Line_Length then
128 for J in 1 .. Name_Len loop
130 Write_Char (To_Upper (Name_Buffer (J)));
132 Write_Char (Name_Buffer (J));
137 Name_Buffer (J) = '_'
138 or else Is_Digit (Name_Buffer (J));
147 procedure Output_String (S : String_Id) is
149 String_To_Name_Buffer (S);
151 -- If line could become too long, create new line.
152 -- Note that the number of characters on the line could be
153 -- twice the number of character in the string (if every
154 -- character is a '"') plus two (the initial and final '"').
156 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
162 Column := Column + 1;
163 String_To_Name_Buffer (S);
165 for J in 1 .. Name_Len loop
166 if Name_Buffer (J) = '"' then
169 Column := Column + 2;
171 Write_Char (Name_Buffer (J));
172 Column := Column + 1;
175 -- If the string does not fit on one line, cut it in parts
178 if J < Name_Len and then Column >= Max_Line_Length then
187 Column := Column + 1;
194 procedure Start_Line (Indent : Natural) is
196 if not Minimize_Empty_Lines then
197 Write_Str ((1 .. Indent => ' '));
198 Column := Column + Indent;
202 ----------------------
203 -- Write_Empty_Line --
204 ----------------------
206 procedure Write_Empty_Line (Always : Boolean := False) is
208 if (Always or else not Minimize_Empty_Lines)
209 and then not Last_Line_Is_Empty then
212 Last_Line_Is_Empty := True;
214 end Write_Empty_Line;
220 procedure Write_Line (S : String) is
223 Last_Line_Is_Empty := False;
232 procedure Write_String (S : String) is
234 -- If the string would not fit on the line,
237 if Column + S'Length > Max_Line_Length then
243 Column := Column + S'Length;
250 procedure Print (Node : Project_Node_Id; Indent : Natural) is
252 if Node /= Empty_Node then
254 case Kind_Of (Node) is
257 pragma Debug (Indicate_Tested (N_Project));
258 if First_With_Clause_Of (Node) /= Empty_Node then
262 Print (First_With_Clause_Of (Node), Indent);
263 Write_Empty_Line (Always => True);
267 Write_String ("project ");
268 Output_Name (Name_Of (Node));
270 -- Check if this project modifies another project
272 if Modified_Project_Path_Of (Node) /= No_String then
273 Write_String (" extends ");
274 Output_String (Modified_Project_Path_Of (Node));
278 Write_Empty_Line (Always => True);
280 -- Output all of the declarations in the project
282 Print (Project_Declaration_Of (Node), Indent);
284 Write_String ("end ");
285 Output_Name (Name_Of (Node));
288 when N_With_Clause =>
289 pragma Debug (Indicate_Tested (N_With_Clause));
291 if Name_Of (Node) /= No_Name then
293 Write_String ("with ");
294 Output_String (String_Value_Of (Node));
298 Print (Next_With_Clause_Of (Node), Indent);
300 when N_Project_Declaration =>
301 pragma Debug (Indicate_Tested (N_Project_Declaration));
303 if First_Declarative_Item_Of (Node) /= Empty_Node then
305 (First_Declarative_Item_Of (Node), Indent + Increment);
306 Write_Empty_Line (Always => True);
309 when N_Declarative_Item =>
310 pragma Debug (Indicate_Tested (N_Declarative_Item));
311 Print (Current_Item_Node (Node), Indent);
312 Print (Next_Declarative_Item (Node), Indent);
314 when N_Package_Declaration =>
315 pragma Debug (Indicate_Tested (N_Package_Declaration));
316 Write_Empty_Line (Always => True);
318 Write_String ("package ");
319 Output_Name (Name_Of (Node));
321 if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
322 Write_String (" renames ");
324 (Name_Of (Project_Of_Renamed_Package_Of (Node)));
326 Output_Name (Name_Of (Node));
332 if First_Declarative_Item_Of (Node) /= Empty_Node then
334 (First_Declarative_Item_Of (Node),
339 Write_String ("end ");
340 Output_Name (Name_Of (Node));
345 when N_String_Type_Declaration =>
346 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
348 Write_String ("type ");
349 Output_Name (Name_Of (Node));
351 Start_Line (Indent + Increment);
355 String_Node : Project_Node_Id :=
356 First_Literal_String (Node);
359 while String_Node /= Empty_Node loop
360 Output_String (String_Value_Of (String_Node));
361 String_Node := Next_Literal_String (String_Node);
363 if String_Node /= Empty_Node then
371 when N_Literal_String =>
372 pragma Debug (Indicate_Tested (N_Literal_String));
373 Output_String (String_Value_Of (Node));
375 when N_Attribute_Declaration =>
376 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
378 Write_String ("for ");
379 Output_Name (Name_Of (Node));
381 if Associative_Array_Index_Of (Node) /= No_String then
383 Output_String (Associative_Array_Index_Of (Node));
387 Write_String (" use ");
388 Print (Expression_Of (Node), Indent);
391 when N_Typed_Variable_Declaration =>
393 (Indicate_Tested (N_Typed_Variable_Declaration));
395 Output_Name (Name_Of (Node));
396 Write_String (" : ");
397 Output_Name (Name_Of (String_Type_Of (Node)));
398 Write_String (" := ");
399 Print (Expression_Of (Node), Indent);
402 when N_Variable_Declaration =>
403 pragma Debug (Indicate_Tested (N_Variable_Declaration));
405 Output_Name (Name_Of (Node));
406 Write_String (" := ");
407 Print (Expression_Of (Node), Indent);
411 pragma Debug (Indicate_Tested (N_Expression));
413 Term : Project_Node_Id := First_Term (Node);
416 while Term /= Empty_Node loop
417 Print (Term, Indent);
418 Term := Next_Term (Term);
420 if Term /= Empty_Node then
421 Write_String (" & ");
427 pragma Debug (Indicate_Tested (N_Term));
428 Print (Current_Term (Node), Indent);
430 when N_Literal_String_List =>
431 pragma Debug (Indicate_Tested (N_Literal_String_List));
435 Expression : Project_Node_Id :=
436 First_Expression_In_List (Node);
439 while Expression /= Empty_Node loop
440 Print (Expression, Indent);
441 Expression := Next_Expression_In_List (Expression);
443 if Expression /= Empty_Node then
451 when N_Variable_Reference =>
452 pragma Debug (Indicate_Tested (N_Variable_Reference));
453 if Project_Node_Of (Node) /= Empty_Node then
454 Output_Name (Name_Of (Project_Node_Of (Node)));
458 if Package_Node_Of (Node) /= Empty_Node then
459 Output_Name (Name_Of (Package_Node_Of (Node)));
463 Output_Name (Name_Of (Node));
465 when N_External_Value =>
466 pragma Debug (Indicate_Tested (N_External_Value));
467 Write_String ("external (");
468 Print (External_Reference_Of (Node), Indent);
470 if External_Default_Of (Node) /= Empty_Node then
472 Print (External_Default_Of (Node), Indent);
477 when N_Attribute_Reference =>
478 pragma Debug (Indicate_Tested (N_Attribute_Reference));
480 if Project_Node_Of (Node) /= Empty_Node
481 and then Project_Node_Of (Node) /= Project
483 Output_Name (Name_Of (Project_Node_Of (Node)));
485 if Package_Node_Of (Node) /= Empty_Node then
487 Output_Name (Name_Of (Package_Node_Of (Node)));
490 elsif Package_Node_Of (Node) /= Empty_Node then
491 Output_Name (Name_Of (Package_Node_Of (Node)));
494 Write_String ("project");
498 Output_Name (Name_Of (Node));
501 Index : constant String_Id :=
502 Associative_Array_Index_Of (Node);
505 if Index /= No_String then
507 Output_String (Index);
512 when N_Case_Construction =>
513 pragma Debug (Indicate_Tested (N_Case_Construction));
516 Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
517 Is_Non_Empty : Boolean := False;
519 while Case_Item /= Empty_Node loop
520 if First_Declarative_Item_Of (Case_Item) /= Empty_Node
521 or else not Eliminate_Empty_Case_Constructions
523 Is_Non_Empty := True;
526 Case_Item := Next_Case_Item (Case_Item);
532 Write_String ("case ");
533 Print (Case_Variable_Reference_Of (Node), Indent);
537 Case_Item : Project_Node_Id :=
538 First_Case_Item_Of (Node);
541 while Case_Item /= Empty_Node loop
543 (Kind_Of (Case_Item) = N_Case_Item);
544 Print (Case_Item, Indent + Increment);
545 Case_Item := Next_Case_Item (Case_Item);
550 Write_Line ("end case;");
555 pragma Debug (Indicate_Tested (N_Case_Item));
557 if First_Declarative_Item_Of (Node) /= Empty_Node
558 or else not Eliminate_Empty_Case_Constructions
562 Write_String ("when ");
564 if First_Choice_Of (Node) = Empty_Node then
565 Write_String ("others");
569 Label : Project_Node_Id := First_Choice_Of (Node);
572 while Label /= Empty_Node loop
573 Print (Label, Indent);
574 Label := Next_Literal_String (Label);
576 if Label /= Empty_Node then
577 Write_String (" | ");
586 First : Project_Node_Id :=
587 First_Declarative_Item_Of (Node);
590 if First = Empty_Node then
594 Print (First, Indent + Increment);
603 if W_Char = null then
604 Write_Char := Output.Write_Char'Access;
606 Write_Char := W_Char;
610 Write_Eol := Output.Write_Eol'Access;
616 Write_Str := Output.Write_Str'Access;
623 if W_Char = null or else W_Str = null then
628 -----------------------
629 -- Output_Statistics --
630 -----------------------
632 procedure Output_Statistics is
634 Output.Write_Line ("Project_Node_Kinds not tested:");
636 for Kind in Project_Node_Kind loop
637 if Not_Tested (Kind) then
638 Output.Write_Str (" ");
639 Output.Write_Line (Project_Node_Kind'Image (Kind));
644 end Output_Statistics;