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