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