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