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