?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merged with mainline at revision 128810.
[official-gcc.git] / gcc / ada / prj-dect.adb
blob6a31f569787812808c7ba1672df2b066c64502ae
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . D E C T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2007, 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
28 with GNAT.Case_Util; use GNAT.Case_Util;
29
30 with Opt; use Opt;
31 with Prj.Attr; use Prj.Attr;
32 with Prj.Attr.PM; use Prj.Attr.PM;
33 with Prj.Err; use Prj.Err;
34 with Prj.Strt; use Prj.Strt;
35 with Prj.Tree; use Prj.Tree;
36 with Snames;
37 with Uintp; use Uintp;
38
39 package body Prj.Dect is
40
41 type Zone is (In_Project, In_Package, In_Case_Construction);
42 -- Used to indicate if we are parsing a package (In_Package),
43 -- a case construction (In_Case_Construction) or none of those two
44 -- (In_Project).
45
46 procedure Parse_Attribute_Declaration
47 (In_Tree : Project_Node_Tree_Ref;
48 Attribute : out Project_Node_Id;
49 First_Attribute : Attribute_Node_Id;
50 Current_Project : Project_Node_Id;
51 Current_Package : Project_Node_Id;
52 Packages_To_Check : String_List_Access);
53 -- Parse an attribute declaration
54
55 procedure Parse_Case_Construction
56 (In_Tree : Project_Node_Tree_Ref;
57 Case_Construction : out Project_Node_Id;
58 First_Attribute : Attribute_Node_Id;
59 Current_Project : Project_Node_Id;
60 Current_Package : Project_Node_Id;
61 Packages_To_Check : String_List_Access);
62 -- Parse a case construction
63
64 procedure Parse_Declarative_Items
65 (In_Tree : Project_Node_Tree_Ref;
66 Declarations : out Project_Node_Id;
67 In_Zone : Zone;
68 First_Attribute : Attribute_Node_Id;
69 Current_Project : Project_Node_Id;
70 Current_Package : Project_Node_Id;
71 Packages_To_Check : String_List_Access);
72 -- Parse declarative items. Depending on In_Zone, some declarative
73 -- items may be forbiden.
74
75 procedure Parse_Package_Declaration
76 (In_Tree : Project_Node_Tree_Ref;
77 Package_Declaration : out Project_Node_Id;
78 Current_Project : Project_Node_Id;
79 Packages_To_Check : String_List_Access);
80 -- Parse a package declaration
81
82 procedure Parse_String_Type_Declaration
83 (In_Tree : Project_Node_Tree_Ref;
84 String_Type : out Project_Node_Id;
85 Current_Project : Project_Node_Id);
86 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
87
88 procedure Parse_Variable_Declaration
89 (In_Tree : Project_Node_Tree_Ref;
90 Variable : out Project_Node_Id;
91 Current_Project : Project_Node_Id;
92 Current_Package : Project_Node_Id);
93 -- Parse a variable assignment
94 -- <variable_Name> := <expression>; OR
95 -- <variable_Name> : <string_type_Name> := <string_expression>;
96
97 -----------
98 -- Parse --
99 -----------
100
101 procedure Parse
102 (In_Tree : Project_Node_Tree_Ref;
103 Declarations : out Project_Node_Id;
104 Current_Project : Project_Node_Id;
105 Extends : Project_Node_Id;
106 Packages_To_Check : String_List_Access)
107 is
108 First_Declarative_Item : Project_Node_Id := Empty_Node;
109
110 begin
111 Declarations :=
112 Default_Project_Node
113 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
114 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
115 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
116 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
117 Parse_Declarative_Items
118 (Declarations => First_Declarative_Item,
119 In_Tree => In_Tree,
120 In_Zone => In_Project,
121 First_Attribute => Prj.Attr.Attribute_First,
122 Current_Project => Current_Project,
123 Current_Package => Empty_Node,
124 Packages_To_Check => Packages_To_Check);
125 Set_First_Declarative_Item_Of
126 (Declarations, In_Tree, To => First_Declarative_Item);
127 end Parse;
128
129 ---------------------------------
130 -- Parse_Attribute_Declaration --
131 ---------------------------------
132
133 procedure Parse_Attribute_Declaration
134 (In_Tree : Project_Node_Tree_Ref;
135 Attribute : out Project_Node_Id;
136 First_Attribute : Attribute_Node_Id;
137 Current_Project : Project_Node_Id;
138 Current_Package : Project_Node_Id;
139 Packages_To_Check : String_List_Access)
140 is
141 Current_Attribute : Attribute_Node_Id := First_Attribute;
142 Full_Associative_Array : Boolean := False;
143 Attribute_Name : Name_Id := No_Name;
144 Optional_Index : Boolean := False;
145 Pkg_Id : Package_Node_Id := Empty_Package;
146 Ignore : Boolean := False;
147
148 begin
149 Attribute :=
150 Default_Project_Node
151 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
152 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
153 Set_Previous_Line_Node (Attribute);
154
155 -- Scan past "for"
156
157 Scan (In_Tree);
158
159 -- Body may be an attribute name
160
161 if Token = Tok_Body then
162 Token := Tok_Identifier;
163 Token_Name := Snames.Name_Body;
164 end if;
165
166 Expect (Tok_Identifier, "identifier");
167
168 if Token = Tok_Identifier then
169 Attribute_Name := Token_Name;
170 Set_Name_Of (Attribute, In_Tree, To => Token_Name);
171 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
172
173 -- Find the attribute
174
175 Current_Attribute :=
176 Attribute_Node_Id_Of (Token_Name, First_Attribute);
177
178 -- If the attribute cannot be found, create the attribute if inside
179 -- an unknown package.
180
181 if Current_Attribute = Empty_Attribute then
182 if Current_Package /= Empty_Node
183 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
184 then
185 Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
186 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
187
188 else
189 -- If not a valid attribute name, issue an error if inside
190 -- a package that need to be checked.
191
192 Ignore := Current_Package /= Empty_Node and then
193 Packages_To_Check /= All_Packages;
194
195 if Ignore then
196
197 -- Check that we are not in a package to check
198
199 Get_Name_String (Name_Of (Current_Package, In_Tree));
200
201 for Index in Packages_To_Check'Range loop
202 if Name_Buffer (1 .. Name_Len) =
203 Packages_To_Check (Index).all
204 then
205 Ignore := False;
206 exit;
207 end if;
208 end loop;
209 end if;
210
211 if not Ignore then
212 Error_Msg_Name_1 := Token_Name;
213 Error_Msg ("undefined attribute %%", Token_Ptr);
214 end if;
215 end if;
216
217 -- Set, if appropriate the index case insensitivity flag
218
219 else
220 if Is_Read_Only (Current_Attribute) then
221 Error_Msg
222 ("read-only attribute cannot be given a value",
223 Token_Ptr);
224 end if;
225
226 if Attribute_Kind_Of (Current_Attribute) in
227 Case_Insensitive_Associative_Array ..
228 Optional_Index_Case_Insensitive_Associative_Array
229 then
230 Set_Case_Insensitive (Attribute, In_Tree, To => True);
231 end if;
232 end if;
233
234 Scan (In_Tree); -- past the attribute name
235 end if;
236
237 -- Change obsolete names of attributes to the new names
238
239 if Current_Package /= Empty_Node
240 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
241 then
242 case Name_Of (Attribute, In_Tree) is
243 when Snames.Name_Specification =>
244 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
245
246 when Snames.Name_Specification_Suffix =>
247 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
248
249 when Snames.Name_Implementation =>
250 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
251
252 when Snames.Name_Implementation_Suffix =>
253 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
254
255 when others =>
256 null;
257 end case;
258 end if;
259
260 -- Associative array attributes
261
262 if Token = Tok_Left_Paren then
263
264 -- If the attribute is not an associative array attribute, report
265 -- an error. If this information is still unknown, set the kind
266 -- to Associative_Array.
267
268 if Current_Attribute /= Empty_Attribute
269 and then Attribute_Kind_Of (Current_Attribute) = Single
270 then
271 Error_Msg ("the attribute """ &
272 Get_Name_String
273 (Attribute_Name_Of (Current_Attribute)) &
274 """ cannot be an associative array",
275 Location_Of (Attribute, In_Tree));
276
277 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
278 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
279 end if;
280
281 Scan (In_Tree); -- past the left parenthesis
282 Expect (Tok_String_Literal, "literal string");
283
284 if Token = Tok_String_Literal then
285 Get_Name_String (Token_Name);
286
287 if Case_Insensitive (Attribute, In_Tree) then
288 To_Lower (Name_Buffer (1 .. Name_Len));
289 end if;
290
291 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
292 Scan (In_Tree); -- past the literal string index
293
294 if Token = Tok_At then
295 case Attribute_Kind_Of (Current_Attribute) is
296 when Optional_Index_Associative_Array |
297 Optional_Index_Case_Insensitive_Associative_Array =>
298 Scan (In_Tree);
299 Expect (Tok_Integer_Literal, "integer literal");
300
301 if Token = Tok_Integer_Literal then
302
303 -- Set the source index value from given literal
304
305 declare
306 Index : constant Int :=
307 UI_To_Int (Int_Literal_Value);
308 begin
309 if Index = 0 then
310 Error_Msg ("index cannot be zero", Token_Ptr);
311 else
312 Set_Source_Index_Of
313 (Attribute, In_Tree, To => Index);
314 end if;
315 end;
316
317 Scan (In_Tree);
318 end if;
319
320 when others =>
321 Error_Msg ("index not allowed here", Token_Ptr);
322 Scan (In_Tree);
323
324 if Token = Tok_Integer_Literal then
325 Scan (In_Tree);
326 end if;
327 end case;
328 end if;
329 end if;
330
331 Expect (Tok_Right_Paren, "`)`");
332
333 if Token = Tok_Right_Paren then
334 Scan (In_Tree); -- past the right parenthesis
335 end if;
336
337 else
338 -- If it is an associative array attribute and there are no left
339 -- parenthesis, then this is a full associative array declaration.
340 -- Flag it as such for later processing of its value.
341
342 if Current_Attribute /= Empty_Attribute
343 and then
344 Attribute_Kind_Of (Current_Attribute) /= Single
345 then
346 if Attribute_Kind_Of (Current_Attribute) = Unknown then
347 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
348
349 else
350 Full_Associative_Array := True;
351 end if;
352 end if;
353 end if;
354
355 -- Set the expression kind of the attribute
356
357 if Current_Attribute /= Empty_Attribute then
358 Set_Expression_Kind_Of
359 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
360 Optional_Index := Optional_Index_Of (Current_Attribute);
361 end if;
362
363 Expect (Tok_Use, "USE");
364
365 if Token = Tok_Use then
366 Scan (In_Tree);
367
368 if Full_Associative_Array then
369
370 -- Expect <project>'<same_attribute_name>, or
371 -- <project>.<same_package_name>'<same_attribute_name>
372
373 declare
374 The_Project : Project_Node_Id := Empty_Node;
375 -- The node of the project where the associative array is
376 -- declared.
377
378 The_Package : Project_Node_Id := Empty_Node;
379 -- The node of the package where the associative array is
380 -- declared, if any.
381
382 Project_Name : Name_Id := No_Name;
383 -- The name of the project where the associative array is
384 -- declared.
385
386 Location : Source_Ptr := No_Location;
387 -- The location of the project name
388
389 begin
390 Expect (Tok_Identifier, "identifier");
391
392 if Token = Tok_Identifier then
393 Location := Token_Ptr;
394
395 -- Find the project node in the imported project or
396 -- in the project being extended.
397
398 The_Project := Imported_Or_Extended_Project_Of
399 (Current_Project, In_Tree, Token_Name);
400
401 if The_Project = Empty_Node then
402 Error_Msg ("unknown project", Location);
403 Scan (In_Tree); -- past the project name
404
405 else
406 Project_Name := Token_Name;
407 Scan (In_Tree); -- past the project name
408
409 -- If this is inside a package, a dot followed by the
410 -- name of the package must followed the project name.
411
412 if Current_Package /= Empty_Node then
413 Expect (Tok_Dot, "`.`");
414
415 if Token /= Tok_Dot then
416 The_Project := Empty_Node;
417
418 else
419 Scan (In_Tree); -- past the dot
420 Expect (Tok_Identifier, "identifier");
421
422 if Token /= Tok_Identifier then
423 The_Project := Empty_Node;
424
425 -- If it is not the same package name, issue error
426
427 elsif
428 Token_Name /= Name_Of (Current_Package, In_Tree)
429 then
430 The_Project := Empty_Node;
431 Error_Msg
432 ("not the same package as " &
433 Get_Name_String
434 (Name_Of (Current_Package, In_Tree)),
435 Token_Ptr);
436
437 else
438 The_Package :=
439 First_Package_Of (The_Project, In_Tree);
440
441 -- Look for the package node
442
443 while The_Package /= Empty_Node
444 and then
445 Name_Of (The_Package, In_Tree) /= Token_Name
446 loop
447 The_Package :=
448 Next_Package_In_Project
449 (The_Package, In_Tree);
450 end loop;
451
452 -- If the package cannot be found in the
453 -- project, issue an error.
454
455 if The_Package = Empty_Node then
456 The_Project := Empty_Node;
457 Error_Msg_Name_2 := Project_Name;
458 Error_Msg_Name_1 := Token_Name;
459 Error_Msg
460 ("package % not declared in project %",
461 Token_Ptr);
462 end if;
463
464 Scan (In_Tree); -- past the package name
465 end if;
466 end if;
467 end if;
468 end if;
469 end if;
470
471 if The_Project /= Empty_Node then
472
473 -- Looking for '<same attribute name>
474
475 Expect (Tok_Apostrophe, "`''`");
476
477 if Token /= Tok_Apostrophe then
478 The_Project := Empty_Node;
479
480 else
481 Scan (In_Tree); -- past the apostrophe
482 Expect (Tok_Identifier, "identifier");
483
484 if Token /= Tok_Identifier then
485 The_Project := Empty_Node;
486
487 else
488 -- If it is not the same attribute name, issue error
489
490 if Token_Name /= Attribute_Name then
491 The_Project := Empty_Node;
492 Error_Msg_Name_1 := Attribute_Name;
493 Error_Msg ("invalid name, should be %", Token_Ptr);
494 end if;
495
496 Scan (In_Tree); -- past the attribute name
497 end if;
498 end if;
499 end if;
500
501 if The_Project = Empty_Node then
502
503 -- If there were any problem, set the attribute id to null,
504 -- so that the node will not be recorded.
505
506 Current_Attribute := Empty_Attribute;
507
508 else
509 -- Set the appropriate field in the node.
510 -- Note that the index and the expression are nil. This
511 -- characterizes full associative array attribute
512 -- declarations.
513
514 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
515 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
516 end if;
517 end;
518
519 -- Other attribute declarations (not full associative array)
520
521 else
522 declare
523 Expression_Location : constant Source_Ptr := Token_Ptr;
524 -- The location of the first token of the expression
525
526 Expression : Project_Node_Id := Empty_Node;
527 -- The expression, value for the attribute declaration
528
529 begin
530 -- Get the expression value and set it in the attribute node
531
532 Parse_Expression
533 (In_Tree => In_Tree,
534 Expression => Expression,
535 Current_Project => Current_Project,
536 Current_Package => Current_Package,
537 Optional_Index => Optional_Index);
538 Set_Expression_Of (Attribute, In_Tree, To => Expression);
539
540 -- If the expression is legal, but not of the right kind
541 -- for the attribute, issue an error.
542
543 if Current_Attribute /= Empty_Attribute
544 and then Expression /= Empty_Node
545 and then Variable_Kind_Of (Current_Attribute) /=
546 Expression_Kind_Of (Expression, In_Tree)
547 then
548 if Variable_Kind_Of (Current_Attribute) = Undefined then
549 Set_Variable_Kind_Of
550 (Current_Attribute,
551 To => Expression_Kind_Of (Expression, In_Tree));
552
553 else
554 Error_Msg
555 ("wrong expression kind for attribute """ &
556 Get_Name_String
557 (Attribute_Name_Of (Current_Attribute)) &
558 """",
559 Expression_Location);
560 end if;
561 end if;
562 end;
563 end if;
564 end if;
565
566 -- If the attribute was not recognized, return an empty node.
567 -- It may be that it is not in a package to check, and the node will
568 -- not be added to the tree.
569
570 if Current_Attribute = Empty_Attribute then
571 Attribute := Empty_Node;
572 end if;
573
574 Set_End_Of_Line (Attribute);
575 Set_Previous_Line_Node (Attribute);
576 end Parse_Attribute_Declaration;
577
578 -----------------------------
579 -- Parse_Case_Construction --
580 -----------------------------
581
582 procedure Parse_Case_Construction
583 (In_Tree : Project_Node_Tree_Ref;
584 Case_Construction : out Project_Node_Id;
585 First_Attribute : Attribute_Node_Id;
586 Current_Project : Project_Node_Id;
587 Current_Package : Project_Node_Id;
588 Packages_To_Check : String_List_Access)
589 is
590 Current_Item : Project_Node_Id := Empty_Node;
591 Next_Item : Project_Node_Id := Empty_Node;
592 First_Case_Item : Boolean := True;
593
594 Variable_Location : Source_Ptr := No_Location;
595
596 String_Type : Project_Node_Id := Empty_Node;
597
598 Case_Variable : Project_Node_Id := Empty_Node;
599
600 First_Declarative_Item : Project_Node_Id := Empty_Node;
601
602 First_Choice : Project_Node_Id := Empty_Node;
603
604 When_Others : Boolean := False;
605 -- Set to True when there is a "when others =>" clause
606
607 begin
608 Case_Construction :=
609 Default_Project_Node
610 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
611 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
612
613 -- Scan past "case"
614
615 Scan (In_Tree);
616
617 -- Get the switch variable
618
619 Expect (Tok_Identifier, "identifier");
620
621 if Token = Tok_Identifier then
622 Variable_Location := Token_Ptr;
623 Parse_Variable_Reference
624 (In_Tree => In_Tree,
625 Variable => Case_Variable,
626 Current_Project => Current_Project,
627 Current_Package => Current_Package);
628 Set_Case_Variable_Reference_Of
629 (Case_Construction, In_Tree, To => Case_Variable);
630
631 else
632 if Token /= Tok_Is then
633 Scan (In_Tree);
634 end if;
635 end if;
636
637 if Case_Variable /= Empty_Node then
638 String_Type := String_Type_Of (Case_Variable, In_Tree);
639
640 if String_Type = Empty_Node then
641 Error_Msg ("variable """ &
642 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
643 """ is not typed",
644 Variable_Location);
645 end if;
646 end if;
647
648 Expect (Tok_Is, "IS");
649
650 if Token = Tok_Is then
651 Set_End_Of_Line (Case_Construction);
652 Set_Previous_Line_Node (Case_Construction);
653 Set_Next_End_Node (Case_Construction);
654
655 -- Scan past "is"
656
657 Scan (In_Tree);
658 end if;
659
660 Start_New_Case_Construction (In_Tree, String_Type);
661
662 When_Loop :
663
664 while Token = Tok_When loop
665
666 if First_Case_Item then
667 Current_Item :=
668 Default_Project_Node
669 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
670 Set_First_Case_Item_Of
671 (Case_Construction, In_Tree, To => Current_Item);
672 First_Case_Item := False;
673
674 else
675 Next_Item :=
676 Default_Project_Node
677 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
678 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
679 Current_Item := Next_Item;
680 end if;
681
682 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
683
684 -- Scan past "when"
685
686 Scan (In_Tree);
687
688 if Token = Tok_Others then
689 When_Others := True;
690
691 -- Scan past "others"
692
693 Scan (In_Tree);
694
695 Expect (Tok_Arrow, "`=>`");
696 Set_End_Of_Line (Current_Item);
697 Set_Previous_Line_Node (Current_Item);
698
699 -- Empty_Node in Field1 of a Case_Item indicates
700 -- the "when others =>" branch.
701
702 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
703
704 Parse_Declarative_Items
705 (In_Tree => In_Tree,
706 Declarations => First_Declarative_Item,
707 In_Zone => In_Case_Construction,
708 First_Attribute => First_Attribute,
709 Current_Project => Current_Project,
710 Current_Package => Current_Package,
711 Packages_To_Check => Packages_To_Check);
712
713 -- "when others =>" must be the last branch, so save the
714 -- Case_Item and exit
715
716 Set_First_Declarative_Item_Of
717 (Current_Item, In_Tree, To => First_Declarative_Item);
718 exit When_Loop;
719
720 else
721 Parse_Choice_List
722 (In_Tree => In_Tree,
723 First_Choice => First_Choice);
724 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
725
726 Expect (Tok_Arrow, "`=>`");
727 Set_End_Of_Line (Current_Item);
728 Set_Previous_Line_Node (Current_Item);
729
730 Parse_Declarative_Items
731 (In_Tree => In_Tree,
732 Declarations => First_Declarative_Item,
733 In_Zone => In_Case_Construction,
734 First_Attribute => First_Attribute,
735 Current_Project => Current_Project,
736 Current_Package => Current_Package,
737 Packages_To_Check => Packages_To_Check);
738
739 Set_First_Declarative_Item_Of
740 (Current_Item, In_Tree, To => First_Declarative_Item);
741
742 end if;
743 end loop When_Loop;
744
745 End_Case_Construction
746 (Check_All_Labels => not When_Others and not Quiet_Output,
747 Case_Location => Location_Of (Case_Construction, In_Tree));
748
749 Expect (Tok_End, "`END CASE`");
750 Remove_Next_End_Node;
751
752 if Token = Tok_End then
753
754 -- Scan past "end"
755
756 Scan (In_Tree);
757
758 Expect (Tok_Case, "CASE");
759
760 end if;
761
762 -- Scan past "case"
763
764 Scan (In_Tree);
765
766 Expect (Tok_Semicolon, "`;`");
767 Set_Previous_End_Node (Case_Construction);
768
769 end Parse_Case_Construction;
770
771 -----------------------------
772 -- Parse_Declarative_Items --
773 -----------------------------
774
775 procedure Parse_Declarative_Items
776 (In_Tree : Project_Node_Tree_Ref;
777 Declarations : out Project_Node_Id;
778 In_Zone : Zone;
779 First_Attribute : Attribute_Node_Id;
780 Current_Project : Project_Node_Id;
781 Current_Package : Project_Node_Id;
782 Packages_To_Check : String_List_Access)
783 is
784 Current_Declarative_Item : Project_Node_Id := Empty_Node;
785 Next_Declarative_Item : Project_Node_Id := Empty_Node;
786 Current_Declaration : Project_Node_Id := Empty_Node;
787 Item_Location : Source_Ptr := No_Location;
788
789 begin
790 Declarations := Empty_Node;
791
792 loop
793 -- We are always positioned at the token that precedes
794 -- the first token of the declarative element.
795 -- Scan past it
796
797 Scan (In_Tree);
798
799 Item_Location := Token_Ptr;
800
801 case Token is
802 when Tok_Identifier =>
803
804 if In_Zone = In_Case_Construction then
805 Error_Msg ("a variable cannot be declared here",
806 Token_Ptr);
807 end if;
808
809 Parse_Variable_Declaration
810 (In_Tree,
811 Current_Declaration,
812 Current_Project => Current_Project,
813 Current_Package => Current_Package);
814
815 Set_End_Of_Line (Current_Declaration);
816 Set_Previous_Line_Node (Current_Declaration);
817
818 when Tok_For =>
819
820 Parse_Attribute_Declaration
821 (In_Tree => In_Tree,
822 Attribute => Current_Declaration,
823 First_Attribute => First_Attribute,
824 Current_Project => Current_Project,
825 Current_Package => Current_Package,
826 Packages_To_Check => Packages_To_Check);
827
828 Set_End_Of_Line (Current_Declaration);
829 Set_Previous_Line_Node (Current_Declaration);
830
831 when Tok_Null =>
832
833 Scan (In_Tree); -- past "null"
834
835 when Tok_Package =>
836
837 -- Package declaration
838
839 if In_Zone /= In_Project then
840 Error_Msg ("a package cannot be declared here", Token_Ptr);
841 end if;
842
843 Parse_Package_Declaration
844 (In_Tree => In_Tree,
845 Package_Declaration => Current_Declaration,
846 Current_Project => Current_Project,
847 Packages_To_Check => Packages_To_Check);
848
849 Set_Previous_End_Node (Current_Declaration);
850
851 when Tok_Type =>
852
853 -- Type String Declaration
854
855 if In_Zone /= In_Project then
856 Error_Msg ("a string type cannot be declared here",
857 Token_Ptr);
858 end if;
859
860 Parse_String_Type_Declaration
861 (In_Tree => In_Tree,
862 String_Type => Current_Declaration,
863 Current_Project => Current_Project);
864
865 Set_End_Of_Line (Current_Declaration);
866 Set_Previous_Line_Node (Current_Declaration);
867
868 when Tok_Case =>
869
870 -- Case construction
871
872 Parse_Case_Construction
873 (In_Tree => In_Tree,
874 Case_Construction => Current_Declaration,
875 First_Attribute => First_Attribute,
876 Current_Project => Current_Project,
877 Current_Package => Current_Package,
878 Packages_To_Check => Packages_To_Check);
879
880 Set_Previous_End_Node (Current_Declaration);
881
882 when others =>
883 exit;
884
885 -- We are leaving Parse_Declarative_Items positionned
886 -- at the first token after the list of declarative items.
887 -- It could be "end" (for a project, a package declaration or
888 -- a case construction) or "when" (for a case construction)
889
890 end case;
891
892 Expect (Tok_Semicolon, "`;` after declarative items");
893
894 -- Insert an N_Declarative_Item in the tree, but only if
895 -- Current_Declaration is not an empty node.
896
897 if Current_Declaration /= Empty_Node then
898 if Current_Declarative_Item = Empty_Node then
899 Current_Declarative_Item :=
900 Default_Project_Node
901 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
902 Declarations := Current_Declarative_Item;
903
904 else
905 Next_Declarative_Item :=
906 Default_Project_Node
907 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
908 Set_Next_Declarative_Item
909 (Current_Declarative_Item, In_Tree,
910 To => Next_Declarative_Item);
911 Current_Declarative_Item := Next_Declarative_Item;
912 end if;
913
914 Set_Current_Item_Node
915 (Current_Declarative_Item, In_Tree,
916 To => Current_Declaration);
917 Set_Location_Of
918 (Current_Declarative_Item, In_Tree, To => Item_Location);
919 end if;
920 end loop;
921 end Parse_Declarative_Items;
922
923 -------------------------------
924 -- Parse_Package_Declaration --
925 -------------------------------
926
927 procedure Parse_Package_Declaration
928 (In_Tree : Project_Node_Tree_Ref;
929 Package_Declaration : out Project_Node_Id;
930 Current_Project : Project_Node_Id;
931 Packages_To_Check : String_List_Access)
932 is
933 First_Attribute : Attribute_Node_Id := Empty_Attribute;
934 Current_Package : Package_Node_Id := Empty_Package;
935 First_Declarative_Item : Project_Node_Id := Empty_Node;
936
937 Package_Location : constant Source_Ptr := Token_Ptr;
938
939 begin
940 Package_Declaration :=
941 Default_Project_Node
942 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
943 Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
944
945 -- Scan past "package"
946
947 Scan (In_Tree);
948 Expect (Tok_Identifier, "identifier");
949
950 if Token = Tok_Identifier then
951 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
952
953 Current_Package := Package_Node_Id_Of (Token_Name);
954
955 if Current_Package /= Empty_Package then
956 First_Attribute := First_Attribute_Of (Current_Package);
957
958 else
959 if not Quiet_Output then
960 Error_Msg ("?""" &
961 Get_Name_String
962 (Name_Of (Package_Declaration, In_Tree)) &
963 """ is not a known package name",
964 Token_Ptr);
965 end if;
966
967 -- Set the package declaration to "ignored" so that it is not
968 -- processed by Prj.Proc.Process.
969
970 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
971
972 -- Add the unknown package in the list of packages
973
974 Add_Unknown_Package (Token_Name, Current_Package);
975 end if;
976
977 Set_Package_Id_Of
978 (Package_Declaration, In_Tree, To => Current_Package);
979
980 declare
981 Current : Project_Node_Id :=
982 First_Package_Of (Current_Project, In_Tree);
983
984 begin
985 while Current /= Empty_Node
986 and then Name_Of (Current, In_Tree) /= Token_Name
987 loop
988 Current := Next_Package_In_Project (Current, In_Tree);
989 end loop;
990
991 if Current /= Empty_Node then
992 Error_Msg
993 ("package """ &
994 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
995 """ is declared twice in the same project",
996 Token_Ptr);
997
998 else
999 -- Add the package to the project list
1000
1001 Set_Next_Package_In_Project
1002 (Package_Declaration, In_Tree,
1003 To => First_Package_Of (Current_Project, In_Tree));
1004 Set_First_Package_Of
1005 (Current_Project, In_Tree, To => Package_Declaration);
1006 end if;
1007 end;
1008
1009 -- Scan past the package name
1010
1011 Scan (In_Tree);
1012 end if;
1013
1014 if Token = Tok_Renames then
1015 if In_Configuration then
1016 Error_Msg
1017 ("no package renames in configuration projects", Token_Ptr);
1018 end if;
1019
1020 -- Scan past "renames"
1021
1022 Scan (In_Tree);
1023
1024 Expect (Tok_Identifier, "identifier");
1025
1026 if Token = Tok_Identifier then
1027 declare
1028 Project_Name : constant Name_Id := Token_Name;
1029
1030 Clause : Project_Node_Id :=
1031 First_With_Clause_Of (Current_Project, In_Tree);
1032 The_Project : Project_Node_Id := Empty_Node;
1033 Extended : constant Project_Node_Id :=
1034 Extended_Project_Of
1035 (Project_Declaration_Of
1036 (Current_Project, In_Tree),
1037 In_Tree);
1038 begin
1039 while Clause /= Empty_Node loop
1040 -- Only non limited imported projects may be used in a
1041 -- renames declaration.
1042
1043 The_Project :=
1044 Non_Limited_Project_Node_Of (Clause, In_Tree);
1045 exit when The_Project /= Empty_Node
1046 and then Name_Of (The_Project, In_Tree) = Project_Name;
1047 Clause := Next_With_Clause_Of (Clause, In_Tree);
1048 end loop;
1049
1050 if Clause = Empty_Node then
1051 -- As we have not found the project in the imports, we check
1052 -- if it's the name of an eventual extended project.
1053
1054 if Extended /= Empty_Node
1055 and then Name_Of (Extended, In_Tree) = Project_Name
1056 then
1057 Set_Project_Of_Renamed_Package_Of
1058 (Package_Declaration, In_Tree, To => Extended);
1059 else
1060 Error_Msg_Name_1 := Project_Name;
1061 Error_Msg
1062 ("% is not an imported or extended project", Token_Ptr);
1063 end if;
1064 else
1065 Set_Project_Of_Renamed_Package_Of
1066 (Package_Declaration, In_Tree, To => The_Project);
1067 end if;
1068 end;
1069
1070 Scan (In_Tree);
1071 Expect (Tok_Dot, "`.`");
1072
1073 if Token = Tok_Dot then
1074 Scan (In_Tree);
1075 Expect (Tok_Identifier, "identifier");
1076
1077 if Token = Tok_Identifier then
1078 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1079 Error_Msg ("not the same package name", Token_Ptr);
1080 elsif
1081 Project_Of_Renamed_Package_Of
1082 (Package_Declaration, In_Tree) /= Empty_Node
1083 then
1084 declare
1085 Current : Project_Node_Id :=
1086 First_Package_Of
1087 (Project_Of_Renamed_Package_Of
1088 (Package_Declaration, In_Tree),
1089 In_Tree);
1090
1091 begin
1092 while Current /= Empty_Node
1093 and then Name_Of (Current, In_Tree) /= Token_Name
1094 loop
1095 Current :=
1096 Next_Package_In_Project (Current, In_Tree);
1097 end loop;
1098
1099 if Current = Empty_Node then
1100 Error_Msg
1101 ("""" &
1102 Get_Name_String (Token_Name) &
1103 """ is not a package declared by the project",
1104 Token_Ptr);
1105 end if;
1106 end;
1107 end if;
1108
1109 Scan (In_Tree);
1110 end if;
1111 end if;
1112 end if;
1113
1114 Expect (Tok_Semicolon, "`;`");
1115 Set_End_Of_Line (Package_Declaration);
1116 Set_Previous_Line_Node (Package_Declaration);
1117
1118 elsif Token = Tok_Is then
1119 Set_End_Of_Line (Package_Declaration);
1120 Set_Previous_Line_Node (Package_Declaration);
1121 Set_Next_End_Node (Package_Declaration);
1122
1123 Parse_Declarative_Items
1124 (In_Tree => In_Tree,
1125 Declarations => First_Declarative_Item,
1126 In_Zone => In_Package,
1127 First_Attribute => First_Attribute,
1128 Current_Project => Current_Project,
1129 Current_Package => Package_Declaration,
1130 Packages_To_Check => Packages_To_Check);
1131
1132 Set_First_Declarative_Item_Of
1133 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1134
1135 Expect (Tok_End, "END");
1136
1137 if Token = Tok_End then
1138
1139 -- Scan past "end"
1140
1141 Scan (In_Tree);
1142 end if;
1143
1144 -- We should have the name of the package after "end"
1145
1146 Expect (Tok_Identifier, "identifier");
1147
1148 if Token = Tok_Identifier
1149 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1150 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1151 then
1152 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1153 Error_Msg ("expected %%", Token_Ptr);
1154 end if;
1155
1156 if Token /= Tok_Semicolon then
1157
1158 -- Scan past the package name
1159
1160 Scan (In_Tree);
1161 end if;
1162
1163 Expect (Tok_Semicolon, "`;`");
1164 Remove_Next_End_Node;
1165
1166 else
1167 Error_Msg ("expected IS or RENAMES", Token_Ptr);
1168 end if;
1169
1170 end Parse_Package_Declaration;
1171
1172 -----------------------------------
1173 -- Parse_String_Type_Declaration --
1174 -----------------------------------
1175
1176 procedure Parse_String_Type_Declaration
1177 (In_Tree : Project_Node_Tree_Ref;
1178 String_Type : out Project_Node_Id;
1179 Current_Project : Project_Node_Id)
1180 is
1181 Current : Project_Node_Id := Empty_Node;
1182 First_String : Project_Node_Id := Empty_Node;
1183
1184 begin
1185 String_Type :=
1186 Default_Project_Node
1187 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1188
1189 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1190
1191 -- Scan past "type"
1192
1193 Scan (In_Tree);
1194
1195 Expect (Tok_Identifier, "identifier");
1196
1197 if Token = Tok_Identifier then
1198 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1199
1200 Current := First_String_Type_Of (Current_Project, In_Tree);
1201 while Current /= Empty_Node
1202 and then
1203 Name_Of (Current, In_Tree) /= Token_Name
1204 loop
1205 Current := Next_String_Type (Current, In_Tree);
1206 end loop;
1207
1208 if Current /= Empty_Node then
1209 Error_Msg ("duplicate string type name """ &
1210 Get_Name_String (Token_Name) &
1211 """",
1212 Token_Ptr);
1213 else
1214 Current := First_Variable_Of (Current_Project, In_Tree);
1215 while Current /= Empty_Node
1216 and then Name_Of (Current, In_Tree) /= Token_Name
1217 loop
1218 Current := Next_Variable (Current, In_Tree);
1219 end loop;
1220
1221 if Current /= Empty_Node then
1222 Error_Msg ("""" &
1223 Get_Name_String (Token_Name) &
1224 """ is already a variable name", Token_Ptr);
1225 else
1226 Set_Next_String_Type
1227 (String_Type, In_Tree,
1228 To => First_String_Type_Of (Current_Project, In_Tree));
1229 Set_First_String_Type_Of
1230 (Current_Project, In_Tree, To => String_Type);
1231 end if;
1232 end if;
1233
1234 -- Scan past the name
1235
1236 Scan (In_Tree);
1237 end if;
1238
1239 Expect (Tok_Is, "IS");
1240
1241 if Token = Tok_Is then
1242 Scan (In_Tree);
1243 end if;
1244
1245 Expect (Tok_Left_Paren, "`(`");
1246
1247 if Token = Tok_Left_Paren then
1248 Scan (In_Tree);
1249 end if;
1250
1251 Parse_String_Type_List
1252 (In_Tree => In_Tree, First_String => First_String);
1253 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1254
1255 Expect (Tok_Right_Paren, "`)`");
1256
1257 if Token = Tok_Right_Paren then
1258 Scan (In_Tree);
1259 end if;
1260
1261 end Parse_String_Type_Declaration;
1262
1263 --------------------------------
1264 -- Parse_Variable_Declaration --
1265 --------------------------------
1266
1267 procedure Parse_Variable_Declaration
1268 (In_Tree : Project_Node_Tree_Ref;
1269 Variable : out Project_Node_Id;
1270 Current_Project : Project_Node_Id;
1271 Current_Package : Project_Node_Id)
1272 is
1273 Expression_Location : Source_Ptr;
1274 String_Type_Name : Name_Id := No_Name;
1275 Project_String_Type_Name : Name_Id := No_Name;
1276 Type_Location : Source_Ptr := No_Location;
1277 Project_Location : Source_Ptr := No_Location;
1278 Expression : Project_Node_Id := Empty_Node;
1279 Variable_Name : constant Name_Id := Token_Name;
1280 OK : Boolean := True;
1281
1282 begin
1283 Variable :=
1284 Default_Project_Node
1285 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1286 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1287 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1288
1289 -- Scan past the variable name
1290
1291 Scan (In_Tree);
1292
1293 if Token = Tok_Colon then
1294
1295 -- Typed string variable declaration
1296
1297 Scan (In_Tree);
1298 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1299 Expect (Tok_Identifier, "identifier");
1300
1301 OK := Token = Tok_Identifier;
1302
1303 if OK then
1304 String_Type_Name := Token_Name;
1305 Type_Location := Token_Ptr;
1306 Scan (In_Tree);
1307
1308 if Token = Tok_Dot then
1309 Project_String_Type_Name := String_Type_Name;
1310 Project_Location := Type_Location;
1311
1312 -- Scan past the dot
1313
1314 Scan (In_Tree);
1315 Expect (Tok_Identifier, "identifier");
1316
1317 if Token = Tok_Identifier then
1318 String_Type_Name := Token_Name;
1319 Type_Location := Token_Ptr;
1320 Scan (In_Tree);
1321 else
1322 OK := False;
1323 end if;
1324 end if;
1325
1326 if OK then
1327 declare
1328 Current : Project_Node_Id :=
1329 First_String_Type_Of (Current_Project, In_Tree);
1330
1331 begin
1332 if Project_String_Type_Name /= No_Name then
1333 declare
1334 The_Project_Name_And_Node : constant
1335 Tree_Private_Part.Project_Name_And_Node :=
1336 Tree_Private_Part.Projects_Htable.Get
1337 (In_Tree.Projects_HT, Project_String_Type_Name);
1338
1339 use Tree_Private_Part;
1340
1341 begin
1342 if The_Project_Name_And_Node =
1343 Tree_Private_Part.No_Project_Name_And_Node
1344 then
1345 Error_Msg ("unknown project """ &
1346 Get_Name_String
1347 (Project_String_Type_Name) &
1348 """",
1349 Project_Location);
1350 Current := Empty_Node;
1351 else
1352 Current :=
1353 First_String_Type_Of
1354 (The_Project_Name_And_Node.Node, In_Tree);
1355 end if;
1356 end;
1357 end if;
1358
1359 while Current /= Empty_Node
1360 and then Name_Of (Current, In_Tree) /= String_Type_Name
1361 loop
1362 Current := Next_String_Type (Current, In_Tree);
1363 end loop;
1364
1365 if Current = Empty_Node then
1366 Error_Msg ("unknown string type """ &
1367 Get_Name_String (String_Type_Name) &
1368 """",
1369 Type_Location);
1370 OK := False;
1371 else
1372 Set_String_Type_Of
1373 (Variable, In_Tree, To => Current);
1374 end if;
1375 end;
1376 end if;
1377 end if;
1378 end if;
1379
1380 Expect (Tok_Colon_Equal, "`:=`");
1381
1382 OK := OK and (Token = Tok_Colon_Equal);
1383
1384 if Token = Tok_Colon_Equal then
1385 Scan (In_Tree);
1386 end if;
1387
1388 -- Get the single string or string list value
1389
1390 Expression_Location := Token_Ptr;
1391
1392 Parse_Expression
1393 (In_Tree => In_Tree,
1394 Expression => Expression,
1395 Current_Project => Current_Project,
1396 Current_Package => Current_Package,
1397 Optional_Index => False);
1398 Set_Expression_Of (Variable, In_Tree, To => Expression);
1399
1400 if Expression /= Empty_Node then
1401 -- A typed string must have a single string value, not a list
1402
1403 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1404 and then Expression_Kind_Of (Expression, In_Tree) = List
1405 then
1406 Error_Msg
1407 ("expression must be a single string", Expression_Location);
1408 end if;
1409
1410 Set_Expression_Kind_Of
1411 (Variable, In_Tree,
1412 To => Expression_Kind_Of (Expression, In_Tree));
1413 end if;
1414
1415 if OK then
1416 declare
1417 The_Variable : Project_Node_Id := Empty_Node;
1418
1419 begin
1420 if Current_Package /= Empty_Node then
1421 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1422 elsif Current_Project /= Empty_Node then
1423 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1424 end if;
1425
1426 while The_Variable /= Empty_Node
1427 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1428 loop
1429 The_Variable := Next_Variable (The_Variable, In_Tree);
1430 end loop;
1431
1432 if The_Variable = Empty_Node then
1433 if Current_Package /= Empty_Node then
1434 Set_Next_Variable
1435 (Variable, In_Tree,
1436 To => First_Variable_Of (Current_Package, In_Tree));
1437 Set_First_Variable_Of
1438 (Current_Package, In_Tree, To => Variable);
1439
1440 elsif Current_Project /= Empty_Node then
1441 Set_Next_Variable
1442 (Variable, In_Tree,
1443 To => First_Variable_Of (Current_Project, In_Tree));
1444 Set_First_Variable_Of
1445 (Current_Project, In_Tree, To => Variable);
1446 end if;
1447
1448 else
1449 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1450 if
1451 Expression_Kind_Of (The_Variable, In_Tree) = Undefined
1452 then
1453 Set_Expression_Kind_Of
1454 (The_Variable, In_Tree,
1455 To => Expression_Kind_Of (Variable, In_Tree));
1456
1457 else
1458 if Expression_Kind_Of (The_Variable, In_Tree) /=
1459 Expression_Kind_Of (Variable, In_Tree)
1460 then
1461 Error_Msg ("wrong expression kind for variable """ &
1462 Get_Name_String
1463 (Name_Of (The_Variable, In_Tree)) &
1464 """",
1465 Expression_Location);
1466 end if;
1467 end if;
1468 end if;
1469 end if;
1470 end;
1471 end if;
1472
1473 end Parse_Variable_Declaration;
1474
1475 end Prj.Dect;
Mirror of the offical gcc git repository hosted at gcc.gnu.org