gcc/ada/prj-dect.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . D E C T                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2010, 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 Err_Vars; use Err_Vars;
  27
  28 with GNAT.Case_Util;        use GNAT.Case_Util;
  29 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  30
  31 with Opt;         use Opt;
  32 with Prj.Attr;    use Prj.Attr;
  33 with Prj.Attr.PM; use Prj.Attr.PM;
  34 with Prj.Err;     use Prj.Err;
  35 with Prj.Strt;    use Prj.Strt;
  36 with Prj.Tree;    use Prj.Tree;
  37 with Snames;
  38 with Uintp;       use Uintp;
  39
  40 with GNAT.Strings;
  41
  42 package body Prj.Dect is
  43
  44    use GNAT;
  45
  46    type Zone is (In_Project, In_Package, In_Case_Construction);
  47    --  Used to indicate if we are parsing a package (In_Package),
  48    --  a case construction (In_Case_Construction) or none of those two
  49    --  (In_Project).
  50
  51    procedure Rename_Obsolescent_Attributes
  52      (In_Tree         : Project_Node_Tree_Ref;
  53       Attribute       : Project_Node_Id;
  54       Current_Package : Project_Node_Id);
  55    --  Rename obsolescent attributes in the tree.
  56    --  When the attribute has been renamed since its initial introduction in
  57    --  the design of projects, we replace the old name in the tree with the
  58    --  new name, so that the code does not have to check both names forever.
  59
  60    procedure Check_Attribute_Allowed
  61      (In_Tree         : Project_Node_Tree_Ref;
  62       Project         : Project_Node_Id;
  63       Attribute       : Project_Node_Id;
  64       Flags           : Processing_Flags);
  65    --  Check whether the attribute is valid in this project.
  66    --  In particular, depending on the type of project (qualifier), some
  67    --  attributes might be disabled.
  68
  69    procedure Check_Package_Allowed
  70      (In_Tree         : Project_Node_Tree_Ref;
  71       Project         : Project_Node_Id;
  72       Current_Package : Project_Node_Id;
  73       Flags           : Processing_Flags);
  74    --  Check whether the package is valid in this project
  75
  76    procedure Parse_Attribute_Declaration
  77      (In_Tree           : Project_Node_Tree_Ref;
  78       Attribute         : out Project_Node_Id;
  79       First_Attribute   : Attribute_Node_Id;
  80       Current_Project   : Project_Node_Id;
  81       Current_Package   : Project_Node_Id;
  82       Packages_To_Check : String_List_Access;
  83       Flags             : Processing_Flags);
  84    --  Parse an attribute declaration
  85
  86    procedure Parse_Case_Construction
  87      (In_Tree           : Project_Node_Tree_Ref;
  88       Case_Construction : out Project_Node_Id;
  89       First_Attribute   : Attribute_Node_Id;
  90       Current_Project   : Project_Node_Id;
  91       Current_Package   : Project_Node_Id;
  92       Packages_To_Check : String_List_Access;
  93       Is_Config_File    : Boolean;
  94       Flags             : Processing_Flags);
  95    --  Parse a case construction
  96
  97    procedure Parse_Declarative_Items
  98      (In_Tree           : Project_Node_Tree_Ref;
  99       Declarations      : out Project_Node_Id;
 100       In_Zone           : Zone;
 101       First_Attribute   : Attribute_Node_Id;
 102       Current_Project   : Project_Node_Id;
 103       Current_Package   : Project_Node_Id;
 104       Packages_To_Check : String_List_Access;
 105       Is_Config_File    : Boolean;
 106       Flags             : Processing_Flags);
 107    --  Parse declarative items. Depending on In_Zone, some declarative items
 108    --  may be forbidden. Is_Config_File should be set to True if the project
 109    --  represents a config file (.cgpr) since some specific checks apply.
 110
 111    procedure Parse_Package_Declaration
 112      (In_Tree             : Project_Node_Tree_Ref;
 113       Package_Declaration : out Project_Node_Id;
 114       Current_Project     : Project_Node_Id;
 115       Packages_To_Check   : String_List_Access;
 116       Is_Config_File      : Boolean;
 117       Flags               : Processing_Flags);
 118    --  Parse a package declaration.
 119    --  Is_Config_File should be set to True if the project represents a config
 120    --  file (.cgpr) since some specific checks apply.
 121
 122    procedure Parse_String_Type_Declaration
 123      (In_Tree         : Project_Node_Tree_Ref;
 124       String_Type     : out Project_Node_Id;
 125       Current_Project : Project_Node_Id;
 126       Flags           : Processing_Flags);
 127    --  type <name> is ( <literal_string> { , <literal_string> } ) ;
 128
 129    procedure Parse_Variable_Declaration
 130      (In_Tree         : Project_Node_Tree_Ref;
 131       Variable        : out Project_Node_Id;
 132       Current_Project : Project_Node_Id;
 133       Current_Package : Project_Node_Id;
 134       Flags           : Processing_Flags);
 135    --  Parse a variable assignment
 136    --  <variable_Name> := <expression>; OR
 137    --  <variable_Name> : <string_type_Name> := <string_expression>;
 138
 139    -----------
 140    -- Parse --
 141    -----------
 142
 143    procedure Parse
 144      (In_Tree           : Project_Node_Tree_Ref;
 145       Declarations      : out Project_Node_Id;
 146       Current_Project   : Project_Node_Id;
 147       Extends           : Project_Node_Id;
 148       Packages_To_Check : String_List_Access;
 149       Is_Config_File    : Boolean;
 150       Flags             : Processing_Flags)
 151    is
 152       First_Declarative_Item : Project_Node_Id := Empty_Node;
 153
 154    begin
 155       Declarations :=
 156         Default_Project_Node
 157           (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
 158       Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
 159       Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
 160       Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
 161       Parse_Declarative_Items
 162         (Declarations      => First_Declarative_Item,
 163          In_Tree           => In_Tree,
 164          In_Zone           => In_Project,
 165          First_Attribute   => Prj.Attr.Attribute_First,
 166          Current_Project   => Current_Project,
 167          Current_Package   => Empty_Node,
 168          Packages_To_Check => Packages_To_Check,
 169          Is_Config_File    => Is_Config_File,
 170          Flags             => Flags);
 171       Set_First_Declarative_Item_Of
 172         (Declarations, In_Tree, To => First_Declarative_Item);
 173    end Parse;
 174
 175    -----------------------------------
 176    -- Rename_Obsolescent_Attributes --
 177    -----------------------------------
 178
 179    procedure Rename_Obsolescent_Attributes
 180      (In_Tree         : Project_Node_Tree_Ref;
 181       Attribute       : Project_Node_Id;
 182       Current_Package : Project_Node_Id)
 183    is
 184    begin
 185       if Present (Current_Package)
 186         and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
 187       then
 188          case Name_Of (Attribute, In_Tree) is
 189          when Snames.Name_Specification =>
 190             Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
 191
 192          when Snames.Name_Specification_Suffix =>
 193             Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
 194
 195          when Snames.Name_Implementation =>
 196             Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
 197
 198          when Snames.Name_Implementation_Suffix =>
 199             Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
 200
 201          when others =>
 202             null;
 203          end case;
 204       end if;
 205    end Rename_Obsolescent_Attributes;
 206
 207    ---------------------------
 208    -- Check_Package_Allowed --
 209    ---------------------------
 210
 211    procedure Check_Package_Allowed
 212      (In_Tree         : Project_Node_Tree_Ref;
 213       Project         : Project_Node_Id;
 214       Current_Package : Project_Node_Id;
 215       Flags           : Processing_Flags)
 216    is
 217       Qualif : constant Project_Qualifier :=
 218                  Project_Qualifier_Of (Project, In_Tree);
 219       Name   : constant Name_Id := Name_Of (Current_Package, In_Tree);
 220    begin
 221       if Qualif = Aggregate
 222         and then Name /= Snames.Name_Builder
 223       then
 224          Error_Msg_Name_1 := Name;
 225          Error_Msg
 226            (Flags,
 227             "package %% is forbidden in aggregate projects",
 228             Location_Of (Current_Package, In_Tree));
 229       end if;
 230    end Check_Package_Allowed;
 231
 232    -----------------------------
 233    -- Check_Attribute_Allowed --
 234    -----------------------------
 235
 236    procedure Check_Attribute_Allowed
 237      (In_Tree         : Project_Node_Tree_Ref;
 238       Project         : Project_Node_Id;
 239       Attribute       : Project_Node_Id;
 240       Flags           : Processing_Flags)
 241    is
 242       Qualif : constant Project_Qualifier :=
 243                  Project_Qualifier_Of (Project, In_Tree);
 244       Name   : constant Name_Id := Name_Of (Attribute, In_Tree);
 245
 246    begin
 247       case Qualif is
 248          when Aggregate =>
 249             if Name = Snames.Name_Languages
 250               or else Name = Snames.Name_Source_Files
 251               or else Name = Snames.Name_Source_List_File
 252               or else Name = Snames.Name_Locally_Removed_Files
 253               or else Name = Snames.Name_Excluded_Source_Files
 254               or else Name = Snames.Name_Excluded_Source_List_File
 255               or else Name = Snames.Name_Interfaces
 256               or else Name = Snames.Name_Object_Dir
 257               or else Name = Snames.Name_Exec_Dir
 258               or else Name = Snames.Name_Source_Dirs
 259               or else Name = Snames.Name_Inherit_Source_Path
 260             then
 261                Error_Msg_Name_1 := Name;
 262                Error_Msg
 263                  (Flags,
 264                   "%% is not valid in aggregate projects",
 265                   Location_Of (Attribute, In_Tree));
 266             end if;
 267
 268          when others =>
 269             if Name = Snames.Name_Project_Files
 270               or else Name = Snames.Name_Project_Path
 271               or else Name = Snames.Name_External
 272             then
 273                Error_Msg_Name_1 := Name;
 274                Error_Msg
 275                  (Flags,
 276                   "%% is only valid in aggregate projects",
 277                   Location_Of (Attribute, In_Tree));
 278             end if;
 279       end case;
 280    end Check_Attribute_Allowed;
 281
 282    ---------------------------------
 283    -- Parse_Attribute_Declaration --
 284    ---------------------------------
 285
 286    procedure Parse_Attribute_Declaration
 287      (In_Tree           : Project_Node_Tree_Ref;
 288       Attribute         : out Project_Node_Id;
 289       First_Attribute   : Attribute_Node_Id;
 290       Current_Project   : Project_Node_Id;
 291       Current_Package   : Project_Node_Id;
 292       Packages_To_Check : String_List_Access;
 293       Flags             : Processing_Flags)
 294    is
 295       Current_Attribute      : Attribute_Node_Id := First_Attribute;
 296       Full_Associative_Array : Boolean           := False;
 297       Attribute_Name         : Name_Id           := No_Name;
 298       Optional_Index         : Boolean           := False;
 299       Pkg_Id                 : Package_Node_Id   := Empty_Package;
 300
 301       procedure Process_Attribute_Name;
 302       --  Read the name of the attribute, and check its type
 303
 304       procedure Process_Associative_Array_Index;
 305       --  Read the index of the associative array and check its validity
 306
 307       ----------------------------
 308       -- Process_Attribute_Name --
 309       ----------------------------
 310
 311       procedure Process_Attribute_Name is
 312          Ignore : Boolean;
 313
 314       begin
 315          Attribute_Name := Token_Name;
 316          Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
 317          Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
 318
 319          --  Find the attribute
 320
 321          Current_Attribute :=
 322            Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
 323
 324          --  If the attribute cannot be found, create the attribute if inside
 325          --  an unknown package.
 326
 327          if Current_Attribute = Empty_Attribute then
 328             if Present (Current_Package)
 329               and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
 330             then
 331                Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
 332                Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
 333
 334             else
 335                --  If not a valid attribute name, issue an error if inside
 336                --  a package that need to be checked.
 337
 338                Ignore := Present (Current_Package) and then
 339                           Packages_To_Check /= All_Packages;
 340
 341                if Ignore then
 342
 343                   --  Check that we are not in a package to check
 344
 345                   Get_Name_String (Name_Of (Current_Package, In_Tree));
 346
 347                   for Index in Packages_To_Check'Range loop
 348                      if Name_Buffer (1 .. Name_Len) =
 349                        Packages_To_Check (Index).all
 350                      then
 351                         Ignore := False;
 352                         exit;
 353                      end if;
 354                   end loop;
 355                end if;
 356
 357                if not Ignore then
 358                   Error_Msg_Name_1 := Token_Name;
 359                   Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
 360                end if;
 361             end if;
 362
 363          --  Set, if appropriate the index case insensitivity flag
 364
 365          else
 366             if Is_Read_Only (Current_Attribute) then
 367                Error_Msg_Name_1 := Token_Name;
 368                Error_Msg
 369                  (Flags, "read-only attribute %% cannot be given a value",
 370                   Token_Ptr);
 371             end if;
 372
 373             if Attribute_Kind_Of (Current_Attribute) in
 374                  All_Case_Insensitive_Associative_Array
 375             then
 376                Set_Case_Insensitive (Attribute, In_Tree, To => True);
 377             end if;
 378          end if;
 379
 380          Scan (In_Tree); --  past the attribute name
 381
 382          --  Set the expression kind of the attribute
 383
 384          if Current_Attribute /= Empty_Attribute then
 385             Set_Expression_Kind_Of
 386               (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
 387             Optional_Index := Optional_Index_Of (Current_Attribute);
 388          end if;
 389       end Process_Attribute_Name;
 390
 391       -------------------------------------
 392       -- Process_Associative_Array_Index --
 393       -------------------------------------
 394
 395       procedure Process_Associative_Array_Index is
 396       begin
 397          --  If the attribute is not an associative array attribute, report
 398          --  an error. If this information is still unknown, set the kind
 399          --  to Associative_Array.
 400
 401          if Current_Attribute /= Empty_Attribute
 402            and then Attribute_Kind_Of (Current_Attribute) = Single
 403          then
 404             Error_Msg (Flags,
 405                        "the attribute """ &
 406                        Get_Name_String (Attribute_Name_Of (Current_Attribute))
 407                        & """ cannot be an associative array",
 408                        Location_Of (Attribute, In_Tree));
 409
 410          elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
 411             Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
 412          end if;
 413
 414          Scan (In_Tree); --  past the left parenthesis
 415
 416          if Others_Allowed_For (Current_Attribute)
 417            and then Token = Tok_Others
 418          then
 419             Set_Associative_Array_Index_Of
 420               (Attribute, In_Tree, All_Other_Names);
 421             Scan (In_Tree); --  past others
 422
 423          else
 424             if Others_Allowed_For (Current_Attribute) then
 425                Expect (Tok_String_Literal, "literal string or others");
 426             else
 427                Expect (Tok_String_Literal, "literal string");
 428             end if;
 429
 430             if Token = Tok_String_Literal then
 431                Get_Name_String (Token_Name);
 432
 433                if Case_Insensitive (Attribute, In_Tree) then
 434                   To_Lower (Name_Buffer (1 .. Name_Len));
 435                end if;
 436
 437                Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
 438                Scan (In_Tree); --  past the literal string index
 439
 440                if Token = Tok_At then
 441                   case Attribute_Kind_Of (Current_Attribute) is
 442                   when Optional_Index_Associative_Array |
 443                        Optional_Index_Case_Insensitive_Associative_Array =>
 444                      Scan (In_Tree);
 445                      Expect (Tok_Integer_Literal, "integer literal");
 446
 447                      if Token = Tok_Integer_Literal then
 448
 449                         --  Set the source index value from given literal
 450
 451                         declare
 452                            Index : constant Int :=
 453                                      UI_To_Int (Int_Literal_Value);
 454                         begin
 455                            if Index = 0 then
 456                               Error_Msg
 457                                 (Flags, "index cannot be zero", Token_Ptr);
 458                            else
 459                               Set_Source_Index_Of
 460                                 (Attribute, In_Tree, To => Index);
 461                            end if;
 462                         end;
 463
 464                         Scan (In_Tree);
 465                      end if;
 466
 467                   when others =>
 468                      Error_Msg (Flags, "index not allowed here", Token_Ptr);
 469                      Scan (In_Tree);
 470
 471                      if Token = Tok_Integer_Literal then
 472                         Scan (In_Tree);
 473                      end if;
 474                   end case;
 475                end if;
 476             end if;
 477          end if;
 478
 479          Expect (Tok_Right_Paren, "`)`");
 480
 481          if Token = Tok_Right_Paren then
 482             Scan (In_Tree); --  past the right parenthesis
 483          end if;
 484       end Process_Associative_Array_Index;
 485
 486    begin
 487       Attribute :=
 488         Default_Project_Node
 489           (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
 490       Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
 491       Set_Previous_Line_Node (Attribute);
 492
 493       --  Scan past "for"
 494
 495       Scan (In_Tree);
 496
 497       --  Body may be an attribute name
 498
 499       if Token = Tok_Body then
 500          Token := Tok_Identifier;
 501          Token_Name := Snames.Name_Body;
 502       end if;
 503
 504       Expect (Tok_Identifier, "identifier");
 505       Process_Attribute_Name;
 506       Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
 507       Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
 508
 509       --  Associative array attributes
 510
 511       if Token = Tok_Left_Paren then
 512          Process_Associative_Array_Index;
 513
 514       else
 515          --  If it is an associative array attribute and there are no left
 516          --  parenthesis, then this is a full associative array declaration.
 517          --  Flag it as such for later processing of its value.
 518
 519          if Current_Attribute /= Empty_Attribute
 520            and then
 521              Attribute_Kind_Of (Current_Attribute) /= Single
 522          then
 523             if Attribute_Kind_Of (Current_Attribute) = Unknown then
 524                Set_Attribute_Kind_Of (Current_Attribute, To => Single);
 525
 526             else
 527                Full_Associative_Array := True;
 528             end if;
 529          end if;
 530       end if;
 531
 532       Expect (Tok_Use, "USE");
 533
 534       if Token = Tok_Use then
 535          Scan (In_Tree);
 536
 537          if Full_Associative_Array then
 538
 539             --  Expect <project>'<same_attribute_name>, or
 540             --  <project>.<same_package_name>'<same_attribute_name>
 541
 542             declare
 543                The_Project : Project_Node_Id := Empty_Node;
 544                --  The node of the project where the associative array is
 545                --  declared.
 546
 547                The_Package : Project_Node_Id := Empty_Node;
 548                --  The node of the package where the associative array is
 549                --  declared, if any.
 550
 551                Project_Name : Name_Id := No_Name;
 552                --  The name of the project where the associative array is
 553                --  declared.
 554
 555                Location : Source_Ptr := No_Location;
 556                --  The location of the project name
 557
 558             begin
 559                Expect (Tok_Identifier, "identifier");
 560
 561                if Token = Tok_Identifier then
 562                   Location := Token_Ptr;
 563
 564                   --  Find the project node in the imported project or
 565                   --  in the project being extended.
 566
 567                   The_Project := Imported_Or_Extended_Project_Of
 568                                    (Current_Project, In_Tree, Token_Name);
 569
 570                   if No (The_Project) then
 571                      Error_Msg (Flags, "unknown project", Location);
 572                      Scan (In_Tree); --  past the project name
 573
 574                   else
 575                      Project_Name := Token_Name;
 576                      Scan (In_Tree); --  past the project name
 577
 578                      --  If this is inside a package, a dot followed by the
 579                      --  name of the package must followed the project name.
 580
 581                      if Present (Current_Package) then
 582                         Expect (Tok_Dot, "`.`");
 583
 584                         if Token /= Tok_Dot then
 585                            The_Project := Empty_Node;
 586
 587                         else
 588                            Scan (In_Tree); --  past the dot
 589                            Expect (Tok_Identifier, "identifier");
 590
 591                            if Token /= Tok_Identifier then
 592                               The_Project := Empty_Node;
 593
 594                            --  If it is not the same package name, issue error
 595
 596                            elsif
 597                              Token_Name /= Name_Of (Current_Package, In_Tree)
 598                            then
 599                               The_Project := Empty_Node;
 600                               Error_Msg
 601                                 (Flags, "not the same package as " &
 602                                  Get_Name_String
 603                                    (Name_Of (Current_Package, In_Tree)),
 604                                  Token_Ptr);
 605
 606                            else
 607                               The_Package :=
 608                                 First_Package_Of (The_Project, In_Tree);
 609
 610                               --  Look for the package node
 611
 612                               while Present (The_Package)
 613                                 and then
 614                                 Name_Of (The_Package, In_Tree) /= Token_Name
 615                               loop
 616                                  The_Package :=
 617                                    Next_Package_In_Project
 618                                      (The_Package, In_Tree);
 619                               end loop;
 620
 621                               --  If the package cannot be found in the
 622                               --  project, issue an error.
 623
 624                               if No (The_Package) then
 625                                  The_Project := Empty_Node;
 626                                  Error_Msg_Name_2 := Project_Name;
 627                                  Error_Msg_Name_1 := Token_Name;
 628                                  Error_Msg
 629                                    (Flags,
 630                                     "package % not declared in project %",
 631                                     Token_Ptr);
 632                               end if;
 633
 634                               Scan (In_Tree); --  past the package name
 635                            end if;
 636                         end if;
 637                      end if;
 638                   end if;
 639                end if;
 640
 641                if Present (The_Project) then
 642
 643                   --  Looking for '<same attribute name>
 644
 645                   Expect (Tok_Apostrophe, "`''`");
 646
 647                   if Token /= Tok_Apostrophe then
 648                      The_Project := Empty_Node;
 649
 650                   else
 651                      Scan (In_Tree); --  past the apostrophe
 652                      Expect (Tok_Identifier, "identifier");
 653
 654                      if Token /= Tok_Identifier then
 655                         The_Project := Empty_Node;
 656
 657                      else
 658                         --  If it is not the same attribute name, issue error
 659
 660                         if Token_Name /= Attribute_Name then
 661                            The_Project := Empty_Node;
 662                            Error_Msg_Name_1 := Attribute_Name;
 663                            Error_Msg
 664                              (Flags, "invalid name, should be %", Token_Ptr);
 665                         end if;
 666
 667                         Scan (In_Tree); --  past the attribute name
 668                      end if;
 669                   end if;
 670                end if;
 671
 672                if No (The_Project) then
 673
 674                   --  If there were any problem, set the attribute id to null,
 675                   --  so that the node will not be recorded.
 676
 677                   Current_Attribute := Empty_Attribute;
 678
 679                else
 680                   --  Set the appropriate field in the node.
 681                   --  Note that the index and the expression are nil. This
 682                   --  characterizes full associative array attribute
 683                   --  declarations.
 684
 685                   Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
 686                   Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
 687                end if;
 688             end;
 689
 690          --  Other attribute declarations (not full associative array)
 691
 692          else
 693             declare
 694                Expression_Location : constant Source_Ptr := Token_Ptr;
 695                --  The location of the first token of the expression
 696
 697                Expression          : Project_Node_Id     := Empty_Node;
 698                --  The expression, value for the attribute declaration
 699
 700             begin
 701                --  Get the expression value and set it in the attribute node
 702
 703                Parse_Expression
 704                  (In_Tree         => In_Tree,
 705                   Expression      => Expression,
 706                   Flags           => Flags,
 707                   Current_Project => Current_Project,
 708                   Current_Package => Current_Package,
 709                   Optional_Index  => Optional_Index);
 710                Set_Expression_Of (Attribute, In_Tree, To => Expression);
 711
 712                --  If the expression is legal, but not of the right kind
 713                --  for the attribute, issue an error.
 714
 715                if Current_Attribute /= Empty_Attribute
 716                  and then Present (Expression)
 717                  and then Variable_Kind_Of (Current_Attribute) /=
 718                  Expression_Kind_Of (Expression, In_Tree)
 719                then
 720                   if  Variable_Kind_Of (Current_Attribute) = Undefined then
 721                      Set_Variable_Kind_Of
 722                        (Current_Attribute,
 723                         To => Expression_Kind_Of (Expression, In_Tree));
 724
 725                   else
 726                      Error_Msg
 727                        (Flags, "wrong expression kind for attribute """ &
 728                         Get_Name_String
 729                           (Attribute_Name_Of (Current_Attribute)) &
 730                         """",
 731                         Expression_Location);
 732                   end if;
 733                end if;
 734             end;
 735          end if;
 736       end if;
 737
 738       --  If the attribute was not recognized, return an empty node.
 739       --  It may be that it is not in a package to check, and the node will
 740       --  not be added to the tree.
 741
 742       if Current_Attribute = Empty_Attribute then
 743          Attribute := Empty_Node;
 744       end if;
 745
 746       Set_End_Of_Line (Attribute);
 747       Set_Previous_Line_Node (Attribute);
 748    end Parse_Attribute_Declaration;
 749
 750    -----------------------------
 751    -- Parse_Case_Construction --
 752    -----------------------------
 753
 754    procedure Parse_Case_Construction
 755      (In_Tree           : Project_Node_Tree_Ref;
 756       Case_Construction : out Project_Node_Id;
 757       First_Attribute   : Attribute_Node_Id;
 758       Current_Project   : Project_Node_Id;
 759       Current_Package   : Project_Node_Id;
 760       Packages_To_Check : String_List_Access;
 761       Is_Config_File    : Boolean;
 762       Flags             : Processing_Flags)
 763    is
 764       Current_Item    : Project_Node_Id := Empty_Node;
 765       Next_Item       : Project_Node_Id := Empty_Node;
 766       First_Case_Item : Boolean := True;
 767
 768       Variable_Location : Source_Ptr := No_Location;
 769
 770       String_Type : Project_Node_Id := Empty_Node;
 771
 772       Case_Variable : Project_Node_Id := Empty_Node;
 773
 774       First_Declarative_Item : Project_Node_Id := Empty_Node;
 775
 776       First_Choice           : Project_Node_Id := Empty_Node;
 777
 778       When_Others            : Boolean := False;
 779       --  Set to True when there is a "when others =>" clause
 780
 781    begin
 782       Case_Construction  :=
 783         Default_Project_Node
 784           (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
 785       Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
 786
 787       --  Scan past "case"
 788
 789       Scan (In_Tree);
 790
 791       --  Get the switch variable
 792
 793       Expect (Tok_Identifier, "identifier");
 794
 795       if Token = Tok_Identifier then
 796          Variable_Location := Token_Ptr;
 797          Parse_Variable_Reference
 798            (In_Tree         => In_Tree,
 799             Variable        => Case_Variable,
 800             Flags           => Flags,
 801             Current_Project => Current_Project,
 802             Current_Package => Current_Package);
 803          Set_Case_Variable_Reference_Of
 804            (Case_Construction, In_Tree, To => Case_Variable);
 805
 806       else
 807          if Token /= Tok_Is then
 808             Scan (In_Tree);
 809          end if;
 810       end if;
 811
 812       if Present (Case_Variable) then
 813          String_Type := String_Type_Of (Case_Variable, In_Tree);
 814
 815          if No (String_Type) then
 816             Error_Msg (Flags,
 817                        "variable """ &
 818                        Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
 819                        """ is not typed",
 820                        Variable_Location);
 821          end if;
 822       end if;
 823
 824       Expect (Tok_Is, "IS");
 825
 826       if Token = Tok_Is then
 827          Set_End_Of_Line (Case_Construction);
 828          Set_Previous_Line_Node (Case_Construction);
 829          Set_Next_End_Node (Case_Construction);
 830
 831          --  Scan past "is"
 832
 833          Scan (In_Tree);
 834       end if;
 835
 836       Start_New_Case_Construction (In_Tree, String_Type);
 837
 838       When_Loop :
 839
 840       while Token = Tok_When loop
 841
 842          if First_Case_Item then
 843             Current_Item :=
 844               Default_Project_Node
 845                 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
 846             Set_First_Case_Item_Of
 847               (Case_Construction, In_Tree, To => Current_Item);
 848             First_Case_Item := False;
 849
 850          else
 851             Next_Item :=
 852               Default_Project_Node
 853                 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
 854             Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
 855             Current_Item := Next_Item;
 856          end if;
 857
 858          Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
 859
 860          --  Scan past "when"
 861
 862          Scan (In_Tree);
 863
 864          if Token = Tok_Others then
 865             When_Others := True;
 866
 867             --  Scan past "others"
 868
 869             Scan (In_Tree);
 870
 871             Expect (Tok_Arrow, "`=>`");
 872             Set_End_Of_Line (Current_Item);
 873             Set_Previous_Line_Node (Current_Item);
 874
 875             --  Empty_Node in Field1 of a Case_Item indicates
 876             --  the "when others =>" branch.
 877
 878             Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
 879
 880             Parse_Declarative_Items
 881               (In_Tree           => In_Tree,
 882                Declarations      => First_Declarative_Item,
 883                In_Zone           => In_Case_Construction,
 884                First_Attribute   => First_Attribute,
 885                Current_Project   => Current_Project,
 886                Current_Package   => Current_Package,
 887                Packages_To_Check => Packages_To_Check,
 888                Is_Config_File    => Is_Config_File,
 889                Flags             => Flags);
 890
 891             --  "when others =>" must be the last branch, so save the
 892             --  Case_Item and exit
 893
 894             Set_First_Declarative_Item_Of
 895               (Current_Item, In_Tree, To => First_Declarative_Item);
 896             exit When_Loop;
 897
 898          else
 899             Parse_Choice_List
 900               (In_Tree      => In_Tree,
 901                First_Choice => First_Choice,
 902                Flags        => Flags);
 903             Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
 904
 905             Expect (Tok_Arrow, "`=>`");
 906             Set_End_Of_Line (Current_Item);
 907             Set_Previous_Line_Node (Current_Item);
 908
 909             Parse_Declarative_Items
 910               (In_Tree           => In_Tree,
 911                Declarations      => First_Declarative_Item,
 912                In_Zone           => In_Case_Construction,
 913                First_Attribute   => First_Attribute,
 914                Current_Project   => Current_Project,
 915                Current_Package   => Current_Package,
 916                Packages_To_Check => Packages_To_Check,
 917                Is_Config_File    => Is_Config_File,
 918                Flags             => Flags);
 919
 920             Set_First_Declarative_Item_Of
 921               (Current_Item, In_Tree, To => First_Declarative_Item);
 922
 923          end if;
 924       end loop When_Loop;
 925
 926       End_Case_Construction
 927         (Check_All_Labels => not When_Others and not Quiet_Output,
 928          Case_Location    => Location_Of (Case_Construction, In_Tree),
 929          Flags            => Flags);
 930
 931       Expect (Tok_End, "`END CASE`");
 932       Remove_Next_End_Node;
 933
 934       if Token = Tok_End then
 935
 936          --  Scan past "end"
 937
 938          Scan (In_Tree);
 939
 940          Expect (Tok_Case, "CASE");
 941
 942       end if;
 943
 944       --  Scan past "case"
 945
 946       Scan (In_Tree);
 947
 948       Expect (Tok_Semicolon, "`;`");
 949       Set_Previous_End_Node (Case_Construction);
 950
 951    end Parse_Case_Construction;
 952
 953    -----------------------------
 954    -- Parse_Declarative_Items --
 955    -----------------------------
 956
 957    procedure Parse_Declarative_Items
 958      (In_Tree           : Project_Node_Tree_Ref;
 959       Declarations      : out Project_Node_Id;
 960       In_Zone           : Zone;
 961       First_Attribute   : Attribute_Node_Id;
 962       Current_Project   : Project_Node_Id;
 963       Current_Package   : Project_Node_Id;
 964       Packages_To_Check : String_List_Access;
 965       Is_Config_File    : Boolean;
 966       Flags             : Processing_Flags)
 967    is
 968       Current_Declarative_Item : Project_Node_Id := Empty_Node;
 969       Next_Declarative_Item    : Project_Node_Id := Empty_Node;
 970       Current_Declaration      : Project_Node_Id := Empty_Node;
 971       Item_Location            : Source_Ptr      := No_Location;
 972
 973    begin
 974       Declarations := Empty_Node;
 975
 976       loop
 977          --  We are always positioned at the token that precedes the first
 978          --  token of the declarative element. Scan past it.
 979
 980          Scan (In_Tree);
 981
 982          Item_Location := Token_Ptr;
 983
 984          case Token is
 985             when Tok_Identifier =>
 986
 987                if In_Zone = In_Case_Construction then
 988
 989                   --  Check if the variable has already been declared
 990
 991                   declare
 992                      The_Variable : Project_Node_Id := Empty_Node;
 993
 994                   begin
 995                      if Present (Current_Package) then
 996                         The_Variable :=
 997                           First_Variable_Of (Current_Package, In_Tree);
 998                      elsif Present (Current_Project) then
 999                         The_Variable :=
1000                           First_Variable_Of (Current_Project, In_Tree);
1001                      end if;
1002
1003                      while Present (The_Variable)
1004                        and then Name_Of (The_Variable, In_Tree) /=
1005                                 Token_Name
1006                      loop
1007                         The_Variable := Next_Variable (The_Variable, In_Tree);
1008                      end loop;
1009
1010                      --  It is an error to declare a variable in a case
1011                      --  construction for the first time.
1012
1013                      if No (The_Variable) then
1014                         Error_Msg
1015                           (Flags,
1016                            "a variable cannot be declared " &
1017                            "for the first time here",
1018                            Token_Ptr);
1019                      end if;
1020                   end;
1021                end if;
1022
1023                Parse_Variable_Declaration
1024                  (In_Tree,
1025                   Current_Declaration,
1026                   Current_Project => Current_Project,
1027                   Current_Package => Current_Package,
1028                   Flags           => Flags);
1029
1030                Set_End_Of_Line (Current_Declaration);
1031                Set_Previous_Line_Node (Current_Declaration);
1032
1033             when Tok_For =>
1034
1035                Parse_Attribute_Declaration
1036                  (In_Tree           => In_Tree,
1037                   Attribute         => Current_Declaration,
1038                   First_Attribute   => First_Attribute,
1039                   Current_Project   => Current_Project,
1040                   Current_Package   => Current_Package,
1041                   Packages_To_Check => Packages_To_Check,
1042                   Flags             => Flags);
1043
1044                Set_End_Of_Line (Current_Declaration);
1045                Set_Previous_Line_Node (Current_Declaration);
1046
1047             when Tok_Null =>
1048
1049                Scan (In_Tree); --  past "null"
1050
1051             when Tok_Package =>
1052
1053                --  Package declaration
1054
1055                if In_Zone /= In_Project then
1056                   Error_Msg
1057                     (Flags, "a package cannot be declared here", Token_Ptr);
1058                end if;
1059
1060                Parse_Package_Declaration
1061                  (In_Tree             => In_Tree,
1062                   Package_Declaration => Current_Declaration,
1063                   Current_Project     => Current_Project,
1064                   Packages_To_Check   => Packages_To_Check,
1065                   Is_Config_File      => Is_Config_File,
1066                   Flags               => Flags);
1067
1068                Set_Previous_End_Node (Current_Declaration);
1069
1070             when Tok_Type =>
1071
1072                --  Type String Declaration
1073
1074                if In_Zone /= In_Project then
1075                   Error_Msg (Flags,
1076                              "a string type cannot be declared here",
1077                              Token_Ptr);
1078                end if;
1079
1080                Parse_String_Type_Declaration
1081                  (In_Tree         => In_Tree,
1082                   String_Type     => Current_Declaration,
1083                   Current_Project => Current_Project,
1084                   Flags           => Flags);
1085
1086                Set_End_Of_Line (Current_Declaration);
1087                Set_Previous_Line_Node (Current_Declaration);
1088
1089             when Tok_Case =>
1090
1091                --  Case construction
1092
1093                Parse_Case_Construction
1094                  (In_Tree           => In_Tree,
1095                   Case_Construction => Current_Declaration,
1096                   First_Attribute   => First_Attribute,
1097                   Current_Project   => Current_Project,
1098                   Current_Package   => Current_Package,
1099                   Packages_To_Check => Packages_To_Check,
1100                   Is_Config_File    => Is_Config_File,
1101                   Flags             => Flags);
1102
1103                Set_Previous_End_Node (Current_Declaration);
1104
1105             when others =>
1106                exit;
1107
1108                --  We are leaving Parse_Declarative_Items positioned
1109                --  at the first token after the list of declarative items.
1110                --  It could be "end" (for a project, a package declaration or
1111                --  a case construction) or "when" (for a case construction)
1112
1113          end case;
1114
1115          Expect (Tok_Semicolon, "`;` after declarative items");
1116
1117          --  Insert an N_Declarative_Item in the tree, but only if
1118          --  Current_Declaration is not an empty node.
1119
1120          if Present (Current_Declaration) then
1121             if No (Current_Declarative_Item) then
1122                Current_Declarative_Item :=
1123                  Default_Project_Node
1124                    (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1125                Declarations  := Current_Declarative_Item;
1126
1127             else
1128                Next_Declarative_Item :=
1129                  Default_Project_Node
1130                    (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1131                Set_Next_Declarative_Item
1132                  (Current_Declarative_Item, In_Tree,
1133                   To => Next_Declarative_Item);
1134                Current_Declarative_Item := Next_Declarative_Item;
1135             end if;
1136
1137             Set_Current_Item_Node
1138               (Current_Declarative_Item, In_Tree,
1139                To => Current_Declaration);
1140             Set_Location_Of
1141               (Current_Declarative_Item, In_Tree, To => Item_Location);
1142          end if;
1143       end loop;
1144    end Parse_Declarative_Items;
1145
1146    -------------------------------
1147    -- Parse_Package_Declaration --
1148    -------------------------------
1149
1150    procedure Parse_Package_Declaration
1151      (In_Tree             : Project_Node_Tree_Ref;
1152       Package_Declaration : out Project_Node_Id;
1153       Current_Project     : Project_Node_Id;
1154       Packages_To_Check   : String_List_Access;
1155       Is_Config_File      : Boolean;
1156       Flags               : Processing_Flags)
1157    is
1158       First_Attribute        : Attribute_Node_Id := Empty_Attribute;
1159       Current_Package        : Package_Node_Id   := Empty_Package;
1160       First_Declarative_Item : Project_Node_Id   := Empty_Node;
1161       Package_Location       : constant Source_Ptr := Token_Ptr;
1162       Renaming               : Boolean := False;
1163       Extending              : Boolean := False;
1164
1165    begin
1166       Package_Declaration :=
1167         Default_Project_Node
1168           (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
1169       Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
1170
1171       --  Scan past "package"
1172
1173       Scan (In_Tree);
1174       Expect (Tok_Identifier, "identifier");
1175
1176       if Token = Tok_Identifier then
1177          Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
1178
1179          Current_Package := Package_Node_Id_Of (Token_Name);
1180
1181          if Current_Package = Empty_Package then
1182             if not Quiet_Output then
1183                declare
1184                   List  : constant Strings.String_List := Package_Name_List;
1185                   Index : Natural;
1186                   Name  : constant String := Get_Name_String (Token_Name);
1187
1188                begin
1189                   --  Check for possible misspelling of a known package name
1190
1191                   Index := 0;
1192                   loop
1193                      if Index >= List'Last then
1194                         Index := 0;
1195                         exit;
1196                      end if;
1197
1198                      Index := Index + 1;
1199                      exit when
1200                        GNAT.Spelling_Checker.Is_Bad_Spelling_Of
1201                          (Name, List (Index).all);
1202                   end loop;
1203
1204                   --  Issue warning(s) in verbose mode or when a possible
1205                   --  misspelling has been found.
1206
1207                   if Verbose_Mode or else Index /= 0 then
1208                      Error_Msg (Flags,
1209                                 "?""" &
1210                                 Get_Name_String
1211                                  (Name_Of (Package_Declaration, In_Tree)) &
1212                                 """ is not a known package name",
1213                                 Token_Ptr);
1214                   end if;
1215
1216                   if Index /= 0 then
1217                      Error_Msg -- CODEFIX
1218                        (Flags,
1219                         "\?possible misspelling of """ &
1220                         List (Index).all & """", Token_Ptr);
1221                   end if;
1222                end;
1223             end if;
1224
1225             --  Set the package declaration to "ignored" so that it is not
1226             --  processed by Prj.Proc.Process.
1227
1228             Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1229
1230             --  Add the unknown package in the list of packages
1231
1232             Add_Unknown_Package (Token_Name, Current_Package);
1233
1234          elsif Current_Package = Unknown_Package then
1235
1236             --  Set the package declaration to "ignored" so that it is not
1237             --  processed by Prj.Proc.Process.
1238
1239             Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1240
1241          else
1242             First_Attribute := First_Attribute_Of (Current_Package);
1243          end if;
1244
1245          Set_Package_Id_Of
1246            (Package_Declaration, In_Tree, To => Current_Package);
1247
1248          declare
1249             Current : Project_Node_Id :=
1250                         First_Package_Of (Current_Project, In_Tree);
1251
1252          begin
1253             while Present (Current)
1254               and then Name_Of (Current, In_Tree) /= Token_Name
1255             loop
1256                Current := Next_Package_In_Project (Current, In_Tree);
1257             end loop;
1258
1259             if Present (Current) then
1260                Error_Msg
1261                  (Flags,
1262                   "package """ &
1263                   Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
1264                   """ is declared twice in the same project",
1265                   Token_Ptr);
1266
1267             else
1268                --  Add the package to the project list
1269
1270                Set_Next_Package_In_Project
1271                  (Package_Declaration, In_Tree,
1272                   To => First_Package_Of (Current_Project, In_Tree));
1273                Set_First_Package_Of
1274                  (Current_Project, In_Tree, To => Package_Declaration);
1275             end if;
1276          end;
1277
1278          --  Scan past the package name
1279
1280          Scan (In_Tree);
1281       end if;
1282
1283       Check_Package_Allowed
1284         (In_Tree, Current_Project, Package_Declaration, Flags);
1285
1286       if Token = Tok_Renames then
1287          Renaming := True;
1288       elsif Token = Tok_Extends then
1289          Extending := True;
1290       end if;
1291
1292       if Renaming or else Extending then
1293          if Is_Config_File then
1294             Error_Msg
1295               (Flags,
1296                "no package rename or extension in configuration projects",
1297                Token_Ptr);
1298          end if;
1299
1300          --  Scan past "renames" or "extends"
1301
1302          Scan (In_Tree);
1303
1304          Expect (Tok_Identifier, "identifier");
1305
1306          if Token = Tok_Identifier then
1307             declare
1308                Project_Name : constant Name_Id := Token_Name;
1309
1310                Clause       : Project_Node_Id :=
1311                               First_With_Clause_Of (Current_Project, In_Tree);
1312                The_Project  : Project_Node_Id := Empty_Node;
1313                Extended     : constant Project_Node_Id :=
1314                                 Extended_Project_Of
1315                                   (Project_Declaration_Of
1316                                     (Current_Project, In_Tree),
1317                                    In_Tree);
1318             begin
1319                while Present (Clause) loop
1320                   --  Only non limited imported projects may be used in a
1321                   --  renames declaration.
1322
1323                   The_Project :=
1324                     Non_Limited_Project_Node_Of (Clause, In_Tree);
1325                   exit when Present (The_Project)
1326                     and then Name_Of (The_Project, In_Tree) = Project_Name;
1327                   Clause := Next_With_Clause_Of (Clause, In_Tree);
1328                end loop;
1329
1330                if No (Clause) then
1331                   --  As we have not found the project in the imports, we check
1332                   --  if it's the name of an eventual extended project.
1333
1334                   if Present (Extended)
1335                     and then Name_Of (Extended, In_Tree) = Project_Name
1336                   then
1337                      Set_Project_Of_Renamed_Package_Of
1338                        (Package_Declaration, In_Tree, To => Extended);
1339                   else
1340                      Error_Msg_Name_1 := Project_Name;
1341                      Error_Msg
1342                        (Flags,
1343                         "% is not an imported or extended project", Token_Ptr);
1344                   end if;
1345                else
1346                   Set_Project_Of_Renamed_Package_Of
1347                     (Package_Declaration, In_Tree, To => The_Project);
1348                end if;
1349             end;
1350
1351             Scan (In_Tree);
1352             Expect (Tok_Dot, "`.`");
1353
1354             if Token = Tok_Dot then
1355                Scan (In_Tree);
1356                Expect (Tok_Identifier, "identifier");
1357
1358                if Token = Tok_Identifier then
1359                   if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1360                      Error_Msg (Flags, "not the same package name", Token_Ptr);
1361                   elsif
1362                     Present (Project_Of_Renamed_Package_Of
1363                                (Package_Declaration, In_Tree))
1364                   then
1365                      declare
1366                         Current : Project_Node_Id :=
1367                                     First_Package_Of
1368                                       (Project_Of_Renamed_Package_Of
1369                                            (Package_Declaration, In_Tree),
1370                                        In_Tree);
1371
1372                      begin
1373                         while Present (Current)
1374                           and then Name_Of (Current, In_Tree) /= Token_Name
1375                         loop
1376                            Current :=
1377                              Next_Package_In_Project (Current, In_Tree);
1378                         end loop;
1379
1380                         if No (Current) then
1381                            Error_Msg
1382                              (Flags, """" &
1383                               Get_Name_String (Token_Name) &
1384                               """ is not a package declared by the project",
1385                               Token_Ptr);
1386                         end if;
1387                      end;
1388                   end if;
1389
1390                   Scan (In_Tree);
1391                end if;
1392             end if;
1393          end if;
1394       end if;
1395
1396       if Renaming then
1397          Expect (Tok_Semicolon, "`;`");
1398          Set_End_Of_Line (Package_Declaration);
1399          Set_Previous_Line_Node (Package_Declaration);
1400
1401       elsif Token = Tok_Is then
1402          Set_End_Of_Line (Package_Declaration);
1403          Set_Previous_Line_Node (Package_Declaration);
1404          Set_Next_End_Node (Package_Declaration);
1405
1406          Parse_Declarative_Items
1407            (In_Tree           => In_Tree,
1408             Declarations      => First_Declarative_Item,
1409             In_Zone           => In_Package,
1410             First_Attribute   => First_Attribute,
1411             Current_Project   => Current_Project,
1412             Current_Package   => Package_Declaration,
1413             Packages_To_Check => Packages_To_Check,
1414             Is_Config_File    => Is_Config_File,
1415             Flags             => Flags);
1416
1417          Set_First_Declarative_Item_Of
1418            (Package_Declaration, In_Tree, To => First_Declarative_Item);
1419
1420          Expect (Tok_End, "END");
1421
1422          if Token = Tok_End then
1423
1424             --  Scan past "end"
1425
1426             Scan (In_Tree);
1427          end if;
1428
1429          --  We should have the name of the package after "end"
1430
1431          Expect (Tok_Identifier, "identifier");
1432
1433          if Token = Tok_Identifier
1434            and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1435            and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1436          then
1437             Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1438             Error_Msg (Flags, "expected %%", Token_Ptr);
1439          end if;
1440
1441          if Token /= Tok_Semicolon then
1442
1443             --  Scan past the package name
1444
1445             Scan (In_Tree);
1446          end if;
1447
1448          Expect (Tok_Semicolon, "`;`");
1449          Remove_Next_End_Node;
1450
1451       else
1452          Error_Msg (Flags, "expected IS", Token_Ptr);
1453       end if;
1454
1455    end Parse_Package_Declaration;
1456
1457    -----------------------------------
1458    -- Parse_String_Type_Declaration --
1459    -----------------------------------
1460
1461    procedure Parse_String_Type_Declaration
1462      (In_Tree         : Project_Node_Tree_Ref;
1463       String_Type     : out Project_Node_Id;
1464       Current_Project : Project_Node_Id;
1465       Flags           : Processing_Flags)
1466    is
1467       Current      : Project_Node_Id := Empty_Node;
1468       First_String : Project_Node_Id := Empty_Node;
1469
1470    begin
1471       String_Type :=
1472         Default_Project_Node
1473           (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1474
1475       Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1476
1477       --  Scan past "type"
1478
1479       Scan (In_Tree);
1480
1481       Expect (Tok_Identifier, "identifier");
1482
1483       if Token = Tok_Identifier then
1484          Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1485
1486          Current := First_String_Type_Of (Current_Project, In_Tree);
1487          while Present (Current)
1488            and then
1489            Name_Of (Current, In_Tree) /= Token_Name
1490          loop
1491             Current := Next_String_Type (Current, In_Tree);
1492          end loop;
1493
1494          if Present (Current) then
1495             Error_Msg (Flags,
1496                        "duplicate string type name """ &
1497                        Get_Name_String (Token_Name) &
1498                        """",
1499                        Token_Ptr);
1500          else
1501             Current := First_Variable_Of (Current_Project, In_Tree);
1502             while Present (Current)
1503               and then Name_Of (Current, In_Tree) /= Token_Name
1504             loop
1505                Current := Next_Variable (Current, In_Tree);
1506             end loop;
1507
1508             if Present (Current) then
1509                Error_Msg (Flags,
1510                           """" &
1511                           Get_Name_String (Token_Name) &
1512                           """ is already a variable name", Token_Ptr);
1513             else
1514                Set_Next_String_Type
1515                  (String_Type, In_Tree,
1516                   To => First_String_Type_Of (Current_Project, In_Tree));
1517                Set_First_String_Type_Of
1518                  (Current_Project, In_Tree, To => String_Type);
1519             end if;
1520          end if;
1521
1522          --  Scan past the name
1523
1524          Scan (In_Tree);
1525       end if;
1526
1527       Expect (Tok_Is, "IS");
1528
1529       if Token = Tok_Is then
1530          Scan (In_Tree);
1531       end if;
1532
1533       Expect (Tok_Left_Paren, "`(`");
1534
1535       if Token = Tok_Left_Paren then
1536          Scan (In_Tree);
1537       end if;
1538
1539       Parse_String_Type_List
1540         (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
1541       Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1542
1543       Expect (Tok_Right_Paren, "`)`");
1544
1545       if Token = Tok_Right_Paren then
1546          Scan (In_Tree);
1547       end if;
1548
1549    end Parse_String_Type_Declaration;
1550
1551    --------------------------------
1552    -- Parse_Variable_Declaration --
1553    --------------------------------
1554
1555    procedure Parse_Variable_Declaration
1556      (In_Tree         : Project_Node_Tree_Ref;
1557       Variable        : out Project_Node_Id;
1558       Current_Project : Project_Node_Id;
1559       Current_Package : Project_Node_Id;
1560       Flags           : Processing_Flags)
1561    is
1562       Expression_Location      : Source_Ptr;
1563       String_Type_Name         : Name_Id := No_Name;
1564       Project_String_Type_Name : Name_Id := No_Name;
1565       Type_Location            : Source_Ptr := No_Location;
1566       Project_Location         : Source_Ptr := No_Location;
1567       Expression               : Project_Node_Id := Empty_Node;
1568       Variable_Name            : constant Name_Id := Token_Name;
1569       OK                       : Boolean := True;
1570
1571    begin
1572       Variable :=
1573         Default_Project_Node
1574           (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1575       Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1576       Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1577
1578       --  Scan past the variable name
1579
1580       Scan (In_Tree);
1581
1582       if Token = Tok_Colon then
1583
1584          --  Typed string variable declaration
1585
1586          Scan (In_Tree);
1587          Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1588          Expect (Tok_Identifier, "identifier");
1589
1590          OK := Token = Tok_Identifier;
1591
1592          if OK then
1593             String_Type_Name := Token_Name;
1594             Type_Location := Token_Ptr;
1595             Scan (In_Tree);
1596
1597             if Token = Tok_Dot then
1598                Project_String_Type_Name := String_Type_Name;
1599                Project_Location := Type_Location;
1600
1601                --  Scan past the dot
1602
1603                Scan (In_Tree);
1604                Expect (Tok_Identifier, "identifier");
1605
1606                if Token = Tok_Identifier then
1607                   String_Type_Name := Token_Name;
1608                   Type_Location := Token_Ptr;
1609                   Scan (In_Tree);
1610                else
1611                   OK := False;
1612                end if;
1613             end if;
1614
1615             if OK then
1616                declare
1617                   Proj    : Project_Node_Id := Current_Project;
1618                   Current : Project_Node_Id := Empty_Node;
1619
1620                begin
1621                   if Project_String_Type_Name /= No_Name then
1622                      declare
1623                         The_Project_Name_And_Node : constant
1624                           Tree_Private_Part.Project_Name_And_Node :=
1625                           Tree_Private_Part.Projects_Htable.Get
1626                             (In_Tree.Projects_HT, Project_String_Type_Name);
1627
1628                         use Tree_Private_Part;
1629
1630                      begin
1631                         if The_Project_Name_And_Node =
1632                              Tree_Private_Part.No_Project_Name_And_Node
1633                         then
1634                            Error_Msg (Flags,
1635                                       "unknown project """ &
1636                                       Get_Name_String
1637                                          (Project_String_Type_Name) &
1638                                       """",
1639                                       Project_Location);
1640                            Current := Empty_Node;
1641                         else
1642                            Current :=
1643                              First_String_Type_Of
1644                                (The_Project_Name_And_Node.Node, In_Tree);
1645                            while
1646                              Present (Current)
1647                              and then
1648                                Name_Of (Current, In_Tree) /= String_Type_Name
1649                            loop
1650                               Current := Next_String_Type (Current, In_Tree);
1651                            end loop;
1652                         end if;
1653                      end;
1654
1655                   else
1656                      --  Look for a string type with the correct name in this
1657                      --  project or in any of its ancestors.
1658
1659                      loop
1660                         Current :=
1661                           First_String_Type_Of (Proj, In_Tree);
1662                         while
1663                           Present (Current)
1664                           and then
1665                             Name_Of (Current, In_Tree) /= String_Type_Name
1666                         loop
1667                            Current := Next_String_Type (Current, In_Tree);
1668                         end loop;
1669
1670                         exit when Present (Current);
1671
1672                         Proj := Parent_Project_Of (Proj, In_Tree);
1673                         exit when No (Proj);
1674                      end loop;
1675                   end if;
1676
1677                   if No (Current) then
1678                      Error_Msg (Flags,
1679                                 "unknown string type """ &
1680                                 Get_Name_String (String_Type_Name) &
1681                                 """",
1682                                 Type_Location);
1683                      OK := False;
1684
1685                   else
1686                      Set_String_Type_Of
1687                        (Variable, In_Tree, To => Current);
1688                   end if;
1689                end;
1690             end if;
1691          end if;
1692       end if;
1693
1694       Expect (Tok_Colon_Equal, "`:=`");
1695
1696       OK := OK and then Token = Tok_Colon_Equal;
1697
1698       if Token = Tok_Colon_Equal then
1699          Scan (In_Tree);
1700       end if;
1701
1702       --  Get the single string or string list value
1703
1704       Expression_Location := Token_Ptr;
1705
1706       Parse_Expression
1707         (In_Tree         => In_Tree,
1708          Expression      => Expression,
1709          Flags           => Flags,
1710          Current_Project => Current_Project,
1711          Current_Package => Current_Package,
1712          Optional_Index  => False);
1713       Set_Expression_Of (Variable, In_Tree, To => Expression);
1714
1715       if Present (Expression) then
1716          --  A typed string must have a single string value, not a list
1717
1718          if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1719            and then Expression_Kind_Of (Expression, In_Tree) = List
1720          then
1721             Error_Msg
1722               (Flags,
1723                "expression must be a single string", Expression_Location);
1724          end if;
1725
1726          Set_Expression_Kind_Of
1727            (Variable, In_Tree,
1728             To => Expression_Kind_Of (Expression, In_Tree));
1729       end if;
1730
1731       if OK then
1732          declare
1733             The_Variable : Project_Node_Id := Empty_Node;
1734
1735          begin
1736             if Present (Current_Package) then
1737                The_Variable := First_Variable_Of (Current_Package, In_Tree);
1738             elsif Present (Current_Project) then
1739                The_Variable := First_Variable_Of (Current_Project, In_Tree);
1740             end if;
1741
1742             while Present (The_Variable)
1743               and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1744             loop
1745                The_Variable := Next_Variable (The_Variable, In_Tree);
1746             end loop;
1747
1748             if No (The_Variable) then
1749                if Present (Current_Package) then
1750                   Set_Next_Variable
1751                     (Variable, In_Tree,
1752                      To => First_Variable_Of (Current_Package, In_Tree));
1753                   Set_First_Variable_Of
1754                     (Current_Package, In_Tree, To => Variable);
1755
1756                elsif Present (Current_Project) then
1757                   Set_Next_Variable
1758                     (Variable, In_Tree,
1759                      To => First_Variable_Of (Current_Project, In_Tree));
1760                   Set_First_Variable_Of
1761                     (Current_Project, In_Tree, To => Variable);
1762                end if;
1763
1764             else
1765                if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1766                   if Expression_Kind_Of (The_Variable, In_Tree) =
1767                                                             Undefined
1768                   then
1769                      Set_Expression_Kind_Of
1770                        (The_Variable, In_Tree,
1771                         To => Expression_Kind_Of (Variable, In_Tree));
1772
1773                   else
1774                      if Expression_Kind_Of (The_Variable, In_Tree) /=
1775                        Expression_Kind_Of (Variable, In_Tree)
1776                      then
1777                         Error_Msg (Flags,
1778                                    "wrong expression kind for variable """ &
1779                                    Get_Name_String
1780                                      (Name_Of (The_Variable, In_Tree)) &
1781                                      """",
1782                                    Expression_Location);
1783                      end if;
1784                   end if;
1785                end if;
1786             end if;
1787          end;
1788       end if;
1789    end Parse_Variable_Declaration;
1790
1791 end Prj.Dect;