gcc/ada/prj-pp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               P R J . P P                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --             Copyright (C) 2001-2002 Free Software Foundation, Inc.       --
  11 --                                                                          --
  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.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Characters.Handling; use Ada.Characters.Handling;
  29
  30 with Hostparm;
  31 with Namet;     use Namet;
  32 with Output;    use Output;
  33 with Stringt;   use Stringt;
  34
  35 package body Prj.PP is
  36
  37    use Prj.Tree;
  38
  39    Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
  40
  41    Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
  42    --  Maximum length of a line.
  43
  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.
  47
  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.
  51    --
  52
  53    ---------------------
  54    -- Indicate_Tested --
  55    ---------------------
  56
  57    procedure Indicate_Tested (Kind : Project_Node_Kind) is
  58    begin
  59       Not_Tested (Kind) := False;
  60    end Indicate_Tested;
  61
  62    ------------------
  63    -- Pretty_Print --
  64    ------------------
  65
  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
  74
  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.
  81
  82       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
  83       --  Outputs a name
  84
  85       procedure Start_Line (Indent : Natural);
  86       --  Outputs the indentation at the beginning of the line.
  87
  88       procedure Output_String (S : String_Id);
  89       --  Outputs a string using the default output procedures
  90
  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
  94       --  is False.
  95
  96       procedure Write_Line (S : String);
  97       --  Outputs S followed by a new line
  98
  99       procedure Write_String (S : String);
 100       --  Outputs S using Write_Str, starting a new line if line would
 101       --  become too long.
 102
 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.
 107
 108       Last_Line_Is_Empty : Boolean := False;
 109       --  Used to avoid two consecutive empty lines.
 110
 111       -----------------
 112       -- Output_Name --
 113       -----------------
 114
 115       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
 116          Capital : Boolean := Capitalize;
 117
 118       begin
 119          Get_Name_String (Name);
 120
 121          --  If line would become too long, create new line
 122
 123          if Column + Name_Len > Max_Line_Length then
 124             Write_Eol.all;
 125             Column := 0;
 126          end if;
 127
 128          for J in 1 .. Name_Len loop
 129             if Capital then
 130                Write_Char (To_Upper (Name_Buffer (J)));
 131             else
 132                Write_Char (Name_Buffer (J));
 133             end if;
 134
 135             if Capitalize then
 136                Capital :=
 137                  Name_Buffer (J) = '_'
 138                  or else Is_Digit (Name_Buffer (J));
 139             end if;
 140          end loop;
 141       end Output_Name;
 142
 143       -------------------
 144       -- Output_String --
 145       -------------------
 146
 147       procedure Output_String (S : String_Id) is
 148       begin
 149          String_To_Name_Buffer (S);
 150
 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 '"').
 155
 156          if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
 157             Write_Eol.all;
 158             Column := 0;
 159          end if;
 160
 161          Write_Char ('"');
 162          Column := Column + 1;
 163          String_To_Name_Buffer (S);
 164
 165          for J in 1 .. Name_Len loop
 166             if Name_Buffer (J) = '"' then
 167                Write_Char ('"');
 168                Write_Char ('"');
 169                Column := Column + 2;
 170             else
 171                Write_Char (Name_Buffer (J));
 172                Column := Column + 1;
 173             end if;
 174
 175             --  If the string does not fit on one line, cut it in parts
 176             --  and concatenate.
 177
 178             if J < Name_Len and then Column >= Max_Line_Length then
 179                Write_Str (""" &");
 180                Write_Eol.all;
 181                Write_Char ('"');
 182                Column := 1;
 183             end if;
 184          end loop;
 185
 186          Write_Char ('"');
 187          Column := Column + 1;
 188       end Output_String;
 189
 190       ----------------
 191       -- Start_Line --
 192       ----------------
 193
 194       procedure Start_Line (Indent : Natural) is
 195       begin
 196          if not Minimize_Empty_Lines then
 197             Write_Str ((1 .. Indent => ' '));
 198             Column := Column + Indent;
 199          end if;
 200       end Start_Line;
 201
 202       ----------------------
 203       -- Write_Empty_Line --
 204       ----------------------
 205
 206       procedure Write_Empty_Line (Always : Boolean := False) is
 207       begin
 208          if (Always or else not Minimize_Empty_Lines)
 209            and then not Last_Line_Is_Empty then
 210             Write_Eol.all;
 211             Column := 0;
 212             Last_Line_Is_Empty := True;
 213          end if;
 214       end Write_Empty_Line;
 215
 216       ----------------
 217       -- Write_Line --
 218       ----------------
 219
 220       procedure Write_Line (S : String) is
 221       begin
 222          Write_String (S);
 223          Last_Line_Is_Empty := False;
 224          Write_Eol.all;
 225          Column := 0;
 226       end Write_Line;
 227
 228       ------------------
 229       -- Write_String --
 230       ------------------
 231
 232       procedure Write_String (S : String) is
 233       begin
 234          --  If the string would not fit on the line,
 235          --  start a new line.
 236
 237          if Column + S'Length > Max_Line_Length then
 238             Write_Eol.all;
 239             Column := 0;
 240          end if;
 241
 242          Write_Str (S);
 243          Column := Column + S'Length;
 244       end Write_String;
 245
 246       -----------
 247       -- Print --
 248       -----------
 249
 250       procedure Print (Node   : Project_Node_Id; Indent : Natural) is
 251       begin
 252          if Node /= Empty_Node then
 253
 254             case Kind_Of (Node) is
 255
 256                when N_Project  =>
 257                   pragma Debug (Indicate_Tested (N_Project));
 258                   if First_With_Clause_Of (Node) /= Empty_Node then
 259
 260                      --  with clause(s)
 261
 262                      Print (First_With_Clause_Of (Node), Indent);
 263                      Write_Empty_Line (Always => True);
 264                   end if;
 265
 266                   Start_Line (Indent);
 267                   Write_String ("project ");
 268                   Output_Name (Name_Of (Node));
 269
 270                   --  Check if this project modifies another project
 271
 272                   if Modified_Project_Path_Of (Node) /= No_String then
 273                      Write_String (" extends ");
 274                      Output_String (Modified_Project_Path_Of (Node));
 275                   end if;
 276
 277                   Write_Line (" is");
 278                   Write_Empty_Line (Always => True);
 279
 280                   --  Output all of the declarations in the project
 281
 282                   Print (Project_Declaration_Of (Node), Indent);
 283                   Start_Line (Indent);
 284                   Write_String ("end ");
 285                   Output_Name (Name_Of (Node));
 286                   Write_Line (";");
 287
 288                when N_With_Clause =>
 289                   pragma Debug (Indicate_Tested (N_With_Clause));
 290
 291                   if Name_Of (Node) /= No_Name then
 292                      Start_Line (Indent);
 293                      Write_String ("with ");
 294                      Output_String (String_Value_Of (Node));
 295                      Write_Line (";");
 296                   end if;
 297
 298                   Print (Next_With_Clause_Of (Node), Indent);
 299
 300                when N_Project_Declaration =>
 301                   pragma Debug (Indicate_Tested (N_Project_Declaration));
 302
 303                   if First_Declarative_Item_Of (Node) /= Empty_Node then
 304                      Print
 305                        (First_Declarative_Item_Of (Node), Indent + Increment);
 306                      Write_Empty_Line (Always => True);
 307                   end if;
 308
 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);
 313
 314                when N_Package_Declaration =>
 315                   pragma Debug (Indicate_Tested (N_Package_Declaration));
 316                   Write_Empty_Line (Always => True);
 317                   Start_Line (Indent);
 318                   Write_String ("package ");
 319                   Output_Name (Name_Of (Node));
 320
 321                   if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
 322                      Write_String (" renames ");
 323                      Output_Name
 324                        (Name_Of (Project_Of_Renamed_Package_Of (Node)));
 325                      Write_String (".");
 326                      Output_Name (Name_Of (Node));
 327                      Write_Line (";");
 328
 329                   else
 330                      Write_Line (" is");
 331
 332                      if First_Declarative_Item_Of (Node) /= Empty_Node then
 333                         Print
 334                           (First_Declarative_Item_Of (Node),
 335                            Indent + Increment);
 336                      end if;
 337
 338                      Start_Line (Indent);
 339                      Write_String ("end ");
 340                      Output_Name (Name_Of (Node));
 341                      Write_Line (";");
 342                      Write_Empty_Line;
 343                   end if;
 344
 345                when N_String_Type_Declaration =>
 346                   pragma Debug (Indicate_Tested (N_String_Type_Declaration));
 347                   Start_Line (Indent);
 348                   Write_String ("type ");
 349                   Output_Name (Name_Of (Node));
 350                   Write_Line (" is");
 351                   Start_Line (Indent + Increment);
 352                   Write_String ("(");
 353
 354                   declare
 355                      String_Node : Project_Node_Id :=
 356                        First_Literal_String (Node);
 357
 358                   begin
 359                      while String_Node /= Empty_Node loop
 360                         Output_String (String_Value_Of (String_Node));
 361                         String_Node := Next_Literal_String (String_Node);
 362
 363                         if String_Node /= Empty_Node then
 364                            Write_String (", ");
 365                         end if;
 366                      end loop;
 367                   end;
 368
 369                   Write_Line (");");
 370
 371                when N_Literal_String =>
 372                   pragma Debug (Indicate_Tested (N_Literal_String));
 373                   Output_String (String_Value_Of (Node));
 374
 375                when N_Attribute_Declaration =>
 376                   pragma Debug (Indicate_Tested (N_Attribute_Declaration));
 377                   Start_Line (Indent);
 378                   Write_String ("for ");
 379                   Output_Name (Name_Of (Node));
 380
 381                   if Associative_Array_Index_Of (Node) /= No_String then
 382                      Write_String (" (");
 383                      Output_String (Associative_Array_Index_Of (Node));
 384                      Write_String (")");
 385                   end if;
 386
 387                   Write_String (" use ");
 388                   Print (Expression_Of (Node), Indent);
 389                   Write_Line (";");
 390
 391                when N_Typed_Variable_Declaration =>
 392                   pragma Debug
 393                     (Indicate_Tested (N_Typed_Variable_Declaration));
 394                   Start_Line (Indent);
 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);
 400                   Write_Line (";");
 401
 402                when N_Variable_Declaration =>
 403                   pragma Debug (Indicate_Tested (N_Variable_Declaration));
 404                   Start_Line (Indent);
 405                   Output_Name (Name_Of (Node));
 406                   Write_String (" := ");
 407                   Print (Expression_Of (Node), Indent);
 408                   Write_Line (";");
 409
 410                when N_Expression =>
 411                   pragma Debug (Indicate_Tested (N_Expression));
 412                   declare
 413                      Term : Project_Node_Id := First_Term (Node);
 414
 415                   begin
 416                      while Term /= Empty_Node loop
 417                         Print (Term, Indent);
 418                         Term := Next_Term (Term);
 419
 420                         if Term /= Empty_Node then
 421                            Write_String (" & ");
 422                         end if;
 423                      end loop;
 424                   end;
 425
 426                when N_Term =>
 427                   pragma Debug (Indicate_Tested (N_Term));
 428                   Print (Current_Term (Node), Indent);
 429
 430                when N_Literal_String_List =>
 431                   pragma Debug (Indicate_Tested (N_Literal_String_List));
 432                   Write_String ("(");
 433
 434                   declare
 435                      Expression : Project_Node_Id :=
 436                        First_Expression_In_List (Node);
 437
 438                   begin
 439                      while Expression /= Empty_Node loop
 440                         Print (Expression, Indent);
 441                         Expression := Next_Expression_In_List (Expression);
 442
 443                         if Expression /= Empty_Node then
 444                            Write_String (", ");
 445                         end if;
 446                      end loop;
 447                   end;
 448
 449                   Write_String (")");
 450
 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)));
 455                      Write_String (".");
 456                   end if;
 457
 458                   if Package_Node_Of (Node) /= Empty_Node then
 459                      Output_Name (Name_Of (Package_Node_Of (Node)));
 460                      Write_String (".");
 461                   end if;
 462
 463                   Output_Name (Name_Of (Node));
 464
 465                when N_External_Value =>
 466                   pragma Debug (Indicate_Tested (N_External_Value));
 467                   Write_String ("external (");
 468                   Print (External_Reference_Of (Node), Indent);
 469
 470                   if External_Default_Of (Node) /= Empty_Node then
 471                      Write_String (", ");
 472                      Print (External_Default_Of (Node), Indent);
 473                   end if;
 474
 475                   Write_String (")");
 476
 477                when N_Attribute_Reference =>
 478                   pragma Debug (Indicate_Tested (N_Attribute_Reference));
 479
 480                   if Project_Node_Of (Node) /= Empty_Node
 481                     and then Project_Node_Of (Node) /= Project
 482                   then
 483                      Output_Name (Name_Of (Project_Node_Of (Node)));
 484
 485                      if Package_Node_Of (Node) /= Empty_Node then
 486                         Write_String (".");
 487                         Output_Name (Name_Of (Package_Node_Of (Node)));
 488                      end if;
 489
 490                   elsif Package_Node_Of (Node) /= Empty_Node then
 491                      Output_Name (Name_Of (Package_Node_Of (Node)));
 492
 493                   else
 494                      Write_String ("project");
 495                   end if;
 496
 497                   Write_String ("'");
 498                   Output_Name (Name_Of (Node));
 499
 500                   declare
 501                      Index : constant String_Id :=
 502                        Associative_Array_Index_Of (Node);
 503
 504                   begin
 505                      if Index /= No_String then
 506                         Write_String (" (");
 507                         Output_String (Index);
 508                         Write_String (")");
 509                      end if;
 510                   end;
 511
 512                when N_Case_Construction =>
 513                   pragma Debug (Indicate_Tested (N_Case_Construction));
 514
 515                   declare
 516                      Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
 517                      Is_Non_Empty : Boolean := False;
 518                   begin
 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
 522                         then
 523                            Is_Non_Empty := True;
 524                            exit;
 525                         end if;
 526                         Case_Item := Next_Case_Item (Case_Item);
 527                      end loop;
 528
 529                      if Is_Non_Empty then
 530                         Write_Empty_Line;
 531                         Start_Line (Indent);
 532                         Write_String ("case ");
 533                         Print (Case_Variable_Reference_Of (Node), Indent);
 534                         Write_Line (" is");
 535
 536                         declare
 537                            Case_Item : Project_Node_Id :=
 538                              First_Case_Item_Of (Node);
 539
 540                         begin
 541                            while Case_Item /= Empty_Node loop
 542                               pragma Assert
 543                                 (Kind_Of (Case_Item) = N_Case_Item);
 544                               Print (Case_Item, Indent + Increment);
 545                               Case_Item := Next_Case_Item (Case_Item);
 546                            end loop;
 547                         end;
 548
 549                         Start_Line (Indent);
 550                         Write_Line ("end case;");
 551                      end if;
 552                   end;
 553
 554                when N_Case_Item =>
 555                   pragma Debug (Indicate_Tested (N_Case_Item));
 556
 557                   if First_Declarative_Item_Of (Node) /= Empty_Node
 558                     or else not Eliminate_Empty_Case_Constructions
 559                   then
 560                      Write_Empty_Line;
 561                      Start_Line (Indent);
 562                      Write_String ("when ");
 563
 564                      if First_Choice_Of (Node) = Empty_Node then
 565                         Write_String ("others");
 566
 567                      else
 568                         declare
 569                            Label : Project_Node_Id := First_Choice_Of (Node);
 570
 571                         begin
 572                            while Label /= Empty_Node loop
 573                               Print (Label, Indent);
 574                               Label := Next_Literal_String (Label);
 575
 576                               if Label /= Empty_Node then
 577                                  Write_String (" | ");
 578                               end if;
 579                            end loop;
 580                         end;
 581                      end if;
 582
 583                      Write_Line (" =>");
 584
 585                      declare
 586                         First : Project_Node_Id :=
 587                           First_Declarative_Item_Of (Node);
 588
 589                      begin
 590                         if First = Empty_Node then
 591                            Write_Eol.all;
 592
 593                         else
 594                            Print (First, Indent + Increment);
 595                         end if;
 596                      end;
 597                   end if;
 598             end case;
 599          end if;
 600       end Print;
 601
 602    begin
 603       if W_Char = null then
 604          Write_Char := Output.Write_Char'Access;
 605       else
 606          Write_Char := W_Char;
 607       end if;
 608
 609       if W_Eol = null then
 610          Write_Eol := Output.Write_Eol'Access;
 611       else
 612          Write_Eol := W_Eol;
 613       end if;
 614
 615       if W_Str = null then
 616          Write_Str := Output.Write_Str'Access;
 617       else
 618          Write_Str := W_Str;
 619       end if;
 620
 621       Print (Project, 0);
 622
 623       if W_Char = null or else W_Str = null then
 624          Output.Write_Eol;
 625       end if;
 626    end Pretty_Print;
 627
 628    -----------------------
 629    -- Output_Statistics --
 630    -----------------------
 631
 632    procedure Output_Statistics is
 633    begin
 634       Output.Write_Line ("Project_Node_Kinds not tested:");
 635
 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));
 640          end if;
 641       end loop;
 642
 643       Output.Write_Eol;
 644    end Output_Statistics;
 645
 646 end Prj.PP;