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