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