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