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