OSDN Git Service

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