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-2016, 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 Eliminate
 330
 331    "Peliminate#" &
 332    "Ladefault_switches#" &
 333    "LbOswitches#" &
 334
 335    --  package Metrics
 336
 337    "Pmetrics#" &
 338    "Ladefault_switches#" &
 339    "LbOswitches#" &
 340
 341    --  package Ide
 342
 343    "Pide#" &
 344    "Ladefault_switches#" &
 345    "SVremote_host#" &
 346    "SVprogram_host#" &
 347    "SVcommunication_protocol#" &
 348    "Sacompiler_command#" &
 349    "SVdebugger_command#" &
 350    "SVgnatlist#" &
 351    "SVvcs_kind#" &
 352    "SVvcs_file_check#" &
 353    "SVvcs_log_check#" &
 354    "SVdocumentation_dir#" &
 355
 356    --  package Install
 357
 358    "Pinstall#" &
 359    "SVprefix#" &
 360    "SVsources_subdir#" &
 361    "SVexec_subdir#" &
 362    "SVlib_subdir#" &
 363    "SVproject_subdir#" &
 364    "SVactive#" &
 365    "LAartifacts#" &
 366    "LArequired_artifacts#" &
 367    "SVmode#" &
 368    "SVinstall_name#" &
 369
 370    --  package Remote
 371
 372    "Premote#" &
 373    "SVroot_dir#" &
 374    "LVexcluded_patterns#" &
 375    "LVincluded_patterns#" &
 376    "LVincluded_artifact_patterns#" &
 377
 378    --  package Stack
 379
 380    "Pstack#" &
 381    "LVswitches#" &
 382
 383    --  package Codepeer
 384
 385    "Pcodepeer#" &
 386    "SVoutput_directory#" &
 387    "SVdatabase_directory#" &
 388    "SVmessage_patterns#" &
 389    "SVadditional_patterns#" &
 390    "LVswitches#" &
 391    "LVexcluded_source_files#" &
 392
 393    --  package Prove
 394
 395    "Pprove#" &
 396
 397    --  package GnatTest
 398
 399    "Pgnattest#" &
 400
 401    "#";
 402
 403    Initialized : Boolean := False;
 404    --  A flag to avoid multiple initialization
 405
 406    Package_Names     : String_List_Access := new Strings.String_List (1 .. 20);
 407    Last_Package_Name : Natural := 0;
 408    --  Package_Names (1 .. Last_Package_Name) contains the list of the known
 409    --  package names, coming from the Initialization_Data string or from
 410    --  calls to one of the two procedures Register_New_Package.
 411
 412    procedure Add_Package_Name (Name : String);
 413    --  Add a package name in the Package_Name list, extending it, if necessary
 414
 415    function Name_Id_Of (Name : String) return Name_Id;
 416    --  Returns the Name_Id for Name in lower case
 417
 418    ----------------------
 419    -- Add_Package_Name --
 420    ----------------------
 421
 422    procedure Add_Package_Name (Name : String) is
 423    begin
 424       if Last_Package_Name = Package_Names'Last then
 425          declare
 426             New_List : constant Strings.String_List_Access :=
 427                          new Strings.String_List (1 .. Package_Names'Last * 2);
 428          begin
 429             New_List (Package_Names'Range) := Package_Names.all;
 430             Package_Names := New_List;
 431          end;
 432       end if;
 433
 434       Last_Package_Name := Last_Package_Name + 1;
 435       Package_Names (Last_Package_Name) := new String'(Name);
 436    end Add_Package_Name;
 437
 438    --------------------------
 439    -- Attribute_Default_Of --
 440    --------------------------
 441
 442    function Attribute_Default_Of
 443      (Attribute : Attribute_Node_Id) return Attribute_Default_Value
 444    is
 445    begin
 446       if Attribute = Empty_Attribute then
 447          return Empty_Value;
 448       else
 449          return Attrs.Table (Attribute.Value).Default;
 450       end if;
 451    end Attribute_Default_Of;
 452
 453    -----------------------
 454    -- Attribute_Kind_Of --
 455    -----------------------
 456
 457    function Attribute_Kind_Of
 458      (Attribute : Attribute_Node_Id) return Attribute_Kind
 459    is
 460    begin
 461       if Attribute = Empty_Attribute then
 462          return Unknown;
 463       else
 464          return Attrs.Table (Attribute.Value).Attr_Kind;
 465       end if;
 466    end Attribute_Kind_Of;
 467
 468    -----------------------
 469    -- Attribute_Name_Of --
 470    -----------------------
 471
 472    function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
 473    begin
 474       if Attribute = Empty_Attribute then
 475          return No_Name;
 476       else
 477          return Attrs.Table (Attribute.Value).Name;
 478       end if;
 479    end Attribute_Name_Of;
 480
 481    --------------------------
 482    -- Attribute_Node_Id_Of --
 483    --------------------------
 484
 485    function Attribute_Node_Id_Of
 486      (Name        : Name_Id;
 487       Starting_At : Attribute_Node_Id) return Attribute_Node_Id
 488    is
 489       Id : Attr_Node_Id := Starting_At.Value;
 490
 491    begin
 492       while Id /= Empty_Attr
 493         and then Attrs.Table (Id).Name /= Name
 494       loop
 495          Id := Attrs.Table (Id).Next;
 496       end loop;
 497
 498       return (Value => Id);
 499    end Attribute_Node_Id_Of;
 500
 501    ----------------
 502    -- Initialize --
 503    ----------------
 504
 505    procedure Initialize is
 506       Start             : Positive          := Initialization_Data'First;
 507       Finish            : Positive          := Start;
 508       Current_Package   : Pkg_Node_Id       := Empty_Pkg;
 509       Current_Attribute : Attr_Node_Id      := Empty_Attr;
 510       Is_An_Attribute   : Boolean           := False;
 511       Var_Kind          : Variable_Kind     := Undefined;
 512       Optional_Index    : Boolean           := False;
 513       Attr_Kind         : Attribute_Kind    := Single;
 514       Package_Name      : Name_Id           := No_Name;
 515       Attribute_Name    : Name_Id           := No_Name;
 516       First_Attribute   : Attr_Node_Id      := Attr.First_Attribute;
 517       Read_Only         : Boolean;
 518       Others_Allowed    : Boolean;
 519       Default           : Attribute_Default_Value;
 520
 521       function Attribute_Location return String;
 522       --  Returns a string depending if we are in the project level attributes
 523       --  or in the attributes of a package.
 524
 525       ------------------------
 526       -- Attribute_Location --
 527       ------------------------
 528
 529       function Attribute_Location return String is
 530       begin
 531          if Package_Name = No_Name then
 532             return "project level attributes";
 533
 534          else
 535             return "attribute of package """ &
 536             Get_Name_String (Package_Name) & """";
 537          end if;
 538       end Attribute_Location;
 539
 540    --  Start of processing for Initialize
 541
 542    begin
 543       --  Don't allow Initialize action to be repeated
 544
 545       if Initialized then
 546          return;
 547       end if;
 548
 549       --  Make sure the two tables are empty
 550
 551       Attrs.Init;
 552       Package_Attributes.Init;
 553
 554       while Initialization_Data (Start) /= '#' loop
 555          Is_An_Attribute := True;
 556          case Initialization_Data (Start) is
 557             when 'P' =>
 558
 559                --  New allowed package
 560
 561                Start := Start + 1;
 562
 563                Finish := Start;
 564                while Initialization_Data (Finish) /= '#' loop
 565                   Finish := Finish + 1;
 566                end loop;
 567
 568                Package_Name :=
 569                  Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 570
 571                for Index in First_Package .. Package_Attributes.Last loop
 572                   if Package_Name = Package_Attributes.Table (Index).Name then
 573                      Osint.Fail ("duplicate name """
 574                                  & Initialization_Data (Start .. Finish - 1)
 575                                  & """ in predefined packages.");
 576                   end if;
 577                end loop;
 578
 579                Is_An_Attribute := False;
 580                Current_Attribute := Empty_Attr;
 581                Package_Attributes.Increment_Last;
 582                Current_Package := Package_Attributes.Last;
 583                Package_Attributes.Table (Current_Package) :=
 584                  (Name             => Package_Name,
 585                   Known            => True,
 586                   First_Attribute  => Empty_Attr);
 587                Start := Finish + 1;
 588
 589                Add_Package_Name (Get_Name_String (Package_Name));
 590
 591             when 'S' =>
 592                Var_Kind       := Single;
 593                Optional_Index := False;
 594
 595             when 's' =>
 596                Var_Kind       := Single;
 597                Optional_Index := True;
 598
 599             when 'L' =>
 600                Var_Kind       := List;
 601                Optional_Index := False;
 602
 603             when 'l' =>
 604                Var_Kind         := List;
 605                Optional_Index := True;
 606
 607             when others =>
 608                raise Program_Error;
 609          end case;
 610
 611          if Is_An_Attribute then
 612
 613             --  New attribute
 614
 615             Start := Start + 1;
 616             case Initialization_Data (Start) is
 617                when 'V' =>
 618                   Attr_Kind := Single;
 619
 620                when 'A' =>
 621                   Attr_Kind := Associative_Array;
 622
 623                when 'a' =>
 624                   Attr_Kind := Case_Insensitive_Associative_Array;
 625
 626                when 'b' =>
 627                   if Osint.File_Names_Case_Sensitive then
 628                      Attr_Kind := Associative_Array;
 629                   else
 630                      Attr_Kind := Case_Insensitive_Associative_Array;
 631                   end if;
 632
 633                when 'c' =>
 634                   if Osint.File_Names_Case_Sensitive then
 635                      Attr_Kind := Optional_Index_Associative_Array;
 636                   else
 637                      Attr_Kind :=
 638                        Optional_Index_Case_Insensitive_Associative_Array;
 639                   end if;
 640
 641                when others =>
 642                   raise Program_Error;
 643             end case;
 644
 645             Start := Start + 1;
 646
 647             Read_Only := False;
 648             Others_Allowed := False;
 649             Default := Empty_Value;
 650
 651             if Initialization_Data (Start) = 'R' then
 652                Read_Only := True;
 653                Default := Read_Only_Value;
 654                Start := Start + 1;
 655
 656             elsif Initialization_Data (Start) = 'O' then
 657                Others_Allowed := True;
 658                Start := Start + 1;
 659             end if;
 660
 661             Finish := Start;
 662
 663             while Initialization_Data (Finish) /= '#'
 664                     and then
 665                   Initialization_Data (Finish) /= 'D'
 666             loop
 667                Finish := Finish + 1;
 668             end loop;
 669
 670             Attribute_Name :=
 671               Name_Id_Of (Initialization_Data (Start .. Finish - 1));
 672
 673             if Initialization_Data (Finish) = 'D' then
 674                Start := Finish + 1;
 675
 676                Finish := Start;
 677                while Initialization_Data (Finish) /= '#' loop
 678                   Finish := Finish + 1;
 679                end loop;
 680
 681                declare
 682                   Default_Name : constant String :=
 683                                    Initialization_Data (Start .. Finish - 1);
 684                   pragma Unsuppress (All_Checks);
 685                begin
 686                   Default := Attribute_Default_Value'Value (Default_Name);
 687                exception
 688                   when Constraint_Error =>
 689                      Osint.Fail
 690                        ("illegal default value """ &
 691                         Default_Name &
 692                         """ for attribute " &
 693                         Get_Name_String (Attribute_Name));
 694                end;
 695             end if;
 696
 697             Attrs.Increment_Last;
 698
 699             if Current_Attribute = Empty_Attr then
 700                First_Attribute := Attrs.Last;
 701
 702                if Current_Package /= Empty_Pkg then
 703                   Package_Attributes.Table (Current_Package).First_Attribute
 704                     := Attrs.Last;
 705                end if;
 706
 707             else
 708                --  Check that there are no duplicate attributes
 709
 710                for Index in First_Attribute .. Attrs.Last - 1 loop
 711                   if Attribute_Name = Attrs.Table (Index).Name then
 712                      Osint.Fail ("duplicate attribute """
 713                                  & Initialization_Data (Start .. Finish - 1)
 714                                  & """ in " & Attribute_Location);
 715                   end if;
 716                end loop;
 717
 718                Attrs.Table (Current_Attribute).Next :=
 719                  Attrs.Last;
 720             end if;
 721
 722             Current_Attribute := Attrs.Last;
 723             Attrs.Table (Current_Attribute) :=
 724               (Name           => Attribute_Name,
 725                Var_Kind       => Var_Kind,
 726                Optional_Index => Optional_Index,
 727                Attr_Kind      => Attr_Kind,
 728                Read_Only      => Read_Only,
 729                Others_Allowed => Others_Allowed,
 730                Default        => Default,
 731                Next           => Empty_Attr);
 732             Start := Finish + 1;
 733          end if;
 734       end loop;
 735
 736       Initialized := True;
 737    end Initialize;
 738
 739    ------------------
 740    -- Is_Read_Only --
 741    ------------------
 742
 743    function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
 744    begin
 745       return Attrs.Table (Attribute.Value).Read_Only;
 746    end Is_Read_Only;
 747
 748    ----------------
 749    -- Name_Id_Of --
 750    ----------------
 751
 752    function Name_Id_Of (Name : String) return Name_Id is
 753    begin
 754       Name_Len := 0;
 755       Add_Str_To_Name_Buffer (Name);
 756       To_Lower (Name_Buffer (1 .. Name_Len));
 757       return Name_Find;
 758    end Name_Id_Of;
 759
 760    --------------------
 761    -- Next_Attribute --
 762    --------------------
 763
 764    function Next_Attribute
 765      (After : Attribute_Node_Id) return Attribute_Node_Id
 766    is
 767    begin
 768       if After = Empty_Attribute then
 769          return Empty_Attribute;
 770       else
 771          return (Value => Attrs.Table (After.Value).Next);
 772       end if;
 773    end Next_Attribute;
 774
 775    -----------------------
 776    -- Optional_Index_Of --
 777    -----------------------
 778
 779    function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
 780    begin
 781       if Attribute = Empty_Attribute then
 782          return False;
 783       else
 784          return Attrs.Table (Attribute.Value).Optional_Index;
 785       end if;
 786    end Optional_Index_Of;
 787
 788    function Others_Allowed_For
 789      (Attribute : Attribute_Node_Id) return Boolean
 790    is
 791    begin
 792       if Attribute = Empty_Attribute then
 793          return False;
 794       else
 795          return Attrs.Table (Attribute.Value).Others_Allowed;
 796       end if;
 797    end Others_Allowed_For;
 798
 799    -----------------------
 800    -- Package_Name_List --
 801    -----------------------
 802
 803    function Package_Name_List return Strings.String_List is
 804    begin
 805       return Package_Names (1 .. Last_Package_Name);
 806    end Package_Name_List;
 807
 808    ------------------------
 809    -- Package_Node_Id_Of --
 810    ------------------------
 811
 812    function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
 813    begin
 814       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 815          if Package_Attributes.Table (Index).Name = Name then
 816             if Package_Attributes.Table (Index).Known then
 817                return (Value => Index);
 818             else
 819                return Unknown_Package;
 820             end if;
 821          end if;
 822       end loop;
 823
 824       --  If there is no package with this name, return Empty_Package
 825
 826       return Empty_Package;
 827    end Package_Node_Id_Of;
 828
 829    ----------------------------
 830    -- Register_New_Attribute --
 831    ----------------------------
 832
 833    procedure Register_New_Attribute
 834      (Name               : String;
 835       In_Package         : Package_Node_Id;
 836       Attr_Kind          : Defined_Attribute_Kind;
 837       Var_Kind           : Defined_Variable_Kind;
 838       Index_Is_File_Name : Boolean                 := False;
 839       Opt_Index          : Boolean                 := False;
 840       Default            : Attribute_Default_Value := Empty_Value)
 841    is
 842       Attr_Name       : Name_Id;
 843       First_Attr      : Attr_Node_Id := Empty_Attr;
 844       Curr_Attr       : Attr_Node_Id;
 845       Real_Attr_Kind  : Attribute_Kind;
 846
 847    begin
 848       if Name'Length = 0 then
 849          Fail ("cannot register an attribute with no name");
 850          raise Project_Error;
 851       end if;
 852
 853       if In_Package = Empty_Package then
 854          Fail ("attempt to add attribute """
 855                & Name
 856                & """ to an undefined package");
 857          raise Project_Error;
 858       end if;
 859
 860       Attr_Name := Name_Id_Of (Name);
 861
 862       First_Attr :=
 863         Package_Attributes.Table (In_Package.Value).First_Attribute;
 864
 865       --  Check if attribute name is a duplicate
 866
 867       Curr_Attr := First_Attr;
 868       while Curr_Attr /= Empty_Attr loop
 869          if Attrs.Table (Curr_Attr).Name = Attr_Name then
 870             Fail ("duplicate attribute name """
 871                   & Name
 872                   & """ in package """
 873                   & Get_Name_String
 874                      (Package_Attributes.Table (In_Package.Value).Name)
 875                   & """");
 876             raise Project_Error;
 877          end if;
 878
 879          Curr_Attr := Attrs.Table (Curr_Attr).Next;
 880       end loop;
 881
 882       Real_Attr_Kind := Attr_Kind;
 883
 884       --  If Index_Is_File_Name, change the attribute kind if necessary
 885
 886       if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
 887          case Attr_Kind is
 888             when Associative_Array =>
 889                Real_Attr_Kind := Case_Insensitive_Associative_Array;
 890
 891             when Optional_Index_Associative_Array =>
 892                Real_Attr_Kind :=
 893                  Optional_Index_Case_Insensitive_Associative_Array;
 894
 895             when others =>
 896                null;
 897          end case;
 898       end if;
 899
 900       --  Add the new attribute
 901
 902       Attrs.Increment_Last;
 903       Attrs.Table (Attrs.Last) :=
 904         (Name           => Attr_Name,
 905          Var_Kind       => Var_Kind,
 906          Optional_Index => Opt_Index,
 907          Attr_Kind      => Real_Attr_Kind,
 908          Read_Only      => False,
 909          Others_Allowed => False,
 910          Default        => Default,
 911          Next           => First_Attr);
 912
 913       Package_Attributes.Table (In_Package.Value).First_Attribute :=
 914         Attrs.Last;
 915    end Register_New_Attribute;
 916
 917    --------------------------
 918    -- Register_New_Package --
 919    --------------------------
 920
 921    procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
 922       Pkg_Name : Name_Id;
 923       Found    : Boolean := False;
 924
 925    begin
 926       if Name'Length = 0 then
 927          Fail ("cannot register a package with no name");
 928          Id := Empty_Package;
 929          return;
 930       end if;
 931
 932       Pkg_Name := Name_Id_Of (Name);
 933
 934       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 935          if Package_Attributes.Table (Index).Name = Pkg_Name then
 936             if Package_Attributes.Table (Index).Known then
 937                Fail ("cannot register a package with a non unique name """
 938                      & Name
 939                      & """");
 940                Id := Empty_Package;
 941                return;
 942
 943             else
 944                Found := True;
 945                Id := (Value => Index);
 946                exit;
 947             end if;
 948          end if;
 949       end loop;
 950
 951       if not Found then
 952          Package_Attributes.Increment_Last;
 953          Id := (Value => Package_Attributes.Last);
 954       end if;
 955
 956       Package_Attributes.Table (Id.Value) :=
 957         (Name             => Pkg_Name,
 958          Known            => True,
 959          First_Attribute  => Empty_Attr);
 960
 961       Add_Package_Name (Get_Name_String (Pkg_Name));
 962    end Register_New_Package;
 963
 964    procedure Register_New_Package
 965      (Name       : String;
 966       Attributes : Attribute_Data_Array)
 967    is
 968       Pkg_Name   : Name_Id;
 969       Attr_Name  : Name_Id;
 970       First_Attr : Attr_Node_Id := Empty_Attr;
 971       Curr_Attr  : Attr_Node_Id;
 972       Attr_Kind  : Attribute_Kind;
 973
 974    begin
 975       if Name'Length = 0 then
 976          Fail ("cannot register a package with no name");
 977          raise Project_Error;
 978       end if;
 979
 980       Pkg_Name := Name_Id_Of (Name);
 981
 982       for Index in Package_Attributes.First .. Package_Attributes.Last loop
 983          if Package_Attributes.Table (Index).Name = Pkg_Name then
 984             Fail ("cannot register a package with a non unique name """
 985                   & Name
 986                   & """");
 987             raise Project_Error;
 988          end if;
 989       end loop;
 990
 991       for Index in Attributes'Range loop
 992          Attr_Name := Name_Id_Of (Attributes (Index).Name);
 993
 994          Curr_Attr := First_Attr;
 995          while Curr_Attr /= Empty_Attr loop
 996             if Attrs.Table (Curr_Attr).Name = Attr_Name then
 997                Fail ("duplicate attribute name """
 998                      & Attributes (Index).Name
 999                      & """ in new package """
1000                      & Name
1001                      & """");
1002                raise Project_Error;
1003             end if;
1004
1005             Curr_Attr := Attrs.Table (Curr_Attr).Next;
1006          end loop;
1007
1008          Attr_Kind := Attributes (Index).Attr_Kind;
1009
1010          if Attributes (Index).Index_Is_File_Name
1011            and then not Osint.File_Names_Case_Sensitive
1012          then
1013             case Attr_Kind is
1014                when Associative_Array =>
1015                   Attr_Kind := Case_Insensitive_Associative_Array;
1016
1017                when Optional_Index_Associative_Array =>
1018                   Attr_Kind :=
1019                     Optional_Index_Case_Insensitive_Associative_Array;
1020
1021                when others =>
1022                   null;
1023             end case;
1024          end if;
1025
1026          Attrs.Increment_Last;
1027          Attrs.Table (Attrs.Last) :=
1028            (Name           => Attr_Name,
1029             Var_Kind       => Attributes (Index).Var_Kind,
1030             Optional_Index => Attributes (Index).Opt_Index,
1031             Attr_Kind      => Attr_Kind,
1032             Read_Only      => False,
1033             Others_Allowed => False,
1034             Default        => Attributes (Index).Default,
1035             Next           => First_Attr);
1036          First_Attr := Attrs.Last;
1037       end loop;
1038
1039       Package_Attributes.Increment_Last;
1040       Package_Attributes.Table (Package_Attributes.Last) :=
1041         (Name             => Pkg_Name,
1042          Known            => True,
1043          First_Attribute  => First_Attr);
1044
1045       Add_Package_Name (Get_Name_String (Pkg_Name));
1046    end Register_New_Package;
1047
1048    ---------------------------
1049    -- Set_Attribute_Kind_Of --
1050    ---------------------------
1051
1052    procedure Set_Attribute_Kind_Of
1053      (Attribute : Attribute_Node_Id;
1054       To        : Attribute_Kind)
1055    is
1056    begin
1057       if Attribute /= Empty_Attribute then
1058          Attrs.Table (Attribute.Value).Attr_Kind := To;
1059       end if;
1060    end Set_Attribute_Kind_Of;
1061
1062    --------------------------
1063    -- Set_Variable_Kind_Of --
1064    --------------------------
1065
1066    procedure Set_Variable_Kind_Of
1067      (Attribute : Attribute_Node_Id;
1068       To        : Variable_Kind)
1069    is
1070    begin
1071       if Attribute /= Empty_Attribute then
1072          Attrs.Table (Attribute.Value).Var_Kind := To;
1073       end if;
1074    end Set_Variable_Kind_Of;
1075
1076    ----------------------
1077    -- Variable_Kind_Of --
1078    ----------------------
1079
1080    function Variable_Kind_Of
1081      (Attribute : Attribute_Node_Id) return Variable_Kind
1082    is
1083    begin
1084       if Attribute = Empty_Attribute then
1085          return Undefined;
1086       else
1087          return Attrs.Table (Attribute.Value).Var_Kind;
1088       end if;
1089    end Variable_Kind_Of;
1090
1091    ------------------------
1092    -- First_Attribute_Of --
1093    ------------------------
1094
1095    function First_Attribute_Of
1096      (Pkg : Package_Node_Id) return Attribute_Node_Id
1097    is
1098    begin
1099       if Pkg = Empty_Package or else Pkg = Unknown_Package then
1100          return Empty_Attribute;
1101       else
1102          return
1103            (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1104       end if;
1105    end First_Attribute_Of;
1106
1107 end Prj.Attr;