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