?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* builtins.def (BUILT_IN_STACK_ALLOC): Remove.
[official-gcc.git] / gcc / ada / prj-pp.adb
blobf9cceb5bc52f7d6f216ed4fbe71ebabd3723705b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . P P --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Ada.Characters.Handling; use Ada.Characters.Handling;
28
29 with Hostparm;
30 with Namet; use Namet;
31 with Output; use Output;
32 with Snames;
33
34 package body Prj.PP is
35
36 use Prj.Tree;
37
38 Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
39
40 Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
41 -- Maximum length of a line.
42
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.
46
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.
50
51 ---------------------
52 -- Indicate_Tested --
53 ---------------------
54
55 procedure Indicate_Tested (Kind : Project_Node_Kind) is
56 begin
57 Not_Tested (Kind) := False;
58 end Indicate_Tested;
59
60 ------------------
61 -- Pretty_Print --
62 ------------------
63
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)
73 is
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.
79
80 procedure Output_Attribute_Name (Name : Name_Id);
81 -- Outputs an attribute name, taking into account the value of
82 -- Backward_Compatibility.
83
84 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
85 -- Outputs a name
86
87 procedure Start_Line (Indent : Natural);
88 -- Outputs the indentation at the beginning of the line.
89
90 procedure Output_String (S : Name_Id);
91 -- Outputs a string using the default output procedures
92
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.
96
97 procedure Write_Line (S : String);
98 -- Outputs S followed by a new line
99
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.
105
106 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
107
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.
112
113 Last_Line_Is_Empty : Boolean := False;
114 -- Used to avoid two consecutive empty lines.
115
116 ---------------------------
117 -- Output_Attribute_Name --
118 ---------------------------
119
120 procedure Output_Attribute_Name (Name : Name_Id) is
121 begin
122 if Backward_Compatibility then
123 case Name is
124 when Snames.Name_Spec =>
125 Output_Name (Snames.Name_Specification);
126
127 when Snames.Name_Spec_Suffix =>
128 Output_Name (Snames.Name_Specification_Suffix);
129
130 when Snames.Name_Body =>
131 Output_Name (Snames.Name_Implementation);
132
133 when Snames.Name_Body_Suffix =>
134 Output_Name (Snames.Name_Implementation_Suffix);
135
136 when others =>
137 Output_Name (Name);
138 end case;
139
140 else
141 Output_Name (Name);
142 end if;
143 end Output_Attribute_Name;
144
145 -----------------
146 -- Output_Name --
147 -----------------
148
149 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
150 Capital : Boolean := Capitalize;
151
152 begin
153 Get_Name_String (Name);
154
155 -- If line would become too long, create new line
156
157 if Column + Name_Len > Max_Line_Length then
158 Write_Eol.all;
159 Column := 0;
160 end if;
161
162 for J in 1 .. Name_Len loop
163 if Capital then
164 Write_Char (To_Upper (Name_Buffer (J)));
165 else
166 Write_Char (Name_Buffer (J));
167 end if;
168
169 if Capitalize then
170 Capital :=
171 Name_Buffer (J) = '_'
172 or else Is_Digit (Name_Buffer (J));
173 end if;
174 end loop;
175
176 Column := Column + Name_Len;
177 end Output_Name;
178
179 -------------------
180 -- Output_String --
181 -------------------
182
183 procedure Output_String (S : Name_Id) is
184 begin
185 Get_Name_String (S);
186
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 '"').
191
192 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
193 Write_Eol.all;
194 Column := 0;
195 end if;
196
197 Write_Char ('"');
198 Column := Column + 1;
199 Get_Name_String (S);
200
201 for J in 1 .. Name_Len loop
202 if Name_Buffer (J) = '"' then
203 Write_Char ('"');
204 Write_Char ('"');
205 Column := Column + 2;
206 else
207 Write_Char (Name_Buffer (J));
208 Column := Column + 1;
209 end if;
210
211 -- If the string does not fit on one line, cut it in parts
212 -- and concatenate.
213
214 if J < Name_Len and then Column >= Max_Line_Length then
215 Write_Str (""" &");
216 Write_Eol.all;
217 Write_Char ('"');
218 Column := 1;
219 end if;
220 end loop;
221
222 Write_Char ('"');
223 Column := Column + 1;
224 end Output_String;
225
226 ----------------
227 -- Start_Line --
228 ----------------
229
230 procedure Start_Line (Indent : Natural) is
231 begin
232 if not Minimize_Empty_Lines then
233 Write_Str ((1 .. Indent => ' '));
234 Column := Column + Indent;
235 end if;
236 end Start_Line;
237
238 ----------------------
239 -- Write_Empty_Line --
240 ----------------------
241
242 procedure Write_Empty_Line (Always : Boolean := False) is
243 begin
244 if (Always or else not Minimize_Empty_Lines)
245 and then not Last_Line_Is_Empty then
246 Write_Eol.all;
247 Column := 0;
248 Last_Line_Is_Empty := True;
249 end if;
250 end Write_Empty_Line;
251
252 -------------------------------
253 -- Write_End_Of_Line_Comment --
254 -------------------------------
255
256 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
257 Value : constant Name_Id := End_Of_Line_Comment (Node);
258
259 begin
260 if Value /= No_Name then
261 Write_String (" --");
262 Write_String (Get_Name_String (Value), Truncated => True);
263 end if;
264
265 Write_Line ("");
266 end Write_End_Of_Line_Comment;
267
268 ----------------
269 -- Write_Line --
270 ----------------
271
272 procedure Write_Line (S : String) is
273 begin
274 Write_String (S);
275 Last_Line_Is_Empty := False;
276 Write_Eol.all;
277 Column := 0;
278 end Write_Line;
279
280 ------------------
281 -- Write_String --
282 ------------------
283
284 procedure Write_String (S : String; Truncated : Boolean := False) is
285 Length : Natural := S'Length;
286 begin
287 -- If the string would not fit on the line,
288 -- start a new line.
289
290 if Column + Length > Max_Line_Length then
291 if Truncated then
292 Length := Max_Line_Length - Column;
293
294 else
295 Write_Eol.all;
296 Column := 0;
297 end if;
298 end if;
299
300 Write_Str (S (S'First .. S'First + Length - 1));
301 Column := Column + Length;
302 end Write_String;
303
304 -----------
305 -- Print --
306 -----------
307
308 procedure Print (Node : Project_Node_Id; Indent : Natural) is
309 begin
310 if Node /= Empty_Node then
311
312 case Kind_Of (Node) is
313
314 when N_Project =>
315 pragma Debug (Indicate_Tested (N_Project));
316 if First_With_Clause_Of (Node) /= Empty_Node then
317
318 -- with clause(s)
319
320 Print (First_With_Clause_Of (Node), Indent);
321 Write_Empty_Line (Always => True);
322 end if;
323
324 Print (First_Comment_Before (Node), Indent);
325 Start_Line (Indent);
326 Write_String ("project ");
327 Output_Name (Name_Of (Node));
328
329 -- Check if this project extends another project
330
331 if Extended_Project_Path_Of (Node) /= No_Name then
332 Write_String (" extends ");
333 Output_String (Extended_Project_Path_Of (Node));
334 end if;
335
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);
340
341 -- Output all of the declarations in the project
342
343 Print (Project_Declaration_Of (Node), Indent);
344 Print (First_Comment_Before_End (Node), Indent + Increment);
345 Start_Line (Indent);
346 Write_String ("end ");
347 Output_Name (Name_Of (Node));
348 Write_Line (";");
349 Print (First_Comment_After_End (Node), Indent);
350
351 when N_With_Clause =>
352 pragma Debug (Indicate_Tested (N_With_Clause));
353
354 if Name_Of (Node) /= No_Name then
355 Print (First_Comment_Before (Node), Indent);
356 Start_Line (Indent);
357
358 if Non_Limited_Project_Node_Of (Node) = Empty_Node then
359 Write_String ("limited ");
360 end if;
361
362 Write_String ("with ");
363 Output_String (String_Value_Of (Node));
364 Write_String (";");
365 Write_End_Of_Line_Comment (Node);
366 Print (First_Comment_After (Node), Indent);
367 end if;
368
369 Print (Next_With_Clause_Of (Node), Indent);
370
371 when N_Project_Declaration =>
372 pragma Debug (Indicate_Tested (N_Project_Declaration));
373
374 if First_Declarative_Item_Of (Node) /= Empty_Node then
375 Print
376 (First_Declarative_Item_Of (Node), Indent + Increment);
377 Write_Empty_Line (Always => True);
378 end if;
379
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);
384
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);
389 Start_Line (Indent);
390 Write_String ("package ");
391 Output_Name (Name_Of (Node));
392
393 if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
394 Write_String (" renames ");
395 Output_Name
396 (Name_Of (Project_Of_Renamed_Package_Of (Node)));
397 Write_String (".");
398 Output_Name (Name_Of (Node));
399 Write_String (";");
400 Write_End_Of_Line_Comment (Node);
401 Print (First_Comment_After_End (Node), Indent);
402
403 else
404 Write_String (" is");
405 Write_End_Of_Line_Comment (Node);
406 Print (First_Comment_After (Node), Indent + Increment);
407
408 if First_Declarative_Item_Of (Node) /= Empty_Node then
409 Print
410 (First_Declarative_Item_Of (Node),
411 Indent + Increment);
412 end if;
413
414 Print (First_Comment_Before_End (Node),
415 Indent + Increment);
416 Start_Line (Indent);
417 Write_String ("end ");
418 Output_Name (Name_Of (Node));
419 Write_Line (";");
420 Print (First_Comment_After_End (Node), Indent);
421 Write_Empty_Line;
422 end if;
423
424 when N_String_Type_Declaration =>
425 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
426 Print (First_Comment_Before (Node), Indent);
427 Start_Line (Indent);
428 Write_String ("type ");
429 Output_Name (Name_Of (Node));
430 Write_Line (" is");
431 Start_Line (Indent + Increment);
432 Write_String ("(");
433
434 declare
435 String_Node : Project_Node_Id :=
436 First_Literal_String (Node);
437
438 begin
439 while String_Node /= Empty_Node loop
440 Output_String (String_Value_Of (String_Node));
441 String_Node := Next_Literal_String (String_Node);
442
443 if String_Node /= Empty_Node then
444 Write_String (", ");
445 end if;
446 end loop;
447 end;
448
449 Write_String (");");
450 Write_End_Of_Line_Comment (Node);
451 Print (First_Comment_After (Node), Indent);
452
453 when N_Literal_String =>
454 pragma Debug (Indicate_Tested (N_Literal_String));
455 Output_String (String_Value_Of (Node));
456
457 if Source_Index_Of (Node) /= 0 then
458 Write_String (" at ");
459 Write_String (Source_Index_Of (Node)'Img);
460 end if;
461
462 when N_Attribute_Declaration =>
463 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
464 Print (First_Comment_Before (Node), Indent);
465 Start_Line (Indent);
466 Write_String ("for ");
467 Output_Attribute_Name (Name_Of (Node));
468
469 if Associative_Array_Index_Of (Node) /= No_Name then
470 Write_String (" (");
471 Output_String (Associative_Array_Index_Of (Node));
472
473 if Source_Index_Of (Node) /= 0 then
474 Write_String (" at ");
475 Write_String (Source_Index_Of (Node)'Img);
476 end if;
477
478 Write_String (")");
479 end if;
480
481 Write_String (" use ");
482 Print (Expression_Of (Node), Indent);
483 Write_String (";");
484 Write_End_Of_Line_Comment (Node);
485 Print (First_Comment_After (Node), Indent);
486
487 when N_Typed_Variable_Declaration =>
488 pragma Debug
489 (Indicate_Tested (N_Typed_Variable_Declaration));
490 Print (First_Comment_Before (Node), Indent);
491 Start_Line (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);
497 Write_String (";");
498 Write_End_Of_Line_Comment (Node);
499 Print (First_Comment_After (Node), Indent);
500
501 when N_Variable_Declaration =>
502 pragma Debug (Indicate_Tested (N_Variable_Declaration));
503 Print (First_Comment_Before (Node), Indent);
504 Start_Line (Indent);
505 Output_Name (Name_Of (Node));
506 Write_String (" := ");
507 Print (Expression_Of (Node), Indent);
508 Write_String (";");
509 Write_End_Of_Line_Comment (Node);
510 Print (First_Comment_After (Node), Indent);
511
512 when N_Expression =>
513 pragma Debug (Indicate_Tested (N_Expression));
514 declare
515 Term : Project_Node_Id := First_Term (Node);
516
517 begin
518 while Term /= Empty_Node loop
519 Print (Term, Indent);
520 Term := Next_Term (Term);
521
522 if Term /= Empty_Node then
523 Write_String (" & ");
524 end if;
525 end loop;
526 end;
527
528 when N_Term =>
529 pragma Debug (Indicate_Tested (N_Term));
530 Print (Current_Term (Node), Indent);
531
532 when N_Literal_String_List =>
533 pragma Debug (Indicate_Tested (N_Literal_String_List));
534 Write_String ("(");
535
536 declare
537 Expression : Project_Node_Id :=
538 First_Expression_In_List (Node);
539
540 begin
541 while Expression /= Empty_Node loop
542 Print (Expression, Indent);
543 Expression := Next_Expression_In_List (Expression);
544
545 if Expression /= Empty_Node then
546 Write_String (", ");
547 end if;
548 end loop;
549 end;
550
551 Write_String (")");
552
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)));
557 Write_String (".");
558 end if;
559
560 if Package_Node_Of (Node) /= Empty_Node then
561 Output_Name (Name_Of (Package_Node_Of (Node)));
562 Write_String (".");
563 end if;
564
565 Output_Name (Name_Of (Node));
566
567 when N_External_Value =>
568 pragma Debug (Indicate_Tested (N_External_Value));
569 Write_String ("external (");
570 Print (External_Reference_Of (Node), Indent);
571
572 if External_Default_Of (Node) /= Empty_Node then
573 Write_String (", ");
574 Print (External_Default_Of (Node), Indent);
575 end if;
576
577 Write_String (")");
578
579 when N_Attribute_Reference =>
580 pragma Debug (Indicate_Tested (N_Attribute_Reference));
581
582 if Project_Node_Of (Node) /= Empty_Node
583 and then Project_Node_Of (Node) /= Project
584 then
585 Output_Name (Name_Of (Project_Node_Of (Node)));
586
587 if Package_Node_Of (Node) /= Empty_Node then
588 Write_String (".");
589 Output_Name (Name_Of (Package_Node_Of (Node)));
590 end if;
591
592 elsif Package_Node_Of (Node) /= Empty_Node then
593 Output_Name (Name_Of (Package_Node_Of (Node)));
594
595 else
596 Write_String ("project");
597 end if;
598
599 Write_String ("'");
600 Output_Attribute_Name (Name_Of (Node));
601
602 declare
603 Index : constant Name_Id :=
604 Associative_Array_Index_Of (Node);
605
606 begin
607 if Index /= No_Name then
608 Write_String (" (");
609 Output_String (Index);
610 Write_String (")");
611 end if;
612 end;
613
614 when N_Case_Construction =>
615 pragma Debug (Indicate_Tested (N_Case_Construction));
616
617 declare
618 Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
619 Is_Non_Empty : Boolean := False;
620 begin
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
624 then
625 Is_Non_Empty := True;
626 exit;
627 end if;
628 Case_Item := Next_Case_Item (Case_Item);
629 end loop;
630
631 if Is_Non_Empty then
632 Write_Empty_Line;
633 Print (First_Comment_Before (Node), Indent);
634 Start_Line (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);
640
641 declare
642 Case_Item : Project_Node_Id :=
643 First_Case_Item_Of (Node);
644
645 begin
646 while Case_Item /= Empty_Node loop
647 pragma Assert
648 (Kind_Of (Case_Item) = N_Case_Item);
649 Print (Case_Item, Indent + Increment);
650 Case_Item := Next_Case_Item (Case_Item);
651 end loop;
652 end;
653
654 Print (First_Comment_Before_End (Node),
655 Indent + Increment);
656 Start_Line (Indent);
657 Write_Line ("end case;");
658 Print (First_Comment_After_End (Node), Indent);
659 end if;
660 end;
661
662 when N_Case_Item =>
663 pragma Debug (Indicate_Tested (N_Case_Item));
664
665 if First_Declarative_Item_Of (Node) /= Empty_Node
666 or else not Eliminate_Empty_Case_Constructions
667 then
668 Write_Empty_Line;
669 Print (First_Comment_Before (Node), Indent);
670 Start_Line (Indent);
671 Write_String ("when ");
672
673 if First_Choice_Of (Node) = Empty_Node then
674 Write_String ("others");
675
676 else
677 declare
678 Label : Project_Node_Id := First_Choice_Of (Node);
679
680 begin
681 while Label /= Empty_Node loop
682 Print (Label, Indent);
683 Label := Next_Literal_String (Label);
684
685 if Label /= Empty_Node then
686 Write_String (" | ");
687 end if;
688 end loop;
689 end;
690 end if;
691
692 Write_String (" =>");
693 Write_End_Of_Line_Comment (Node);
694 Print (First_Comment_After (Node), Indent + Increment);
695
696 declare
697 First : constant Project_Node_Id :=
698 First_Declarative_Item_Of (Node);
699
700 begin
701 if First = Empty_Node then
702 Write_Empty_Line;
703
704 else
705 Print (First, Indent + Increment);
706 end if;
707 end;
708 end if;
709
710 when N_Comment_Zones =>
711
712 -- Nothing to do, because it will not be processed directly
713
714 null;
715
716 when N_Comment =>
717 pragma Debug (Indicate_Tested (N_Comment));
718
719 if Follows_Empty_Line (Node) then
720 Write_Empty_Line;
721 end if;
722
723 Start_Line (Indent);
724 Write_String ("--");
725 Write_String
726 (Get_Name_String (String_Value_Of (Node)),
727 Truncated => True);
728 Write_Line ("");
729
730 if Is_Followed_By_Empty_Line (Node) then
731 Write_Empty_Line;
732 end if;
733
734 Print (Next_Comment (Node), Indent);
735 end case;
736 end if;
737 end Print;
738
739 -- Start of processing for Pretty_Print
740
741 begin
742 if W_Char = null then
743 Write_Char := Output.Write_Char'Access;
744 else
745 Write_Char := W_Char;
746 end if;
747
748 if W_Eol = null then
749 Write_Eol := Output.Write_Eol'Access;
750 else
751 Write_Eol := W_Eol;
752 end if;
753
754 if W_Str = null then
755 Write_Str := Output.Write_Str'Access;
756 else
757 Write_Str := W_Str;
758 end if;
759
760 Print (Project, 0);
761
762 if W_Char = null or else W_Str = null then
763 Output.Write_Eol;
764 end if;
765 end Pretty_Print;
766
767 -----------------------
768 -- Output_Statistics --
769 -----------------------
770
771 procedure Output_Statistics is
772 begin
773 Output.Write_Line ("Project_Node_Kinds not tested:");
774
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));
779 end if;
780 end loop;
781
782 Output.Write_Eol;
783 end Output_Statistics;
784
785 end Prj.PP;
Mirror of the offical gcc git repository hosted at gcc.gnu.org