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