1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2002 Free Software Foundation, Inc --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Errout; use Errout;
28 with Namet; use Namet;
29 with Prj.Strt; use Prj.Strt;
30 with Prj.Tree; use Prj.Tree;
31 with Scans; use Scans;
32 with Sinfo; use Sinfo;
33 with Types; use Types;
34 with Prj.Attr; use Prj.Attr;
36 package body Prj.Dect is
38 type Zone is (In_Project, In_Package, In_Case_Construction);
39 -- Needs a comment ???
41 procedure Parse_Attribute_Declaration
42 (Attribute : out Project_Node_Id;
43 First_Attribute : Attribute_Node_Id;
44 Current_Project : Project_Node_Id;
45 Current_Package : Project_Node_Id);
46 -- Parse an attribute declaration.
48 procedure Parse_Case_Construction
49 (Case_Construction : out Project_Node_Id;
50 First_Attribute : Attribute_Node_Id;
51 Current_Project : Project_Node_Id;
52 Current_Package : Project_Node_Id);
53 -- Parse a case construction
55 procedure Parse_Declarative_Items
56 (Declarations : out Project_Node_Id;
58 First_Attribute : Attribute_Node_Id;
59 Current_Project : Project_Node_Id;
60 Current_Package : Project_Node_Id);
61 -- Parse declarative items. Depending on In_Zone, some declarative
62 -- items may be forbiden.
64 procedure Parse_Package_Declaration
65 (Package_Declaration : out Project_Node_Id;
66 Current_Project : Project_Node_Id);
67 -- Parse a package declaration
69 procedure Parse_String_Type_Declaration
70 (String_Type : out Project_Node_Id;
71 Current_Project : Project_Node_Id);
72 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
74 procedure Parse_Variable_Declaration
75 (Variable : out Project_Node_Id;
76 Current_Project : Project_Node_Id;
77 Current_Package : Project_Node_Id);
78 -- Parse a variable assignment
79 -- <variable_Name> := <expression>; OR
80 -- <variable_Name> : <string_type_Name> := <string_expression>;
87 (Declarations : out Project_Node_Id;
88 Current_Project : Project_Node_Id;
89 Extends : Project_Node_Id)
91 First_Declarative_Item : Project_Node_Id := Empty_Node;
94 Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
95 Set_Location_Of (Declarations, To => Token_Ptr);
96 Set_Modified_Project_Of (Declarations, To => Extends);
97 Set_Project_Declaration_Of (Current_Project, Declarations);
98 Parse_Declarative_Items
99 (Declarations => First_Declarative_Item,
100 In_Zone => In_Project,
101 First_Attribute => Prj.Attr.Attribute_First,
102 Current_Project => Current_Project,
103 Current_Package => Empty_Node);
104 Set_First_Declarative_Item_Of
105 (Declarations, To => First_Declarative_Item);
108 ---------------------------------
109 -- Parse_Attribute_Declaration --
110 ---------------------------------
112 procedure Parse_Attribute_Declaration
113 (Attribute : out Project_Node_Id;
114 First_Attribute : Attribute_Node_Id;
115 Current_Project : Project_Node_Id;
116 Current_Package : Project_Node_Id)
118 Current_Attribute : Attribute_Node_Id := First_Attribute;
121 Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
122 Set_Location_Of (Attribute, To => Token_Ptr);
128 Expect (Tok_Identifier, "identifier");
130 if Token = Tok_Identifier then
131 Set_Name_Of (Attribute, To => Token_Name);
132 Set_Location_Of (Attribute, To => Token_Ptr);
134 while Current_Attribute /= Empty_Attribute
136 Attributes.Table (Current_Attribute).Name /= Token_Name
138 Current_Attribute := Attributes.Table (Current_Attribute).Next;
141 if Current_Attribute = Empty_Attribute then
142 Error_Msg ("undefined attribute """ &
143 Get_Name_String (Name_Of (Attribute)) &
147 elsif Attributes.Table (Current_Attribute).Kind_2 =
148 Case_Insensitive_Associative_Array
150 Set_Case_Insensitive (Attribute, To => True);
156 if Token = Tok_Left_Paren then
157 if Current_Attribute /= Empty_Attribute
158 and then Attributes.Table (Current_Attribute).Kind_2 = Single
160 Error_Msg ("the attribute """ &
162 (Attributes.Table (Current_Attribute).Name) &
163 """ cannot be an associative array",
164 Location_Of (Attribute));
168 Expect (Tok_String_Literal, "literal string");
170 if Token = Tok_String_Literal then
171 Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
175 Expect (Tok_Right_Paren, ")");
177 if Token = Tok_Right_Paren then
182 if Current_Attribute /= Empty_Attribute
184 Attributes.Table (Current_Attribute).Kind_2 /= Single
186 Error_Msg ("the attribute """ &
188 (Attributes.Table (Current_Attribute).Name) &
189 """ needs to be an associative array",
190 Location_Of (Attribute));
194 if Current_Attribute /= Empty_Attribute then
195 Set_Expression_Kind_Of
196 (Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
199 Expect (Tok_Use, "use");
201 if Token = Tok_Use then
205 Expression_Location : constant Source_Ptr := Token_Ptr;
206 Expression : Project_Node_Id := Empty_Node;
210 (Expression => Expression,
211 Current_Project => Current_Project,
212 Current_Package => Current_Package);
213 Set_Expression_Of (Attribute, To => Expression);
215 if Current_Attribute /= Empty_Attribute
216 and then Expression /= Empty_Node
217 and then Attributes.Table (Current_Attribute).Kind_1 /=
218 Expression_Kind_Of (Expression)
221 ("wrong expression kind for attribute """ &
223 (Attributes.Table (Current_Attribute).Name) &
225 Expression_Location);
230 end Parse_Attribute_Declaration;
232 -----------------------------
233 -- Parse_Case_Construction --
234 -----------------------------
236 procedure Parse_Case_Construction
237 (Case_Construction : out Project_Node_Id;
238 First_Attribute : Attribute_Node_Id;
239 Current_Project : Project_Node_Id;
240 Current_Package : Project_Node_Id)
242 Current_Item : Project_Node_Id := Empty_Node;
243 Next_Item : Project_Node_Id := Empty_Node;
244 First_Case_Item : Boolean := True;
246 Variable_Location : Source_Ptr := No_Location;
248 String_Type : Project_Node_Id := Empty_Node;
250 Case_Variable : Project_Node_Id := Empty_Node;
252 First_Declarative_Item : Project_Node_Id := Empty_Node;
254 First_Choice : Project_Node_Id := Empty_Node;
258 Default_Project_Node (Of_Kind => N_Case_Construction);
259 Set_Location_Of (Case_Construction, To => Token_Ptr);
265 -- Get the switch variable
267 Expect (Tok_Identifier, "identifier");
269 if Token = Tok_Identifier then
270 Variable_Location := Token_Ptr;
271 Parse_Variable_Reference
272 (Variable => Case_Variable,
273 Current_Project => Current_Project,
274 Current_Package => Current_Package);
275 Set_Case_Variable_Reference_Of
276 (Case_Construction, To => Case_Variable);
279 if Token /= Tok_Is then
284 if Case_Variable /= Empty_Node then
285 String_Type := String_Type_Of (Case_Variable);
287 if String_Type = Empty_Node then
288 Error_Msg ("variable """ &
289 Get_Name_String (Name_Of (Case_Variable)) &
295 Expect (Tok_Is, "is");
297 if Token = Tok_Is then
304 Start_New_Case_Construction (String_Type);
308 while Token = Tok_When loop
310 if First_Case_Item then
311 Current_Item := Default_Project_Node (Of_Kind => N_Case_Item);
312 Set_First_Case_Item_Of (Case_Construction, To => Current_Item);
313 First_Case_Item := False;
316 Next_Item := Default_Project_Node (Of_Kind => N_Case_Item);
317 Set_Next_Case_Item (Current_Item, To => Next_Item);
318 Current_Item := Next_Item;
321 Set_Location_Of (Current_Item, To => Token_Ptr);
327 if Token = Tok_Others then
329 -- Scan past "others"
333 Expect (Tok_Arrow, "=>");
335 -- Empty_Node in Field1 of a Case_Item indicates
336 -- the "when others =>" branch.
338 Set_First_Choice_Of (Current_Item, To => Empty_Node);
340 Parse_Declarative_Items
341 (Declarations => First_Declarative_Item,
342 In_Zone => In_Case_Construction,
343 First_Attribute => First_Attribute,
344 Current_Project => Current_Project,
345 Current_Package => Current_Package);
347 -- "when others =>" must be the last branch, so save the
348 -- Case_Item and exit
350 Set_First_Declarative_Item_Of
351 (Current_Item, To => First_Declarative_Item);
355 Parse_Choice_List (First_Choice => First_Choice);
356 Set_First_Choice_Of (Current_Item, To => First_Choice);
358 Expect (Tok_Arrow, "=>");
360 Parse_Declarative_Items
361 (Declarations => First_Declarative_Item,
362 In_Zone => In_Case_Construction,
363 First_Attribute => First_Attribute,
364 Current_Project => Current_Project,
365 Current_Package => Current_Package);
367 Set_First_Declarative_Item_Of
368 (Current_Item, To => First_Declarative_Item);
373 End_Case_Construction;
375 Expect (Tok_End, "end case");
377 if Token = Tok_End then
383 Expect (Tok_Case, "case");
391 Expect (Tok_Semicolon, ";");
393 end Parse_Case_Construction;
395 -----------------------------
396 -- Parse_Declarative_Items --
397 -----------------------------
399 procedure Parse_Declarative_Items
400 (Declarations : out Project_Node_Id;
402 First_Attribute : Attribute_Node_Id;
403 Current_Project : Project_Node_Id;
404 Current_Package : Project_Node_Id)
406 Current_Declarative_Item : Project_Node_Id := Empty_Node;
407 Next_Declarative_Item : Project_Node_Id := Empty_Node;
408 Current_Declaration : Project_Node_Id := Empty_Node;
409 Item_Location : Source_Ptr := No_Location;
412 Declarations := Empty_Node;
415 -- We are always positioned at the token that precedes
416 -- the first token of the declarative element.
421 Item_Location := Token_Ptr;
424 when Tok_Identifier =>
426 if In_Zone = In_Case_Construction then
427 Error_Msg ("a variable cannot be declared here",
431 Parse_Variable_Declaration
432 (Current_Declaration,
433 Current_Project => Current_Project,
434 Current_Package => Current_Package);
438 Parse_Attribute_Declaration
439 (Attribute => Current_Declaration,
440 First_Attribute => First_Attribute,
441 Current_Project => Current_Project,
442 Current_Package => Current_Package);
446 -- Package declaration
448 if In_Zone /= In_Project then
449 Error_Msg ("a package cannot be declared here", Token_Ptr);
452 Parse_Package_Declaration
453 (Package_Declaration => Current_Declaration,
454 Current_Project => Current_Project);
458 -- Type String Declaration
460 if In_Zone /= In_Project then
461 Error_Msg ("a string type cannot be declared here",
465 Parse_String_Type_Declaration
466 (String_Type => Current_Declaration,
467 Current_Project => Current_Project);
473 Parse_Case_Construction
474 (Case_Construction => Current_Declaration,
475 First_Attribute => First_Attribute,
476 Current_Project => Current_Project,
477 Current_Package => Current_Package);
482 -- We are leaving Parse_Declarative_Items positionned
483 -- at the first token after the list of declarative items.
484 -- It could be "end" (for a project, a package declaration or
485 -- a case construction) or "when" (for a case construction)
489 Expect (Tok_Semicolon, "; after declarative items");
491 if Current_Declarative_Item = Empty_Node then
492 Current_Declarative_Item :=
493 Default_Project_Node (Of_Kind => N_Declarative_Item);
494 Declarations := Current_Declarative_Item;
497 Next_Declarative_Item :=
498 Default_Project_Node (Of_Kind => N_Declarative_Item);
499 Set_Next_Declarative_Item
500 (Current_Declarative_Item, To => Next_Declarative_Item);
501 Current_Declarative_Item := Next_Declarative_Item;
504 Set_Current_Item_Node
505 (Current_Declarative_Item, To => Current_Declaration);
506 Set_Location_Of (Current_Declarative_Item, To => Item_Location);
510 end Parse_Declarative_Items;
512 -------------------------------
513 -- Parse_Package_Declaration --
514 -------------------------------
516 procedure Parse_Package_Declaration
517 (Package_Declaration : out Project_Node_Id;
518 Current_Project : Project_Node_Id)
520 First_Attribute : Attribute_Node_Id := Empty_Attribute;
521 Current_Package : Package_Node_Id := Empty_Package;
522 First_Declarative_Item : Project_Node_Id := Empty_Node;
525 Package_Declaration :=
526 Default_Project_Node (Of_Kind => N_Package_Declaration);
527 Set_Location_Of (Package_Declaration, To => Token_Ptr);
529 -- Scan past "package"
533 Expect (Tok_Identifier, "identifier");
535 if Token = Tok_Identifier then
537 Set_Name_Of (Package_Declaration, To => Token_Name);
539 for Index in Package_Attributes.First .. Package_Attributes.Last loop
540 if Token_Name = Package_Attributes.Table (Index).Name then
542 Package_Attributes.Table (Index).First_Attribute;
543 Current_Package := Index;
548 if Current_Package = Empty_Package then
550 Get_Name_String (Name_Of (Package_Declaration)) &
551 """ is not an allowed package name",
555 Set_Package_Id_Of (Package_Declaration, To => Current_Package);
558 Current : Project_Node_Id := First_Package_Of (Current_Project);
561 while Current /= Empty_Node
562 and then Name_Of (Current) /= Token_Name
564 Current := Next_Package_In_Project (Current);
567 if Current /= Empty_Node then
570 Get_Name_String (Name_Of (Package_Declaration)) &
571 """ is declared twice in the same project",
575 -- Add the package to the project list
577 Set_Next_Package_In_Project
578 (Package_Declaration,
579 To => First_Package_Of (Current_Project));
581 (Current_Project, To => Package_Declaration);
586 -- Scan past the package name
591 if Token = Tok_Renames then
593 -- Scan past "renames"
597 Expect (Tok_Identifier, "identifier");
599 if Token = Tok_Identifier then
601 Project_Name : Name_Id := Token_Name;
602 Clause : Project_Node_Id :=
603 First_With_Clause_Of (Current_Project);
604 The_Project : Project_Node_Id := Empty_Node;
607 while Clause /= Empty_Node loop
608 The_Project := Project_Node_Of (Clause);
609 exit when Name_Of (The_Project) = Project_Name;
610 Clause := Next_With_Clause_Of (Clause);
613 if Clause = Empty_Node then
615 Get_Name_String (Project_Name) &
616 """ is not an imported project", Token_Ptr);
618 Set_Project_Of_Renamed_Package_Of
619 (Package_Declaration, To => The_Project);
624 Expect (Tok_Dot, ".");
626 if Token = Tok_Dot then
628 Expect (Tok_Identifier, "identifier");
630 if Token = Tok_Identifier then
631 if Name_Of (Package_Declaration) /= Token_Name then
632 Error_Msg ("not the same package name", Token_Ptr);
634 Project_Of_Renamed_Package_Of (Package_Declaration)
638 Current : Project_Node_Id :=
640 (Project_Of_Renamed_Package_Of
641 (Package_Declaration));
644 while Current /= Empty_Node
645 and then Name_Of (Current) /= Token_Name
647 Current := Next_Package_In_Project (Current);
650 if Current = Empty_Node then
653 Get_Name_String (Token_Name) &
654 """ is not a package declared by the project",
665 Expect (Tok_Semicolon, ";");
667 elsif Token = Tok_Is then
669 Parse_Declarative_Items
670 (Declarations => First_Declarative_Item,
671 In_Zone => In_Package,
672 First_Attribute => First_Attribute,
673 Current_Project => Current_Project,
674 Current_Package => Package_Declaration);
676 Set_First_Declarative_Item_Of
677 (Package_Declaration, To => First_Declarative_Item);
679 Expect (Tok_End, "end");
681 if Token = Tok_End then
688 -- We should have the name of the package after "end"
690 Expect (Tok_Identifier, "identifier");
692 if Token = Tok_Identifier
693 and then Name_Of (Package_Declaration) /= No_Name
694 and then Token_Name /= Name_Of (Package_Declaration)
696 Error_Msg_Name_1 := Name_Of (Package_Declaration);
697 Error_Msg ("expected {", Token_Ptr);
700 if Token /= Tok_Semicolon then
702 -- Scan past the package name
707 Expect (Tok_Semicolon, ";");
710 Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
713 end Parse_Package_Declaration;
715 -----------------------------------
716 -- Parse_String_Type_Declaration --
717 -----------------------------------
719 procedure Parse_String_Type_Declaration
720 (String_Type : out Project_Node_Id;
721 Current_Project : Project_Node_Id)
723 Current : Project_Node_Id := Empty_Node;
724 First_String : Project_Node_Id := Empty_Node;
728 Default_Project_Node (Of_Kind => N_String_Type_Declaration);
730 Set_Location_Of (String_Type, To => Token_Ptr);
736 Expect (Tok_Identifier, "identifier");
738 if Token = Tok_Identifier then
739 Set_Name_Of (String_Type, To => Token_Name);
741 Current := First_String_Type_Of (Current_Project);
742 while Current /= Empty_Node
744 Name_Of (Current) /= Token_Name
746 Current := Next_String_Type (Current);
749 if Current /= Empty_Node then
750 Error_Msg ("duplicate string type name """ &
751 Get_Name_String (Token_Name) &
755 Current := First_Variable_Of (Current_Project);
756 while Current /= Empty_Node
757 and then Name_Of (Current) /= Token_Name
759 Current := Next_Variable (Current);
762 if Current /= Empty_Node then
764 Get_Name_String (Token_Name) &
765 """ is already a variable name", Token_Ptr);
768 (String_Type, To => First_String_Type_Of (Current_Project));
769 Set_First_String_Type_Of (Current_Project, To => String_Type);
773 -- Scan past the name
778 Expect (Tok_Is, "is");
780 if Token = Tok_Is then
784 Expect (Tok_Left_Paren, "(");
786 if Token = Tok_Left_Paren then
790 Parse_String_Type_List (First_String => First_String);
791 Set_First_Literal_String (String_Type, To => First_String);
793 Expect (Tok_Right_Paren, ")");
795 if Token = Tok_Right_Paren then
799 end Parse_String_Type_Declaration;
801 --------------------------------
802 -- Parse_Variable_Declaration --
803 --------------------------------
805 procedure Parse_Variable_Declaration
806 (Variable : out Project_Node_Id;
807 Current_Project : Project_Node_Id;
808 Current_Package : Project_Node_Id)
810 Expression_Location : Source_Ptr;
811 String_Type_Name : Name_Id := No_Name;
812 Project_String_Type_Name : Name_Id := No_Name;
813 Type_Location : Source_Ptr := No_Location;
814 Project_Location : Source_Ptr := No_Location;
815 Expression : Project_Node_Id := Empty_Node;
816 Variable_Name : constant Name_Id := Token_Name;
820 Default_Project_Node (Of_Kind => N_Variable_Declaration);
821 Set_Name_Of (Variable, To => Variable_Name);
822 Set_Location_Of (Variable, To => Token_Ptr);
824 -- Scan past the variable name
828 if Token = Tok_Colon then
830 -- Typed string variable declaration
833 Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
834 Expect (Tok_Identifier, "identifier");
836 if Token = Tok_Identifier then
837 String_Type_Name := Token_Name;
838 Type_Location := Token_Ptr;
841 if Token = Tok_Dot then
842 Project_String_Type_Name := String_Type_Name;
843 Project_Location := Type_Location;
848 Expect (Tok_Identifier, "identifier");
850 if Token = Tok_Identifier then
851 String_Type_Name := Token_Name;
852 Type_Location := Token_Ptr;
855 String_Type_Name := No_Name;
859 if String_Type_Name /= No_Name then
861 Current : Project_Node_Id :=
862 First_String_Type_Of (Current_Project);
865 if Project_String_Type_Name /= No_Name then
867 The_Project_Name_And_Node : constant
868 Tree_Private_Part.Project_Name_And_Node :=
869 Tree_Private_Part.Projects_Htable.Get
870 (Project_String_Type_Name);
872 use Tree_Private_Part;
875 if The_Project_Name_And_Node =
876 Tree_Private_Part.No_Project_Name_And_Node
878 Error_Msg ("unknown project """ &
880 (Project_String_Type_Name) &
883 Current := Empty_Node;
887 (The_Project_Name_And_Node.Node);
892 while Current /= Empty_Node
893 and then Name_Of (Current) /= String_Type_Name
895 Current := Next_String_Type (Current);
898 if Current = Empty_Node then
899 Error_Msg ("unknown string type """ &
900 Get_Name_String (String_Type_Name) &
905 (Variable, To => Current);
912 Expect (Tok_Colon_Equal, ":=");
914 if Token = Tok_Colon_Equal then
918 -- Get the single string or string list value
920 Expression_Location := Token_Ptr;
923 (Expression => Expression,
924 Current_Project => Current_Project,
925 Current_Package => Current_Package);
926 Set_Expression_Of (Variable, To => Expression);
928 if Expression /= Empty_Node then
929 Set_Expression_Kind_Of
930 (Variable, To => Expression_Kind_Of (Expression));
934 The_Variable : Project_Node_Id := Empty_Node;
937 if Current_Package /= Empty_Node then
938 The_Variable := First_Variable_Of (Current_Package);
939 elsif Current_Project /= Empty_Node then
940 The_Variable := First_Variable_Of (Current_Project);
943 while The_Variable /= Empty_Node
944 and then Name_Of (The_Variable) /= Variable_Name
946 The_Variable := Next_Variable (The_Variable);
949 if The_Variable = Empty_Node then
950 if Current_Package /= Empty_Node then
952 (Variable, To => First_Variable_Of (Current_Package));
953 Set_First_Variable_Of (Current_Package, To => Variable);
955 elsif Current_Project /= Empty_Node then
957 (Variable, To => First_Variable_Of (Current_Project));
958 Set_First_Variable_Of (Current_Project, To => Variable);
962 if Expression_Kind_Of (Variable) /= Undefined then
963 if Expression_Kind_Of (The_Variable) = Undefined then
964 Set_Expression_Kind_Of
965 (The_Variable, To => Expression_Kind_Of (Variable));
968 if Expression_Kind_Of (The_Variable) /=
969 Expression_Kind_Of (Variable)
971 Error_Msg ("wrong expression kind for variable """ &
972 Get_Name_String (Name_Of (The_Variable)) &
974 Expression_Location);
981 end Parse_Variable_Declaration;