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