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