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