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