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