?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-03-25 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / prj-dect.adb
blob2ce031046eef42499f02358def1cd22dff015d46
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-2013, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Err_Vars; use Err_Vars;
27 with Opt; use Opt;
28 with Prj.Attr; use Prj.Attr;
29 with Prj.Attr.PM; use Prj.Attr.PM;
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 Uintp; use Uintp;
35
36 with GNAT; use GNAT;
37 with GNAT.Case_Util; use GNAT.Case_Util;
38 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
39 with GNAT.Strings;
40
41 package body Prj.Dect is
42
43 type Zone is (In_Project, In_Package, In_Case_Construction);
44 -- Used to indicate if we are parsing a package (In_Package), a case
45 -- construction (In_Case_Construction) or none of those two (In_Project).
46
47 procedure Rename_Obsolescent_Attributes
48 (In_Tree : Project_Node_Tree_Ref;
49 Attribute : Project_Node_Id;
50 Current_Package : Project_Node_Id);
51 -- Rename obsolescent attributes in the tree. When the attribute has been
52 -- renamed since its initial introduction in the design of projects, we
53 -- replace the old name in the tree with the new name, so that the code
54 -- does not have to check both names forever.
55
56 procedure Check_Attribute_Allowed
57 (In_Tree : Project_Node_Tree_Ref;
58 Project : Project_Node_Id;
59 Attribute : Project_Node_Id;
60 Flags : Processing_Flags);
61 -- Check whether the attribute is valid in this project. In particular,
62 -- depending on the type of project (qualifier), some attributes might
63 -- be disabled.
64
65 procedure Check_Package_Allowed
66 (In_Tree : Project_Node_Tree_Ref;
67 Project : Project_Node_Id;
68 Current_Package : Project_Node_Id;
69 Flags : Processing_Flags);
70 -- Check whether the package is valid in this project
71
72 procedure Parse_Attribute_Declaration
73 (In_Tree : Project_Node_Tree_Ref;
74 Attribute : out Project_Node_Id;
75 First_Attribute : Attribute_Node_Id;
76 Current_Project : Project_Node_Id;
77 Current_Package : Project_Node_Id;
78 Packages_To_Check : String_List_Access;
79 Flags : Processing_Flags);
80 -- Parse an attribute declaration
81
82 procedure Parse_Case_Construction
83 (In_Tree : Project_Node_Tree_Ref;
84 Case_Construction : out Project_Node_Id;
85 First_Attribute : Attribute_Node_Id;
86 Current_Project : Project_Node_Id;
87 Current_Package : Project_Node_Id;
88 Packages_To_Check : String_List_Access;
89 Is_Config_File : Boolean;
90 Flags : Processing_Flags);
91 -- Parse a case construction
92
93 procedure Parse_Declarative_Items
94 (In_Tree : Project_Node_Tree_Ref;
95 Declarations : out Project_Node_Id;
96 In_Zone : Zone;
97 First_Attribute : Attribute_Node_Id;
98 Current_Project : Project_Node_Id;
99 Current_Package : Project_Node_Id;
100 Packages_To_Check : String_List_Access;
101 Is_Config_File : Boolean;
102 Flags : Processing_Flags);
103 -- Parse declarative items. Depending on In_Zone, some declarative items
104 -- may be forbidden. Is_Config_File should be set to True if the project
105 -- represents a config file (.cgpr) since some specific checks apply.
106
107 procedure Parse_Package_Declaration
108 (In_Tree : Project_Node_Tree_Ref;
109 Package_Declaration : out Project_Node_Id;
110 Current_Project : Project_Node_Id;
111 Packages_To_Check : String_List_Access;
112 Is_Config_File : Boolean;
113 Flags : Processing_Flags);
114 -- Parse a package declaration.
115 -- Is_Config_File should be set to True if the project represents a config
116 -- file (.cgpr) since some specific checks apply.
117
118 procedure Parse_String_Type_Declaration
119 (In_Tree : Project_Node_Tree_Ref;
120 String_Type : out Project_Node_Id;
121 Current_Project : Project_Node_Id;
122 Flags : Processing_Flags);
123 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
124
125 procedure Parse_Variable_Declaration
126 (In_Tree : Project_Node_Tree_Ref;
127 Variable : out Project_Node_Id;
128 Current_Project : Project_Node_Id;
129 Current_Package : Project_Node_Id;
130 Flags : Processing_Flags);
131 -- Parse a variable assignment
132 -- <variable_Name> := <expression>; OR
133 -- <variable_Name> : <string_type_Name> := <string_expression>;
134
135 -----------
136 -- Parse --
137 -----------
138
139 procedure Parse
140 (In_Tree : Project_Node_Tree_Ref;
141 Declarations : out Project_Node_Id;
142 Current_Project : Project_Node_Id;
143 Extends : Project_Node_Id;
144 Packages_To_Check : String_List_Access;
145 Is_Config_File : Boolean;
146 Flags : Processing_Flags)
147 is
148 First_Declarative_Item : Project_Node_Id := Empty_Node;
149
150 begin
151 Declarations :=
152 Default_Project_Node
153 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
154 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
155 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
156 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
157 Parse_Declarative_Items
158 (Declarations => First_Declarative_Item,
159 In_Tree => In_Tree,
160 In_Zone => In_Project,
161 First_Attribute => Prj.Attr.Attribute_First,
162 Current_Project => Current_Project,
163 Current_Package => Empty_Node,
164 Packages_To_Check => Packages_To_Check,
165 Is_Config_File => Is_Config_File,
166 Flags => Flags);
167 Set_First_Declarative_Item_Of
168 (Declarations, In_Tree, To => First_Declarative_Item);
169 end Parse;
170
171 -----------------------------------
172 -- Rename_Obsolescent_Attributes --
173 -----------------------------------
174
175 procedure Rename_Obsolescent_Attributes
176 (In_Tree : Project_Node_Tree_Ref;
177 Attribute : Project_Node_Id;
178 Current_Package : Project_Node_Id)
179 is
180 begin
181 if Present (Current_Package)
182 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
183 then
184 case Name_Of (Attribute, In_Tree) is
185 when Snames.Name_Specification =>
186 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
187
188 when Snames.Name_Specification_Suffix =>
189 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
190
191 when Snames.Name_Implementation =>
192 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
193
194 when Snames.Name_Implementation_Suffix =>
195 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
196
197 when others =>
198 null;
199 end case;
200 end if;
201 end Rename_Obsolescent_Attributes;
202
203 ---------------------------
204 -- Check_Package_Allowed --
205 ---------------------------
206
207 procedure Check_Package_Allowed
208 (In_Tree : Project_Node_Tree_Ref;
209 Project : Project_Node_Id;
210 Current_Package : Project_Node_Id;
211 Flags : Processing_Flags)
212 is
213 Qualif : constant Project_Qualifier :=
214 Project_Qualifier_Of (Project, In_Tree);
215 Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
216 begin
217 if Qualif in Aggregate_Project
218 and then Name /= Snames.Name_Builder
219 then
220 Error_Msg_Name_1 := Name;
221 Error_Msg
222 (Flags,
223 "package %% is forbidden in aggregate projects",
224 Location_Of (Current_Package, In_Tree));
225 end if;
226 end Check_Package_Allowed;
227
228 -----------------------------
229 -- Check_Attribute_Allowed --
230 -----------------------------
231
232 procedure Check_Attribute_Allowed
233 (In_Tree : Project_Node_Tree_Ref;
234 Project : Project_Node_Id;
235 Attribute : Project_Node_Id;
236 Flags : Processing_Flags)
237 is
238 Qualif : constant Project_Qualifier :=
239 Project_Qualifier_Of (Project, In_Tree);
240 Name : constant Name_Id := Name_Of (Attribute, In_Tree);
241
242 begin
243 case Qualif is
244 when Aggregate | Aggregate_Library =>
245 if Name = Snames.Name_Languages
246 or else Name = Snames.Name_Source_Files
247 or else Name = Snames.Name_Source_List_File
248 or else Name = Snames.Name_Locally_Removed_Files
249 or else Name = Snames.Name_Excluded_Source_Files
250 or else Name = Snames.Name_Excluded_Source_List_File
251 or else Name = Snames.Name_Interfaces
252 or else Name = Snames.Name_Object_Dir
253 or else Name = Snames.Name_Exec_Dir
254 or else Name = Snames.Name_Source_Dirs
255 or else Name = Snames.Name_Inherit_Source_Path
256 or else
257 (Qualif = Aggregate and then Name = Snames.Name_Library_Dir)
258 or else
259 (Qualif = Aggregate and then Name = Snames.Name_Library_Name)
260 or else Name = Snames.Name_Main
261 or else Name = Snames.Name_Roots
262 or else Name = Snames.Name_Externally_Built
263 or else Name = Snames.Name_Executable
264 or else Name = Snames.Name_Executable_Suffix
265 or else Name = Snames.Name_Default_Switches
266 then
267 Error_Msg_Name_1 := Name;
268 Error_Msg
269 (Flags,
270 "%% is not valid in aggregate projects",
271 Location_Of (Attribute, In_Tree));
272 end if;
273
274 when others =>
275 if Name = Snames.Name_Project_Files
276 or else Name = Snames.Name_Project_Path
277 or else Name = Snames.Name_External
278 then
279 Error_Msg_Name_1 := Name;
280 Error_Msg
281 (Flags,
282 "%% is only valid in aggregate projects",
283 Location_Of (Attribute, In_Tree));
284 end if;
285 end case;
286 end Check_Attribute_Allowed;
287
288 ---------------------------------
289 -- Parse_Attribute_Declaration --
290 ---------------------------------
291
292 procedure Parse_Attribute_Declaration
293 (In_Tree : Project_Node_Tree_Ref;
294 Attribute : out Project_Node_Id;
295 First_Attribute : Attribute_Node_Id;
296 Current_Project : Project_Node_Id;
297 Current_Package : Project_Node_Id;
298 Packages_To_Check : String_List_Access;
299 Flags : Processing_Flags)
300 is
301 Current_Attribute : Attribute_Node_Id := First_Attribute;
302 Full_Associative_Array : Boolean := False;
303 Attribute_Name : Name_Id := No_Name;
304 Optional_Index : Boolean := False;
305 Pkg_Id : Package_Node_Id := Empty_Package;
306
307 procedure Process_Attribute_Name;
308 -- Read the name of the attribute, and check its type
309
310 procedure Process_Associative_Array_Index;
311 -- Read the index of the associative array and check its validity
312
313 ----------------------------
314 -- Process_Attribute_Name --
315 ----------------------------
316
317 procedure Process_Attribute_Name is
318 Ignore : Boolean;
319
320 begin
321 Attribute_Name := Token_Name;
322 Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
323 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
324
325 -- Find the attribute
326
327 Current_Attribute :=
328 Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
329
330 -- If the attribute cannot be found, create the attribute if inside
331 -- an unknown package.
332
333 if Current_Attribute = Empty_Attribute then
334 if Present (Current_Package)
335 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
336 then
337 Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
338 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
339
340 else
341 -- If not a valid attribute name, issue an error if inside
342 -- a package that need to be checked.
343
344 Ignore := Present (Current_Package) and then
345 Packages_To_Check /= All_Packages;
346
347 if Ignore then
348
349 -- Check that we are not in a package to check
350
351 Get_Name_String (Name_Of (Current_Package, In_Tree));
352
353 for Index in Packages_To_Check'Range loop
354 if Name_Buffer (1 .. Name_Len) =
355 Packages_To_Check (Index).all
356 then
357 Ignore := False;
358 exit;
359 end if;
360 end loop;
361 end if;
362
363 if not Ignore then
364 Error_Msg_Name_1 := Token_Name;
365 Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
366 end if;
367 end if;
368
369 -- Set, if appropriate the index case insensitivity flag
370
371 else
372 if Is_Read_Only (Current_Attribute) then
373 Error_Msg_Name_1 := Token_Name;
374 Error_Msg
375 (Flags, "read-only attribute %% cannot be given a value",
376 Token_Ptr);
377 end if;
378
379 if Attribute_Kind_Of (Current_Attribute) in
380 All_Case_Insensitive_Associative_Array
381 then
382 Set_Case_Insensitive (Attribute, In_Tree, To => True);
383 end if;
384 end if;
385
386 Scan (In_Tree); -- past the attribute name
387
388 -- Set the expression kind of the attribute
389
390 if Current_Attribute /= Empty_Attribute then
391 Set_Expression_Kind_Of
392 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
393 Optional_Index := Optional_Index_Of (Current_Attribute);
394 end if;
395 end Process_Attribute_Name;
396
397 -------------------------------------
398 -- Process_Associative_Array_Index --
399 -------------------------------------
400
401 procedure Process_Associative_Array_Index is
402 begin
403 -- If the attribute is not an associative array attribute, report
404 -- an error. If this information is still unknown, set the kind
405 -- to Associative_Array.
406
407 if Current_Attribute /= Empty_Attribute
408 and then Attribute_Kind_Of (Current_Attribute) = Single
409 then
410 Error_Msg (Flags,
411 "the attribute """ &
412 Get_Name_String (Attribute_Name_Of (Current_Attribute))
413 & """ cannot be an associative array",
414 Location_Of (Attribute, In_Tree));
415
416 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
417 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
418 end if;
419
420 Scan (In_Tree); -- past the left parenthesis
421
422 if Others_Allowed_For (Current_Attribute)
423 and then Token = Tok_Others
424 then
425 Set_Associative_Array_Index_Of
426 (Attribute, In_Tree, All_Other_Names);
427 Scan (In_Tree); -- past others
428
429 else
430 if Others_Allowed_For (Current_Attribute) then
431 Expect (Tok_String_Literal, "literal string or others");
432 else
433 Expect (Tok_String_Literal, "literal string");
434 end if;
435
436 if Token = Tok_String_Literal then
437 Get_Name_String (Token_Name);
438
439 if Case_Insensitive (Attribute, In_Tree) then
440 To_Lower (Name_Buffer (1 .. Name_Len));
441 end if;
442
443 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
444 Scan (In_Tree); -- past the literal string index
445
446 if Token = Tok_At then
447 case Attribute_Kind_Of (Current_Attribute) is
448 when Optional_Index_Associative_Array |
449 Optional_Index_Case_Insensitive_Associative_Array =>
450 Scan (In_Tree);
451 Expect (Tok_Integer_Literal, "integer literal");
452
453 if Token = Tok_Integer_Literal then
454
455 -- Set the source index value from given literal
456
457 declare
458 Index : constant Int :=
459 UI_To_Int (Int_Literal_Value);
460 begin
461 if Index = 0 then
462 Error_Msg
463 (Flags, "index cannot be zero", Token_Ptr);
464 else
465 Set_Source_Index_Of
466 (Attribute, In_Tree, To => Index);
467 end if;
468 end;
469
470 Scan (In_Tree);
471 end if;
472
473 when others =>
474 Error_Msg (Flags, "index not allowed here", Token_Ptr);
475 Scan (In_Tree);
476
477 if Token = Tok_Integer_Literal then
478 Scan (In_Tree);
479 end if;
480 end case;
481 end if;
482 end if;
483 end if;
484
485 Expect (Tok_Right_Paren, "`)`");
486
487 if Token = Tok_Right_Paren then
488 Scan (In_Tree); -- past the right parenthesis
489 end if;
490 end Process_Associative_Array_Index;
491
492 begin
493 Attribute :=
494 Default_Project_Node
495 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
496 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
497 Set_Previous_Line_Node (Attribute);
498
499 -- Scan past "for"
500
501 Scan (In_Tree);
502
503 -- Body or External may be an attribute name
504
505 if Token = Tok_Body then
506 Token := Tok_Identifier;
507 Token_Name := Snames.Name_Body;
508 end if;
509
510 if Token = Tok_External then
511 Token := Tok_Identifier;
512 Token_Name := Snames.Name_External;
513 end if;
514
515 Expect (Tok_Identifier, "identifier");
516 Process_Attribute_Name;
517 Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
518 Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
519
520 -- Associative array attributes
521
522 if Token = Tok_Left_Paren then
523 Process_Associative_Array_Index;
524
525 else
526 -- If it is an associative array attribute and there are no left
527 -- parenthesis, then this is a full associative array declaration.
528 -- Flag it as such for later processing of its value.
529
530 if Current_Attribute /= Empty_Attribute
531 and then
532 Attribute_Kind_Of (Current_Attribute) /= Single
533 then
534 if Attribute_Kind_Of (Current_Attribute) = Unknown then
535 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
536
537 else
538 Full_Associative_Array := True;
539 end if;
540 end if;
541 end if;
542
543 Expect (Tok_Use, "USE");
544
545 if Token = Tok_Use then
546 Scan (In_Tree);
547
548 if Full_Associative_Array then
549
550 -- Expect <project>'<same_attribute_name>, or
551 -- <project>.<same_package_name>'<same_attribute_name>
552
553 declare
554 The_Project : Project_Node_Id := Empty_Node;
555 -- The node of the project where the associative array is
556 -- declared.
557
558 The_Package : Project_Node_Id := Empty_Node;
559 -- The node of the package where the associative array is
560 -- declared, if any.
561
562 Project_Name : Name_Id := No_Name;
563 -- The name of the project where the associative array is
564 -- declared.
565
566 Location : Source_Ptr := No_Location;
567 -- The location of the project name
568
569 begin
570 Expect (Tok_Identifier, "identifier");
571
572 if Token = Tok_Identifier then
573 Location := Token_Ptr;
574
575 -- Find the project node in the imported project or
576 -- in the project being extended.
577
578 The_Project := Imported_Or_Extended_Project_Of
579 (Current_Project, In_Tree, Token_Name);
580
581 if No (The_Project) then
582 Error_Msg (Flags, "unknown project", Location);
583 Scan (In_Tree); -- past the project name
584
585 else
586 Project_Name := Token_Name;
587 Scan (In_Tree); -- past the project name
588
589 -- If this is inside a package, a dot followed by the
590 -- name of the package must followed the project name.
591
592 if Present (Current_Package) then
593 Expect (Tok_Dot, "`.`");
594
595 if Token /= Tok_Dot then
596 The_Project := Empty_Node;
597
598 else
599 Scan (In_Tree); -- past the dot
600 Expect (Tok_Identifier, "identifier");
601
602 if Token /= Tok_Identifier then
603 The_Project := Empty_Node;
604
605 -- If it is not the same package name, issue error
606
607 elsif
608 Token_Name /= Name_Of (Current_Package, In_Tree)
609 then
610 The_Project := Empty_Node;
611 Error_Msg
612 (Flags, "not the same package as " &
613 Get_Name_String
614 (Name_Of (Current_Package, In_Tree)),
615 Token_Ptr);
616
617 else
618 The_Package :=
619 First_Package_Of (The_Project, In_Tree);
620
621 -- Look for the package node
622
623 while Present (The_Package)
624 and then
625 Name_Of (The_Package, In_Tree) /= Token_Name
626 loop
627 The_Package :=
628 Next_Package_In_Project
629 (The_Package, In_Tree);
630 end loop;
631
632 -- If the package cannot be found in the
633 -- project, issue an error.
634
635 if No (The_Package) then
636 The_Project := Empty_Node;
637 Error_Msg_Name_2 := Project_Name;
638 Error_Msg_Name_1 := Token_Name;
639 Error_Msg
640 (Flags,
641 "package % not declared in project %",
642 Token_Ptr);
643 end if;
644
645 Scan (In_Tree); -- past the package name
646 end if;
647 end if;
648 end if;
649 end if;
650 end if;
651
652 if Present (The_Project) then
653
654 -- Looking for '<same attribute name>
655
656 Expect (Tok_Apostrophe, "`''`");
657
658 if Token /= Tok_Apostrophe then
659 The_Project := Empty_Node;
660
661 else
662 Scan (In_Tree); -- past the apostrophe
663 Expect (Tok_Identifier, "identifier");
664
665 if Token /= Tok_Identifier then
666 The_Project := Empty_Node;
667
668 else
669 -- If it is not the same attribute name, issue error
670
671 if Token_Name /= Attribute_Name then
672 The_Project := Empty_Node;
673 Error_Msg_Name_1 := Attribute_Name;
674 Error_Msg
675 (Flags, "invalid name, should be %", Token_Ptr);
676 end if;
677
678 Scan (In_Tree); -- past the attribute name
679 end if;
680 end if;
681 end if;
682
683 if No (The_Project) then
684
685 -- If there were any problem, set the attribute id to null,
686 -- so that the node will not be recorded.
687
688 Current_Attribute := Empty_Attribute;
689
690 else
691 -- Set the appropriate field in the node.
692 -- Note that the index and the expression are nil. This
693 -- characterizes full associative array attribute
694 -- declarations.
695
696 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
697 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
698 end if;
699 end;
700
701 -- Other attribute declarations (not full associative array)
702
703 else
704 declare
705 Expression_Location : constant Source_Ptr := Token_Ptr;
706 -- The location of the first token of the expression
707
708 Expression : Project_Node_Id := Empty_Node;
709 -- The expression, value for the attribute declaration
710
711 begin
712 -- Get the expression value and set it in the attribute node
713
714 Parse_Expression
715 (In_Tree => In_Tree,
716 Expression => Expression,
717 Flags => Flags,
718 Current_Project => Current_Project,
719 Current_Package => Current_Package,
720 Optional_Index => Optional_Index);
721 Set_Expression_Of (Attribute, In_Tree, To => Expression);
722
723 -- If the expression is legal, but not of the right kind
724 -- for the attribute, issue an error.
725
726 if Current_Attribute /= Empty_Attribute
727 and then Present (Expression)
728 and then Variable_Kind_Of (Current_Attribute) /=
729 Expression_Kind_Of (Expression, In_Tree)
730 then
731 if Variable_Kind_Of (Current_Attribute) = Undefined then
732 Set_Variable_Kind_Of
733 (Current_Attribute,
734 To => Expression_Kind_Of (Expression, In_Tree));
735
736 else
737 Error_Msg
738 (Flags, "wrong expression kind for attribute """ &
739 Get_Name_String
740 (Attribute_Name_Of (Current_Attribute)) &
741 """",
742 Expression_Location);
743 end if;
744 end if;
745 end;
746 end if;
747 end if;
748
749 -- If the attribute was not recognized, return an empty node.
750 -- It may be that it is not in a package to check, and the node will
751 -- not be added to the tree.
752
753 if Current_Attribute = Empty_Attribute then
754 Attribute := Empty_Node;
755 end if;
756
757 Set_End_Of_Line (Attribute);
758 Set_Previous_Line_Node (Attribute);
759 end Parse_Attribute_Declaration;
760
761 -----------------------------
762 -- Parse_Case_Construction --
763 -----------------------------
764
765 procedure Parse_Case_Construction
766 (In_Tree : Project_Node_Tree_Ref;
767 Case_Construction : out Project_Node_Id;
768 First_Attribute : Attribute_Node_Id;
769 Current_Project : Project_Node_Id;
770 Current_Package : Project_Node_Id;
771 Packages_To_Check : String_List_Access;
772 Is_Config_File : Boolean;
773 Flags : Processing_Flags)
774 is
775 Current_Item : Project_Node_Id := Empty_Node;
776 Next_Item : Project_Node_Id := Empty_Node;
777 First_Case_Item : Boolean := True;
778
779 Variable_Location : Source_Ptr := No_Location;
780
781 String_Type : Project_Node_Id := Empty_Node;
782
783 Case_Variable : Project_Node_Id := Empty_Node;
784
785 First_Declarative_Item : Project_Node_Id := Empty_Node;
786
787 First_Choice : Project_Node_Id := Empty_Node;
788
789 When_Others : Boolean := False;
790 -- Set to True when there is a "when others =>" clause
791
792 begin
793 Case_Construction :=
794 Default_Project_Node
795 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
796 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
797
798 -- Scan past "case"
799
800 Scan (In_Tree);
801
802 -- Get the switch variable
803
804 Expect (Tok_Identifier, "identifier");
805
806 if Token = Tok_Identifier then
807 Variable_Location := Token_Ptr;
808 Parse_Variable_Reference
809 (In_Tree => In_Tree,
810 Variable => Case_Variable,
811 Flags => Flags,
812 Current_Project => Current_Project,
813 Current_Package => Current_Package);
814 Set_Case_Variable_Reference_Of
815 (Case_Construction, In_Tree, To => Case_Variable);
816
817 else
818 if Token /= Tok_Is then
819 Scan (In_Tree);
820 end if;
821 end if;
822
823 if Present (Case_Variable) then
824 String_Type := String_Type_Of (Case_Variable, In_Tree);
825
826 if No (String_Type) then
827 Error_Msg (Flags,
828 "variable """ &
829 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
830 """ is not typed",
831 Variable_Location);
832 end if;
833 end if;
834
835 Expect (Tok_Is, "IS");
836
837 if Token = Tok_Is then
838 Set_End_Of_Line (Case_Construction);
839 Set_Previous_Line_Node (Case_Construction);
840 Set_Next_End_Node (Case_Construction);
841
842 -- Scan past "is"
843
844 Scan (In_Tree);
845 end if;
846
847 Start_New_Case_Construction (In_Tree, String_Type);
848
849 When_Loop :
850
851 while Token = Tok_When loop
852
853 if First_Case_Item then
854 Current_Item :=
855 Default_Project_Node
856 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
857 Set_First_Case_Item_Of
858 (Case_Construction, In_Tree, To => Current_Item);
859 First_Case_Item := False;
860
861 else
862 Next_Item :=
863 Default_Project_Node
864 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
865 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
866 Current_Item := Next_Item;
867 end if;
868
869 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
870
871 -- Scan past "when"
872
873 Scan (In_Tree);
874
875 if Token = Tok_Others then
876 When_Others := True;
877
878 -- Scan past "others"
879
880 Scan (In_Tree);
881
882 Expect (Tok_Arrow, "`=>`");
883 Set_End_Of_Line (Current_Item);
884 Set_Previous_Line_Node (Current_Item);
885
886 -- Empty_Node in Field1 of a Case_Item indicates
887 -- the "when others =>" branch.
888
889 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
890
891 Parse_Declarative_Items
892 (In_Tree => In_Tree,
893 Declarations => First_Declarative_Item,
894 In_Zone => In_Case_Construction,
895 First_Attribute => First_Attribute,
896 Current_Project => Current_Project,
897 Current_Package => Current_Package,
898 Packages_To_Check => Packages_To_Check,
899 Is_Config_File => Is_Config_File,
900 Flags => Flags);
901
902 -- "when others =>" must be the last branch, so save the
903 -- Case_Item and exit
904
905 Set_First_Declarative_Item_Of
906 (Current_Item, In_Tree, To => First_Declarative_Item);
907 exit When_Loop;
908
909 else
910 Parse_Choice_List
911 (In_Tree => In_Tree,
912 First_Choice => First_Choice,
913 Flags => Flags);
914 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
915
916 Expect (Tok_Arrow, "`=>`");
917 Set_End_Of_Line (Current_Item);
918 Set_Previous_Line_Node (Current_Item);
919
920 Parse_Declarative_Items
921 (In_Tree => In_Tree,
922 Declarations => First_Declarative_Item,
923 In_Zone => In_Case_Construction,
924 First_Attribute => First_Attribute,
925 Current_Project => Current_Project,
926 Current_Package => Current_Package,
927 Packages_To_Check => Packages_To_Check,
928 Is_Config_File => Is_Config_File,
929 Flags => Flags);
930
931 Set_First_Declarative_Item_Of
932 (Current_Item, In_Tree, To => First_Declarative_Item);
933
934 end if;
935 end loop When_Loop;
936
937 End_Case_Construction
938 (Check_All_Labels => not When_Others and not Quiet_Output,
939 Case_Location => Location_Of (Case_Construction, In_Tree),
940 Flags => Flags);
941
942 Expect (Tok_End, "`END CASE`");
943 Remove_Next_End_Node;
944
945 if Token = Tok_End then
946
947 -- Scan past "end"
948
949 Scan (In_Tree);
950
951 Expect (Tok_Case, "CASE");
952
953 end if;
954
955 -- Scan past "case"
956
957 Scan (In_Tree);
958
959 Expect (Tok_Semicolon, "`;`");
960 Set_Previous_End_Node (Case_Construction);
961
962 end Parse_Case_Construction;
963
964 -----------------------------
965 -- Parse_Declarative_Items --
966 -----------------------------
967
968 procedure Parse_Declarative_Items
969 (In_Tree : Project_Node_Tree_Ref;
970 Declarations : out Project_Node_Id;
971 In_Zone : Zone;
972 First_Attribute : Attribute_Node_Id;
973 Current_Project : Project_Node_Id;
974 Current_Package : Project_Node_Id;
975 Packages_To_Check : String_List_Access;
976 Is_Config_File : Boolean;
977 Flags : Processing_Flags)
978 is
979 Current_Declarative_Item : Project_Node_Id := Empty_Node;
980 Next_Declarative_Item : Project_Node_Id := Empty_Node;
981 Current_Declaration : Project_Node_Id := Empty_Node;
982 Item_Location : Source_Ptr := No_Location;
983
984 begin
985 Declarations := Empty_Node;
986
987 loop
988 -- We are always positioned at the token that precedes the first
989 -- token of the declarative element. Scan past it.
990
991 Scan (In_Tree);
992
993 Item_Location := Token_Ptr;
994
995 case Token is
996 when Tok_Identifier =>
997
998 if In_Zone = In_Case_Construction then
999
1000 -- Check if the variable has already been declared
1001
1002 declare
1003 The_Variable : Project_Node_Id := Empty_Node;
1004
1005 begin
1006 if Present (Current_Package) then
1007 The_Variable :=
1008 First_Variable_Of (Current_Package, In_Tree);
1009 elsif Present (Current_Project) then
1010 The_Variable :=
1011 First_Variable_Of (Current_Project, In_Tree);
1012 end if;
1013
1014 while Present (The_Variable)
1015 and then Name_Of (The_Variable, In_Tree) /=
1016 Token_Name
1017 loop
1018 The_Variable := Next_Variable (The_Variable, In_Tree);
1019 end loop;
1020
1021 -- It is an error to declare a variable in a case
1022 -- construction for the first time.
1023
1024 if No (The_Variable) then
1025 Error_Msg
1026 (Flags,
1027 "a variable cannot be declared " &
1028 "for the first time here",
1029 Token_Ptr);
1030 end if;
1031 end;
1032 end if;
1033
1034 Parse_Variable_Declaration
1035 (In_Tree,
1036 Current_Declaration,
1037 Current_Project => Current_Project,
1038 Current_Package => Current_Package,
1039 Flags => Flags);
1040
1041 Set_End_Of_Line (Current_Declaration);
1042 Set_Previous_Line_Node (Current_Declaration);
1043
1044 when Tok_For =>
1045
1046 Parse_Attribute_Declaration
1047 (In_Tree => In_Tree,
1048 Attribute => Current_Declaration,
1049 First_Attribute => First_Attribute,
1050 Current_Project => Current_Project,
1051 Current_Package => Current_Package,
1052 Packages_To_Check => Packages_To_Check,
1053 Flags => Flags);
1054
1055 Set_End_Of_Line (Current_Declaration);
1056 Set_Previous_Line_Node (Current_Declaration);
1057
1058 when Tok_Null =>
1059
1060 Scan (In_Tree); -- past "null"
1061
1062 when Tok_Package =>
1063
1064 -- Package declaration
1065
1066 if In_Zone /= In_Project then
1067 Error_Msg
1068 (Flags, "a package cannot be declared here", Token_Ptr);
1069 end if;
1070
1071 Parse_Package_Declaration
1072 (In_Tree => In_Tree,
1073 Package_Declaration => Current_Declaration,
1074 Current_Project => Current_Project,
1075 Packages_To_Check => Packages_To_Check,
1076 Is_Config_File => Is_Config_File,
1077 Flags => Flags);
1078
1079 Set_Previous_End_Node (Current_Declaration);
1080
1081 when Tok_Type =>
1082
1083 -- Type String Declaration
1084
1085 if In_Zone /= In_Project then
1086 Error_Msg (Flags,
1087 "a string type cannot be declared here",
1088 Token_Ptr);
1089 end if;
1090
1091 Parse_String_Type_Declaration
1092 (In_Tree => In_Tree,
1093 String_Type => Current_Declaration,
1094 Current_Project => Current_Project,
1095 Flags => Flags);
1096
1097 Set_End_Of_Line (Current_Declaration);
1098 Set_Previous_Line_Node (Current_Declaration);
1099
1100 when Tok_Case =>
1101
1102 -- Case construction
1103
1104 Parse_Case_Construction
1105 (In_Tree => In_Tree,
1106 Case_Construction => Current_Declaration,
1107 First_Attribute => First_Attribute,
1108 Current_Project => Current_Project,
1109 Current_Package => Current_Package,
1110 Packages_To_Check => Packages_To_Check,
1111 Is_Config_File => Is_Config_File,
1112 Flags => Flags);
1113
1114 Set_Previous_End_Node (Current_Declaration);
1115
1116 when others =>
1117 exit;
1118
1119 -- We are leaving Parse_Declarative_Items positioned
1120 -- at the first token after the list of declarative items.
1121 -- It could be "end" (for a project, a package declaration or
1122 -- a case construction) or "when" (for a case construction)
1123
1124 end case;
1125
1126 Expect (Tok_Semicolon, "`;` after declarative items");
1127
1128 -- Insert an N_Declarative_Item in the tree, but only if
1129 -- Current_Declaration is not an empty node.
1130
1131 if Present (Current_Declaration) then
1132 if No (Current_Declarative_Item) then
1133 Current_Declarative_Item :=
1134 Default_Project_Node
1135 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1136 Declarations := Current_Declarative_Item;
1137
1138 else
1139 Next_Declarative_Item :=
1140 Default_Project_Node
1141 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
1142 Set_Next_Declarative_Item
1143 (Current_Declarative_Item, In_Tree,
1144 To => Next_Declarative_Item);
1145 Current_Declarative_Item := Next_Declarative_Item;
1146 end if;
1147
1148 Set_Current_Item_Node
1149 (Current_Declarative_Item, In_Tree,
1150 To => Current_Declaration);
1151 Set_Location_Of
1152 (Current_Declarative_Item, In_Tree, To => Item_Location);
1153 end if;
1154 end loop;
1155 end Parse_Declarative_Items;
1156
1157 -------------------------------
1158 -- Parse_Package_Declaration --
1159 -------------------------------
1160
1161 procedure Parse_Package_Declaration
1162 (In_Tree : Project_Node_Tree_Ref;
1163 Package_Declaration : out Project_Node_Id;
1164 Current_Project : Project_Node_Id;
1165 Packages_To_Check : String_List_Access;
1166 Is_Config_File : Boolean;
1167 Flags : Processing_Flags)
1168 is
1169 First_Attribute : Attribute_Node_Id := Empty_Attribute;
1170 Current_Package : Package_Node_Id := Empty_Package;
1171 First_Declarative_Item : Project_Node_Id := Empty_Node;
1172 Package_Location : constant Source_Ptr := Token_Ptr;
1173 Renaming : Boolean := False;
1174 Extending : Boolean := False;
1175
1176 begin
1177 Package_Declaration :=
1178 Default_Project_Node
1179 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
1180 Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
1181
1182 -- Scan past "package"
1183
1184 Scan (In_Tree);
1185 Expect (Tok_Identifier, "identifier");
1186
1187 if Token = Tok_Identifier then
1188 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
1189
1190 Current_Package := Package_Node_Id_Of (Token_Name);
1191
1192 if Current_Package = Empty_Package then
1193 if not Quiet_Output then
1194 declare
1195 List : constant Strings.String_List := Package_Name_List;
1196 Index : Natural;
1197 Name : constant String := Get_Name_String (Token_Name);
1198
1199 begin
1200 -- Check for possible misspelling of a known package name
1201
1202 Index := 0;
1203 loop
1204 if Index >= List'Last then
1205 Index := 0;
1206 exit;
1207 end if;
1208
1209 Index := Index + 1;
1210 exit when
1211 GNAT.Spelling_Checker.Is_Bad_Spelling_Of
1212 (Name, List (Index).all);
1213 end loop;
1214
1215 -- Issue warning(s) in verbose mode or when a possible
1216 -- misspelling has been found.
1217
1218 if Verbose_Mode or else Index /= 0 then
1219 Error_Msg (Flags,
1220 "?""" &
1221 Get_Name_String
1222 (Name_Of (Package_Declaration, In_Tree)) &
1223 """ is not a known package name",
1224 Token_Ptr);
1225 end if;
1226
1227 if Index /= 0 then
1228 Error_Msg -- CODEFIX
1229 (Flags,
1230 "\?possible misspelling of """ &
1231 List (Index).all & """", Token_Ptr);
1232 end if;
1233 end;
1234 end if;
1235
1236 -- Set the package declaration to "ignored" so that it is not
1237 -- processed by Prj.Proc.Process.
1238
1239 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1240
1241 -- Add the unknown package in the list of packages
1242
1243 Add_Unknown_Package (Token_Name, Current_Package);
1244
1245 elsif Current_Package = Unknown_Package then
1246
1247 -- Set the package declaration to "ignored" so that it is not
1248 -- processed by Prj.Proc.Process.
1249
1250 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1251
1252 else
1253 First_Attribute := First_Attribute_Of (Current_Package);
1254 end if;
1255
1256 Set_Package_Id_Of
1257 (Package_Declaration, In_Tree, To => Current_Package);
1258
1259 declare
1260 Current : Project_Node_Id :=
1261 First_Package_Of (Current_Project, In_Tree);
1262
1263 begin
1264 while Present (Current)
1265 and then Name_Of (Current, In_Tree) /= Token_Name
1266 loop
1267 Current := Next_Package_In_Project (Current, In_Tree);
1268 end loop;
1269
1270 if Present (Current) then
1271 Error_Msg
1272 (Flags,
1273 "package """ &
1274 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
1275 """ is declared twice in the same project",
1276 Token_Ptr);
1277
1278 else
1279 -- Add the package to the project list
1280
1281 Set_Next_Package_In_Project
1282 (Package_Declaration, In_Tree,
1283 To => First_Package_Of (Current_Project, In_Tree));
1284 Set_First_Package_Of
1285 (Current_Project, In_Tree, To => Package_Declaration);
1286 end if;
1287 end;
1288
1289 -- Scan past the package name
1290
1291 Scan (In_Tree);
1292 end if;
1293
1294 Check_Package_Allowed
1295 (In_Tree, Current_Project, Package_Declaration, Flags);
1296
1297 if Token = Tok_Renames then
1298 Renaming := True;
1299 elsif Token = Tok_Extends then
1300 Extending := True;
1301 end if;
1302
1303 if Renaming or else Extending then
1304 if Is_Config_File then
1305 Error_Msg
1306 (Flags,
1307 "no package rename or extension in configuration projects",
1308 Token_Ptr);
1309 end if;
1310
1311 -- Scan past "renames" or "extends"
1312
1313 Scan (In_Tree);
1314
1315 Expect (Tok_Identifier, "identifier");
1316
1317 if Token = Tok_Identifier then
1318 declare
1319 Project_Name : constant Name_Id := Token_Name;
1320
1321 Clause : Project_Node_Id :=
1322 First_With_Clause_Of (Current_Project, In_Tree);
1323 The_Project : Project_Node_Id := Empty_Node;
1324 Extended : constant Project_Node_Id :=
1325 Extended_Project_Of
1326 (Project_Declaration_Of
1327 (Current_Project, In_Tree),
1328 In_Tree);
1329 begin
1330 while Present (Clause) loop
1331 -- Only non limited imported projects may be used in a
1332 -- renames declaration.
1333
1334 The_Project :=
1335 Non_Limited_Project_Node_Of (Clause, In_Tree);
1336 exit when Present (The_Project)
1337 and then Name_Of (The_Project, In_Tree) = Project_Name;
1338 Clause := Next_With_Clause_Of (Clause, In_Tree);
1339 end loop;
1340
1341 if No (Clause) then
1342 -- As we have not found the project in the imports, we check
1343 -- if it's the name of an eventual extended project.
1344
1345 if Present (Extended)
1346 and then Name_Of (Extended, In_Tree) = Project_Name
1347 then
1348 Set_Project_Of_Renamed_Package_Of
1349 (Package_Declaration, In_Tree, To => Extended);
1350 else
1351 Error_Msg_Name_1 := Project_Name;
1352 Error_Msg
1353 (Flags,
1354 "% is not an imported or extended project", Token_Ptr);
1355 end if;
1356 else
1357 Set_Project_Of_Renamed_Package_Of
1358 (Package_Declaration, In_Tree, To => The_Project);
1359 end if;
1360 end;
1361
1362 Scan (In_Tree);
1363 Expect (Tok_Dot, "`.`");
1364
1365 if Token = Tok_Dot then
1366 Scan (In_Tree);
1367 Expect (Tok_Identifier, "identifier");
1368
1369 if Token = Tok_Identifier then
1370 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1371 Error_Msg (Flags, "not the same package name", Token_Ptr);
1372 elsif
1373 Present (Project_Of_Renamed_Package_Of
1374 (Package_Declaration, In_Tree))
1375 then
1376 declare
1377 Current : Project_Node_Id :=
1378 First_Package_Of
1379 (Project_Of_Renamed_Package_Of
1380 (Package_Declaration, In_Tree),
1381 In_Tree);
1382
1383 begin
1384 while Present (Current)
1385 and then Name_Of (Current, In_Tree) /= Token_Name
1386 loop
1387 Current :=
1388 Next_Package_In_Project (Current, In_Tree);
1389 end loop;
1390
1391 if No (Current) then
1392 Error_Msg
1393 (Flags, """" &
1394 Get_Name_String (Token_Name) &
1395 """ is not a package declared by the project",
1396 Token_Ptr);
1397 end if;
1398 end;
1399 end if;
1400
1401 Scan (In_Tree);
1402 end if;
1403 end if;
1404 end if;
1405 end if;
1406
1407 if Renaming then
1408 Expect (Tok_Semicolon, "`;`");
1409 Set_End_Of_Line (Package_Declaration);
1410 Set_Previous_Line_Node (Package_Declaration);
1411
1412 elsif Token = Tok_Is then
1413 Set_End_Of_Line (Package_Declaration);
1414 Set_Previous_Line_Node (Package_Declaration);
1415 Set_Next_End_Node (Package_Declaration);
1416
1417 Parse_Declarative_Items
1418 (In_Tree => In_Tree,
1419 Declarations => First_Declarative_Item,
1420 In_Zone => In_Package,
1421 First_Attribute => First_Attribute,
1422 Current_Project => Current_Project,
1423 Current_Package => Package_Declaration,
1424 Packages_To_Check => Packages_To_Check,
1425 Is_Config_File => Is_Config_File,
1426 Flags => Flags);
1427
1428 Set_First_Declarative_Item_Of
1429 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1430
1431 Expect (Tok_End, "END");
1432
1433 if Token = Tok_End then
1434
1435 -- Scan past "end"
1436
1437 Scan (In_Tree);
1438 end if;
1439
1440 -- We should have the name of the package after "end"
1441
1442 Expect (Tok_Identifier, "identifier");
1443
1444 if Token = Tok_Identifier
1445 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1446 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1447 then
1448 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1449 Error_Msg (Flags, "expected %%", Token_Ptr);
1450 end if;
1451
1452 if Token /= Tok_Semicolon then
1453
1454 -- Scan past the package name
1455
1456 Scan (In_Tree);
1457 end if;
1458
1459 Expect (Tok_Semicolon, "`;`");
1460 Remove_Next_End_Node;
1461
1462 else
1463 Error_Msg (Flags, "expected IS", Token_Ptr);
1464 end if;
1465
1466 end Parse_Package_Declaration;
1467
1468 -----------------------------------
1469 -- Parse_String_Type_Declaration --
1470 -----------------------------------
1471
1472 procedure Parse_String_Type_Declaration
1473 (In_Tree : Project_Node_Tree_Ref;
1474 String_Type : out Project_Node_Id;
1475 Current_Project : Project_Node_Id;
1476 Flags : Processing_Flags)
1477 is
1478 Current : Project_Node_Id := Empty_Node;
1479 First_String : Project_Node_Id := Empty_Node;
1480
1481 begin
1482 String_Type :=
1483 Default_Project_Node
1484 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1485
1486 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1487
1488 -- Scan past "type"
1489
1490 Scan (In_Tree);
1491
1492 Expect (Tok_Identifier, "identifier");
1493
1494 if Token = Tok_Identifier then
1495 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1496
1497 Current := First_String_Type_Of (Current_Project, In_Tree);
1498 while Present (Current)
1499 and then
1500 Name_Of (Current, In_Tree) /= Token_Name
1501 loop
1502 Current := Next_String_Type (Current, In_Tree);
1503 end loop;
1504
1505 if Present (Current) then
1506 Error_Msg (Flags,
1507 "duplicate string type name """ &
1508 Get_Name_String (Token_Name) &
1509 """",
1510 Token_Ptr);
1511 else
1512 Current := First_Variable_Of (Current_Project, In_Tree);
1513 while Present (Current)
1514 and then Name_Of (Current, In_Tree) /= Token_Name
1515 loop
1516 Current := Next_Variable (Current, In_Tree);
1517 end loop;
1518
1519 if Present (Current) then
1520 Error_Msg (Flags,
1521 """" &
1522 Get_Name_String (Token_Name) &
1523 """ is already a variable name", Token_Ptr);
1524 else
1525 Set_Next_String_Type
1526 (String_Type, In_Tree,
1527 To => First_String_Type_Of (Current_Project, In_Tree));
1528 Set_First_String_Type_Of
1529 (Current_Project, In_Tree, To => String_Type);
1530 end if;
1531 end if;
1532
1533 -- Scan past the name
1534
1535 Scan (In_Tree);
1536 end if;
1537
1538 Expect (Tok_Is, "IS");
1539
1540 if Token = Tok_Is then
1541 Scan (In_Tree);
1542 end if;
1543
1544 Expect (Tok_Left_Paren, "`(`");
1545
1546 if Token = Tok_Left_Paren then
1547 Scan (In_Tree);
1548 end if;
1549
1550 Parse_String_Type_List
1551 (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
1552 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1553
1554 Expect (Tok_Right_Paren, "`)`");
1555
1556 if Token = Tok_Right_Paren then
1557 Scan (In_Tree);
1558 end if;
1559
1560 end Parse_String_Type_Declaration;
1561
1562 --------------------------------
1563 -- Parse_Variable_Declaration --
1564 --------------------------------
1565
1566 procedure Parse_Variable_Declaration
1567 (In_Tree : Project_Node_Tree_Ref;
1568 Variable : out Project_Node_Id;
1569 Current_Project : Project_Node_Id;
1570 Current_Package : Project_Node_Id;
1571 Flags : Processing_Flags)
1572 is
1573 Expression_Location : Source_Ptr;
1574 String_Type_Name : Name_Id := No_Name;
1575 Project_String_Type_Name : Name_Id := No_Name;
1576 Type_Location : Source_Ptr := No_Location;
1577 Project_Location : Source_Ptr := No_Location;
1578 Expression : Project_Node_Id := Empty_Node;
1579 Variable_Name : constant Name_Id := Token_Name;
1580 OK : Boolean := True;
1581
1582 begin
1583 Variable :=
1584 Default_Project_Node
1585 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1586 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1587 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1588
1589 -- Scan past the variable name
1590
1591 Scan (In_Tree);
1592
1593 if Token = Tok_Colon then
1594
1595 -- Typed string variable declaration
1596
1597 Scan (In_Tree);
1598 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1599 Expect (Tok_Identifier, "identifier");
1600
1601 OK := Token = Tok_Identifier;
1602
1603 if OK then
1604 String_Type_Name := Token_Name;
1605 Type_Location := Token_Ptr;
1606 Scan (In_Tree);
1607
1608 if Token = Tok_Dot then
1609 Project_String_Type_Name := String_Type_Name;
1610 Project_Location := Type_Location;
1611
1612 -- Scan past the dot
1613
1614 Scan (In_Tree);
1615 Expect (Tok_Identifier, "identifier");
1616
1617 if Token = Tok_Identifier then
1618 String_Type_Name := Token_Name;
1619 Type_Location := Token_Ptr;
1620 Scan (In_Tree);
1621 else
1622 OK := False;
1623 end if;
1624 end if;
1625
1626 if OK then
1627 declare
1628 Proj : Project_Node_Id := Current_Project;
1629 Current : Project_Node_Id := Empty_Node;
1630
1631 begin
1632 if Project_String_Type_Name /= No_Name then
1633 declare
1634 The_Project_Name_And_Node : constant
1635 Tree_Private_Part.Project_Name_And_Node :=
1636 Tree_Private_Part.Projects_Htable.Get
1637 (In_Tree.Projects_HT, Project_String_Type_Name);
1638
1639 use Tree_Private_Part;
1640
1641 begin
1642 if The_Project_Name_And_Node =
1643 Tree_Private_Part.No_Project_Name_And_Node
1644 then
1645 Error_Msg (Flags,
1646 "unknown project """ &
1647 Get_Name_String
1648 (Project_String_Type_Name) &
1649 """",
1650 Project_Location);
1651 Current := Empty_Node;
1652 else
1653 Current :=
1654 First_String_Type_Of
1655 (The_Project_Name_And_Node.Node, In_Tree);
1656 while
1657 Present (Current)
1658 and then
1659 Name_Of (Current, In_Tree) /= String_Type_Name
1660 loop
1661 Current := Next_String_Type (Current, In_Tree);
1662 end loop;
1663 end if;
1664 end;
1665
1666 else
1667 -- Look for a string type with the correct name in this
1668 -- project or in any of its ancestors.
1669
1670 loop
1671 Current :=
1672 First_String_Type_Of (Proj, In_Tree);
1673 while
1674 Present (Current)
1675 and then
1676 Name_Of (Current, In_Tree) /= String_Type_Name
1677 loop
1678 Current := Next_String_Type (Current, In_Tree);
1679 end loop;
1680
1681 exit when Present (Current);
1682
1683 Proj := Parent_Project_Of (Proj, In_Tree);
1684 exit when No (Proj);
1685 end loop;
1686 end if;
1687
1688 if No (Current) then
1689 Error_Msg (Flags,
1690 "unknown string type """ &
1691 Get_Name_String (String_Type_Name) &
1692 """",
1693 Type_Location);
1694 OK := False;
1695
1696 else
1697 Set_String_Type_Of
1698 (Variable, In_Tree, To => Current);
1699 end if;
1700 end;
1701 end if;
1702 end if;
1703 end if;
1704
1705 Expect (Tok_Colon_Equal, "`:=`");
1706
1707 OK := OK and then Token = Tok_Colon_Equal;
1708
1709 if Token = Tok_Colon_Equal then
1710 Scan (In_Tree);
1711 end if;
1712
1713 -- Get the single string or string list value
1714
1715 Expression_Location := Token_Ptr;
1716
1717 Parse_Expression
1718 (In_Tree => In_Tree,
1719 Expression => Expression,
1720 Flags => Flags,
1721 Current_Project => Current_Project,
1722 Current_Package => Current_Package,
1723 Optional_Index => False);
1724 Set_Expression_Of (Variable, In_Tree, To => Expression);
1725
1726 if Present (Expression) then
1727 -- A typed string must have a single string value, not a list
1728
1729 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1730 and then Expression_Kind_Of (Expression, In_Tree) = List
1731 then
1732 Error_Msg
1733 (Flags,
1734 "expression must be a single string", Expression_Location);
1735 end if;
1736
1737 Set_Expression_Kind_Of
1738 (Variable, In_Tree,
1739 To => Expression_Kind_Of (Expression, In_Tree));
1740 end if;
1741
1742 if OK then
1743 declare
1744 The_Variable : Project_Node_Id := Empty_Node;
1745
1746 begin
1747 if Present (Current_Package) then
1748 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1749 elsif Present (Current_Project) then
1750 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1751 end if;
1752
1753 while Present (The_Variable)
1754 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1755 loop
1756 The_Variable := Next_Variable (The_Variable, In_Tree);
1757 end loop;
1758
1759 if No (The_Variable) then
1760 if Present (Current_Package) then
1761 Set_Next_Variable
1762 (Variable, In_Tree,
1763 To => First_Variable_Of (Current_Package, In_Tree));
1764 Set_First_Variable_Of
1765 (Current_Package, In_Tree, To => Variable);
1766
1767 elsif Present (Current_Project) then
1768 Set_Next_Variable
1769 (Variable, In_Tree,
1770 To => First_Variable_Of (Current_Project, In_Tree));
1771 Set_First_Variable_Of
1772 (Current_Project, In_Tree, To => Variable);
1773 end if;
1774
1775 else
1776 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1777 if Expression_Kind_Of (The_Variable, In_Tree) =
1778 Undefined
1779 then
1780 Set_Expression_Kind_Of
1781 (The_Variable, In_Tree,
1782 To => Expression_Kind_Of (Variable, In_Tree));
1783
1784 else
1785 if Expression_Kind_Of (The_Variable, In_Tree) /=
1786 Expression_Kind_Of (Variable, In_Tree)
1787 then
1788 Error_Msg (Flags,
1789 "wrong expression kind for variable """ &
1790 Get_Name_String
1791 (Name_Of (The_Variable, In_Tree)) &
1792 """",
1793 Expression_Location);
1794 end if;
1795 end if;
1796 end if;
1797 end if;
1798 end;
1799 end if;
1800 end Parse_Variable_Declaration;
1801
1802 end Prj.Dect;
Mirror of the offical gcc git repository hosted at gcc.gnu.org