gcc/ada/prj-attr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P R J . A T T R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Namet;   use Namet;
  28 with Osint;
  29 with Prj.Com; use Prj.Com;
  30 with System.Case_Util; use System.Case_Util;
  31
  32 package body Prj.Attr is
  33
  34    --  Data for predefined attributes and packages
  35
  36    --  Names end with '#'
  37
  38    --  Package names are preceded by 'P'
  39
  40    --  Attribute names are preceded by two letters:
  41
  42    --  The first letter is one of
  43    --    'S' for Single
  44    --    's' for Single with optional index
  45    --    'L' for List
  46    --    'l' for List of strings with optional indexes
  47
  48    --  The second letter is one of
  49    --    'V' for single variable
  50    --    'A' for associative array
  51    --    'a' for case insensitive associative array
  52    --    'b' for associative array, case insensitive if file names are case
  53    --        insensitive
  54    --    'c' same as 'b', with optional index
  55
  56    --  End is indicated by two consecutive '#'
  57
  58    Initialization_Data : constant String :=
  59
  60    --  project attributes
  61
  62      "SVobject_dir#" &
  63      "SVexec_dir#" &
  64      "LVsource_dirs#" &
  65      "LVsource_files#" &
  66      "LVlocally_removed_files#" &
  67      "SVsource_list_file#" &
  68      "SVlibrary_dir#" &
  69      "SVlibrary_name#" &
  70      "SVlibrary_kind#" &
  71      "SVlibrary_version#" &
  72      "LVlibrary_interface#" &
  73      "SVlibrary_auto_init#" &
  74      "LVlibrary_options#" &
  75      "SVlibrary_src_dir#" &
  76      "SVlibrary_ali_dir#" &
  77      "SVlibrary_gcc#" &
  78      "SVlibrary_symbol_file#" &
  79      "SVlibrary_symbol_policy#" &
  80      "SVlibrary_reference_symbol_file#" &
  81      "lVmain#" &
  82      "LVlanguages#" &
  83      "SVmain_language#" &
  84      "LVada_roots#" &
  85      "SVexternally_built#" &
  86
  87    --  package Naming
  88
  89      "Pnaming#" &
  90      "Saspecification_suffix#" &
  91      "Saspec_suffix#" &
  92      "Saimplementation_suffix#" &
  93      "Sabody_suffix#" &
  94      "SVseparate_suffix#" &
  95      "SVcasing#" &
  96      "SVdot_replacement#" &
  97      "sAspecification#" &
  98      "sAspec#" &
  99      "sAimplementation#" &
 100      "sAbody#" &
 101      "Laspecification_exceptions#" &
 102      "Laimplementation_exceptions#" &
 103
 104    --  package Compiler
 105
 106      "Pcompiler#" &
 107      "Ladefault_switches#" &
 108      "Lcswitches#" &
 109      "SVlocal_configuration_pragmas#" &
 110
 111    --  package Builder
 112
 113      "Pbuilder#" &
 114      "Ladefault_switches#" &
 115      "Lcswitches#" &
 116      "Scexecutable#" &
 117      "SVexecutable_suffix#" &
 118      "SVglobal_configuration_pragmas#" &
 119
 120    --  package gnatls
 121
 122      "Pgnatls#" &
 123      "LVswitches#" &
 124
 125    --  package Binder
 126
 127      "Pbinder#" &
 128      "Ladefault_switches#" &
 129      "Lcswitches#" &
 130
 131    --  package Linker
 132
 133      "Plinker#" &
 134      "Ladefault_switches#" &
 135      "Lcswitches#" &
 136      "LVlinker_options#" &
 137
 138    --  package Cross_Reference
 139
 140      "Pcross_reference#" &
 141      "Ladefault_switches#" &
 142      "Lbswitches#" &
 143
 144    --  package Finder
 145
 146      "Pfinder#" &
 147      "Ladefault_switches#" &
 148      "Lbswitches#" &
 149
 150    --  package Pretty_Printer
 151
 152      "Ppretty_printer#" &
 153      "Ladefault_switches#" &
 154      "Lbswitches#" &
 155
 156    --  package gnatstub
 157
 158      "Pgnatstub#" &
 159      "Ladefault_switches#" &
 160      "Lbswitches#" &
 161
 162    --  package Check
 163
 164      "Pcheck#" &
 165      "Ladefault_switches#" &
 166      "Lbswitches#" &
 167
 168    --  package Eliminate
 169
 170      "Peliminate#" &
 171      "Ladefault_switches#" &
 172      "Lbswitches#" &
 173
 174    --  package Metrics
 175
 176      "Pmetrics#" &
 177      "Ladefault_switches#" &
 178      "Lbswitches#" &
 179
 180    --  package Ide
 181
 182      "Pide#" &
 183      "Ladefault_switches#" &
 184      "SVremote_host#" &
 185      "SVprogram_host#" &
 186      "SVcommunication_protocol#" &
 187      "Sacompiler_command#" &
 188      "SVdebugger_command#" &
 189      "SVgnatlist#" &
 190      "SVvcs_kind#" &
 191      "SVvcs_file_check#" &
 192      "SVvcs_log_check#" &
 193
 194    --  package Language_Processing
 195
 196      "Planguage_processing#" &
 197      "Lacompiler_driver#" &
 198      "Sacompiler_kind#" &
 199      "Ladependency_option#" &
 200      "Lacompute_dependency#" &
 201      "Lainclude_option#" &
 202      "Sabinder_driver#" &
 203      "SVdefault_linker#" &
 204
 205      "#";
 206
 207    Initialized : Boolean := False;
 208    --  A flag to avoid multiple initialization
 209
 210    function Name_Id_Of (Name : String) return Name_Id;
 211    --  Returns the Name_Id for Name in lower case
 212
 213    -----------------------
 214    -- Attribute_Kind_Of --
 215    -----------------------
 216
 217    function Attribute_Kind_Of
 218      (Attribute : Attribute_Node_Id) return Attribute_Kind
 219    is
 220    begin
 221       if Attribute = Empty_Attribute then
 222          return Unknown;
 223       else
 224          return Attrs.Table (Attribute.Value).Attr_Kind;
 225       end if;
 226    end Attribute_Kind_Of;
 227
 228    -----------------------
 229    -- Attribute_Name_Of --
 230    -----------------------
 231
 232    function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
 233    begin
 234       if Attribute = Empty_Attribute then
 235          return No_Name;
 236       else
 237          return Attrs.Table (Attribute.Value).Name;
 238       end if;
 239    end Attribute_Name_Of;
 240
 241    --------------------------
 242    -- Attribute_Node_Id_Of --
 243    --------------------------
 244
 245    function Attribute_Node_Id_Of
 246      (Name        : Name_Id;
 247       Starting_At : Attribute_Node_Id) return Attribute_Node_Id
 248    is
 249       Id : Attr_Node_Id := Starting_At.Value;
 250
 251    begin
 252       while Id /= Empty_Attr
 253         and then Attrs.Table (Id).Name /= Name
 254       loop
 255          Id := Attrs.Table (Id).Next;
 256       end loop;
 257
 258       return (Value => Id);
 259    end Attribute_Node_Id_Of;
 260
 261    ----------------
 262    -- Initialize --
 263    ----------------
 264
 265    procedure Initialize is
 266       Start             : Positive          := Initialization_Data'First;
 267       Finish            : Positive          := Start;
 268       Current_Package   : Pkg_Node_Id       := Empty_Pkg;
 269       Current_Attribute : Attr_Node_Id      := Empty_Attr;
 270       Is_An_Attribute   : Boolean           := False;
 271       Var_Kind          : Variable_Kind     := Undefined;
 272       Optional_Index    : Boolean           := False;
 273       Attr_Kind            : Attribute_Kind := Single;
 274       Package_Name      : Name_Id           := No_Name;
 275       Attribute_Name    : Name_Id           := No_Name;
 276       First_Attribute   : Attr_Node_Id      := Attr.First_Attribute;
 277
 278       function Attribute_Location return String;
 279       --  Returns a string depending if we are in the project level attributes
 280       --  or in the attributes of a package.
 281
 282       ------------------------
 283       -- Attribute_Location --
 284       ------------------------
 285
 286       function Attribute_Location return String is
 287       begin
 288          if Package_Name = No_Name then
 289             return "project level attributes";
 290
 291          else
 292             return "attribute of package """ &
 293             Get_Name_String (Package_Name) & """";
 294          end if;
 295       end Attribute_Location;
 296
 297    --  Start of processing for Initialize
 298
 299    begin
 300       --  Don't allow Initialize action to be repeated
 301
 302       if Initialized then
 303          return;
 304       end if;
 305
 306       --  Make sure the two tables are empty
 307
 308       Attrs.Init;
 309       Package_Attributes.Init;
 310
 311       while Initialization_Data (Start) /= '#' loop
 312          Is_An_Attribute := True;
 313          case Initialization_Data (Start) is
 314             when 'P' =>
 315
 316                --  New allowed package
 317
 318                Start := Start + 1;
 319
 320                Finish := Start;
 321                while Initialization_Data (Finish) /= '#' loop
 322                   Finish := Finish + 1;
 323                end loop;
 324
 325                Package_Name :=
 326                  Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 327
 328                for Index in First_Package .. Package_Attributes.Last loop
 329                   if Package_Name = Package_Attributes.Table (Index).Name then
 330                      Osint.Fail ("duplicate name """,
 331                            Initialization_Data (Start .. Finish - 1),
 332                            """ in predefined packages.");
 333                   end if;
 334                end loop;
 335
 336                Is_An_Attribute := False;
 337                Current_Attribute := Empty_Attr;
 338                Package_Attributes.Increment_Last;
 339                Current_Package := Package_Attributes.Last;
 340                Package_Attributes.Table (Current_Package) :=
 341                  (Name            => Package_Name,
 342                   Known           => True,
 343                   First_Attribute => Empty_Attr);
 344                Start := Finish + 1;
 345
 346             when 'S' =>
 347                Var_Kind       := Single;
 348                Optional_Index := False;
 349
 350             when 's' =>
 351                Var_Kind       := Single;
 352                Optional_Index := True;
 353
 354             when 'L' =>
 355                Var_Kind       := List;
 356                Optional_Index := False;
 357
 358             when 'l' =>
 359                Var_Kind         := List;
 360                Optional_Index := True;
 361
 362             when others =>
 363                raise Program_Error;
 364          end case;
 365
 366          if Is_An_Attribute then
 367
 368             --  New attribute
 369
 370             Start := Start + 1;
 371             case Initialization_Data (Start) is
 372                when 'V' =>
 373                   Attr_Kind := Single;
 374
 375                when 'A' =>
 376                   Attr_Kind := Associative_Array;
 377
 378                when 'a' =>
 379                   Attr_Kind := Case_Insensitive_Associative_Array;
 380
 381                when 'b' =>
 382                   if Osint.File_Names_Case_Sensitive then
 383                      Attr_Kind := Associative_Array;
 384                   else
 385                      Attr_Kind := Case_Insensitive_Associative_Array;
 386                   end if;
 387
 388                when 'c' =>
 389                   if Osint.File_Names_Case_Sensitive then
 390                      Attr_Kind := Optional_Index_Associative_Array;
 391                   else
 392                      Attr_Kind :=
 393                        Optional_Index_Case_Insensitive_Associative_Array;
 394                   end if;
 395
 396                when others =>
 397                   raise Program_Error;
 398             end case;
 399
 400             Start := Start + 1;
 401             Finish := Start;
 402
 403             while Initialization_Data (Finish) /= '#' loop
 404                Finish := Finish + 1;
 405             end loop;
 406
 407             Attribute_Name :=
 408               Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 409             Attrs.Increment_Last;
 410
 411             if Current_Attribute = Empty_Attr then
 412                First_Attribute := Attrs.Last;
 413
 414                if Current_Package /= Empty_Pkg then
 415                   Package_Attributes.Table (Current_Package).First_Attribute
 416                     := Attrs.Last;
 417                end if;
 418
 419             else
 420                --  Check that there are no duplicate attributes
 421
 422                for Index in First_Attribute .. Attrs.Last - 1 loop
 423                   if Attribute_Name = Attrs.Table (Index).Name then
 424                      Osint.Fail ("duplicate attribute """,
 425                            Initialization_Data (Start .. Finish - 1),
 426                            """ in " & Attribute_Location);
 427                   end if;
 428                end loop;
 429
 430                Attrs.Table (Current_Attribute).Next :=
 431                  Attrs.Last;
 432             end if;
 433
 434             Current_Attribute := Attrs.Last;
 435             Attrs.Table (Current_Attribute) :=
 436               (Name           => Attribute_Name,
 437                Var_Kind       => Var_Kind,
 438                Optional_Index => Optional_Index,
 439                Attr_Kind      => Attr_Kind,
 440                Next           => Empty_Attr);
 441             Start := Finish + 1;
 442          end if;
 443       end loop;
 444
 445       Initialized := True;
 446    end Initialize;
 447
 448    ----------------
 449    -- Name_Id_Of --
 450    ----------------
 451
 452    function Name_Id_Of (Name : String) return Name_Id is
 453    begin
 454       Name_Len := 0;
 455       Add_Str_To_Name_Buffer (Name);
 456       To_Lower (Name_Buffer (1 .. Name_Len));
 457       return Name_Find;
 458    end Name_Id_Of;
 459
 460    --------------------
 461    -- Next_Attribute --
 462    --------------------
 463
 464    function Next_Attribute
 465      (After : Attribute_Node_Id) return Attribute_Node_Id
 466    is
 467    begin
 468       if After = Empty_Attribute then
 469          return Empty_Attribute;
 470       else
 471          return (Value => Attrs.Table (After.Value).Next);
 472       end if;
 473    end Next_Attribute;
 474
 475    -----------------------
 476    -- Optional_Index_Of --
 477    -----------------------
 478
 479    function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
 480    begin
 481       if Attribute = Empty_Attribute then
 482          return False;
 483       else
 484          return Attrs.Table (Attribute.Value).Optional_Index;
 485       end if;
 486    end Optional_Index_Of;
 487
 488    ------------------------
 489    -- Package_Node_Id_Of --
 490    ------------------------
 491
 492    function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
 493    begin
 494       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 495          if Package_Attributes.Table (Index).Name = Name then
 496             return (Value => Index);
 497          end if;
 498       end loop;
 499
 500       --  If there is no package with this name, return Empty_Package
 501
 502       return Empty_Package;
 503    end Package_Node_Id_Of;
 504
 505    ----------------------------
 506    -- Register_New_Attribute --
 507    ----------------------------
 508
 509    procedure Register_New_Attribute
 510      (Name               : String;
 511       In_Package         : Package_Node_Id;
 512       Attr_Kind          : Defined_Attribute_Kind;
 513       Var_Kind           : Defined_Variable_Kind;
 514       Index_Is_File_Name : Boolean := False;
 515       Opt_Index          : Boolean := False)
 516    is
 517       Attr_Name       : Name_Id;
 518       First_Attr      : Attr_Node_Id := Empty_Attr;
 519       Curr_Attr       : Attr_Node_Id;
 520       Real_Attr_Kind  : Attribute_Kind;
 521
 522    begin
 523       if Name'Length = 0 then
 524          Fail ("cannot register an attribute with no name");
 525          raise Project_Error;
 526       end if;
 527
 528       if In_Package = Empty_Package then
 529          Fail ("attempt to add attribute """, Name,
 530                """ to an undefined package");
 531          raise Project_Error;
 532       end if;
 533
 534       Attr_Name := Name_Id_Of (Name);
 535
 536       First_Attr :=
 537         Package_Attributes.Table (In_Package.Value).First_Attribute;
 538
 539       --  Check if attribute name is a duplicate
 540
 541       Curr_Attr := First_Attr;
 542       while Curr_Attr /= Empty_Attr loop
 543          if Attrs.Table (Curr_Attr).Name = Attr_Name then
 544             Fail ("duplicate attribute name """, Name,
 545                   """ in package """ &
 546                   Get_Name_String
 547                     (Package_Attributes.Table (In_Package.Value).Name) &
 548                   """");
 549             raise Project_Error;
 550          end if;
 551
 552          Curr_Attr := Attrs.Table (Curr_Attr).Next;
 553       end loop;
 554
 555       Real_Attr_Kind := Attr_Kind;
 556
 557       --  If Index_Is_File_Name, change the attribute kind if necessary
 558
 559       if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
 560          case Attr_Kind is
 561             when Associative_Array =>
 562                Real_Attr_Kind := Case_Insensitive_Associative_Array;
 563
 564             when Optional_Index_Associative_Array =>
 565                Real_Attr_Kind :=
 566                  Optional_Index_Case_Insensitive_Associative_Array;
 567
 568             when others =>
 569                null;
 570          end case;
 571       end if;
 572
 573       --  Add the new attribute
 574
 575       Attrs.Increment_Last;
 576       Attrs.Table (Attrs.Last) :=
 577         (Name           => Attr_Name,
 578          Var_Kind       => Var_Kind,
 579          Optional_Index => Opt_Index,
 580          Attr_Kind      => Real_Attr_Kind,
 581          Next           => First_Attr);
 582       Package_Attributes.Table (In_Package.Value).First_Attribute :=
 583         Attrs.Last;
 584    end Register_New_Attribute;
 585
 586    --------------------------
 587    -- Register_New_Package --
 588    --------------------------
 589
 590    procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
 591       Pkg_Name : Name_Id;
 592
 593    begin
 594       if Name'Length = 0 then
 595          Fail ("cannot register a package with no name");
 596          Id := Empty_Package;
 597          return;
 598       end if;
 599
 600       Pkg_Name := Name_Id_Of (Name);
 601
 602       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 603          if Package_Attributes.Table (Index).Name = Pkg_Name then
 604             Fail ("cannot register a package with a non unique name""",
 605                   Name, """");
 606             Id := Empty_Package;
 607             return;
 608          end if;
 609       end loop;
 610
 611       Package_Attributes.Increment_Last;
 612       Id := (Value => Package_Attributes.Last);
 613       Package_Attributes.Table (Package_Attributes.Last) :=
 614         (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr);
 615    end Register_New_Package;
 616
 617    procedure Register_New_Package
 618      (Name       : String;
 619       Attributes : Attribute_Data_Array)
 620    is
 621       Pkg_Name   : Name_Id;
 622       Attr_Name  : Name_Id;
 623       First_Attr : Attr_Node_Id := Empty_Attr;
 624       Curr_Attr  : Attr_Node_Id;
 625       Attr_Kind  : Attribute_Kind;
 626
 627    begin
 628       if Name'Length = 0 then
 629          Fail ("cannot register a package with no name");
 630          raise Project_Error;
 631       end if;
 632
 633       Pkg_Name := Name_Id_Of (Name);
 634
 635       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 636          if Package_Attributes.Table (Index).Name = Pkg_Name then
 637             Fail ("cannot register a package with a non unique name""",
 638                   Name, """");
 639             raise Project_Error;
 640          end if;
 641       end loop;
 642
 643       for Index in Attributes'Range loop
 644          Attr_Name := Name_Id_Of (Attributes (Index).Name);
 645
 646          Curr_Attr := First_Attr;
 647          while Curr_Attr /= Empty_Attr loop
 648             if Attrs.Table (Curr_Attr).Name = Attr_Name then
 649                Fail ("duplicate attribute name """, Attributes (Index).Name,
 650                      """ in new package """ & Name & """");
 651                raise Project_Error;
 652             end if;
 653
 654             Curr_Attr := Attrs.Table (Curr_Attr).Next;
 655          end loop;
 656
 657          Attr_Kind := Attributes (Index).Attr_Kind;
 658
 659          if Attributes (Index).Index_Is_File_Name
 660            and then not Osint.File_Names_Case_Sensitive
 661          then
 662             case Attr_Kind is
 663                when Associative_Array =>
 664                   Attr_Kind := Case_Insensitive_Associative_Array;
 665
 666                when Optional_Index_Associative_Array =>
 667                   Attr_Kind :=
 668                     Optional_Index_Case_Insensitive_Associative_Array;
 669
 670                when others =>
 671                   null;
 672             end case;
 673          end if;
 674
 675          Attrs.Increment_Last;
 676          Attrs.Table (Attrs.Last) :=
 677            (Name           => Attr_Name,
 678             Var_Kind       => Attributes (Index).Var_Kind,
 679             Optional_Index => Attributes (Index).Opt_Index,
 680             Attr_Kind      => Attr_Kind,
 681             Next           => First_Attr);
 682          First_Attr := Attrs.Last;
 683       end loop;
 684
 685       Package_Attributes.Increment_Last;
 686       Package_Attributes.Table (Package_Attributes.Last) :=
 687         (Name => Pkg_Name, Known => True, First_Attribute => First_Attr);
 688    end Register_New_Package;
 689
 690    ---------------------------
 691    -- Set_Attribute_Kind_Of --
 692    ---------------------------
 693
 694    procedure Set_Attribute_Kind_Of
 695      (Attribute : Attribute_Node_Id;
 696       To        : Attribute_Kind)
 697    is
 698    begin
 699       if Attribute /= Empty_Attribute then
 700          Attrs.Table (Attribute.Value).Attr_Kind := To;
 701       end if;
 702    end Set_Attribute_Kind_Of;
 703
 704    --------------------------
 705    -- Set_Variable_Kind_Of --
 706    --------------------------
 707
 708    procedure Set_Variable_Kind_Of
 709      (Attribute : Attribute_Node_Id;
 710       To        : Variable_Kind)
 711    is
 712    begin
 713       if Attribute /= Empty_Attribute then
 714          Attrs.Table (Attribute.Value).Var_Kind := To;
 715       end if;
 716    end Set_Variable_Kind_Of;
 717
 718    ----------------------
 719    -- Variable_Kind_Of --
 720    ----------------------
 721
 722    function Variable_Kind_Of
 723      (Attribute : Attribute_Node_Id) return Variable_Kind
 724    is
 725    begin
 726       if Attribute = Empty_Attribute then
 727          return Undefined;
 728       else
 729          return Attrs.Table (Attribute.Value).Var_Kind;
 730       end if;
 731    end Variable_Kind_Of;
 732
 733    ------------------------
 734    -- First_Attribute_Of --
 735    ------------------------
 736
 737    function First_Attribute_Of
 738      (Pkg : Package_Node_Id) return Attribute_Node_Id
 739    is
 740    begin
 741       if Pkg = Empty_Package then
 742          return Empty_Attribute;
 743       else
 744          return
 745            (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
 746       end if;
 747    end First_Attribute_Of;
 748
 749 end Prj.Attr;