1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
30 with Namet
; use Namet
;
31 with Output
; use Output
;
34 package body Prj
.PP
is
38 Not_Tested
: array (Project_Node_Kind
) of Boolean := (others => True);
40 Max_Line_Length
: constant := Hostparm
.Max_Line_Length
- 5;
41 -- Maximum length of a line.
43 Column
: Natural := 0;
44 -- Column number of the last character in the line. Used to avoid
45 -- outputing lines longer than Max_Line_Length.
47 procedure Indicate_Tested
(Kind
: Project_Node_Kind
);
48 -- Set the corresponding component of array Not_Tested to False.
49 -- Only called by pragmas Debug.
55 procedure Indicate_Tested
(Kind
: Project_Node_Kind
) is
57 Not_Tested
(Kind
) := False;
64 procedure Pretty_Print
65 (Project
: Prj
.Tree
.Project_Node_Id
;
66 Increment
: Positive := 3;
67 Eliminate_Empty_Case_Constructions
: Boolean := False;
68 Minimize_Empty_Lines
: Boolean := False;
69 W_Char
: Write_Char_Ap
:= null;
70 W_Eol
: Write_Eol_Ap
:= null;
71 W_Str
: Write_Str_Ap
:= null;
72 Backward_Compatibility
: Boolean)
74 procedure Print
(Node
: Project_Node_Id
; Indent
: Natural);
75 -- A recursive procedure that traverses a project file tree and outputs
76 -- its source. Current_Prj is the project that we are printing. This
77 -- is used when printing attributes, since in nested packages they
78 -- need to use a fully qualified name.
80 procedure Output_Attribute_Name
(Name
: Name_Id
);
81 -- Outputs an attribute name, taking into account the value of
82 -- Backward_Compatibility.
84 procedure Output_Name
(Name
: Name_Id
; Capitalize
: Boolean := True);
87 procedure Start_Line
(Indent
: Natural);
88 -- Outputs the indentation at the beginning of the line.
90 procedure Output_String
(S
: Name_Id
);
91 -- Outputs a string using the default output procedures
93 procedure Write_Empty_Line
(Always
: Boolean := False);
94 -- Outputs an empty line, only if the previous line was not empty
95 -- already and either Always is True or Minimize_Empty_Lines is False.
97 procedure Write_Line
(S
: String);
98 -- Outputs S followed by a new line
100 procedure Write_String
(S
: String; Truncated
: Boolean := False);
101 -- Outputs S using Write_Str, starting a new line if line would
102 -- become too long, when Truncated = False.
103 -- When Truncated = True, only the part of the string that can fit on
104 -- the line is output.
106 procedure Write_End_Of_Line_Comment
(Node
: Project_Node_Id
);
108 Write_Char
: Write_Char_Ap
:= Output
.Write_Char
'Access;
109 Write_Eol
: Write_Eol_Ap
:= Output
.Write_Eol
'Access;
110 Write_Str
: Write_Str_Ap
:= Output
.Write_Str
'Access;
111 -- These three access to procedure values are used for the output.
113 Last_Line_Is_Empty
: Boolean := False;
114 -- Used to avoid two consecutive empty lines.
116 ---------------------------
117 -- Output_Attribute_Name --
118 ---------------------------
120 procedure Output_Attribute_Name
(Name
: Name_Id
) is
122 if Backward_Compatibility
then
124 when Snames
.Name_Spec
=>
125 Output_Name
(Snames
.Name_Specification
);
127 when Snames
.Name_Spec_Suffix
=>
128 Output_Name
(Snames
.Name_Specification_Suffix
);
130 when Snames
.Name_Body
=>
131 Output_Name
(Snames
.Name_Implementation
);
133 when Snames
.Name_Body_Suffix
=>
134 Output_Name
(Snames
.Name_Implementation_Suffix
);
143 end Output_Attribute_Name
;
149 procedure Output_Name
(Name
: Name_Id
; Capitalize
: Boolean := True) is
150 Capital
: Boolean := Capitalize
;
153 Get_Name_String
(Name
);
155 -- If line would become too long, create new line
157 if Column
+ Name_Len
> Max_Line_Length
then
162 for J
in 1 .. Name_Len
loop
164 Write_Char
(To_Upper
(Name_Buffer
(J
)));
166 Write_Char
(Name_Buffer
(J
));
171 Name_Buffer
(J
) = '_'
172 or else Is_Digit
(Name_Buffer
(J
));
176 Column
:= Column
+ Name_Len
;
183 procedure Output_String
(S
: Name_Id
) is
187 -- If line could become too long, create new line.
188 -- Note that the number of characters on the line could be
189 -- twice the number of character in the string (if every
190 -- character is a '"') plus two (the initial and final '"').
192 if Column
+ Name_Len
+ Name_Len
+ 2 > Max_Line_Length
then
198 Column
:= Column
+ 1;
201 for J
in 1 .. Name_Len
loop
202 if Name_Buffer
(J
) = '"' then
205 Column
:= Column
+ 2;
207 Write_Char
(Name_Buffer
(J
));
208 Column
:= Column
+ 1;
211 -- If the string does not fit on one line, cut it in parts
214 if J
< Name_Len
and then Column
>= Max_Line_Length
then
223 Column
:= Column
+ 1;
230 procedure Start_Line
(Indent
: Natural) is
232 if not Minimize_Empty_Lines
then
233 Write_Str
((1 .. Indent
=> ' '));
234 Column
:= Column
+ Indent
;
238 ----------------------
239 -- Write_Empty_Line --
240 ----------------------
242 procedure Write_Empty_Line
(Always
: Boolean := False) is
244 if (Always
or else not Minimize_Empty_Lines
)
245 and then not Last_Line_Is_Empty
then
248 Last_Line_Is_Empty
:= True;
250 end Write_Empty_Line
;
252 -------------------------------
253 -- Write_End_Of_Line_Comment --
254 -------------------------------
256 procedure Write_End_Of_Line_Comment
(Node
: Project_Node_Id
) is
257 Value
: constant Name_Id
:= End_Of_Line_Comment
(Node
);
260 if Value
/= No_Name
then
261 Write_String
(" --");
262 Write_String
(Get_Name_String
(Value
), Truncated
=> True);
266 end Write_End_Of_Line_Comment
;
272 procedure Write_Line
(S
: String) is
275 Last_Line_Is_Empty
:= False;
284 procedure Write_String
(S
: String; Truncated
: Boolean := False) is
285 Length
: Natural := S
'Length;
287 -- If the string would not fit on the line,
290 if Column
+ Length
> Max_Line_Length
then
292 Length
:= Max_Line_Length
- Column
;
300 Write_Str
(S
(S
'First .. S
'First + Length
- 1));
301 Column
:= Column
+ Length
;
308 procedure Print
(Node
: Project_Node_Id
; Indent
: Natural) is
310 if Node
/= Empty_Node
then
312 case Kind_Of
(Node
) is
315 pragma Debug
(Indicate_Tested
(N_Project
));
316 if First_With_Clause_Of
(Node
) /= Empty_Node
then
320 Print
(First_With_Clause_Of
(Node
), Indent
);
321 Write_Empty_Line
(Always
=> True);
324 Print
(First_Comment_Before
(Node
), Indent
);
326 Write_String
("project ");
327 Output_Name
(Name_Of
(Node
));
329 -- Check if this project extends another project
331 if Extended_Project_Path_Of
(Node
) /= No_Name
then
332 Write_String
(" extends ");
333 Output_String
(Extended_Project_Path_Of
(Node
));
336 Write_String
(" is");
337 Write_End_Of_Line_Comment
(Node
);
338 Print
(First_Comment_After
(Node
), Indent
+ Increment
);
339 Write_Empty_Line
(Always
=> True);
341 -- Output all of the declarations in the project
343 Print
(Project_Declaration_Of
(Node
), Indent
);
344 Print
(First_Comment_Before_End
(Node
), Indent
+ Increment
);
346 Write_String
("end ");
347 Output_Name
(Name_Of
(Node
));
349 Print
(First_Comment_After_End
(Node
), Indent
);
351 when N_With_Clause
=>
352 pragma Debug
(Indicate_Tested
(N_With_Clause
));
354 if Name_Of
(Node
) /= No_Name
then
355 Print
(First_Comment_Before
(Node
), Indent
);
358 if Non_Limited_Project_Node_Of
(Node
) = Empty_Node
then
359 Write_String
("limited ");
362 Write_String
("with ");
363 Output_String
(String_Value_Of
(Node
));
365 Write_End_Of_Line_Comment
(Node
);
366 Print
(First_Comment_After
(Node
), Indent
);
369 Print
(Next_With_Clause_Of
(Node
), Indent
);
371 when N_Project_Declaration
=>
372 pragma Debug
(Indicate_Tested
(N_Project_Declaration
));
374 if First_Declarative_Item_Of
(Node
) /= Empty_Node
then
376 (First_Declarative_Item_Of
(Node
), Indent
+ Increment
);
377 Write_Empty_Line
(Always
=> True);
380 when N_Declarative_Item
=>
381 pragma Debug
(Indicate_Tested
(N_Declarative_Item
));
382 Print
(Current_Item_Node
(Node
), Indent
);
383 Print
(Next_Declarative_Item
(Node
), Indent
);
385 when N_Package_Declaration
=>
386 pragma Debug
(Indicate_Tested
(N_Package_Declaration
));
387 Write_Empty_Line
(Always
=> True);
388 Print
(First_Comment_Before
(Node
), Indent
);
390 Write_String
("package ");
391 Output_Name
(Name_Of
(Node
));
393 if Project_Of_Renamed_Package_Of
(Node
) /= Empty_Node
then
394 Write_String
(" renames ");
396 (Name_Of
(Project_Of_Renamed_Package_Of
(Node
)));
398 Output_Name
(Name_Of
(Node
));
400 Write_End_Of_Line_Comment
(Node
);
401 Print
(First_Comment_After_End
(Node
), Indent
);
404 Write_String
(" is");
405 Write_End_Of_Line_Comment
(Node
);
406 Print
(First_Comment_After
(Node
), Indent
+ Increment
);
408 if First_Declarative_Item_Of
(Node
) /= Empty_Node
then
410 (First_Declarative_Item_Of
(Node
),
414 Print
(First_Comment_Before_End
(Node
),
417 Write_String
("end ");
418 Output_Name
(Name_Of
(Node
));
420 Print
(First_Comment_After_End
(Node
), Indent
);
424 when N_String_Type_Declaration
=>
425 pragma Debug
(Indicate_Tested
(N_String_Type_Declaration
));
426 Print
(First_Comment_Before
(Node
), Indent
);
428 Write_String
("type ");
429 Output_Name
(Name_Of
(Node
));
431 Start_Line
(Indent
+ Increment
);
435 String_Node
: Project_Node_Id
:=
436 First_Literal_String
(Node
);
439 while String_Node
/= Empty_Node
loop
440 Output_String
(String_Value_Of
(String_Node
));
441 String_Node
:= Next_Literal_String
(String_Node
);
443 if String_Node
/= Empty_Node
then
450 Write_End_Of_Line_Comment
(Node
);
451 Print
(First_Comment_After
(Node
), Indent
);
453 when N_Literal_String
=>
454 pragma Debug
(Indicate_Tested
(N_Literal_String
));
455 Output_String
(String_Value_Of
(Node
));
457 if Source_Index_Of
(Node
) /= 0 then
458 Write_String
(" at ");
459 Write_String
(Source_Index_Of
(Node
)'Img);
462 when N_Attribute_Declaration
=>
463 pragma Debug
(Indicate_Tested
(N_Attribute_Declaration
));
464 Print
(First_Comment_Before
(Node
), Indent
);
466 Write_String
("for ");
467 Output_Attribute_Name
(Name_Of
(Node
));
469 if Associative_Array_Index_Of
(Node
) /= No_Name
then
471 Output_String
(Associative_Array_Index_Of
(Node
));
473 if Source_Index_Of
(Node
) /= 0 then
474 Write_String
(" at ");
475 Write_String
(Source_Index_Of
(Node
)'Img);
481 Write_String
(" use ");
482 Print
(Expression_Of
(Node
), Indent
);
484 Write_End_Of_Line_Comment
(Node
);
485 Print
(First_Comment_After
(Node
), Indent
);
487 when N_Typed_Variable_Declaration
=>
489 (Indicate_Tested
(N_Typed_Variable_Declaration
));
490 Print
(First_Comment_Before
(Node
), Indent
);
492 Output_Name
(Name_Of
(Node
));
493 Write_String
(" : ");
494 Output_Name
(Name_Of
(String_Type_Of
(Node
)));
495 Write_String
(" := ");
496 Print
(Expression_Of
(Node
), Indent
);
498 Write_End_Of_Line_Comment
(Node
);
499 Print
(First_Comment_After
(Node
), Indent
);
501 when N_Variable_Declaration
=>
502 pragma Debug
(Indicate_Tested
(N_Variable_Declaration
));
503 Print
(First_Comment_Before
(Node
), Indent
);
505 Output_Name
(Name_Of
(Node
));
506 Write_String
(" := ");
507 Print
(Expression_Of
(Node
), Indent
);
509 Write_End_Of_Line_Comment
(Node
);
510 Print
(First_Comment_After
(Node
), Indent
);
513 pragma Debug
(Indicate_Tested
(N_Expression
));
515 Term
: Project_Node_Id
:= First_Term
(Node
);
518 while Term
/= Empty_Node
loop
519 Print
(Term
, Indent
);
520 Term
:= Next_Term
(Term
);
522 if Term
/= Empty_Node
then
523 Write_String
(" & ");
529 pragma Debug
(Indicate_Tested
(N_Term
));
530 Print
(Current_Term
(Node
), Indent
);
532 when N_Literal_String_List
=>
533 pragma Debug
(Indicate_Tested
(N_Literal_String_List
));
537 Expression
: Project_Node_Id
:=
538 First_Expression_In_List
(Node
);
541 while Expression
/= Empty_Node
loop
542 Print
(Expression
, Indent
);
543 Expression
:= Next_Expression_In_List
(Expression
);
545 if Expression
/= Empty_Node
then
553 when N_Variable_Reference
=>
554 pragma Debug
(Indicate_Tested
(N_Variable_Reference
));
555 if Project_Node_Of
(Node
) /= Empty_Node
then
556 Output_Name
(Name_Of
(Project_Node_Of
(Node
)));
560 if Package_Node_Of
(Node
) /= Empty_Node
then
561 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
565 Output_Name
(Name_Of
(Node
));
567 when N_External_Value
=>
568 pragma Debug
(Indicate_Tested
(N_External_Value
));
569 Write_String
("external (");
570 Print
(External_Reference_Of
(Node
), Indent
);
572 if External_Default_Of
(Node
) /= Empty_Node
then
574 Print
(External_Default_Of
(Node
), Indent
);
579 when N_Attribute_Reference
=>
580 pragma Debug
(Indicate_Tested
(N_Attribute_Reference
));
582 if Project_Node_Of
(Node
) /= Empty_Node
583 and then Project_Node_Of
(Node
) /= Project
585 Output_Name
(Name_Of
(Project_Node_Of
(Node
)));
587 if Package_Node_Of
(Node
) /= Empty_Node
then
589 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
592 elsif Package_Node_Of
(Node
) /= Empty_Node
then
593 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
596 Write_String
("project");
600 Output_Attribute_Name
(Name_Of
(Node
));
603 Index
: constant Name_Id
:=
604 Associative_Array_Index_Of
(Node
);
607 if Index
/= No_Name
then
609 Output_String
(Index
);
614 when N_Case_Construction
=>
615 pragma Debug
(Indicate_Tested
(N_Case_Construction
));
618 Case_Item
: Project_Node_Id
:= First_Case_Item_Of
(Node
);
619 Is_Non_Empty
: Boolean := False;
621 while Case_Item
/= Empty_Node
loop
622 if First_Declarative_Item_Of
(Case_Item
) /= Empty_Node
623 or else not Eliminate_Empty_Case_Constructions
625 Is_Non_Empty
:= True;
628 Case_Item
:= Next_Case_Item
(Case_Item
);
633 Print
(First_Comment_Before
(Node
), Indent
);
635 Write_String
("case ");
636 Print
(Case_Variable_Reference_Of
(Node
), Indent
);
637 Write_String
(" is");
638 Write_End_Of_Line_Comment
(Node
);
639 Print
(First_Comment_After
(Node
), Indent
+ Increment
);
642 Case_Item
: Project_Node_Id
:=
643 First_Case_Item_Of
(Node
);
646 while Case_Item
/= Empty_Node
loop
648 (Kind_Of
(Case_Item
) = N_Case_Item
);
649 Print
(Case_Item
, Indent
+ Increment
);
650 Case_Item
:= Next_Case_Item
(Case_Item
);
654 Print
(First_Comment_Before_End
(Node
),
657 Write_Line
("end case;");
658 Print
(First_Comment_After_End
(Node
), Indent
);
663 pragma Debug
(Indicate_Tested
(N_Case_Item
));
665 if First_Declarative_Item_Of
(Node
) /= Empty_Node
666 or else not Eliminate_Empty_Case_Constructions
669 Print
(First_Comment_Before
(Node
), Indent
);
671 Write_String
("when ");
673 if First_Choice_Of
(Node
) = Empty_Node
then
674 Write_String
("others");
678 Label
: Project_Node_Id
:= First_Choice_Of
(Node
);
681 while Label
/= Empty_Node
loop
682 Print
(Label
, Indent
);
683 Label
:= Next_Literal_String
(Label
);
685 if Label
/= Empty_Node
then
686 Write_String
(" | ");
692 Write_String
(" =>");
693 Write_End_Of_Line_Comment
(Node
);
694 Print
(First_Comment_After
(Node
), Indent
+ Increment
);
697 First
: constant Project_Node_Id
:=
698 First_Declarative_Item_Of
(Node
);
701 if First
= Empty_Node
then
705 Print
(First
, Indent
+ Increment
);
710 when N_Comment_Zones
=>
712 -- Nothing to do, because it will not be processed directly
717 pragma Debug
(Indicate_Tested
(N_Comment
));
719 if Follows_Empty_Line
(Node
) then
726 (Get_Name_String
(String_Value_Of
(Node
)),
730 if Is_Followed_By_Empty_Line
(Node
) then
734 Print
(Next_Comment
(Node
), Indent
);
739 -- Start of processing for Pretty_Print
742 if W_Char
= null then
743 Write_Char
:= Output
.Write_Char
'Access;
745 Write_Char
:= W_Char
;
749 Write_Eol
:= Output
.Write_Eol
'Access;
755 Write_Str
:= Output
.Write_Str
'Access;
762 if W_Char
= null or else W_Str
= null then
767 -----------------------
768 -- Output_Statistics --
769 -----------------------
771 procedure Output_Statistics
is
773 Output
.Write_Line
("Project_Node_Kinds not tested:");
775 for Kind
in Project_Node_Kind
loop
776 if Kind
/= N_Comment_Zones
and then Not_Tested
(Kind
) then
777 Output
.Write_Str
(" ");
778 Output
.Write_Line
(Project_Node_Kind
'Image (Kind
));
783 end Output_Statistics
;