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