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-2014, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Osint;
  27 with Prj.Com; use Prj.Com;
  28
  29 with GNAT.Case_Util; use GNAT.Case_Util;
  30
  31 package body Prj.Attr is
  32
  33    use GNAT;
  34
  35    --  Data for predefined attributes and packages
  36
  37    --  Names are in lower case and end with '#' or 'D'
  38
  39    --  Package names are preceded by 'P'
  40
  41    --  Attribute names are preceded by two or three letters:
  42
  43    --  The first letter is one of
  44    --    'S' for Single
  45    --    's' for Single with optional index
  46    --    'L' for List
  47    --    'l' for List of strings with optional indexes
  48
  49    --  The second letter is one of
  50    --    'V' for single variable
  51    --    'A' for associative array
  52    --    'a' for case insensitive associative array
  53    --    'b' for associative array, case insensitive if file names are case
  54    --        insensitive
  55    --    'c' same as 'b', with optional index
  56
  57    --  The third optional letter is
  58    --     'R' the attribute is read-only
  59    --     'O' others is allowed as an index for an associative array
  60
  61    --  If the character after the name in lower case letter is a 'D' (for
  62    --  default), then 'D' must be followed by an enumeration value of type
  63    --  Attribute_Default_Value, followed by a '#'.
  64
  65    --  Example:
  66    --    "SVobject_dirDdot_value#"
  67
  68    --  End is indicated by two consecutive '#'.
  69
  70    Initialization_Data : constant String :=
  71
  72    --  project level attributes
  73
  74    --  General
  75
  76    "SVRname#" &
  77    "SVRproject_dir#" &
  78    "lVmain#" &
  79    "LVlanguages#" &
  80    "Lbroots#" &
  81    "SVexternally_built#" &
  82
  83    --  Directories
  84
  85    "SVobject_dirDdot_value#" &
  86    "SVexec_dirDobject_dir_value#" &
  87    "LVsource_dirsDdot_value#" &
  88    "Lainherit_source_path#" &
  89    "LVexcluded_source_dirs#" &
  90    "LVignore_source_sub_dirs#" &
  91
  92    --  Source files
  93
  94    "LVsource_files#" &
  95    "LVlocally_removed_files#" &
  96    "LVexcluded_source_files#" &
  97    "SVsource_list_file#" &
  98    "SVexcluded_source_list_file#" &
  99    "LVinterfaces#" &
 100
 101    --  Projects (in aggregate projects)
 102
 103    "LVproject_files#" &
 104    "LVproject_path#" &
 105    "SAexternal#" &
 106
 107    --  Libraries
 108
 109    "SVlibrary_dir#" &
 110    "SVlibrary_name#" &
 111    "SVlibrary_kind#" &
 112    "SVlibrary_version#" &
 113    "LVlibrary_interface#" &
 114    "SVlibrary_standalone#" &
 115    "LVlibrary_encapsulated_options#" &
 116    "SVlibrary_encapsulated_supported#" &
 117    "SVlibrary_auto_init#" &
 118    "LVleading_library_options#" &
 119    "LVlibrary_options#" &
 120    "Lalibrary_rpath_options#" &
 121    "SVlibrary_src_dir#" &
 122    "SVlibrary_ali_dir#" &
 123    "SVlibrary_gcc#" &
 124    "SVlibrary_symbol_file#" &
 125    "SVlibrary_symbol_policy#" &
 126    "SVlibrary_reference_symbol_file#" &
 127
 128    --  Configuration - General
 129
 130    "SVdefault_language#" &
 131    "LVrun_path_option#" &
 132    "SVrun_path_origin#" &
 133    "SVseparate_run_path_options#" &
 134    "Satoolchain_version#" &
 135    "Satoolchain_description#" &
 136    "Saobject_generated#" &
 137    "Saobjects_linked#" &
 138    "SVtargetDtarget_value#" &
 139
 140    --  Configuration - Libraries
 141
 142    "SVlibrary_builder#" &
 143    "SVlibrary_support#" &
 144
 145    --  Configuration - Archives
 146
 147    "LVarchive_builder#" &
 148    "LVarchive_builder_append_option#" &
 149    "LVarchive_indexer#" &
 150    "SVarchive_suffix#" &
 151    "LVlibrary_partial_linker#" &
 152
 153    --  Configuration - Shared libraries
 154
 155    "SVshared_library_prefix#" &
 156    "SVshared_library_suffix#" &
 157    "SVsymbolic_link_supported#" &
 158    "SVlibrary_major_minor_id_supported#" &
 159    "SVlibrary_auto_init_supported#" &
 160    "LVshared_library_minimum_switches#" &
 161    "LVlibrary_version_switches#" &
 162    "SVlibrary_install_name_option#" &
 163    "Saruntime_library_dir#" &
 164    "Saruntime_source_dir#" &
 165
 166    --  package Naming
 167    --  Some attributes are obsolescent, and renamed in the tree (see
 168    --  Prj.Dect.Rename_Obsolescent_Attributes).
 169
 170    "Pnaming#" &
 171    "Saspecification_suffix#" &  --  Always renamed to "spec_suffix" in tree
 172    "Saspec_suffix#" &
 173    "Saimplementation_suffix#" & --  Always renamed to "body_suffix" in tree
 174    "Sabody_suffix#" &
 175    "SVseparate_suffix#" &
 176    "SVcasing#" &
 177    "SVdot_replacement#" &
 178    "saspecification#" &  --  Always renamed to "spec" in project tree
 179    "saspec#" &
 180    "saimplementation#" & --  Always renamed to "body" in project tree
 181    "sabody#" &
 182    "Laspecification_exceptions#" &
 183    "Laimplementation_exceptions#" &
 184
 185    --  package Compiler
 186
 187    "Pcompiler#" &
 188    "Ladefault_switches#" &
 189    "LcOswitches#" &
 190    "SVlocal_configuration_pragmas#" &
 191    "Salocal_config_file#" &
 192
 193    --  Configuration - Compiling
 194
 195    "Sadriver#" &
 196    "Salanguage_kind#" &
 197    "Sadependency_kind#" &
 198    "Larequired_switches#" &
 199    "Laleading_required_switches#" &
 200    "Latrailing_required_switches#" &
 201    "Lapic_option#" &
 202    "Sapath_syntax#" &
 203    "Lasource_file_switches#" &
 204    "Saobject_file_suffix#" &
 205    "Laobject_file_switches#" &
 206    "Lamulti_unit_switches#" &
 207    "Samulti_unit_object_separator#" &
 208
 209    --  Configuration - Mapping files
 210
 211    "Lamapping_file_switches#" &
 212    "Samapping_spec_suffix#" &
 213    "Samapping_body_suffix#" &
 214
 215    --  Configuration - Config files
 216
 217    "Laconfig_file_switches#" &
 218    "Saconfig_body_file_name#" &
 219    "Saconfig_body_file_name_index#" &
 220    "Saconfig_body_file_name_pattern#" &
 221    "Saconfig_spec_file_name#" &
 222    "Saconfig_spec_file_name_index#" &
 223    "Saconfig_spec_file_name_pattern#" &
 224    "Saconfig_file_unique#" &
 225
 226    --  Configuration - Dependencies
 227
 228    "Ladependency_switches#" &
 229    "Ladependency_driver#" &
 230
 231    --  Configuration - Search paths
 232
 233    "Lainclude_switches#" &
 234    "Sainclude_path#" &
 235    "Sainclude_path_file#" &
 236    "Laobject_path_switches#" &
 237
 238    --  package Builder
 239
 240    "Pbuilder#" &
 241    "Ladefault_switches#" &
 242    "LcOswitches#" &
 243    "Lcglobal_compilation_switches#" &
 244    "Scexecutable#" &
 245    "SVexecutable_suffix#" &
 246    "SVglobal_configuration_pragmas#" &
 247    "Saglobal_config_file#" &
 248
 249    --  package gnatls
 250
 251    "Pgnatls#" &
 252    "LVswitches#" &
 253
 254    --  package Binder
 255
 256    "Pbinder#" &
 257    "Ladefault_switches#" &
 258    "LcOswitches#" &
 259
 260    --  Configuration - Binding
 261
 262    "Sadriver#" &
 263    "Larequired_switches#" &
 264    "Saprefix#" &
 265    "Saobjects_path#" &
 266    "Saobjects_path_file#" &
 267
 268    --  package Linker
 269
 270    "Plinker#" &
 271    "LVrequired_switches#" &
 272    "Ladefault_switches#" &
 273    "LcOleading_switches#" &
 274    "LcOswitches#" &
 275    "LcOtrailing_switches#" &
 276    "LVlinker_options#" &
 277    "SVmap_file_option#" &
 278
 279    --  Configuration - Linking
 280
 281    "SVdriver#" &
 282    "LVexecutable_switch#" &
 283    "SVlib_dir_switch#" &
 284    "SVlib_name_switch#" &
 285
 286    --  Configuration - Response files
 287
 288    "SVmax_command_line_length#" &
 289    "SVresponse_file_format#" &
 290    "LVresponse_file_switches#" &
 291
 292    --  package Clean
 293
 294    "Pclean#" &
 295    "LVswitches#" &
 296    "Lasource_artifact_extensions#" &
 297    "Laobject_artifact_extensions#" &
 298    "LVartifacts_in_exec_dir#" &
 299    "LVartifacts_in_object_dir#" &
 300
 301    --  package Cross_Reference
 302
 303    "Pcross_reference#" &
 304    "Ladefault_switches#" &
 305    "LbOswitches#" &
 306
 307    --  package Finder
 308
 309    "Pfinder#" &
 310    "Ladefault_switches#" &
 311    "LbOswitches#" &
 312
 313    --  package Pretty_Printer
 314
 315    "Ppretty_printer#" &
 316    "Ladefault_switches#" &
 317    "LbOswitches#" &
 318
 319    --  package gnatstub
 320
 321    "Pgnatstub#" &
 322    "Ladefault_switches#" &
 323    "LbOswitches#" &
 324
 325    --  package Check
 326
 327    "Pcheck#" &
 328    "Ladefault_switches#" &
 329    "LbOswitches#" &
 330
 331    --  package Synchronize
 332
 333    "Psynchronize#" &
 334    "Ladefault_switches#" &
 335    "LbOswitches#" &
 336
 337    --  package Eliminate
 338
 339    "Peliminate#" &
 340    "Ladefault_switches#" &
 341    "LbOswitches#" &
 342
 343    --  package Metrics
 344
 345    "Pmetrics#" &
 346    "Ladefault_switches#" &
 347    "LbOswitches#" &
 348
 349    --  package Ide
 350
 351    "Pide#" &
 352    "Ladefault_switches#" &
 353    "SVremote_host#" &
 354    "SVprogram_host#" &
 355    "SVcommunication_protocol#" &
 356    "Sacompiler_command#" &
 357    "SVdebugger_command#" &
 358    "SVgnatlist#" &
 359    "SVvcs_kind#" &
 360    "SVvcs_file_check#" &
 361    "SVvcs_log_check#" &
 362    "SVdocumentation_dir#" &
 363
 364    --  package Install
 365
 366    "Pinstall#" &
 367    "SVprefix#" &
 368    "SVsources_subdir#" &
 369    "SVexec_subdir#" &
 370    "SVlib_subdir#" &
 371    "SVproject_subdir#" &
 372    "SVactive#" &
 373    "LAartifacts#" &
 374
 375    --  package Remote
 376
 377    "Premote#" &
 378    "SVroot_dir#" &
 379    "LVexcluded_patterns#" &
 380    "LVincluded_patterns#" &
 381    "LVincluded_artifact_patterns#" &
 382
 383    --  package Stack
 384
 385    "Pstack#" &
 386    "LVswitches#" &
 387
 388    "#";
 389
 390    Initialized : Boolean := False;
 391    --  A flag to avoid multiple initialization
 392
 393    Package_Names     : String_List_Access := new Strings.String_List (1 .. 20);
 394    Last_Package_Name : Natural := 0;
 395    --  Package_Names (1 .. Last_Package_Name) contains the list of the known
 396    --  package names, coming from the Initialization_Data string or from
 397    --  calls to one of the two procedures Register_New_Package.
 398
 399    procedure Add_Package_Name (Name : String);
 400    --  Add a package name in the Package_Name list, extending it, if necessary
 401
 402    function Name_Id_Of (Name : String) return Name_Id;
 403    --  Returns the Name_Id for Name in lower case
 404
 405    ----------------------
 406    -- Add_Package_Name --
 407    ----------------------
 408
 409    procedure Add_Package_Name (Name : String) is
 410    begin
 411       if Last_Package_Name = Package_Names'Last then
 412          declare
 413             New_List : constant Strings.String_List_Access :=
 414                          new Strings.String_List (1 .. Package_Names'Last * 2);
 415          begin
 416             New_List (Package_Names'Range) := Package_Names.all;
 417             Package_Names := New_List;
 418          end;
 419       end if;
 420
 421       Last_Package_Name := Last_Package_Name + 1;
 422       Package_Names (Last_Package_Name) := new String'(Name);
 423    end Add_Package_Name;
 424
 425    --------------------------
 426    -- Attribute_Default_Of --
 427    --------------------------
 428
 429    function Attribute_Default_Of
 430      (Attribute : Attribute_Node_Id) return Attribute_Default_Value
 431    is
 432    begin
 433       if Attribute = Empty_Attribute then
 434          return Empty_Value;
 435       else
 436          return Attrs.Table (Attribute.Value).Default;
 437       end if;
 438    end Attribute_Default_Of;
 439
 440    -----------------------
 441    -- Attribute_Kind_Of --
 442    -----------------------
 443
 444    function Attribute_Kind_Of
 445      (Attribute : Attribute_Node_Id) return Attribute_Kind
 446    is
 447    begin
 448       if Attribute = Empty_Attribute then
 449          return Unknown;
 450       else
 451          return Attrs.Table (Attribute.Value).Attr_Kind;
 452       end if;
 453    end Attribute_Kind_Of;
 454
 455    -----------------------
 456    -- Attribute_Name_Of --
 457    -----------------------
 458
 459    function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
 460    begin
 461       if Attribute = Empty_Attribute then
 462          return No_Name;
 463       else
 464          return Attrs.Table (Attribute.Value).Name;
 465       end if;
 466    end Attribute_Name_Of;
 467
 468    --------------------------
 469    -- Attribute_Node_Id_Of --
 470    --------------------------
 471
 472    function Attribute_Node_Id_Of
 473      (Name        : Name_Id;
 474       Starting_At : Attribute_Node_Id) return Attribute_Node_Id
 475    is
 476       Id : Attr_Node_Id := Starting_At.Value;
 477
 478    begin
 479       while Id /= Empty_Attr
 480         and then Attrs.Table (Id).Name /= Name
 481       loop
 482          Id := Attrs.Table (Id).Next;
 483       end loop;
 484
 485       return (Value => Id);
 486    end Attribute_Node_Id_Of;
 487
 488    ----------------
 489    -- Initialize --
 490    ----------------
 491
 492    procedure Initialize is
 493       Start             : Positive          := Initialization_Data'First;
 494       Finish            : Positive          := Start;
 495       Current_Package   : Pkg_Node_Id       := Empty_Pkg;
 496       Current_Attribute : Attr_Node_Id      := Empty_Attr;
 497       Is_An_Attribute   : Boolean           := False;
 498       Var_Kind          : Variable_Kind     := Undefined;
 499       Optional_Index    : Boolean           := False;
 500       Attr_Kind         : Attribute_Kind    := Single;
 501       Package_Name      : Name_Id           := No_Name;
 502       Attribute_Name    : Name_Id           := No_Name;
 503       First_Attribute   : Attr_Node_Id      := Attr.First_Attribute;
 504       Read_Only         : Boolean;
 505       Others_Allowed    : Boolean;
 506       Default           : Attribute_Default_Value;
 507
 508       function Attribute_Location return String;
 509       --  Returns a string depending if we are in the project level attributes
 510       --  or in the attributes of a package.
 511
 512       ------------------------
 513       -- Attribute_Location --
 514       ------------------------
 515
 516       function Attribute_Location return String is
 517       begin
 518          if Package_Name = No_Name then
 519             return "project level attributes";
 520
 521          else
 522             return "attribute of package """ &
 523             Get_Name_String (Package_Name) & """";
 524          end if;
 525       end Attribute_Location;
 526
 527    --  Start of processing for Initialize
 528
 529    begin
 530       --  Don't allow Initialize action to be repeated
 531
 532       if Initialized then
 533          return;
 534       end if;
 535
 536       --  Make sure the two tables are empty
 537
 538       Attrs.Init;
 539       Package_Attributes.Init;
 540
 541       while Initialization_Data (Start) /= '#' loop
 542          Is_An_Attribute := True;
 543          case Initialization_Data (Start) is
 544             when 'P' =>
 545
 546                --  New allowed package
 547
 548                Start := Start + 1;
 549
 550                Finish := Start;
 551                while Initialization_Data (Finish) /= '#' loop
 552                   Finish := Finish + 1;
 553                end loop;
 554
 555                Package_Name :=
 556                  Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 557
 558                for Index in First_Package .. Package_Attributes.Last loop
 559                   if Package_Name = Package_Attributes.Table (Index).Name then
 560                      Osint.Fail ("duplicate name """
 561                                  & Initialization_Data (Start .. Finish - 1)
 562                                  & """ in predefined packages.");
 563                   end if;
 564                end loop;
 565
 566                Is_An_Attribute := False;
 567                Current_Attribute := Empty_Attr;
 568                Package_Attributes.Increment_Last;
 569                Current_Package := Package_Attributes.Last;
 570                Package_Attributes.Table (Current_Package) :=
 571                  (Name             => Package_Name,
 572                   Known            => True,
 573                   First_Attribute  => Empty_Attr);
 574                Start := Finish + 1;
 575
 576                Add_Package_Name (Get_Name_String (Package_Name));
 577
 578             when 'S' =>
 579                Var_Kind       := Single;
 580                Optional_Index := False;
 581
 582             when 's' =>
 583                Var_Kind       := Single;
 584                Optional_Index := True;
 585
 586             when 'L' =>
 587                Var_Kind       := List;
 588                Optional_Index := False;
 589
 590             when 'l' =>
 591                Var_Kind         := List;
 592                Optional_Index := True;
 593
 594             when others =>
 595                raise Program_Error;
 596          end case;
 597
 598          if Is_An_Attribute then
 599
 600             --  New attribute
 601
 602             Start := Start + 1;
 603             case Initialization_Data (Start) is
 604                when 'V' =>
 605                   Attr_Kind := Single;
 606
 607                when 'A' =>
 608                   Attr_Kind := Associative_Array;
 609
 610                when 'a' =>
 611                   Attr_Kind := Case_Insensitive_Associative_Array;
 612
 613                when 'b' =>
 614                   if Osint.File_Names_Case_Sensitive then
 615                      Attr_Kind := Associative_Array;
 616                   else
 617                      Attr_Kind := Case_Insensitive_Associative_Array;
 618                   end if;
 619
 620                when 'c' =>
 621                   if Osint.File_Names_Case_Sensitive then
 622                      Attr_Kind := Optional_Index_Associative_Array;
 623                   else
 624                      Attr_Kind :=
 625                        Optional_Index_Case_Insensitive_Associative_Array;
 626                   end if;
 627
 628                when others =>
 629                   raise Program_Error;
 630             end case;
 631
 632             Start := Start + 1;
 633
 634             Read_Only := False;
 635             Others_Allowed := False;
 636             Default := Empty_Value;
 637
 638             if Initialization_Data (Start) = 'R' then
 639                Read_Only := True;
 640                Default := Read_Only_Value;
 641                Start := Start + 1;
 642
 643             elsif Initialization_Data (Start) = 'O' then
 644                Others_Allowed := True;
 645                Start := Start + 1;
 646             end if;
 647
 648             Finish := Start;
 649
 650             while Initialization_Data (Finish) /= '#'
 651                     and then
 652                   Initialization_Data (Finish) /= 'D'
 653             loop
 654                Finish := Finish + 1;
 655             end loop;
 656
 657             Attribute_Name :=
 658               Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 659
 660             if Initialization_Data (Finish) = 'D' then
 661                Start := Finish + 1;
 662
 663                Finish := Start;
 664                while Initialization_Data (Finish) /= '#' loop
 665                   Finish := Finish + 1;
 666                end loop;
 667
 668                declare
 669                   Default_Name : constant String :=
 670                                    Initialization_Data (Start .. Finish - 1);
 671                   pragma Unsuppress (All_Checks);
 672                begin
 673                   Default := Attribute_Default_Value'Value (Default_Name);
 674                exception
 675                   when Constraint_Error =>
 676                      Osint.Fail
 677                        ("illegal default value """ &
 678                         Default_Name &
 679                         """ for attribute " &
 680                         Get_Name_String (Attribute_Name));
 681                end;
 682             end if;
 683
 684             Attrs.Increment_Last;
 685
 686             if Current_Attribute = Empty_Attr then
 687                First_Attribute := Attrs.Last;
 688
 689                if Current_Package /= Empty_Pkg then
 690                   Package_Attributes.Table (Current_Package).First_Attribute
 691                     := Attrs.Last;
 692                end if;
 693
 694             else
 695                --  Check that there are no duplicate attributes
 696
 697                for Index in First_Attribute .. Attrs.Last - 1 loop
 698                   if Attribute_Name = Attrs.Table (Index).Name then
 699                      Osint.Fail ("duplicate attribute """
 700                                  & Initialization_Data (Start .. Finish - 1)
 701                                  & """ in " & Attribute_Location);
 702                   end if;
 703                end loop;
 704
 705                Attrs.Table (Current_Attribute).Next :=
 706                  Attrs.Last;
 707             end if;
 708
 709             Current_Attribute := Attrs.Last;
 710             Attrs.Table (Current_Attribute) :=
 711               (Name           => Attribute_Name,
 712                Var_Kind       => Var_Kind,
 713                Optional_Index => Optional_Index,
 714                Attr_Kind      => Attr_Kind,
 715                Read_Only      => Read_Only,
 716                Others_Allowed => Others_Allowed,
 717                Default        => Default,
 718                Next           => Empty_Attr);
 719             Start := Finish + 1;
 720          end if;
 721       end loop;
 722
 723       Initialized := True;
 724    end Initialize;
 725
 726    ------------------
 727    -- Is_Read_Only --
 728    ------------------
 729
 730    function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
 731    begin
 732       return Attrs.Table (Attribute.Value).Read_Only;
 733    end Is_Read_Only;
 734
 735    ----------------
 736    -- Name_Id_Of --
 737    ----------------
 738
 739    function Name_Id_Of (Name : String) return Name_Id is
 740    begin
 741       Name_Len := 0;
 742       Add_Str_To_Name_Buffer (Name);
 743       To_Lower (Name_Buffer (1 .. Name_Len));
 744       return Name_Find;
 745    end Name_Id_Of;
 746
 747    --------------------
 748    -- Next_Attribute --
 749    --------------------
 750
 751    function Next_Attribute
 752      (After : Attribute_Node_Id) return Attribute_Node_Id
 753    is
 754    begin
 755       if After = Empty_Attribute then
 756          return Empty_Attribute;
 757       else
 758          return (Value => Attrs.Table (After.Value).Next);
 759       end if;
 760    end Next_Attribute;
 761
 762    -----------------------
 763    -- Optional_Index_Of --
 764    -----------------------
 765
 766    function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
 767    begin
 768       if Attribute = Empty_Attribute then
 769          return False;
 770       else
 771          return Attrs.Table (Attribute.Value).Optional_Index;
 772       end if;
 773    end Optional_Index_Of;
 774
 775    function Others_Allowed_For
 776      (Attribute : Attribute_Node_Id) return Boolean
 777    is
 778    begin
 779       if Attribute = Empty_Attribute then
 780          return False;
 781       else
 782          return Attrs.Table (Attribute.Value).Others_Allowed;
 783       end if;
 784    end Others_Allowed_For;
 785
 786    -----------------------
 787    -- Package_Name_List --
 788    -----------------------
 789
 790    function Package_Name_List return Strings.String_List is
 791    begin
 792       return Package_Names (1 .. Last_Package_Name);
 793    end Package_Name_List;
 794
 795    ------------------------
 796    -- Package_Node_Id_Of --
 797    ------------------------
 798
 799    function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
 800    begin
 801       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 802          if Package_Attributes.Table (Index).Name = Name then
 803             if Package_Attributes.Table (Index).Known then
 804                return (Value => Index);
 805             else
 806                return Unknown_Package;
 807             end if;
 808          end if;
 809       end loop;
 810
 811       --  If there is no package with this name, return Empty_Package
 812
 813       return Empty_Package;
 814    end Package_Node_Id_Of;
 815
 816    ----------------------------
 817    -- Register_New_Attribute --
 818    ----------------------------
 819
 820    procedure Register_New_Attribute
 821      (Name               : String;
 822       In_Package         : Package_Node_Id;
 823       Attr_Kind          : Defined_Attribute_Kind;
 824       Var_Kind           : Defined_Variable_Kind;
 825       Index_Is_File_Name : Boolean                 := False;
 826       Opt_Index          : Boolean                 := False;
 827       Default            : Attribute_Default_Value := Empty_Value)
 828    is
 829       Attr_Name       : Name_Id;
 830       First_Attr      : Attr_Node_Id := Empty_Attr;
 831       Curr_Attr       : Attr_Node_Id;
 832       Real_Attr_Kind  : Attribute_Kind;
 833
 834    begin
 835       if Name'Length = 0 then
 836          Fail ("cannot register an attribute with no name");
 837          raise Project_Error;
 838       end if;
 839
 840       if In_Package = Empty_Package then
 841          Fail ("attempt to add attribute """
 842                & Name
 843                & """ to an undefined package");
 844          raise Project_Error;
 845       end if;
 846
 847       Attr_Name := Name_Id_Of (Name);
 848
 849       First_Attr :=
 850         Package_Attributes.Table (In_Package.Value).First_Attribute;
 851
 852       --  Check if attribute name is a duplicate
 853
 854       Curr_Attr := First_Attr;
 855       while Curr_Attr /= Empty_Attr loop
 856          if Attrs.Table (Curr_Attr).Name = Attr_Name then
 857             Fail ("duplicate attribute name """
 858                   & Name
 859                   & """ in package """
 860                   & Get_Name_String
 861                      (Package_Attributes.Table (In_Package.Value).Name)
 862                   & """");
 863             raise Project_Error;
 864          end if;
 865
 866          Curr_Attr := Attrs.Table (Curr_Attr).Next;
 867       end loop;
 868
 869       Real_Attr_Kind := Attr_Kind;
 870
 871       --  If Index_Is_File_Name, change the attribute kind if necessary
 872
 873       if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
 874          case Attr_Kind is
 875             when Associative_Array =>
 876                Real_Attr_Kind := Case_Insensitive_Associative_Array;
 877
 878             when Optional_Index_Associative_Array =>
 879                Real_Attr_Kind :=
 880                  Optional_Index_Case_Insensitive_Associative_Array;
 881
 882             when others =>
 883                null;
 884          end case;
 885       end if;
 886
 887       --  Add the new attribute
 888
 889       Attrs.Increment_Last;
 890       Attrs.Table (Attrs.Last) :=
 891         (Name           => Attr_Name,
 892          Var_Kind       => Var_Kind,
 893          Optional_Index => Opt_Index,
 894          Attr_Kind      => Real_Attr_Kind,
 895          Read_Only      => False,
 896          Others_Allowed => False,
 897          Default        => Default,
 898          Next           => First_Attr);
 899
 900       Package_Attributes.Table (In_Package.Value).First_Attribute :=
 901         Attrs.Last;
 902    end Register_New_Attribute;
 903
 904    --------------------------
 905    -- Register_New_Package --
 906    --------------------------
 907
 908    procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
 909       Pkg_Name : Name_Id;
 910
 911    begin
 912       if Name'Length = 0 then
 913          Fail ("cannot register a package with no name");
 914          Id := Empty_Package;
 915          return;
 916       end if;
 917
 918       Pkg_Name := Name_Id_Of (Name);
 919
 920       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 921          if Package_Attributes.Table (Index).Name = Pkg_Name then
 922             Fail ("cannot register a package with a non unique name """
 923                   & Name
 924                   & """");
 925             Id := Empty_Package;
 926             return;
 927          end if;
 928       end loop;
 929
 930       Package_Attributes.Increment_Last;
 931       Id := (Value => Package_Attributes.Last);
 932       Package_Attributes.Table (Package_Attributes.Last) :=
 933         (Name             => Pkg_Name,
 934          Known            => True,
 935          First_Attribute  => Empty_Attr);
 936
 937       Add_Package_Name (Get_Name_String (Pkg_Name));
 938    end Register_New_Package;
 939
 940    procedure Register_New_Package
 941      (Name       : String;
 942       Attributes : Attribute_Data_Array)
 943    is
 944       Pkg_Name   : Name_Id;
 945       Attr_Name  : Name_Id;
 946       First_Attr : Attr_Node_Id := Empty_Attr;
 947       Curr_Attr  : Attr_Node_Id;
 948       Attr_Kind  : Attribute_Kind;
 949
 950    begin
 951       if Name'Length = 0 then
 952          Fail ("cannot register a package with no name");
 953          raise Project_Error;
 954       end if;
 955
 956       Pkg_Name := Name_Id_Of (Name);
 957
 958       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 959          if Package_Attributes.Table (Index).Name = Pkg_Name then
 960             Fail ("cannot register a package with a non unique name """
 961                   & Name
 962                   & """");
 963             raise Project_Error;
 964          end if;
 965       end loop;
 966
 967       for Index in Attributes'Range loop
 968          Attr_Name := Name_Id_Of (Attributes (Index).Name);
 969
 970          Curr_Attr := First_Attr;
 971          while Curr_Attr /= Empty_Attr loop
 972             if Attrs.Table (Curr_Attr).Name = Attr_Name then
 973                Fail ("duplicate attribute name """
 974                      & Attributes (Index).Name
 975                      & """ in new package """
 976                      & Name
 977                      & """");
 978                raise Project_Error;
 979             end if;
 980
 981             Curr_Attr := Attrs.Table (Curr_Attr).Next;
 982          end loop;
 983
 984          Attr_Kind := Attributes (Index).Attr_Kind;
 985
 986          if Attributes (Index).Index_Is_File_Name
 987            and then not Osint.File_Names_Case_Sensitive
 988          then
 989             case Attr_Kind is
 990                when Associative_Array =>
 991                   Attr_Kind := Case_Insensitive_Associative_Array;
 992
 993                when Optional_Index_Associative_Array =>
 994                   Attr_Kind :=
 995                     Optional_Index_Case_Insensitive_Associative_Array;
 996
 997                when others =>
 998                   null;
 999             end case;
1000          end if;
1001
1002          Attrs.Increment_Last;
1003          Attrs.Table (Attrs.Last) :=
1004            (Name           => Attr_Name,
1005             Var_Kind       => Attributes (Index).Var_Kind,
1006             Optional_Index => Attributes (Index).Opt_Index,
1007             Attr_Kind      => Attr_Kind,
1008             Read_Only      => False,
1009             Others_Allowed => False,
1010             Default        => Attributes (Index).Default,
1011             Next           => First_Attr);
1012          First_Attr := Attrs.Last;
1013       end loop;
1014
1015       Package_Attributes.Increment_Last;
1016       Package_Attributes.Table (Package_Attributes.Last) :=
1017         (Name             => Pkg_Name,
1018          Known            => True,
1019          First_Attribute  => First_Attr);
1020
1021       Add_Package_Name (Get_Name_String (Pkg_Name));
1022    end Register_New_Package;
1023
1024    ---------------------------
1025    -- Set_Attribute_Kind_Of --
1026    ---------------------------
1027
1028    procedure Set_Attribute_Kind_Of
1029      (Attribute : Attribute_Node_Id;
1030       To        : Attribute_Kind)
1031    is
1032    begin
1033       if Attribute /= Empty_Attribute then
1034          Attrs.Table (Attribute.Value).Attr_Kind := To;
1035       end if;
1036    end Set_Attribute_Kind_Of;
1037
1038    --------------------------
1039    -- Set_Variable_Kind_Of --
1040    --------------------------
1041
1042    procedure Set_Variable_Kind_Of
1043      (Attribute : Attribute_Node_Id;
1044       To        : Variable_Kind)
1045    is
1046    begin
1047       if Attribute /= Empty_Attribute then
1048          Attrs.Table (Attribute.Value).Var_Kind := To;
1049       end if;
1050    end Set_Variable_Kind_Of;
1051
1052    ----------------------
1053    -- Variable_Kind_Of --
1054    ----------------------
1055
1056    function Variable_Kind_Of
1057      (Attribute : Attribute_Node_Id) return Variable_Kind
1058    is
1059    begin
1060       if Attribute = Empty_Attribute then
1061          return Undefined;
1062       else
1063          return Attrs.Table (Attribute.Value).Var_Kind;
1064       end if;
1065    end Variable_Kind_Of;
1066
1067    ------------------------
1068    -- First_Attribute_Of --
1069    ------------------------
1070
1071    function First_Attribute_Of
1072      (Pkg : Package_Node_Id) return Attribute_Node_Id
1073    is
1074    begin
1075       if Pkg = Empty_Package or else Pkg = Unknown_Package then
1076          return Empty_Attribute;
1077       else
1078          return
1079            (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1080       end if;
1081    end First_Attribute_Of;
1082
1083 end Prj.Attr;