gcc/ada/prj-strt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P R J . S T R T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2005 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.Attr;  use Prj.Attr;
  30 with Prj.Err;   use Prj.Err;
  31 with Prj.Tree;  use Prj.Tree;
  32 with Scans;     use Scans;
  33 with Snames;
  34 with Table;
  35 with Types;     use Types;
  36 with Uintp;     use Uintp;
  37
  38 package body Prj.Strt is
  39
  40    Buffer      : String_Access;
  41    Buffer_Last : Natural := 0;
  42
  43    type Choice_String is record
  44       The_String   : Name_Id;
  45       Already_Used : Boolean := False;
  46    end record;
  47    --  The string of a case label, and an indication that it has already
  48    --  been used (to avoid duplicate case labels).
  49
  50    Choices_Initial   : constant := 10;
  51    Choices_Increment : constant := 50;
  52
  53    Choice_Node_Low_Bound  : constant := 0;
  54    Choice_Node_High_Bound : constant := 099_999_999;
  55    --  In practice, infinite
  56
  57    type Choice_Node_Id is
  58      range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
  59
  60    First_Choice_Node_Id : constant Choice_Node_Id :=
  61      Choice_Node_Low_Bound;
  62
  63    package Choices is
  64       new Table.Table (Table_Component_Type => Choice_String,
  65                        Table_Index_Type     => Choice_Node_Id,
  66                        Table_Low_Bound      => First_Choice_Node_Id,
  67                        Table_Initial        => Choices_Initial,
  68                        Table_Increment      => Choices_Increment,
  69                        Table_Name           => "Prj.Strt.Choices");
  70    --  Used to store the case labels and check that there is no duplicate.
  71
  72    package Choice_Lasts is
  73       new Table.Table (Table_Component_Type => Choice_Node_Id,
  74                        Table_Index_Type     => Nat,
  75                        Table_Low_Bound      => 1,
  76                        Table_Initial        => 10,
  77                        Table_Increment      => 100,
  78                        Table_Name           => "Prj.Strt.Choice_Lasts");
  79    --  Used to store the indices of the choices in table Choices,
  80    --  to distinguish nested case constructions.
  81
  82    Choice_First : Choice_Node_Id := 0;
  83    --  Index in table Choices of the first case label of the current
  84    --  case construction. Zero means no current case construction.
  85
  86    type Name_Location is record
  87       Name     : Name_Id := No_Name;
  88       Location : Source_Ptr := No_Location;
  89    end record;
  90    --  Store the identifier and the location of a simple name
  91
  92    package Names is
  93       new Table.Table (Table_Component_Type => Name_Location,
  94                        Table_Index_Type     => Nat,
  95                        Table_Low_Bound      => 1,
  96                        Table_Initial        => 10,
  97                        Table_Increment      => 100,
  98                        Table_Name           => "Prj.Strt.Names");
  99    --  Used to accumulate the single names of a name
 100
 101    procedure Add (This_String : Name_Id);
 102    --  Add a string to the case label list, indicating that it has not
 103    --  yet been used.
 104
 105    procedure Add_To_Names (NL : Name_Location);
 106    --  Add one single names to table Names
 107
 108    procedure External_Reference
 109      (In_Tree        : Project_Node_Tree_Ref;
 110       External_Value : out Project_Node_Id);
 111    --  Parse an external reference. Current token is "external".
 112
 113    procedure Attribute_Reference
 114      (In_Tree         : Project_Node_Tree_Ref;
 115       Reference       : out Project_Node_Id;
 116       First_Attribute : Attribute_Node_Id;
 117       Current_Project : Project_Node_Id;
 118       Current_Package : Project_Node_Id);
 119    --  Parse an attribute reference. Current token is an apostrophe.
 120
 121    procedure Terms
 122      (In_Tree         : Project_Node_Tree_Ref;
 123       Term            : out Project_Node_Id;
 124       Expr_Kind       : in out Variable_Kind;
 125       Current_Project : Project_Node_Id;
 126       Current_Package : Project_Node_Id;
 127       Optional_Index  : Boolean);
 128    --  Recursive procedure to parse one term or several terms concatenated
 129    --  using "&".
 130
 131    ---------
 132    -- Add --
 133    ---------
 134
 135    procedure Add (This_String : Name_Id) is
 136    begin
 137       Choices.Increment_Last;
 138       Choices.Table (Choices.Last) :=
 139         (The_String   => This_String,
 140          Already_Used => False);
 141    end Add;
 142
 143    ------------------
 144    -- Add_To_Names --
 145    ------------------
 146
 147    procedure Add_To_Names (NL : Name_Location) is
 148    begin
 149       Names.Increment_Last;
 150       Names.Table (Names.Last) := NL;
 151    end Add_To_Names;
 152
 153    -------------------------
 154    -- Attribute_Reference --
 155    -------------------------
 156
 157    procedure Attribute_Reference
 158      (In_Tree         : Project_Node_Tree_Ref;
 159       Reference       : out Project_Node_Id;
 160       First_Attribute : Attribute_Node_Id;
 161       Current_Project : Project_Node_Id;
 162       Current_Package : Project_Node_Id)
 163    is
 164       Current_Attribute : Attribute_Node_Id := First_Attribute;
 165
 166    begin
 167       --  Declare the node of the attribute reference
 168
 169       Reference :=
 170         Default_Project_Node
 171           (Of_Kind => N_Attribute_Reference, In_Tree => In_Tree);
 172       Set_Location_Of (Reference, In_Tree, To => Token_Ptr);
 173       Scan (In_Tree); --  past apostrophe
 174
 175       --  Body may be an attribute name
 176
 177       if Token = Tok_Body then
 178          Token      := Tok_Identifier;
 179          Token_Name := Snames.Name_Body;
 180       end if;
 181
 182       Expect (Tok_Identifier, "identifier");
 183
 184       if Token = Tok_Identifier then
 185          Set_Name_Of (Reference, In_Tree, To => Token_Name);
 186
 187          --  Check if the identifier is one of the attribute identifiers in the
 188          --  context (package or project level attributes).
 189
 190          Current_Attribute :=
 191            Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute);
 192
 193          --  If the identifier is not allowed, report an error
 194
 195          if Current_Attribute = Empty_Attribute then
 196             Error_Msg_Name_1 := Token_Name;
 197             Error_Msg ("unknown attribute %", Token_Ptr);
 198             Reference := Empty_Node;
 199
 200             --  Scan past the attribute name
 201
 202             Scan (In_Tree);
 203
 204          else
 205             --  Give its characteristics to this attribute reference
 206
 207             Set_Project_Node_Of (Reference, In_Tree, To => Current_Project);
 208             Set_Package_Node_Of (Reference, In_Tree, To => Current_Package);
 209             Set_Expression_Kind_Of
 210               (Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute));
 211             Set_Case_Insensitive
 212               (Reference, In_Tree,
 213                To => Attribute_Kind_Of (Current_Attribute) =
 214                        Case_Insensitive_Associative_Array);
 215
 216             --  Scan past the attribute name
 217
 218             Scan (In_Tree);
 219
 220             --  If the attribute is an associative array, get the index
 221
 222             if Attribute_Kind_Of (Current_Attribute) /= Single then
 223                Expect (Tok_Left_Paren, "`(`");
 224
 225                if Token = Tok_Left_Paren then
 226                   Scan (In_Tree);
 227                   Expect (Tok_String_Literal, "literal string");
 228
 229                   if Token = Tok_String_Literal then
 230                      Set_Associative_Array_Index_Of
 231                        (Reference, In_Tree, To => Token_Name);
 232                      Scan (In_Tree);
 233                      Expect (Tok_Right_Paren, "`)`");
 234
 235                      if Token = Tok_Right_Paren then
 236                         Scan (In_Tree);
 237                      end if;
 238                   end if;
 239                end if;
 240             end if;
 241          end if;
 242
 243          --  Change name of obsolete attributes
 244
 245          if Reference /= Empty_Node then
 246             case Name_Of (Reference, In_Tree) is
 247                when Snames.Name_Specification =>
 248                   Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec);
 249
 250                when Snames.Name_Specification_Suffix =>
 251                   Set_Name_Of
 252                     (Reference, In_Tree, To => Snames.Name_Spec_Suffix);
 253
 254                when Snames.Name_Implementation =>
 255                   Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body);
 256
 257                when Snames.Name_Implementation_Suffix =>
 258                   Set_Name_Of
 259                     (Reference, In_Tree, To => Snames.Name_Body_Suffix);
 260
 261                when others =>
 262                   null;
 263             end case;
 264          end if;
 265       end if;
 266    end Attribute_Reference;
 267
 268    ---------------------------
 269    -- End_Case_Construction --
 270    ---------------------------
 271
 272    procedure End_Case_Construction
 273      (Check_All_Labels   : Boolean;
 274       Case_Location      : Source_Ptr)
 275    is
 276       Non_Used : Natural := 0;
 277       First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
 278    begin
 279       --  First, if Check_All_Labels is True, check if all values
 280       --  of the string type have been used.
 281
 282       if Check_All_Labels then
 283          for Choice in Choice_First .. Choices.Last loop
 284                if not Choices.Table (Choice).Already_Used then
 285                   Non_Used := Non_Used + 1;
 286
 287                   if Non_Used = 1 then
 288                      First_Non_Used := Choice;
 289                   end if;
 290                end if;
 291          end loop;
 292
 293          --  If only one is not used, report a single warning for this value
 294
 295          if Non_Used = 1 then
 296             Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
 297             Error_Msg ("?value { is not used as label", Case_Location);
 298
 299          --  If several are not used, report a warning for each one of them
 300
 301          elsif Non_Used > 1 then
 302             Error_Msg
 303               ("?the following values are not used as labels:",
 304                Case_Location);
 305
 306             for Choice in First_Non_Used .. Choices.Last loop
 307                if not Choices.Table (Choice).Already_Used then
 308                   Error_Msg_Name_1 := Choices.Table (Choice).The_String;
 309                   Error_Msg ("\?{", Case_Location);
 310                end if;
 311             end loop;
 312          end if;
 313       end if;
 314
 315       --  If this is the only case construction, empty the tables
 316
 317       if Choice_Lasts.Last = 1 then
 318          Choice_Lasts.Set_Last (0);
 319          Choices.Set_Last (First_Choice_Node_Id);
 320          Choice_First := 0;
 321
 322       elsif Choice_Lasts.Last = 2 then
 323          --  This is the second case onstruction, set the tables to the first
 324
 325          Choice_Lasts.Set_Last (1);
 326          Choices.Set_Last (Choice_Lasts.Table (1));
 327          Choice_First := 1;
 328
 329       else
 330          --  This is the 3rd or more case construction, set the tables to the
 331          --  previous one.
 332
 333          Choice_Lasts.Decrement_Last;
 334          Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
 335          Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
 336       end if;
 337    end End_Case_Construction;
 338
 339    ------------------------
 340    -- External_Reference --
 341    ------------------------
 342
 343    procedure External_Reference
 344      (In_Tree        : Project_Node_Tree_Ref;
 345       External_Value : out Project_Node_Id)
 346    is
 347       Field_Id : Project_Node_Id := Empty_Node;
 348
 349    begin
 350       External_Value :=
 351         Default_Project_Node
 352           (Of_Kind       => N_External_Value,
 353            In_Tree       => In_Tree,
 354            And_Expr_Kind => Single);
 355       Set_Location_Of (External_Value, In_Tree, To => Token_Ptr);
 356
 357       --  The current token is External
 358
 359       --  Get the left parenthesis
 360
 361       Scan (In_Tree);
 362       Expect (Tok_Left_Paren, "`(`");
 363
 364       --  Scan past the left parenthesis
 365
 366       if Token = Tok_Left_Paren then
 367          Scan (In_Tree);
 368       end if;
 369
 370       --  Get the name of the external reference
 371
 372       Expect (Tok_String_Literal, "literal string");
 373
 374       if Token = Tok_String_Literal then
 375          Field_Id :=
 376            Default_Project_Node
 377              (Of_Kind       => N_Literal_String,
 378               In_Tree       => In_Tree,
 379               And_Expr_Kind => Single);
 380          Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name);
 381          Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id);
 382
 383          --  Scan past the first argument
 384
 385          Scan (In_Tree);
 386
 387          case Token is
 388
 389             when Tok_Right_Paren =>
 390
 391                --  Scan past the right parenthesis
 392                Scan (In_Tree);
 393
 394             when Tok_Comma =>
 395
 396                --  Scan past the comma
 397
 398                Scan (In_Tree);
 399
 400                Expect (Tok_String_Literal, "literal string");
 401
 402                --  Get the default
 403
 404                if Token = Tok_String_Literal then
 405                   Field_Id :=
 406                     Default_Project_Node
 407                       (Of_Kind       => N_Literal_String,
 408                        In_Tree       => In_Tree,
 409                        And_Expr_Kind => Single);
 410                   Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name);
 411                   Set_External_Default_Of
 412                     (External_Value, In_Tree, To => Field_Id);
 413                   Scan (In_Tree);
 414                   Expect (Tok_Right_Paren, "`)`");
 415                end if;
 416
 417                --  Scan past the right parenthesis
 418                if Token = Tok_Right_Paren then
 419                   Scan (In_Tree);
 420                end if;
 421
 422             when others =>
 423                Error_Msg ("`,` or `)` expected", Token_Ptr);
 424          end case;
 425       end if;
 426    end External_Reference;
 427
 428    -----------------------
 429    -- Parse_Choice_List --
 430    -----------------------
 431
 432    procedure Parse_Choice_List
 433      (In_Tree      : Project_Node_Tree_Ref;
 434       First_Choice : out Project_Node_Id)
 435    is
 436       Current_Choice : Project_Node_Id := Empty_Node;
 437       Next_Choice    : Project_Node_Id := Empty_Node;
 438       Choice_String  : Name_Id         := No_Name;
 439       Found          : Boolean         := False;
 440
 441    begin
 442       --  Declare the node of the first choice
 443
 444       First_Choice :=
 445         Default_Project_Node
 446           (Of_Kind       => N_Literal_String,
 447            In_Tree       => In_Tree,
 448            And_Expr_Kind => Single);
 449
 450       --  Initially Current_Choice is the same as First_Choice
 451
 452       Current_Choice := First_Choice;
 453
 454       loop
 455          Expect (Tok_String_Literal, "literal string");
 456          exit when Token /= Tok_String_Literal;
 457          Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr);
 458          Choice_String := Token_Name;
 459
 460          --  Give the string value to the current choice
 461
 462          Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String);
 463
 464          --  Check if the label is part of the string type and if it has not
 465          --  been already used.
 466
 467          Found := False;
 468          for Choice in Choice_First .. Choices.Last loop
 469             if Choices.Table (Choice).The_String = Choice_String then
 470                --  This label is part of the string type
 471
 472                Found := True;
 473
 474                if Choices.Table (Choice).Already_Used then
 475                   --  But it has already appeared in a choice list for this
 476                   --  case construction; report an error.
 477
 478                   Error_Msg_Name_1 := Choice_String;
 479                   Error_Msg ("duplicate case label {", Token_Ptr);
 480                else
 481                   Choices.Table (Choice).Already_Used := True;
 482                end if;
 483
 484                exit;
 485             end if;
 486          end loop;
 487
 488          --  If the label is not part of the string list, report an error
 489
 490          if not Found then
 491             Error_Msg_Name_1 := Choice_String;
 492             Error_Msg ("illegal case label {", Token_Ptr);
 493          end if;
 494
 495          --  Scan past the label
 496
 497          Scan (In_Tree);
 498
 499          --  If there is no '|', we are done
 500
 501          if Token = Tok_Vertical_Bar then
 502             --  Otherwise, declare the node of the next choice, link it to
 503             --  Current_Choice and set Current_Choice to this new node.
 504
 505             Next_Choice :=
 506               Default_Project_Node
 507                 (Of_Kind       => N_Literal_String,
 508                  In_Tree       => In_Tree,
 509                  And_Expr_Kind => Single);
 510             Set_Next_Literal_String
 511               (Current_Choice, In_Tree, To => Next_Choice);
 512             Current_Choice := Next_Choice;
 513             Scan (In_Tree);
 514          else
 515             exit;
 516          end if;
 517       end loop;
 518    end Parse_Choice_List;
 519
 520    ----------------------
 521    -- Parse_Expression --
 522    ----------------------
 523
 524    procedure Parse_Expression
 525      (In_Tree         : Project_Node_Tree_Ref;
 526       Expression      : out Project_Node_Id;
 527       Current_Project : Project_Node_Id;
 528       Current_Package : Project_Node_Id;
 529       Optional_Index  : Boolean)
 530    is
 531       First_Term      : Project_Node_Id := Empty_Node;
 532       Expression_Kind : Variable_Kind := Undefined;
 533
 534    begin
 535       --  Declare the node of the expression
 536
 537       Expression :=
 538         Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree);
 539       Set_Location_Of (Expression, In_Tree, To => Token_Ptr);
 540
 541       --  Parse the term or terms of the expression
 542
 543       Terms (In_Tree         => In_Tree,
 544              Term            => First_Term,
 545              Expr_Kind       => Expression_Kind,
 546              Current_Project => Current_Project,
 547              Current_Package => Current_Package,
 548              Optional_Index  => Optional_Index);
 549
 550       --  Set the first term and the expression kind
 551
 552       Set_First_Term (Expression, In_Tree, To => First_Term);
 553       Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind);
 554    end Parse_Expression;
 555
 556    ----------------------------
 557    -- Parse_String_Type_List --
 558    ----------------------------
 559
 560    procedure Parse_String_Type_List
 561      (In_Tree      : Project_Node_Tree_Ref;
 562       First_String : out Project_Node_Id)
 563    is
 564       Last_String  : Project_Node_Id := Empty_Node;
 565       Next_String  : Project_Node_Id := Empty_Node;
 566       String_Value : Name_Id         := No_Name;
 567
 568    begin
 569       --  Declare the node of the first string
 570
 571       First_String :=
 572         Default_Project_Node
 573           (Of_Kind       => N_Literal_String,
 574            In_Tree       => In_Tree,
 575            And_Expr_Kind => Single);
 576
 577       --  Initially, Last_String is the same as First_String
 578
 579       Last_String := First_String;
 580
 581       loop
 582          Expect (Tok_String_Literal, "literal string");
 583          exit when Token /= Tok_String_Literal;
 584          String_Value := Token_Name;
 585
 586          --  Give its string value to Last_String
 587
 588          Set_String_Value_Of (Last_String, In_Tree, To => String_Value);
 589          Set_Location_Of (Last_String, In_Tree, To => Token_Ptr);
 590
 591          --  Now, check if the string is already part of the string type
 592
 593          declare
 594             Current : Project_Node_Id := First_String;
 595
 596          begin
 597             while Current /= Last_String loop
 598                if String_Value_Of (Current, In_Tree) = String_Value then
 599                   --  This is a repetition, report an error
 600
 601                   Error_Msg_Name_1 := String_Value;
 602                   Error_Msg ("duplicate value { in type", Token_Ptr);
 603                   exit;
 604                end if;
 605
 606                Current := Next_Literal_String (Current, In_Tree);
 607             end loop;
 608          end;
 609
 610          --  Scan past the literal string
 611
 612          Scan (In_Tree);
 613
 614          --  If there is no comma following the literal string, we are done
 615
 616          if Token /= Tok_Comma then
 617             exit;
 618
 619          else
 620             --  Declare the next string, link it to Last_String and set
 621             --  Last_String to its node.
 622
 623             Next_String :=
 624               Default_Project_Node
 625                 (Of_Kind       => N_Literal_String,
 626                  In_Tree       => In_Tree,
 627                  And_Expr_Kind => Single);
 628             Set_Next_Literal_String (Last_String, In_Tree, To => Next_String);
 629             Last_String := Next_String;
 630             Scan (In_Tree);
 631          end if;
 632       end loop;
 633    end Parse_String_Type_List;
 634
 635    ------------------------------
 636    -- Parse_Variable_Reference --
 637    ------------------------------
 638
 639    procedure Parse_Variable_Reference
 640      (In_Tree         : Project_Node_Tree_Ref;
 641       Variable        : out Project_Node_Id;
 642       Current_Project : Project_Node_Id;
 643       Current_Package : Project_Node_Id)
 644    is
 645       Current_Variable : Project_Node_Id := Empty_Node;
 646
 647       The_Package : Project_Node_Id := Current_Package;
 648       The_Project : Project_Node_Id := Current_Project;
 649
 650       Specified_Project : Project_Node_Id   := Empty_Node;
 651       Specified_Package : Project_Node_Id   := Empty_Node;
 652       Look_For_Variable : Boolean           := True;
 653       First_Attribute   : Attribute_Node_Id := Empty_Attribute;
 654       Variable_Name     : Name_Id;
 655
 656    begin
 657       Names.Init;
 658
 659       loop
 660          Expect (Tok_Identifier, "identifier");
 661
 662          if Token /= Tok_Identifier then
 663             Look_For_Variable := False;
 664             exit;
 665          end if;
 666
 667          Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr));
 668          Scan (In_Tree);
 669          exit when Token /= Tok_Dot;
 670          Scan (In_Tree);
 671       end loop;
 672
 673       if Look_For_Variable then
 674
 675          if Token = Tok_Apostrophe then
 676
 677             --  Attribute reference
 678
 679             case Names.Last is
 680                when 0 =>
 681
 682                   --  Cannot happen
 683
 684                   null;
 685
 686                when 1 =>
 687                   --  This may be a project name or a package name.
 688                   --  Project name have precedence.
 689
 690                   --  First, look if it can be a package name
 691
 692                   First_Attribute :=
 693                     First_Attribute_Of
 694                       (Package_Node_Id_Of (Names.Table (1).Name));
 695
 696                   --  Now, look if it can be a project name
 697
 698                   The_Project := Imported_Or_Extended_Project_Of
 699                     (Current_Project, In_Tree, Names.Table (1).Name);
 700
 701                   if The_Project = Empty_Node then
 702                      --  If it is neither a project name nor a package name,
 703                      --  report an error
 704
 705                      if First_Attribute = Empty_Attribute then
 706                         Error_Msg_Name_1 := Names.Table (1).Name;
 707                         Error_Msg ("unknown project %",
 708                                    Names.Table (1).Location);
 709                         First_Attribute := Attribute_First;
 710
 711                      else
 712                         --  If it is a package name, check if the package
 713                         --  has already been declared in the current project.
 714
 715                         The_Package :=
 716                           First_Package_Of (Current_Project, In_Tree);
 717
 718                         while The_Package /= Empty_Node
 719                           and then Name_Of (The_Package, In_Tree) /=
 720                           Names.Table (1).Name
 721                         loop
 722                            The_Package :=
 723                              Next_Package_In_Project (The_Package, In_Tree);
 724                         end loop;
 725
 726                         --  If it has not been already declared, report an
 727                         --  error.
 728
 729                         if The_Package = Empty_Node then
 730                            Error_Msg_Name_1 := Names.Table (1).Name;
 731                            Error_Msg ("package % not yet defined",
 732                                       Names.Table (1).Location);
 733                         end if;
 734                      end if;
 735
 736                   else
 737                      --  It is a project name
 738
 739                      First_Attribute := Attribute_First;
 740                      The_Package     := Empty_Node;
 741                   end if;
 742
 743                when others =>
 744
 745                   --  We have either a project name made of several simple
 746                   --  names (long project), or a project name (short project)
 747                   --  followed by a package name. The long project name has
 748                   --  precedence.
 749
 750                   declare
 751                      Short_Project : Name_Id;
 752                      Long_Project  : Name_Id;
 753
 754                   begin
 755                      --  Clear the Buffer
 756
 757                      Buffer_Last := 0;
 758
 759                      --  Get the name of the short project
 760
 761                      for Index in 1 .. Names.Last - 1 loop
 762                         Add_To_Buffer
 763                           (Get_Name_String (Names.Table (Index).Name),
 764                            Buffer, Buffer_Last);
 765
 766                         if Index /= Names.Last - 1 then
 767                            Add_To_Buffer (".", Buffer, Buffer_Last);
 768                         end if;
 769                      end loop;
 770
 771                      Name_Len := Buffer_Last;
 772                      Name_Buffer (1 .. Buffer_Last) :=
 773                        Buffer (1 .. Buffer_Last);
 774                      Short_Project := Name_Find;
 775
 776                      --  Now, add the last simple name to get the name of the
 777                      --  long project.
 778
 779                      Add_To_Buffer (".", Buffer, Buffer_Last);
 780                      Add_To_Buffer
 781                        (Get_Name_String (Names.Table (Names.Last).Name),
 782                         Buffer, Buffer_Last);
 783                      Name_Len := Buffer_Last;
 784                      Name_Buffer (1 .. Buffer_Last) :=
 785                        Buffer (1 .. Buffer_Last);
 786                      Long_Project := Name_Find;
 787
 788                      --  Check if the long project is imported or extended
 789
 790                      The_Project := Imported_Or_Extended_Project_Of
 791                                       (Current_Project, In_Tree, Long_Project);
 792
 793                      --  If the long project exists, then this is the prefix
 794                      --  of the attribute.
 795
 796                      if The_Project /= Empty_Node then
 797                         First_Attribute := Attribute_First;
 798                         The_Package     := Empty_Node;
 799
 800                      else
 801                         --  Otherwise, check if the short project is imported
 802                         --  or extended.
 803
 804                         The_Project := Imported_Or_Extended_Project_Of
 805                                          (Current_Project, In_Tree,
 806                                           Short_Project);
 807
 808                         --  If the short project does not exist, we report an
 809                         --  error.
 810
 811                         if The_Project = Empty_Node then
 812                            Error_Msg_Name_1 := Long_Project;
 813                            Error_Msg_Name_2 := Short_Project;
 814                            Error_Msg ("unknown projects % or %",
 815                                       Names.Table (1).Location);
 816                            The_Package := Empty_Node;
 817                            First_Attribute := Attribute_First;
 818
 819                         else
 820                            --  Now, we check if the package has been declared
 821                            --  in this project.
 822
 823                            The_Package :=
 824                              First_Package_Of (The_Project, In_Tree);
 825                            while The_Package /= Empty_Node
 826                              and then Name_Of (The_Package, In_Tree) /=
 827                              Names.Table (Names.Last).Name
 828                            loop
 829                               The_Package :=
 830                                 Next_Package_In_Project (The_Package, In_Tree);
 831                            end loop;
 832
 833                            --  If it has not, then we report an error
 834
 835                            if The_Package = Empty_Node then
 836                               Error_Msg_Name_1 :=
 837                                 Names.Table (Names.Last).Name;
 838                               Error_Msg_Name_2 := Short_Project;
 839                               Error_Msg ("package % not declared in project %",
 840                                          Names.Table (Names.Last).Location);
 841                               First_Attribute := Attribute_First;
 842
 843                            else
 844                               --  Otherwise, we have the correct project and
 845                               --  package.
 846
 847                               First_Attribute :=
 848                                 First_Attribute_Of
 849                                   (Package_Id_Of (The_Package, In_Tree));
 850                            end if;
 851                         end if;
 852                      end if;
 853                   end;
 854             end case;
 855
 856             Attribute_Reference
 857               (In_Tree,
 858                Variable,
 859                Current_Project => The_Project,
 860                Current_Package => The_Package,
 861                First_Attribute => First_Attribute);
 862             return;
 863          end if;
 864       end if;
 865
 866       Variable :=
 867         Default_Project_Node
 868           (Of_Kind => N_Variable_Reference, In_Tree => In_Tree);
 869
 870       if Look_For_Variable then
 871          case Names.Last is
 872             when 0 =>
 873
 874                --  Cannot happen
 875
 876                null;
 877
 878             when 1 =>
 879
 880                --  Simple variable name
 881
 882                Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name);
 883
 884             when 2 =>
 885
 886                --  Variable name with a simple name prefix that can be
 887                --  a project name or a package name. Project names have
 888                --  priority over package names.
 889
 890                Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name);
 891
 892                --  Check if it can be a package name
 893
 894                The_Package := First_Package_Of (Current_Project, In_Tree);
 895
 896                while The_Package /= Empty_Node
 897                  and then Name_Of (The_Package, In_Tree) /=
 898                             Names.Table (1).Name
 899                loop
 900                   The_Package :=
 901                     Next_Package_In_Project (The_Package, In_Tree);
 902                end loop;
 903
 904                --  Now look for a possible project name
 905
 906                The_Project := Imported_Or_Extended_Project_Of
 907                               (Current_Project, In_Tree, Names.Table (1).Name);
 908
 909                if The_Project /= Empty_Node then
 910                   Specified_Project := The_Project;
 911
 912                elsif The_Package = Empty_Node then
 913                   Error_Msg_Name_1 := Names.Table (1).Name;
 914                   Error_Msg ("unknown package or project %",
 915                              Names.Table (1).Location);
 916                   Look_For_Variable := False;
 917
 918                else
 919                   Specified_Package := The_Package;
 920                end if;
 921
 922             when others =>
 923
 924                --  Variable name with a prefix that is either a project name
 925                --  made of several simple names, or a project name followed
 926                --  by a package name.
 927
 928                Set_Name_Of
 929                  (Variable, In_Tree, To => Names.Table (Names.Last).Name);
 930
 931                declare
 932                   Short_Project : Name_Id;
 933                   Long_Project  : Name_Id;
 934
 935                begin
 936                   --  First, we get the two possible project names
 937
 938                   --  Clear the buffer
 939
 940                   Buffer_Last := 0;
 941
 942                   --  Add all the simple names, except the last two
 943
 944                   for Index in 1 .. Names.Last - 2 loop
 945                      Add_To_Buffer
 946                        (Get_Name_String (Names.Table (Index).Name),
 947                         Buffer, Buffer_Last);
 948
 949                      if Index /= Names.Last - 2 then
 950                         Add_To_Buffer (".", Buffer, Buffer_Last);
 951                      end if;
 952                   end loop;
 953
 954                   Name_Len := Buffer_Last;
 955                   Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
 956                   Short_Project := Name_Find;
 957
 958                   --  Add the simple name before the name of the variable
 959
 960                   Add_To_Buffer (".", Buffer, Buffer_Last);
 961                   Add_To_Buffer
 962                     (Get_Name_String (Names.Table (Names.Last - 1).Name),
 963                      Buffer, Buffer_Last);
 964                   Name_Len := Buffer_Last;
 965                   Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
 966                   Long_Project := Name_Find;
 967
 968                   --  Check if the prefix is the name of an imported or
 969                   --  extended project.
 970
 971                   The_Project := Imported_Or_Extended_Project_Of
 972                                    (Current_Project, In_Tree, Long_Project);
 973
 974                   if The_Project /= Empty_Node then
 975                      Specified_Project := The_Project;
 976
 977                   else
 978                      --  Now check if the prefix may be a project name followed
 979                      --  by a package name.
 980
 981                      --  First check for a possible project name
 982
 983                      The_Project := Imported_Or_Extended_Project_Of
 984                                    (Current_Project, In_Tree, Short_Project);
 985
 986                      if The_Project = Empty_Node then
 987                         --  Unknown prefix, report an error
 988
 989                         Error_Msg_Name_1 := Long_Project;
 990                         Error_Msg_Name_2 := Short_Project;
 991                         Error_Msg ("unknown projects % or %",
 992                                    Names.Table (1).Location);
 993                         Look_For_Variable := False;
 994
 995                      else
 996                         Specified_Project := The_Project;
 997
 998                         --  Now look for the package in this project
 999
1000                         The_Package := First_Package_Of (The_Project, In_Tree);
1001
1002                         while The_Package /= Empty_Node
1003                           and then Name_Of (The_Package, In_Tree) /=
1004                                               Names.Table (Names.Last - 1).Name
1005                         loop
1006                            The_Package :=
1007                              Next_Package_In_Project (The_Package, In_Tree);
1008                         end loop;
1009
1010                         if The_Package = Empty_Node then
1011                            --  The package does not vexist, report an error
1012
1013                            Error_Msg_Name_1 := Names.Table (2).Name;
1014                            Error_Msg ("unknown package %",
1015                                    Names.Table (Names.Last - 1).Location);
1016                            Look_For_Variable := False;
1017
1018                         else
1019                            Specified_Package := The_Package;
1020                         end if;
1021                      end if;
1022                   end if;
1023                end;
1024          end case;
1025       end if;
1026
1027       if Look_For_Variable then
1028          Variable_Name := Name_Of (Variable, In_Tree);
1029          Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project);
1030          Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package);
1031
1032          if Specified_Project /= Empty_Node then
1033             The_Project := Specified_Project;
1034
1035          else
1036             The_Project := Current_Project;
1037          end if;
1038
1039          Current_Variable := Empty_Node;
1040
1041          --  Look for this variable
1042
1043          --  If a package was specified, check if the variable has been
1044          --  declared in this package.
1045
1046          if Specified_Package /= Empty_Node then
1047             Current_Variable :=
1048               First_Variable_Of (Specified_Package, In_Tree);
1049
1050             while Current_Variable /= Empty_Node
1051               and then
1052               Name_Of (Current_Variable, In_Tree) /= Variable_Name
1053             loop
1054                Current_Variable := Next_Variable (Current_Variable, In_Tree);
1055             end loop;
1056
1057          else
1058             --  Otherwise, if no project has been specified and we are in
1059             --  a package, first check if the variable has been declared in
1060             --  the package.
1061
1062             if Specified_Project = Empty_Node
1063               and then Current_Package /= Empty_Node
1064             then
1065                Current_Variable :=
1066                  First_Variable_Of (Current_Package, In_Tree);
1067
1068                while Current_Variable /= Empty_Node
1069                  and then Name_Of (Current_Variable, In_Tree) /= Variable_Name
1070                loop
1071                   Current_Variable :=
1072                     Next_Variable (Current_Variable, In_Tree);
1073                end loop;
1074             end if;
1075
1076             --  If we have not found the variable in the package, check if the
1077             --  variable has been declared in the project.
1078
1079             if Current_Variable = Empty_Node then
1080                Current_Variable := First_Variable_Of (The_Project, In_Tree);
1081
1082                while Current_Variable /= Empty_Node
1083                  and then Name_Of (Current_Variable, In_Tree) /= Variable_Name
1084                loop
1085                   Current_Variable :=
1086                     Next_Variable (Current_Variable, In_Tree);
1087                end loop;
1088             end if;
1089          end if;
1090
1091          --  If the variable was not found, report an error
1092
1093          if Current_Variable = Empty_Node then
1094             Error_Msg_Name_1 := Variable_Name;
1095             Error_Msg
1096               ("unknown variable %", Names.Table (Names.Last).Location);
1097          end if;
1098       end if;
1099
1100       if Current_Variable /= Empty_Node then
1101          Set_Expression_Kind_Of
1102            (Variable, In_Tree,
1103             To => Expression_Kind_Of (Current_Variable, In_Tree));
1104
1105          if
1106            Kind_Of (Current_Variable, In_Tree) = N_Typed_Variable_Declaration
1107          then
1108             Set_String_Type_Of
1109               (Variable, In_Tree,
1110                To => String_Type_Of (Current_Variable, In_Tree));
1111          end if;
1112       end if;
1113
1114       --  If the variable is followed by a left parenthesis, report an error
1115       --  but attempt to scan the index.
1116
1117       if Token = Tok_Left_Paren then
1118          Error_Msg ("\variables cannot be associative arrays", Token_Ptr);
1119          Scan (In_Tree);
1120          Expect (Tok_String_Literal, "literal string");
1121
1122          if Token = Tok_String_Literal then
1123             Scan (In_Tree);
1124             Expect (Tok_Right_Paren, "`)`");
1125
1126             if Token = Tok_Right_Paren then
1127                Scan (In_Tree);
1128             end if;
1129          end if;
1130       end if;
1131    end Parse_Variable_Reference;
1132
1133    ---------------------------------
1134    -- Start_New_Case_Construction --
1135    ---------------------------------
1136
1137    procedure Start_New_Case_Construction
1138      (In_Tree      : Project_Node_Tree_Ref;
1139       String_Type  : Project_Node_Id)
1140    is
1141       Current_String : Project_Node_Id;
1142
1143    begin
1144       --  Set Choice_First, depending on whether is the first case
1145       --  construction or not.
1146
1147       if Choice_First = 0 then
1148          Choice_First := 1;
1149          Choices.Set_Last (First_Choice_Node_Id);
1150       else
1151          Choice_First := Choices.Last + 1;
1152       end if;
1153
1154       --  Add to table Choices the literal of the string type
1155
1156       if String_Type /= Empty_Node then
1157          Current_String := First_Literal_String (String_Type, In_Tree);
1158
1159          while Current_String /= Empty_Node loop
1160             Add (This_String => String_Value_Of (Current_String, In_Tree));
1161             Current_String := Next_Literal_String (Current_String, In_Tree);
1162          end loop;
1163       end if;
1164
1165       --  Set the value of the last choice in table Choice_Lasts
1166
1167       Choice_Lasts.Increment_Last;
1168       Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
1169
1170    end Start_New_Case_Construction;
1171
1172    -----------
1173    -- Terms --
1174    -----------
1175
1176    procedure Terms
1177      (In_Tree         : Project_Node_Tree_Ref;
1178       Term            : out Project_Node_Id;
1179       Expr_Kind       : in out Variable_Kind;
1180       Current_Project : Project_Node_Id;
1181       Current_Package : Project_Node_Id;
1182       Optional_Index  : Boolean)
1183    is
1184       Next_Term          : Project_Node_Id := Empty_Node;
1185       Term_Id            : Project_Node_Id := Empty_Node;
1186       Current_Expression : Project_Node_Id := Empty_Node;
1187       Next_Expression    : Project_Node_Id := Empty_Node;
1188       Current_Location   : Source_Ptr      := No_Location;
1189       Reference          : Project_Node_Id := Empty_Node;
1190
1191    begin
1192       --  Declare a new node for the term
1193
1194       Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree);
1195       Set_Location_Of (Term, In_Tree, To => Token_Ptr);
1196
1197       case Token is
1198          when Tok_Left_Paren =>
1199
1200             --  If we have a left parenthesis and we don't know the expression
1201             --  kind, then this is a string list.
1202
1203             case Expr_Kind is
1204                when Undefined =>
1205                   Expr_Kind := List;
1206
1207                when List =>
1208                   null;
1209
1210                when Single =>
1211
1212                   --  If we already know that this is a single string, report
1213                   --  an error, but set the expression kind to string list to
1214                   --  avoid several errors.
1215
1216                   Expr_Kind := List;
1217                   Error_Msg
1218                     ("literal string list cannot appear in a string",
1219                      Token_Ptr);
1220             end case;
1221
1222             --  Declare a new node for this literal string list
1223
1224             Term_Id := Default_Project_Node
1225               (Of_Kind       => N_Literal_String_List,
1226                In_Tree       => In_Tree,
1227                And_Expr_Kind => List);
1228             Set_Current_Term (Term, In_Tree, To => Term_Id);
1229             Set_Location_Of  (Term, In_Tree, To => Token_Ptr);
1230
1231             --  Scan past the left parenthesis
1232
1233             Scan (In_Tree);
1234
1235             --  If the left parenthesis is immediately followed by a right
1236             --  parenthesis, the literal string list is empty.
1237
1238             if Token = Tok_Right_Paren then
1239                Scan (In_Tree);
1240
1241             else
1242                --  Otherwise, we parse the expression(s) in the literal string
1243                --  list.
1244
1245                loop
1246                   Current_Location := Token_Ptr;
1247                   Parse_Expression
1248                     (In_Tree         => In_Tree,
1249                      Expression      => Next_Expression,
1250                      Current_Project => Current_Project,
1251                      Current_Package => Current_Package,
1252                      Optional_Index  => Optional_Index);
1253
1254                   --  The expression kind is String list, report an error
1255
1256                   if Expression_Kind_Of (Next_Expression, In_Tree) = List then
1257                      Error_Msg ("single expression expected",
1258                                 Current_Location);
1259                   end if;
1260
1261                   --  If Current_Expression is empty, it means that the
1262                   --  expression is the first in the string list.
1263
1264                   if Current_Expression = Empty_Node then
1265                      Set_First_Expression_In_List
1266                        (Term_Id, In_Tree, To => Next_Expression);
1267                   else
1268                      Set_Next_Expression_In_List
1269                        (Current_Expression, In_Tree, To => Next_Expression);
1270                   end if;
1271
1272                   Current_Expression := Next_Expression;
1273
1274                   --  If there is a comma, continue with the next expression
1275
1276                   exit when Token /= Tok_Comma;
1277                   Scan (In_Tree); -- past the comma
1278                end loop;
1279
1280                --  We expect a closing right parenthesis
1281
1282                Expect (Tok_Right_Paren, "`)`");
1283
1284                if Token = Tok_Right_Paren then
1285                   Scan (In_Tree);
1286                end if;
1287             end if;
1288
1289          when Tok_String_Literal =>
1290
1291             --  If we don't know the expression kind (first term), then it is
1292             --  a simple string.
1293
1294             if Expr_Kind = Undefined then
1295                Expr_Kind := Single;
1296             end if;
1297
1298             --  Declare a new node for the string literal
1299
1300             Term_Id :=
1301               Default_Project_Node
1302                 (Of_Kind => N_Literal_String, In_Tree => In_Tree);
1303             Set_Current_Term (Term, In_Tree, To => Term_Id);
1304             Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name);
1305
1306             --  Scan past the string literal
1307
1308             Scan (In_Tree);
1309
1310             --  Check for possible index expression
1311
1312             if Token = Tok_At then
1313                if not Optional_Index then
1314                   Error_Msg ("index not allowed here", Token_Ptr);
1315                   Scan (In_Tree);
1316
1317                   if Token = Tok_Integer_Literal then
1318                      Scan (In_Tree);
1319                   end if;
1320
1321                --  Set the index value
1322
1323                else
1324                   Scan (In_Tree);
1325                   Expect (Tok_Integer_Literal, "integer literal");
1326
1327                   if Token = Tok_Integer_Literal then
1328                      declare
1329                         Index : constant Int := UI_To_Int (Int_Literal_Value);
1330                      begin
1331                         if Index = 0 then
1332                            Error_Msg ("index cannot be zero", Token_Ptr);
1333                         else
1334                            Set_Source_Index_Of
1335                              (Term_Id, In_Tree, To => Index);
1336                         end if;
1337                      end;
1338
1339                      Scan (In_Tree);
1340                   end if;
1341                end if;
1342             end if;
1343
1344          when Tok_Identifier =>
1345             Current_Location := Token_Ptr;
1346
1347             --  Get the variable or attribute reference
1348
1349             Parse_Variable_Reference
1350               (In_Tree         => In_Tree,
1351                Variable        => Reference,
1352                Current_Project => Current_Project,
1353                Current_Package => Current_Package);
1354             Set_Current_Term (Term, In_Tree, To => Reference);
1355
1356             if Reference /= Empty_Node then
1357
1358                --  If we don't know the expression kind (first term), then it
1359                --  has the kind of the variable or attribute reference.
1360
1361                if Expr_Kind = Undefined then
1362                   Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
1363
1364                elsif Expr_Kind = Single
1365                  and then Expression_Kind_Of (Reference, In_Tree) = List
1366                then
1367                   --  If the expression is a single list, and the reference is
1368                   --  a string list, report an error, and set the expression
1369                   --  kind to string list to avoid multiple errors.
1370
1371                   Expr_Kind := List;
1372                   Error_Msg
1373                     ("list variable cannot appear in single string expression",
1374                      Current_Location);
1375                end if;
1376             end if;
1377
1378          when Tok_Project =>
1379
1380             --  project can appear in an expression as the prefix of an
1381             --  attribute reference of the current project.
1382
1383             Current_Location := Token_Ptr;
1384             Scan (In_Tree);
1385             Expect (Tok_Apostrophe, "`'`");
1386
1387             if Token = Tok_Apostrophe then
1388                Attribute_Reference
1389                  (In_Tree         => In_Tree,
1390                   Reference       => Reference,
1391                   First_Attribute => Prj.Attr.Attribute_First,
1392                   Current_Project => Current_Project,
1393                   Current_Package => Empty_Node);
1394                Set_Current_Term (Term, In_Tree, To => Reference);
1395             end if;
1396
1397             --  Same checks as above for the expression kind
1398
1399             if Reference /= Empty_Node then
1400                if Expr_Kind = Undefined then
1401                   Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
1402
1403                elsif Expr_Kind = Single
1404                  and then Expression_Kind_Of (Reference, In_Tree) = List
1405                then
1406                   Error_Msg
1407                     ("lists cannot appear in single string expression",
1408                      Current_Location);
1409                end if;
1410             end if;
1411
1412          when Tok_External =>
1413             --  An external reference is always a single string
1414
1415             if Expr_Kind = Undefined then
1416                Expr_Kind := Single;
1417             end if;
1418
1419             External_Reference
1420               (In_Tree => In_Tree, External_Value => Reference);
1421             Set_Current_Term (Term, In_Tree, To => Reference);
1422
1423          when others =>
1424             Error_Msg ("cannot be part of an expression", Token_Ptr);
1425             Term := Empty_Node;
1426             return;
1427       end case;
1428
1429       --  If there is an '&', call Terms recursively
1430
1431       if Token = Tok_Ampersand then
1432
1433          --  Scan past the '&'
1434
1435          Scan (In_Tree);
1436
1437          Terms
1438            (In_Tree         => In_Tree,
1439             Term            => Next_Term,
1440             Expr_Kind       => Expr_Kind,
1441             Current_Project => Current_Project,
1442             Current_Package => Current_Package,
1443             Optional_Index  => Optional_Index);
1444
1445          --  And link the next term to this term
1446
1447          Set_Next_Term (Term, In_Tree, To => Next_Term);
1448       end if;
1449    end Terms;
1450
1451 end Prj.Strt;