?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2008-05-30 Vladimir Makarov <vmakarov@redhat.com>
[official-gcc.git] / gcc / ada / prj-strt.adb
blob862b6ff630257c7a31e453e8316072eb6e1df425
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;
Mirror of the offical gcc git repository hosted at gcc.gnu.org