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