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