1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Expander; use Expander;
32 with Exp_Ch6; use Exp_Ch6;
33 with Exp_Util; use Exp_Util;
34 with Freeze; use Freeze;
35 with Ghost; use Ghost;
37 with Lib.Xref; use Lib.Xref;
38 with Namet; use Namet;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
42 with Restrict; use Restrict;
43 with Rident; use Rident;
45 with Sem_Aux; use Sem_Aux;
46 with Sem_Case; use Sem_Case;
47 with Sem_Ch3; use Sem_Ch3;
48 with Sem_Ch6; use Sem_Ch6;
49 with Sem_Ch8; use Sem_Ch8;
50 with Sem_Dim; use Sem_Dim;
51 with Sem_Disp; use Sem_Disp;
52 with Sem_Elab; use Sem_Elab;
53 with Sem_Eval; use Sem_Eval;
54 with Sem_Res; use Sem_Res;
55 with Sem_Type; use Sem_Type;
56 with Sem_Util; use Sem_Util;
57 with Sem_Warn; use Sem_Warn;
58 with Snames; use Snames;
59 with Stand; use Stand;
60 with Sinfo; use Sinfo;
61 with Targparm; use Targparm;
62 with Tbuild; use Tbuild;
63 with Uintp; use Uintp;
65 package body Sem_Ch5 is
67 Current_Assignment : Node_Id := Empty;
68 -- This variable holds the node for an assignment that contains target
69 -- names. The corresponding flag has been set by the parser, and when
70 -- set the analysis of the RHS must be done with all expansion disabled,
71 -- because the assignment is reanalyzed after expansion has replaced all
72 -- occurrences of the target name appropriately.
74 Unblocked_Exit_Count : Nat := 0;
75 -- This variable is used when processing if statements, case statements,
76 -- and block statements. It counts the number of exit points that are not
77 -- blocked by unconditional transfer instructions: for IF and CASE, these
78 -- are the branches of the conditional; for a block, they are the statement
79 -- sequence of the block, and the statement sequences of any exception
80 -- handlers that are part of the block. When processing is complete, if
81 -- this count is zero, it means that control cannot fall through the IF,
82 -- CASE or block statement. This is used for the generation of warning
83 -- messages. This variable is recursively saved on entry to processing the
84 -- construct, and restored on exit.
86 function Has_Sec_Stack_Call (N : Node_Id) return Boolean;
87 -- N is the node for an arbitrary construct. This function searches the
88 -- construct N to see if any expressions within it contain function
89 -- calls that use the secondary stack, returning True if any such call
90 -- is found, and False otherwise.
92 procedure Preanalyze_Range (R_Copy : Node_Id);
93 -- Determine expected type of range or domain of iteration of Ada 2012
94 -- loop by analyzing separate copy. Do the analysis and resolution of the
95 -- copy of the bound(s) with expansion disabled, to prevent the generation
96 -- of finalization actions. This prevents memory leaks when the bounds
97 -- contain calls to functions returning controlled arrays or when the
98 -- domain of iteration is a container.
100 ------------------------
101 -- Analyze_Assignment --
102 ------------------------
104 -- WARNING: This routine manages Ghost regions. Return statements must be
105 -- replaced by gotos which jump to the end of the routine and restore the
108 procedure Analyze_Assignment (N : Node_Id) is
109 Lhs : constant Node_Id := Name (N);
110 Rhs : Node_Id := Expression (N);
112 procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
113 -- N is the node for the left hand side of an assignment, and it is not
114 -- a variable. This routine issues an appropriate diagnostic.
116 function Is_Protected_Part_Of_Constituent
117 (Nod : Node_Id) return Boolean;
118 -- Determine whether arbitrary node Nod denotes a Part_Of constituent of
119 -- a single protected type.
122 -- This is called to kill current value settings of a simple variable
123 -- on the left hand side. We call it if we find any error in analyzing
124 -- the assignment, and at the end of processing before setting any new
125 -- current values in place.
127 procedure Set_Assignment_Type
129 Opnd_Type : in out Entity_Id);
130 -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the
131 -- nominal subtype. This procedure is used to deal with cases where the
132 -- nominal subtype must be replaced by the actual subtype.
134 procedure Transform_BIP_Assignment (Typ : Entity_Id);
135 function Should_Transform_BIP_Assignment
136 (Typ : Entity_Id) return Boolean;
137 -- If the right-hand side of an assignment statement is a build-in-place
138 -- call we cannot build in place, so we insert a temp initialized with
139 -- the call, and transform the assignment statement to copy the temp.
140 -- Transform_BIP_Assignment does the tranformation, and
141 -- Should_Transform_BIP_Assignment determines whether we should.
142 -- The same goes for qualified expressions and conversions whose
143 -- operand is such a call.
145 -- This is only for nonlimited types; assignment statements are illegal
146 -- for limited types, but are generated internally for aggregates and
147 -- init procs. These limited-type are not really assignment statements
148 -- -- conceptually, they are initializations, so should not be
151 -- Similarly, for nonlimited types, aggregates and init procs generate
152 -- assignment statements that are really initializations. These are
153 -- marked No_Ctrl_Actions.
155 function Within_Function return Boolean;
156 -- Determine whether the current scope is a function or appears within
159 -------------------------------
160 -- Diagnose_Non_Variable_Lhs --
161 -------------------------------
163 procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
165 -- Not worth posting another error if left hand side already flagged
166 -- as being illegal in some respect.
168 if Error_Posted (N) then
171 -- Some special bad cases of entity names
173 elsif Is_Entity_Name (N) then
175 Ent : constant Entity_Id := Entity (N);
178 if Ekind (Ent) = E_Loop_Parameter
179 or else Is_Loop_Parameter (Ent)
181 Error_Msg_N ("assignment to loop parameter not allowed", N);
184 elsif Ekind (Ent) = E_In_Parameter then
186 ("assignment to IN mode parameter not allowed", N);
189 -- Renamings of protected private components are turned into
190 -- constants when compiling a protected function. In the case
191 -- of single protected types, the private component appears
194 elsif (Is_Prival (Ent) and then Within_Function)
196 (Ekind (Ent) = E_Component
197 and then Is_Protected_Type (Scope (Ent)))
200 ("protected function cannot modify protected object", N);
205 -- For indexed components, test prefix if it is in array. We do not
206 -- want to recurse for cases where the prefix is a pointer, since we
207 -- may get a message confusing the pointer and what it references.
209 elsif Nkind (N) = N_Indexed_Component
210 and then Is_Array_Type (Etype (Prefix (N)))
212 Diagnose_Non_Variable_Lhs (Prefix (N));
215 -- Another special case for assignment to discriminant
217 elsif Nkind (N) = N_Selected_Component then
218 if Present (Entity (Selector_Name (N)))
219 and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
221 Error_Msg_N ("assignment to discriminant not allowed", N);
224 -- For selection from record, diagnose prefix, but note that again
225 -- we only do this for a record, not e.g. for a pointer.
227 elsif Is_Record_Type (Etype (Prefix (N))) then
228 Diagnose_Non_Variable_Lhs (Prefix (N));
233 -- If we fall through, we have no special message to issue
235 Error_Msg_N ("left hand side of assignment must be a variable", N);
236 end Diagnose_Non_Variable_Lhs;
238 --------------------------------------
239 -- Is_Protected_Part_Of_Constituent --
240 --------------------------------------
242 function Is_Protected_Part_Of_Constituent
243 (Nod : Node_Id) return Boolean
245 Encap_Id : Entity_Id;
249 -- Abstract states and variables may act as Part_Of constituents of
250 -- single protected types, however only variables can be modified by
253 if Is_Entity_Name (Nod) then
254 Var_Id := Entity (Nod);
256 if Present (Var_Id) and then Ekind (Var_Id) = E_Variable then
257 Encap_Id := Encapsulating_State (Var_Id);
259 -- To qualify, the node must denote a reference to a variable
260 -- whose encapsulating state is a single protected object.
264 and then Is_Single_Protected_Object (Encap_Id);
269 end Is_Protected_Part_Of_Constituent;
275 procedure Kill_Lhs is
277 if Is_Entity_Name (Lhs) then
279 Ent : constant Entity_Id := Entity (Lhs);
281 if Present (Ent) then
282 Kill_Current_Values (Ent);
288 -------------------------
289 -- Set_Assignment_Type --
290 -------------------------
292 procedure Set_Assignment_Type
294 Opnd_Type : in out Entity_Id)
299 Require_Entity (Opnd);
301 -- If the assignment operand is an in-out or out parameter, then we
302 -- get the actual subtype (needed for the unconstrained case). If the
303 -- operand is the actual in an entry declaration, then within the
304 -- accept statement it is replaced with a local renaming, which may
305 -- also have an actual subtype.
307 if Is_Entity_Name (Opnd)
308 and then (Ekind (Entity (Opnd)) = E_Out_Parameter
309 or else Ekind_In (Entity (Opnd),
311 E_Generic_In_Out_Parameter)
313 (Ekind (Entity (Opnd)) = E_Variable
314 and then Nkind (Parent (Entity (Opnd))) =
315 N_Object_Renaming_Declaration
316 and then Nkind (Parent (Parent (Entity (Opnd)))) =
319 Opnd_Type := Get_Actual_Subtype (Opnd);
321 -- If assignment operand is a component reference, then we get the
322 -- actual subtype of the component for the unconstrained case.
324 elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
325 and then not Is_Unchecked_Union (Opnd_Type)
327 Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
329 if Present (Decl) then
330 Insert_Action (N, Decl);
331 Mark_Rewrite_Insertion (Decl);
333 Opnd_Type := Defining_Identifier (Decl);
334 Set_Etype (Opnd, Opnd_Type);
335 Freeze_Itype (Opnd_Type, N);
337 elsif Is_Constrained (Etype (Opnd)) then
338 Opnd_Type := Etype (Opnd);
341 -- For slice, use the constrained subtype created for the slice
343 elsif Nkind (Opnd) = N_Slice then
344 Opnd_Type := Etype (Opnd);
346 end Set_Assignment_Type;
348 -------------------------------------
349 -- Should_Transform_BIP_Assignment --
350 -------------------------------------
352 function Should_Transform_BIP_Assignment
353 (Typ : Entity_Id) return Boolean
359 and then not Is_Limited_View (Typ)
360 and then Is_Build_In_Place_Result_Type (Typ)
361 and then not No_Ctrl_Actions (N)
363 -- This function is called early, before name resolution is
364 -- complete, so we have to deal with things that might turn into
365 -- function calls later. N_Function_Call and N_Op nodes are the
366 -- obvious case. An N_Identifier or N_Expanded_Name is a
367 -- parameterless function call if it denotes a function.
368 -- Finally, an attribute reference can be a function call.
370 case Nkind (Unqual_Conv (Rhs)) is
379 case Ekind (Entity (Unqual_Conv (Rhs))) is
389 when N_Attribute_Reference =>
390 Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
391 -- T'Input will turn into a call whose result type is T
401 end Should_Transform_BIP_Assignment;
403 ------------------------------
404 -- Transform_BIP_Assignment --
405 ------------------------------
407 procedure Transform_BIP_Assignment (Typ : Entity_Id) is
409 -- Tranform "X : [constant] T := F (...);" into:
411 -- Temp : constant T := F (...);
414 Loc : constant Source_Ptr := Sloc (N);
415 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs);
416 Obj_Decl : constant Node_Id :=
417 Make_Object_Declaration (Loc,
418 Defining_Identifier => Def_Id,
419 Constant_Present => True,
420 Object_Definition => New_Occurrence_Of (Typ, Loc),
422 Has_Init_Expression => True);
425 Set_Etype (Def_Id, Typ);
426 Set_Expression (N, New_Occurrence_Of (Def_Id, Loc));
428 -- At this point, Rhs is no longer equal to Expression (N), so:
430 Rhs := Expression (N);
432 Insert_Action (N, Obj_Decl);
433 end Transform_BIP_Assignment;
435 ---------------------
436 -- Within_Function --
437 ---------------------
439 function Within_Function return Boolean is
440 Scop_Id : constant Entity_Id := Current_Scope;
443 if Ekind (Scop_Id) = E_Function then
446 elsif Ekind (Enclosing_Dynamic_Scope (Scop_Id)) = E_Function then
455 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
456 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
457 -- Save the Ghost-related attributes to restore on exit
462 Save_Full_Analysis : Boolean := False;
463 -- Force initialization to facilitate static analysis
465 -- Start of processing for Analyze_Assignment
468 Mark_Coextensions (N, Rhs);
470 -- Preserve relevant elaboration-related attributes of the context which
471 -- are no longer available or very expensive to recompute once analysis,
472 -- resolution, and expansion are over.
474 Mark_Elaboration_Attributes
479 -- An assignment statement is Ghost when the left hand side denotes a
480 -- Ghost entity. Set the mode now to ensure that any nodes generated
481 -- during analysis and expansion are properly marked as Ghost.
483 Mark_And_Set_Ghost_Assignment (N);
485 if Has_Target_Names (N) then
486 Current_Assignment := N;
487 Expander_Mode_Save_And_Set (False);
488 Save_Full_Analysis := Full_Analysis;
489 Full_Analysis := False;
491 Current_Assignment := Empty;
497 -- Ensure that we never do an assignment on a variable marked as
498 -- Is_Safe_To_Reevaluate.
501 (not Is_Entity_Name (Lhs)
502 or else Ekind (Entity (Lhs)) /= E_Variable
503 or else not Is_Safe_To_Reevaluate (Entity (Lhs)));
505 -- Start type analysis for assignment
509 -- In the most general case, both Lhs and Rhs can be overloaded, and we
510 -- must compute the intersection of the possible types on each side.
512 if Is_Overloaded (Lhs) then
519 Get_First_Interp (Lhs, I, It);
521 while Present (It.Typ) loop
523 -- An indexed component with generalized indexing is always
524 -- overloaded with the corresponding dereference. Discard the
525 -- interpretation that yields a reference type, which is not
528 if Nkind (Lhs) = N_Indexed_Component
529 and then Present (Generalized_Indexing (Lhs))
530 and then Has_Implicit_Dereference (It.Typ)
534 -- This may be a call to a parameterless function through an
535 -- implicit dereference, so discard interpretation as well.
537 elsif Is_Entity_Name (Lhs)
538 and then Has_Implicit_Dereference (It.Typ)
542 elsif Has_Compatible_Type (Rhs, It.Typ) then
543 if T1 = Any_Type then
546 -- An explicit dereference is overloaded if the prefix
547 -- is. Try to remove the ambiguity on the prefix, the
548 -- error will be posted there if the ambiguity is real.
550 if Nkind (Lhs) = N_Explicit_Dereference then
553 PI1 : Interp_Index := 0;
559 Get_First_Interp (Prefix (Lhs), PI, PIt);
561 while Present (PIt.Typ) loop
562 if Is_Access_Type (PIt.Typ)
563 and then Has_Compatible_Type
564 (Rhs, Designated_Type (PIt.Typ))
568 Disambiguate (Prefix (Lhs),
571 if PIt = No_Interp then
573 ("ambiguous left-hand side in "
574 & "assignment", Lhs);
577 Resolve (Prefix (Lhs), PIt.Typ);
587 Get_Next_Interp (PI, PIt);
593 ("ambiguous left-hand side in assignment", Lhs);
599 Get_Next_Interp (I, It);
603 if T1 = Any_Type then
605 ("no valid types for left-hand side for assignment", Lhs);
611 -- Deal with build-in-place calls for nonlimited types. We don't do this
612 -- later, because resolving the rhs tranforms it incorrectly for build-
615 if Should_Transform_BIP_Assignment (Typ => T1) then
617 -- In certain cases involving user-defined concatenation operators,
618 -- we need to resolve the right-hand side before transforming the
621 case Nkind (Unqual_Conv (Rhs)) is
622 when N_Function_Call =>
625 First (Parameter_Associations (Unqual_Conv (Rhs)));
626 Actual_Exp : Node_Id;
629 while Present (Actual) loop
630 if Nkind (Actual) = N_Parameter_Association then
631 Actual_Exp := Explicit_Actual_Parameter (Actual);
633 Actual_Exp := Actual;
636 if Nkind (Actual_Exp) = N_Op_Concat then
645 when N_Attribute_Reference
656 Transform_BIP_Assignment (Typ => T1);
659 pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
661 -- The resulting assignment type is T1, so now we will resolve the left
662 -- hand side of the assignment using this determined type.
666 -- Cases where Lhs is not a variable. In an instance or an inlined body
667 -- no need for further check because assignment was legal in template.
669 if In_Inlined_Body then
672 elsif not Is_Variable (Lhs) then
674 -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a
682 if Ada_Version >= Ada_2005 then
684 -- Handle chains of renamings
687 while Nkind (Ent) in N_Has_Entity
688 and then Present (Entity (Ent))
689 and then Present (Renamed_Object (Entity (Ent)))
691 Ent := Renamed_Object (Entity (Ent));
694 if (Nkind (Ent) = N_Attribute_Reference
695 and then Attribute_Name (Ent) = Name_Priority)
697 -- Renamings of the attribute Priority applied to protected
698 -- objects have been previously expanded into calls to the
699 -- Get_Ceiling run-time subprogram.
701 or else Is_Expanded_Priority_Attribute (Ent)
703 -- The enclosing subprogram cannot be a protected function
706 while not (Is_Subprogram (S)
707 and then Convention (S) = Convention_Protected)
708 and then S /= Standard_Standard
713 if Ekind (S) = E_Function
714 and then Convention (S) = Convention_Protected
717 ("protected function cannot modify protected object",
721 -- Changes of the ceiling priority of the protected object
722 -- are only effective if the Ceiling_Locking policy is in
723 -- effect (AARM D.5.2 (5/2)).
725 if Locking_Policy /= 'C' then
727 ("assignment to the attribute PRIORITY has no effect??",
730 ("\since no Locking_Policy has been specified??", Lhs);
738 Diagnose_Non_Variable_Lhs (Lhs);
741 -- Error of assigning to limited type. We do however allow this in
742 -- certain cases where the front end generates the assignments.
744 elsif Is_Limited_Type (T1)
745 and then not Assignment_OK (Lhs)
746 and then not Assignment_OK (Original_Node (Lhs))
748 -- CPP constructors can only be called in declarations
750 if Is_CPP_Constructor_Call (Rhs) then
751 Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
754 ("left hand of assignment must not be limited type", Lhs);
755 Explain_Limited_Type (T1, Lhs);
760 -- A class-wide type may be a limited view. This illegal case is not
761 -- caught by previous checks.
763 elsif Ekind (T1) = E_Class_Wide_Type and then From_Limited_With (T1) then
764 Error_Msg_NE ("invalid use of limited view of&", Lhs, T1);
767 -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be
768 -- abstract. This is only checked when the assignment Comes_From_Source,
769 -- because in some cases the expander generates such assignments (such
770 -- in the _assign operation for an abstract type).
772 elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then
774 ("target of assignment operation must not be abstract", Lhs);
777 -- Variables which are Part_Of constituents of single protected types
778 -- behave in similar fashion to protected components. Such variables
779 -- cannot be modified by protected functions.
781 if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then
783 ("protected function cannot modify protected object", Lhs);
786 -- Resolution may have updated the subtype, in case the left-hand side
787 -- is a private protected component. Use the correct subtype to avoid
788 -- scoping issues in the back-end.
792 -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
793 -- type. For example:
797 -- type Acc is access P.T;
800 -- with Pkg; use Acc;
801 -- procedure Example is
804 -- A.all := B.all; -- ERROR
807 if Nkind (Lhs) = N_Explicit_Dereference
808 and then Ekind (T1) = E_Incomplete_Type
810 Error_Msg_N ("invalid use of incomplete type", Lhs);
815 -- Now we can complete the resolution of the right hand side
817 Set_Assignment_Type (Lhs, T1);
819 -- If the target of the assignment is an entity of a mutable type and
820 -- the expression is a conditional expression, its alternatives can be
821 -- of different subtypes of the nominal type of the LHS, so they must be
822 -- resolved with the base type, given that their subtype may differ from
823 -- that of the target mutable object.
825 if Is_Entity_Name (Lhs)
826 and then Ekind_In (Entity (Lhs), E_In_Out_Parameter,
829 and then Is_Composite_Type (T1)
830 and then not Is_Constrained (Etype (Entity (Lhs)))
831 and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression)
833 Resolve (Rhs, Base_Type (T1));
839 -- This is the point at which we check for an unset reference
841 Check_Unset_Reference (Rhs);
842 Check_Unprotected_Access (Lhs, Rhs);
844 -- Remaining steps are skipped if Rhs was syntactically in error
853 if not Covers (T1, T2) then
854 Wrong_Type (Rhs, Etype (Lhs));
859 -- Ada 2005 (AI-326): In case of explicit dereference of incomplete
860 -- types, use the non-limited view if available
862 if Nkind (Rhs) = N_Explicit_Dereference
863 and then Is_Tagged_Type (T2)
864 and then Has_Non_Limited_View (T2)
866 T2 := Non_Limited_View (T2);
869 Set_Assignment_Type (Rhs, T2);
871 if Total_Errors_Detected /= 0 then
881 if T1 = Any_Type or else T2 = Any_Type then
886 -- If the rhs is class-wide or dynamically tagged, then require the lhs
887 -- to be class-wide. The case where the rhs is a dynamically tagged call
888 -- to a dispatching operation with a controlling access result is
889 -- excluded from this check, since the target has an access type (and
890 -- no tag propagation occurs in that case).
892 if (Is_Class_Wide_Type (T2)
893 or else (Is_Dynamically_Tagged (Rhs)
894 and then not Is_Access_Type (T1)))
895 and then not Is_Class_Wide_Type (T1)
897 Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
899 elsif Is_Class_Wide_Type (T1)
900 and then not Is_Class_Wide_Type (T2)
901 and then not Is_Tag_Indeterminate (Rhs)
902 and then not Is_Dynamically_Tagged (Rhs)
904 Error_Msg_N ("dynamically tagged expression required!", Rhs);
907 -- Propagate the tag from a class-wide target to the rhs when the rhs
908 -- is a tag-indeterminate call.
910 if Is_Tag_Indeterminate (Rhs) then
911 if Is_Class_Wide_Type (T1) then
912 Propagate_Tag (Lhs, Rhs);
914 elsif Nkind (Rhs) = N_Function_Call
915 and then Is_Entity_Name (Name (Rhs))
916 and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
919 ("call to abstract function must be dispatching", Name (Rhs));
921 elsif Nkind (Rhs) = N_Qualified_Expression
922 and then Nkind (Expression (Rhs)) = N_Function_Call
923 and then Is_Entity_Name (Name (Expression (Rhs)))
925 Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
928 ("call to abstract function must be dispatching",
929 Name (Expression (Rhs)));
933 -- Ada 2005 (AI-385): When the lhs type is an anonymous access type,
934 -- apply an implicit conversion of the rhs to that type to force
935 -- appropriate static and run-time accessibility checks. This applies
936 -- as well to anonymous access-to-subprogram types that are component
937 -- subtypes or formal parameters.
939 if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then
940 if Is_Local_Anonymous_Access (T1)
941 or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
943 -- Handle assignment to an Ada 2012 stand-alone object
944 -- of an anonymous access type.
946 or else (Ekind (T1) = E_Anonymous_Access_Type
947 and then Nkind (Associated_Node_For_Itype (T1)) =
948 N_Object_Declaration)
951 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
952 Analyze_And_Resolve (Rhs, T1);
956 -- Ada 2005 (AI-231): Assignment to not null variable
958 if Ada_Version >= Ada_2005
959 and then Can_Never_Be_Null (T1)
960 and then not Assignment_OK (Lhs)
962 -- Case where we know the right hand side is null
964 if Known_Null (Rhs) then
965 Apply_Compile_Time_Constraint_Error
968 "(Ada 2005) null not allowed in null-excluding objects??",
969 Reason => CE_Null_Not_Allowed);
971 -- We still mark this as a possible modification, that's necessary
972 -- to reset Is_True_Constant, and desirable for xref purposes.
974 Note_Possible_Modification (Lhs, Sure => True);
977 -- If we know the right hand side is non-null, then we convert to the
978 -- target type, since we don't need a run time check in that case.
980 elsif not Can_Never_Be_Null (T2) then
981 Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
982 Analyze_And_Resolve (Rhs, T1);
986 if Is_Scalar_Type (T1) then
987 Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
989 -- For array types, verify that lengths match. If the right hand side
990 -- is a function call that has been inlined, the assignment has been
991 -- rewritten as a block, and the constraint check will be applied to the
992 -- assignment within the block.
994 elsif Is_Array_Type (T1)
995 and then (Nkind (Rhs) /= N_Type_Conversion
996 or else Is_Constrained (Etype (Rhs)))
997 and then (Nkind (Rhs) /= N_Function_Call
998 or else Nkind (N) /= N_Block_Statement)
1000 -- Assignment verifies that the length of the Lsh and Rhs are equal,
1001 -- but of course the indexes do not have to match. If the right-hand
1002 -- side is a type conversion to an unconstrained type, a length check
1003 -- is performed on the expression itself during expansion. In rare
1004 -- cases, the redundant length check is computed on an index type
1005 -- with a different representation, triggering incorrect code in the
1008 Apply_Length_Check (Rhs, Etype (Lhs));
1011 -- Discriminant checks are applied in the course of expansion
1016 -- Note: modifications of the Lhs may only be recorded after
1017 -- checks have been applied.
1019 Note_Possible_Modification (Lhs, Sure => True);
1021 -- ??? a real accessibility check is needed when ???
1023 -- Post warning for redundant assignment or variable to itself
1025 if Warn_On_Redundant_Constructs
1027 -- We only warn for source constructs
1029 and then Comes_From_Source (N)
1031 -- Where the object is the same on both sides
1033 and then Same_Object (Lhs, Original_Node (Rhs))
1035 -- But exclude the case where the right side was an operation that
1036 -- got rewritten (e.g. JUNK + K, where K was known to be zero). We
1037 -- don't want to warn in such a case, since it is reasonable to write
1038 -- such expressions especially when K is defined symbolically in some
1041 and then Nkind (Original_Node (Rhs)) not in N_Op
1043 if Nkind (Lhs) in N_Has_Entity then
1044 Error_Msg_NE -- CODEFIX
1045 ("?r?useless assignment of & to itself!", N, Entity (Lhs));
1047 Error_Msg_N -- CODEFIX
1048 ("?r?useless assignment of object to itself!", N);
1052 -- Check for non-allowed composite assignment
1054 if not Support_Composite_Assign_On_Target
1055 and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
1056 and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
1058 Error_Msg_CRT ("composite assignment", N);
1061 -- Check elaboration warning for left side if not in elab code
1063 if Legacy_Elaboration_Checks
1064 and not In_Subprogram_Or_Concurrent_Unit
1066 Check_Elab_Assign (Lhs);
1069 -- Save the scenario for later examination by the ABE Processing phase
1071 Record_Elaboration_Scenario (N);
1073 -- Set Referenced_As_LHS if appropriate. We only set this flag if the
1074 -- assignment is a source assignment in the extended main source unit.
1075 -- We are not interested in any reference information outside this
1076 -- context, or in compiler generated assignment statements.
1078 if Comes_From_Source (N)
1079 and then In_Extended_Main_Source_Unit (Lhs)
1081 Set_Referenced_Modified (Lhs, Out_Param => False);
1084 -- RM 7.3.2 (12/3): An assignment to a view conversion (from a type to
1085 -- one of its ancestors) requires an invariant check. Apply check only
1086 -- if expression comes from source, otherwise it will be applied when
1087 -- value is assigned to source entity. This is not done in GNATprove
1088 -- mode, as GNATprove handles invariant checks itself.
1090 if Nkind (Lhs) = N_Type_Conversion
1091 and then Has_Invariants (Etype (Expression (Lhs)))
1092 and then Comes_From_Source (Expression (Lhs))
1093 and then not GNATprove_Mode
1095 Insert_After (N, Make_Invariant_Call (Expression (Lhs)));
1098 -- Final step. If left side is an entity, then we may be able to reset
1099 -- the current tracked values to new safe values. We only have something
1100 -- to do if the left side is an entity name, and expansion has not
1101 -- modified the node into something other than an assignment, and of
1102 -- course we only capture values if it is safe to do so.
1104 if Is_Entity_Name (Lhs)
1105 and then Nkind (N) = N_Assignment_Statement
1108 Ent : constant Entity_Id := Entity (Lhs);
1111 if Safe_To_Capture_Value (N, Ent) then
1113 -- If simple variable on left side, warn if this assignment
1114 -- blots out another one (rendering it useless). We only do
1115 -- this for source assignments, otherwise we can generate bogus
1116 -- warnings when an assignment is rewritten as another
1117 -- assignment, and gets tied up with itself.
1119 -- There may have been a previous reference to a component of
1120 -- the variable, which in general removes the Last_Assignment
1121 -- field of the variable to indicate a relevant use of the
1122 -- previous assignment. However, if the assignment is to a
1123 -- subcomponent the reference may not have registered, because
1124 -- it is not possible to determine whether the context is an
1125 -- assignment. In those cases we generate a Deferred_Reference,
1126 -- to be used at the end of compilation to generate the right
1127 -- kind of reference, and we suppress a potential warning for
1128 -- a useless assignment, which might be premature. This may
1129 -- lose a warning in rare cases, but seems preferable to a
1130 -- misleading warning.
1132 if Warn_On_Modified_Unread
1133 and then Is_Assignable (Ent)
1134 and then Comes_From_Source (N)
1135 and then In_Extended_Main_Source_Unit (Ent)
1136 and then not Has_Deferred_Reference (Ent)
1138 Warn_On_Useless_Assignment (Ent, N);
1141 -- If we are assigning an access type and the left side is an
1142 -- entity, then make sure that the Is_Known_[Non_]Null flags
1143 -- properly reflect the state of the entity after assignment.
1145 if Is_Access_Type (T1) then
1146 if Known_Non_Null (Rhs) then
1147 Set_Is_Known_Non_Null (Ent, True);
1149 elsif Known_Null (Rhs)
1150 and then not Can_Never_Be_Null (Ent)
1152 Set_Is_Known_Null (Ent, True);
1155 Set_Is_Known_Null (Ent, False);
1157 if not Can_Never_Be_Null (Ent) then
1158 Set_Is_Known_Non_Null (Ent, False);
1162 -- For discrete types, we may be able to set the current value
1163 -- if the value is known at compile time.
1165 elsif Is_Discrete_Type (T1)
1166 and then Compile_Time_Known_Value (Rhs)
1168 Set_Current_Value (Ent, Rhs);
1170 Set_Current_Value (Ent, Empty);
1173 -- If not safe to capture values, kill them
1181 -- If assigning to an object in whole or in part, note location of
1182 -- assignment in case no one references value. We only do this for
1183 -- source assignments, otherwise we can generate bogus warnings when an
1184 -- assignment is rewritten as another assignment, and gets tied up with
1188 Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
1191 and then Safe_To_Capture_Value (N, Ent)
1192 and then Nkind (N) = N_Assignment_Statement
1193 and then Warn_On_Modified_Unread
1194 and then Is_Assignable (Ent)
1195 and then Comes_From_Source (N)
1196 and then In_Extended_Main_Source_Unit (Ent)
1198 Set_Last_Assignment (Ent, Lhs);
1202 Analyze_Dimension (N);
1205 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1207 -- If the right-hand side contains target names, expansion has been
1208 -- disabled to prevent expansion that might move target names out of
1209 -- the context of the assignment statement. Restore the expander mode
1210 -- now so that assignment statement can be properly expanded.
1212 if Nkind (N) = N_Assignment_Statement then
1213 if Has_Target_Names (N) then
1214 Expander_Mode_Restore;
1215 Full_Analysis := Save_Full_Analysis;
1218 pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
1220 end Analyze_Assignment;
1222 -----------------------------
1223 -- Analyze_Block_Statement --
1224 -----------------------------
1226 procedure Analyze_Block_Statement (N : Node_Id) is
1227 procedure Install_Return_Entities (Scop : Entity_Id);
1228 -- Install all entities of return statement scope Scop in the visibility
1229 -- chain except for the return object since its entity is reused in a
1232 -----------------------------
1233 -- Install_Return_Entities --
1234 -----------------------------
1236 procedure Install_Return_Entities (Scop : Entity_Id) is
1240 Id := First_Entity (Scop);
1241 while Present (Id) loop
1243 -- Do not install the return object
1245 if not Ekind_In (Id, E_Constant, E_Variable)
1246 or else not Is_Return_Object (Id)
1248 Install_Entity (Id);
1253 end Install_Return_Entities;
1255 -- Local constants and variables
1257 Decls : constant List_Id := Declarations (N);
1258 Id : constant Node_Id := Identifier (N);
1259 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1261 Is_BIP_Return_Statement : Boolean;
1263 -- Start of processing for Analyze_Block_Statement
1266 -- In SPARK mode, we reject block statements. Note that the case of
1267 -- block statements generated by the expander is fine.
1269 if Nkind (Original_Node (N)) = N_Block_Statement then
1270 Check_SPARK_05_Restriction ("block statement is not allowed", N);
1273 -- If no handled statement sequence is present, things are really messed
1274 -- up, and we just return immediately (defence against previous errors).
1277 Check_Error_Detected;
1281 -- Detect whether the block is actually a rewritten return statement of
1282 -- a build-in-place function.
1284 Is_BIP_Return_Statement :=
1286 and then Present (Entity (Id))
1287 and then Ekind (Entity (Id)) = E_Return_Statement
1288 and then Is_Build_In_Place_Function
1289 (Return_Applies_To (Entity (Id)));
1291 -- Normal processing with HSS present
1294 EH : constant List_Id := Exception_Handlers (HSS);
1295 Ent : Entity_Id := Empty;
1298 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1299 -- Recursively save value of this global, will be restored on exit
1302 -- Initialize unblocked exit count for statements of begin block
1303 -- plus one for each exception handler that is present.
1305 Unblocked_Exit_Count := 1;
1307 if Present (EH) then
1308 Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
1311 -- If a label is present analyze it and mark it as referenced
1313 if Present (Id) then
1317 -- An error defense. If we have an identifier, but no entity, then
1318 -- something is wrong. If previous errors, then just remove the
1319 -- identifier and continue, otherwise raise an exception.
1322 Check_Error_Detected;
1323 Set_Identifier (N, Empty);
1326 Set_Ekind (Ent, E_Block);
1327 Generate_Reference (Ent, N, ' ');
1328 Generate_Definition (Ent);
1330 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
1331 Set_Label_Construct (Parent (Ent), N);
1336 -- If no entity set, create a label entity
1339 Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
1340 Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
1341 Set_Parent (Ent, N);
1344 Set_Etype (Ent, Standard_Void_Type);
1345 Set_Block_Node (Ent, Identifier (N));
1348 -- The block served as an extended return statement. Ensure that any
1349 -- entities created during the analysis and expansion of the return
1350 -- object declaration are once again visible.
1352 if Is_BIP_Return_Statement then
1353 Install_Return_Entities (Ent);
1356 if Present (Decls) then
1357 Analyze_Declarations (Decls);
1359 Inspect_Deferred_Constant_Completion (Decls);
1363 Process_End_Label (HSS, 'e', Ent);
1365 -- If exception handlers are present, then we indicate that enclosing
1366 -- scopes contain a block with handlers. We only need to mark non-
1369 if Present (EH) then
1372 Set_Has_Nested_Block_With_Handler (S);
1373 exit when Is_Overloadable (S)
1374 or else Ekind (S) = E_Package
1375 or else Is_Generic_Unit (S);
1380 Check_References (Ent);
1381 Update_Use_Clause_Chain;
1384 if Unblocked_Exit_Count = 0 then
1385 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1386 Check_Unreachable_Code (N);
1388 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1391 end Analyze_Block_Statement;
1393 --------------------------------
1394 -- Analyze_Compound_Statement --
1395 --------------------------------
1397 procedure Analyze_Compound_Statement (N : Node_Id) is
1399 Analyze_List (Actions (N));
1400 end Analyze_Compound_Statement;
1402 ----------------------------
1403 -- Analyze_Case_Statement --
1404 ----------------------------
1406 procedure Analyze_Case_Statement (N : Node_Id) is
1408 Exp_Type : Entity_Id;
1409 Exp_Btype : Entity_Id;
1412 Others_Present : Boolean;
1413 -- Indicates if Others was present
1415 pragma Warnings (Off, Last_Choice);
1416 -- Don't care about assigned value
1418 Statements_Analyzed : Boolean := False;
1419 -- Set True if at least some statement sequences get analyzed. If False
1420 -- on exit, means we had a serious error that prevented full analysis of
1421 -- the case statement, and as a result it is not a good idea to output
1422 -- warning messages about unreachable code.
1424 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1425 -- Recursively save value of this global, will be restored on exit
1427 procedure Non_Static_Choice_Error (Choice : Node_Id);
1428 -- Error routine invoked by the generic instantiation below when the
1429 -- case statement has a non static choice.
1431 procedure Process_Statements (Alternative : Node_Id);
1432 -- Analyzes the statements associated with a case alternative. Needed
1433 -- by instantiation below.
1435 package Analyze_Case_Choices is new
1436 Generic_Analyze_Choices
1437 (Process_Associated_Node => Process_Statements);
1438 use Analyze_Case_Choices;
1439 -- Instantiation of the generic choice analysis package
1441 package Check_Case_Choices is new
1442 Generic_Check_Choices
1443 (Process_Empty_Choice => No_OP,
1444 Process_Non_Static_Choice => Non_Static_Choice_Error,
1445 Process_Associated_Node => No_OP);
1446 use Check_Case_Choices;
1447 -- Instantiation of the generic choice processing package
1449 -----------------------------
1450 -- Non_Static_Choice_Error --
1451 -----------------------------
1453 procedure Non_Static_Choice_Error (Choice : Node_Id) is
1455 Flag_Non_Static_Expr
1456 ("choice given in case statement is not static!", Choice);
1457 end Non_Static_Choice_Error;
1459 ------------------------
1460 -- Process_Statements --
1461 ------------------------
1463 procedure Process_Statements (Alternative : Node_Id) is
1464 Choices : constant List_Id := Discrete_Choices (Alternative);
1468 Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1469 Statements_Analyzed := True;
1471 -- An interesting optimization. If the case statement expression
1472 -- is a simple entity, then we can set the current value within an
1473 -- alternative if the alternative has one possible value.
1477 -- when 2 | 3 => beta
1478 -- when others => gamma
1480 -- Here we know that N is initially 1 within alpha, but for beta and
1481 -- gamma, we do not know anything more about the initial value.
1483 if Is_Entity_Name (Exp) then
1484 Ent := Entity (Exp);
1486 if Ekind_In (Ent, E_Variable,
1490 if List_Length (Choices) = 1
1491 and then Nkind (First (Choices)) in N_Subexpr
1492 and then Compile_Time_Known_Value (First (Choices))
1494 Set_Current_Value (Entity (Exp), First (Choices));
1497 Analyze_Statements (Statements (Alternative));
1499 -- After analyzing the case, set the current value to empty
1500 -- since we won't know what it is for the next alternative
1501 -- (unless reset by this same circuit), or after the case.
1503 Set_Current_Value (Entity (Exp), Empty);
1508 -- Case where expression is not an entity name of a variable
1510 Analyze_Statements (Statements (Alternative));
1511 end Process_Statements;
1513 -- Start of processing for Analyze_Case_Statement
1516 Unblocked_Exit_Count := 0;
1517 Exp := Expression (N);
1520 -- The expression must be of any discrete type. In rare cases, the
1521 -- expander constructs a case statement whose expression has a private
1522 -- type whose full view is discrete. This can happen when generating
1523 -- a stream operation for a variant type after the type is frozen,
1524 -- when the partial of view of the type of the discriminant is private.
1525 -- In that case, use the full view to analyze case alternatives.
1527 if not Is_Overloaded (Exp)
1528 and then not Comes_From_Source (N)
1529 and then Is_Private_Type (Etype (Exp))
1530 and then Present (Full_View (Etype (Exp)))
1531 and then Is_Discrete_Type (Full_View (Etype (Exp)))
1533 Resolve (Exp, Etype (Exp));
1534 Exp_Type := Full_View (Etype (Exp));
1537 Analyze_And_Resolve (Exp, Any_Discrete);
1538 Exp_Type := Etype (Exp);
1541 Check_Unset_Reference (Exp);
1542 Exp_Btype := Base_Type (Exp_Type);
1544 -- The expression must be of a discrete type which must be determinable
1545 -- independently of the context in which the expression occurs, but
1546 -- using the fact that the expression must be of a discrete type.
1547 -- Moreover, the type this expression must not be a character literal
1548 -- (which is always ambiguous) or, for Ada-83, a generic formal type.
1550 -- If error already reported by Resolve, nothing more to do
1552 if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
1555 elsif Exp_Btype = Any_Character then
1557 ("character literal as case expression is ambiguous", Exp);
1560 elsif Ada_Version = Ada_83
1561 and then (Is_Generic_Type (Exp_Btype)
1562 or else Is_Generic_Type (Root_Type (Exp_Btype)))
1565 ("(Ada 83) case expression cannot be of a generic type", Exp);
1569 -- If the case expression is a formal object of mode in out, then treat
1570 -- it as having a nonstatic subtype by forcing use of the base type
1571 -- (which has to get passed to Check_Case_Choices below). Also use base
1572 -- type when the case expression is parenthesized.
1574 if Paren_Count (Exp) > 0
1575 or else (Is_Entity_Name (Exp)
1576 and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
1578 Exp_Type := Exp_Btype;
1581 -- Call instantiated procedures to analyzwe and check discrete choices
1583 Analyze_Choices (Alternatives (N), Exp_Type);
1584 Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
1586 -- Case statement with single OTHERS alternative not allowed in SPARK
1588 if Others_Present and then List_Length (Alternatives (N)) = 1 then
1589 Check_SPARK_05_Restriction
1590 ("OTHERS as unique case alternative is not allowed", N);
1593 if Exp_Type = Universal_Integer and then not Others_Present then
1594 Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
1597 -- If all our exits were blocked by unconditional transfers of control,
1598 -- then the entire CASE statement acts as an unconditional transfer of
1599 -- control, so treat it like one, and check unreachable code. Skip this
1600 -- test if we had serious errors preventing any statement analysis.
1602 if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
1603 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1604 Check_Unreachable_Code (N);
1606 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1609 -- If the expander is active it will detect the case of a statically
1610 -- determined single alternative and remove warnings for the case, but
1611 -- if we are not doing expansion, that circuit won't be active. Here we
1612 -- duplicate the effect of removing warnings in the same way, so that
1613 -- we will get the same set of warnings in -gnatc mode.
1615 if not Expander_Active
1616 and then Compile_Time_Known_Value (Expression (N))
1617 and then Serious_Errors_Detected = 0
1620 Chosen : constant Node_Id := Find_Static_Alternative (N);
1624 Alt := First (Alternatives (N));
1625 while Present (Alt) loop
1626 if Alt /= Chosen then
1627 Remove_Warning_Messages (Statements (Alt));
1634 end Analyze_Case_Statement;
1636 ----------------------------
1637 -- Analyze_Exit_Statement --
1638 ----------------------------
1640 -- If the exit includes a name, it must be the name of a currently open
1641 -- loop. Otherwise there must be an innermost open loop on the stack, to
1642 -- which the statement implicitly refers.
1644 -- Additionally, in SPARK mode:
1646 -- The exit can only name the closest enclosing loop;
1648 -- An exit with a when clause must be directly contained in a loop;
1650 -- An exit without a when clause must be directly contained in an
1651 -- if-statement with no elsif or else, which is itself directly contained
1652 -- in a loop. The exit must be the last statement in the if-statement.
1654 procedure Analyze_Exit_Statement (N : Node_Id) is
1655 Target : constant Node_Id := Name (N);
1656 Cond : constant Node_Id := Condition (N);
1657 Scope_Id : Entity_Id := Empty; -- initialize to prevent warning
1663 Check_Unreachable_Code (N);
1666 if Present (Target) then
1668 U_Name := Entity (Target);
1670 if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
1671 Error_Msg_N ("invalid loop name in exit statement", N);
1675 if Has_Loop_In_Inner_Open_Scopes (U_Name) then
1676 Check_SPARK_05_Restriction
1677 ("exit label must name the closest enclosing loop", N);
1680 Set_Has_Exit (U_Name);
1687 for J in reverse 0 .. Scope_Stack.Last loop
1688 Scope_Id := Scope_Stack.Table (J).Entity;
1689 Kind := Ekind (Scope_Id);
1691 if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then
1692 Set_Has_Exit (Scope_Id);
1695 elsif Kind = E_Block
1696 or else Kind = E_Loop
1697 or else Kind = E_Return_Statement
1703 ("cannot exit from program unit or accept statement", N);
1708 -- Verify that if present the condition is a Boolean expression
1710 if Present (Cond) then
1711 Analyze_And_Resolve (Cond, Any_Boolean);
1712 Check_Unset_Reference (Cond);
1715 -- In SPARK mode, verify that the exit statement respects the SPARK
1718 if Present (Cond) then
1719 if Nkind (Parent (N)) /= N_Loop_Statement then
1720 Check_SPARK_05_Restriction
1721 ("exit with when clause must be directly in loop", N);
1725 if Nkind (Parent (N)) /= N_If_Statement then
1726 if Nkind (Parent (N)) = N_Elsif_Part then
1727 Check_SPARK_05_Restriction
1728 ("exit must be in IF without ELSIF", N);
1730 Check_SPARK_05_Restriction ("exit must be directly in IF", N);
1733 elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
1734 Check_SPARK_05_Restriction
1735 ("exit must be in IF directly in loop", N);
1737 -- First test the presence of ELSE, so that an exit in an ELSE leads
1738 -- to an error mentioning the ELSE.
1740 elsif Present (Else_Statements (Parent (N))) then
1741 Check_SPARK_05_Restriction ("exit must be in IF without ELSE", N);
1743 -- An exit in an ELSIF does not reach here, as it would have been
1744 -- detected in the case (Nkind (Parent (N)) /= N_If_Statement).
1746 elsif Present (Elsif_Parts (Parent (N))) then
1747 Check_SPARK_05_Restriction ("exit must be in IF without ELSIF", N);
1751 -- Chain exit statement to associated loop entity
1753 Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id));
1754 Set_First_Exit_Statement (Scope_Id, N);
1756 -- Since the exit may take us out of a loop, any previous assignment
1757 -- statement is not useless, so clear last assignment indications. It
1758 -- is OK to keep other current values, since if the exit statement
1759 -- does not exit, then the current values are still valid.
1761 Kill_Current_Values (Last_Assignment_Only => True);
1762 end Analyze_Exit_Statement;
1764 ----------------------------
1765 -- Analyze_Goto_Statement --
1766 ----------------------------
1768 procedure Analyze_Goto_Statement (N : Node_Id) is
1769 Label : constant Node_Id := Name (N);
1770 Scope_Id : Entity_Id;
1771 Label_Scope : Entity_Id;
1772 Label_Ent : Entity_Id;
1775 Check_SPARK_05_Restriction ("goto statement is not allowed", N);
1777 -- Actual semantic checks
1779 Check_Unreachable_Code (N);
1780 Kill_Current_Values (Last_Assignment_Only => True);
1783 Label_Ent := Entity (Label);
1785 -- Ignore previous error
1787 if Label_Ent = Any_Id then
1788 Check_Error_Detected;
1791 -- We just have a label as the target of a goto
1793 elsif Ekind (Label_Ent) /= E_Label then
1794 Error_Msg_N ("target of goto statement must be a label", Label);
1797 -- Check that the target of the goto is reachable according to Ada
1798 -- scoping rules. Note: the special gotos we generate for optimizing
1799 -- local handling of exceptions would violate these rules, but we mark
1800 -- such gotos as analyzed when built, so this code is never entered.
1802 elsif not Reachable (Label_Ent) then
1803 Error_Msg_N ("target of goto statement is not reachable", Label);
1807 -- Here if goto passes initial validity checks
1809 Label_Scope := Enclosing_Scope (Label_Ent);
1811 for J in reverse 0 .. Scope_Stack.Last loop
1812 Scope_Id := Scope_Stack.Table (J).Entity;
1814 if Label_Scope = Scope_Id
1815 or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement)
1817 if Scope_Id /= Label_Scope then
1819 ("cannot exit from program unit or accept statement", N);
1826 raise Program_Error;
1827 end Analyze_Goto_Statement;
1829 --------------------------
1830 -- Analyze_If_Statement --
1831 --------------------------
1833 -- A special complication arises in the analysis of if statements
1835 -- The expander has circuitry to completely delete code that it can tell
1836 -- will not be executed (as a result of compile time known conditions). In
1837 -- the analyzer, we ensure that code that will be deleted in this manner
1838 -- is analyzed but not expanded. This is obviously more efficient, but
1839 -- more significantly, difficulties arise if code is expanded and then
1840 -- eliminated (e.g. exception table entries disappear). Similarly, itypes
1841 -- generated in deleted code must be frozen from start, because the nodes
1842 -- on which they depend will not be available at the freeze point.
1844 procedure Analyze_If_Statement (N : Node_Id) is
1847 Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1848 -- Recursively save value of this global, will be restored on exit
1850 Save_In_Deleted_Code : Boolean := In_Deleted_Code;
1852 Del : Boolean := False;
1853 -- This flag gets set True if a True condition has been found, which
1854 -- means that remaining ELSE/ELSIF parts are deleted.
1856 procedure Analyze_Cond_Then (Cnode : Node_Id);
1857 -- This is applied to either the N_If_Statement node itself or to an
1858 -- N_Elsif_Part node. It deals with analyzing the condition and the THEN
1859 -- statements associated with it.
1861 -----------------------
1862 -- Analyze_Cond_Then --
1863 -----------------------
1865 procedure Analyze_Cond_Then (Cnode : Node_Id) is
1866 Cond : constant Node_Id := Condition (Cnode);
1867 Tstm : constant List_Id := Then_Statements (Cnode);
1870 Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1871 Analyze_And_Resolve (Cond, Any_Boolean);
1872 Check_Unset_Reference (Cond);
1873 Set_Current_Value_Condition (Cnode);
1875 -- If already deleting, then just analyze then statements
1878 Analyze_Statements (Tstm);
1880 -- Compile time known value, not deleting yet
1882 elsif Compile_Time_Known_Value (Cond) then
1883 Save_In_Deleted_Code := In_Deleted_Code;
1885 -- If condition is True, then analyze the THEN statements and set
1886 -- no expansion for ELSE and ELSIF parts.
1888 if Is_True (Expr_Value (Cond)) then
1889 Analyze_Statements (Tstm);
1891 Expander_Mode_Save_And_Set (False);
1892 In_Deleted_Code := True;
1894 -- If condition is False, analyze THEN with expansion off
1896 else -- Is_False (Expr_Value (Cond))
1897 Expander_Mode_Save_And_Set (False);
1898 In_Deleted_Code := True;
1899 Analyze_Statements (Tstm);
1900 Expander_Mode_Restore;
1901 In_Deleted_Code := Save_In_Deleted_Code;
1904 -- Not known at compile time, not deleting, normal analysis
1907 Analyze_Statements (Tstm);
1909 end Analyze_Cond_Then;
1911 -- Start of processing for Analyze_If_Statement
1914 -- Initialize exit count for else statements. If there is no else part,
1915 -- this count will stay non-zero reflecting the fact that the uncovered
1916 -- else case is an unblocked exit.
1918 Unblocked_Exit_Count := 1;
1919 Analyze_Cond_Then (N);
1921 -- Now to analyze the elsif parts if any are present
1923 if Present (Elsif_Parts (N)) then
1924 E := First (Elsif_Parts (N));
1925 while Present (E) loop
1926 Analyze_Cond_Then (E);
1931 if Present (Else_Statements (N)) then
1932 Analyze_Statements (Else_Statements (N));
1935 -- If all our exits were blocked by unconditional transfers of control,
1936 -- then the entire IF statement acts as an unconditional transfer of
1937 -- control, so treat it like one, and check unreachable code.
1939 if Unblocked_Exit_Count = 0 then
1940 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1941 Check_Unreachable_Code (N);
1943 Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1947 Expander_Mode_Restore;
1948 In_Deleted_Code := Save_In_Deleted_Code;
1951 if not Expander_Active
1952 and then Compile_Time_Known_Value (Condition (N))
1953 and then Serious_Errors_Detected = 0
1955 if Is_True (Expr_Value (Condition (N))) then
1956 Remove_Warning_Messages (Else_Statements (N));
1958 if Present (Elsif_Parts (N)) then
1959 E := First (Elsif_Parts (N));
1960 while Present (E) loop
1961 Remove_Warning_Messages (Then_Statements (E));
1967 Remove_Warning_Messages (Then_Statements (N));
1971 -- Warn on redundant if statement that has no effect
1973 -- Note, we could also check empty ELSIF parts ???
1975 if Warn_On_Redundant_Constructs
1977 -- If statement must be from source
1979 and then Comes_From_Source (N)
1981 -- Condition must not have obvious side effect
1983 and then Has_No_Obvious_Side_Effects (Condition (N))
1985 -- No elsif parts of else part
1987 and then No (Elsif_Parts (N))
1988 and then No (Else_Statements (N))
1990 -- Then must be a single null statement
1992 and then List_Length (Then_Statements (N)) = 1
1994 -- Go to original node, since we may have rewritten something as
1995 -- a null statement (e.g. a case we could figure the outcome of).
1998 T : constant Node_Id := First (Then_Statements (N));
1999 S : constant Node_Id := Original_Node (T);
2002 if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then
2003 Error_Msg_N ("if statement has no effect?r?", N);
2007 end Analyze_If_Statement;
2009 ----------------------------------------
2010 -- Analyze_Implicit_Label_Declaration --
2011 ----------------------------------------
2013 -- An implicit label declaration is generated in the innermost enclosing
2014 -- declarative part. This is done for labels, and block and loop names.
2016 -- Note: any changes in this routine may need to be reflected in
2017 -- Analyze_Label_Entity.
2019 procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
2020 Id : constant Node_Id := Defining_Identifier (N);
2023 Set_Ekind (Id, E_Label);
2024 Set_Etype (Id, Standard_Void_Type);
2025 Set_Enclosing_Scope (Id, Current_Scope);
2026 end Analyze_Implicit_Label_Declaration;
2028 ------------------------------
2029 -- Analyze_Iteration_Scheme --
2030 ------------------------------
2032 procedure Analyze_Iteration_Scheme (N : Node_Id) is
2034 Iter_Spec : Node_Id;
2035 Loop_Spec : Node_Id;
2038 -- For an infinite loop, there is no iteration scheme
2044 Cond := Condition (N);
2045 Iter_Spec := Iterator_Specification (N);
2046 Loop_Spec := Loop_Parameter_Specification (N);
2048 if Present (Cond) then
2049 Analyze_And_Resolve (Cond, Any_Boolean);
2050 Check_Unset_Reference (Cond);
2051 Set_Current_Value_Condition (N);
2053 elsif Present (Iter_Spec) then
2054 Analyze_Iterator_Specification (Iter_Spec);
2057 Analyze_Loop_Parameter_Specification (Loop_Spec);
2059 end Analyze_Iteration_Scheme;
2061 ------------------------------------
2062 -- Analyze_Iterator_Specification --
2063 ------------------------------------
2065 procedure Analyze_Iterator_Specification (N : Node_Id) is
2066 Def_Id : constant Node_Id := Defining_Identifier (N);
2067 Iter_Name : constant Node_Id := Name (N);
2068 Loc : constant Source_Ptr := Sloc (N);
2069 Subt : constant Node_Id := Subtype_Indication (N);
2071 Bas : Entity_Id := Empty; -- initialize to prevent warning
2074 procedure Check_Reverse_Iteration (Typ : Entity_Id);
2075 -- For an iteration over a container, if the loop carries the Reverse
2076 -- indicator, verify that the container type has an Iterate aspect that
2077 -- implements the reversible iterator interface.
2079 procedure Check_Subtype_Indication (Comp_Type : Entity_Id);
2080 -- If a subtype indication is present, verify that it is consistent
2081 -- with the component type of the array or container name.
2083 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id;
2084 -- For containers with Iterator and related aspects, the cursor is
2085 -- obtained by locating an entity with the proper name in the scope
2088 -----------------------------
2089 -- Check_Reverse_Iteration --
2090 -----------------------------
2092 procedure Check_Reverse_Iteration (Typ : Entity_Id) is
2094 if Reverse_Present (N) then
2095 if Is_Array_Type (Typ)
2096 or else Is_Reversible_Iterator (Typ)
2098 (Present (Find_Aspect (Typ, Aspect_Iterable))
2101 (Get_Iterable_Type_Primitive (Typ, Name_Previous)))
2106 ("container type does not support reverse iteration", N, Typ);
2109 end Check_Reverse_Iteration;
2111 -------------------------------
2112 -- Check_Subtype_Indication --
2113 -------------------------------
2115 procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is
2118 and then (not Covers (Base_Type ((Bas)), Comp_Type)
2119 or else not Subtypes_Statically_Match (Bas, Comp_Type))
2121 if Is_Array_Type (Typ) then
2123 ("subtype indication does not match component type", Subt);
2126 ("subtype indication does not match element type", Subt);
2129 end Check_Subtype_Indication;
2131 ---------------------
2132 -- Get_Cursor_Type --
2133 ---------------------
2135 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
2139 -- If iterator type is derived, the cursor is declared in the scope
2140 -- of the parent type.
2142 if Is_Derived_Type (Typ) then
2143 Ent := First_Entity (Scope (Etype (Typ)));
2145 Ent := First_Entity (Scope (Typ));
2148 while Present (Ent) loop
2149 exit when Chars (Ent) = Name_Cursor;
2157 -- The cursor is the target of generated assignments in the
2158 -- loop, and cannot have a limited type.
2160 if Is_Limited_Type (Etype (Ent)) then
2161 Error_Msg_N ("cursor type cannot be limited", N);
2165 end Get_Cursor_Type;
2167 -- Start of processing for Analyze_Iterator_Specification
2170 Enter_Name (Def_Id);
2172 -- AI12-0151 specifies that when the subtype indication is present, it
2173 -- must statically match the type of the array or container element.
2174 -- To simplify this check, we introduce a subtype declaration with the
2175 -- given subtype indication when it carries a constraint, and rewrite
2176 -- the original as a reference to the created subtype entity.
2178 if Present (Subt) then
2179 if Nkind (Subt) = N_Subtype_Indication then
2181 S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S');
2182 Decl : constant Node_Id :=
2183 Make_Subtype_Declaration (Loc,
2184 Defining_Identifier => S,
2185 Subtype_Indication => New_Copy_Tree (Subt));
2187 Insert_Before (Parent (Parent (N)), Decl);
2189 Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt)));
2195 -- Save entity of subtype indication for subsequent check
2197 Bas := Entity (Subt);
2200 Preanalyze_Range (Iter_Name);
2202 -- If the domain of iteration is a function call, make sure the function
2203 -- itself is frozen. This is an issue if this is a local expression
2206 if Nkind (Iter_Name) = N_Function_Call
2207 and then Is_Entity_Name (Name (Iter_Name))
2208 and then Full_Analysis
2209 and then (In_Assertion_Expr = 0 or else Assertions_Enabled)
2211 Freeze_Before (N, Entity (Name (Iter_Name)));
2214 -- Set the kind of the loop variable, which is not visible within the
2217 Set_Ekind (Def_Id, E_Variable);
2219 -- Provide a link between the iterator variable and the container, for
2220 -- subsequent use in cross-reference and modification information.
2222 if Of_Present (N) then
2223 Set_Related_Expression (Def_Id, Iter_Name);
2225 -- For a container, the iterator is specified through the aspect
2227 if not Is_Array_Type (Etype (Iter_Name)) then
2229 Iterator : constant Entity_Id :=
2230 Find_Value_Of_Aspect
2231 (Etype (Iter_Name), Aspect_Default_Iterator);
2237 -- The domain of iteration must implement either the RM
2238 -- iterator interface, or the SPARK Iterable aspect.
2240 if No (Iterator) then
2241 if No (Find_Aspect (Etype (Iter_Name), Aspect_Iterable)) then
2243 ("cannot iterate over&",
2244 N, Base_Type (Etype (Iter_Name)));
2248 elsif not Is_Overloaded (Iterator) then
2249 Check_Reverse_Iteration (Etype (Iterator));
2251 -- If Iterator is overloaded, use reversible iterator if one is
2254 elsif Is_Overloaded (Iterator) then
2255 Get_First_Interp (Iterator, I, It);
2256 while Present (It.Nam) loop
2257 if Ekind (It.Nam) = E_Function
2258 and then Is_Reversible_Iterator (Etype (It.Nam))
2260 Set_Etype (Iterator, It.Typ);
2261 Set_Entity (Iterator, It.Nam);
2265 Get_Next_Interp (I, It);
2268 Check_Reverse_Iteration (Etype (Iterator));
2274 -- If the domain of iteration is an expression, create a declaration for
2275 -- it, so that finalization actions are introduced outside of the loop.
2276 -- The declaration must be a renaming because the body of the loop may
2277 -- assign to elements.
2279 if not Is_Entity_Name (Iter_Name)
2281 -- When the context is a quantified expression, the renaming
2282 -- declaration is delayed until the expansion phase if we are
2285 and then (Nkind (Parent (N)) /= N_Quantified_Expression
2286 or else Operating_Mode = Check_Semantics)
2288 -- Do not perform this expansion for ASIS and when expansion is
2289 -- disabled, where the temporary may hide the transformation of a
2290 -- selected component into a prefixed function call, and references
2291 -- need to see the original expression.
2293 and then Expander_Active
2296 Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
2302 -- If the domain of iteration is an array component that depends
2303 -- on a discriminant, create actual subtype for it. preanalysis
2304 -- does not generate the actual subtype of a selected component.
2306 if Nkind (Iter_Name) = N_Selected_Component
2307 and then Is_Array_Type (Etype (Iter_Name))
2310 Build_Actual_Subtype_Of_Component
2311 (Etype (Selector_Name (Iter_Name)), Iter_Name);
2312 Insert_Action (N, Act_S);
2314 if Present (Act_S) then
2315 Typ := Defining_Identifier (Act_S);
2317 Typ := Etype (Iter_Name);
2321 Typ := Etype (Iter_Name);
2323 -- Verify that the expression produces an iterator
2325 if not Of_Present (N) and then not Is_Iterator (Typ)
2326 and then not Is_Array_Type (Typ)
2327 and then No (Find_Aspect (Typ, Aspect_Iterable))
2330 ("expect object that implements iterator interface",
2335 -- Protect against malformed iterator
2337 if Typ = Any_Type then
2338 Error_Msg_N ("invalid expression in loop iterator", Iter_Name);
2342 if not Of_Present (N) then
2343 Check_Reverse_Iteration (Typ);
2346 -- For an element iteration over a slice, we must complete
2347 -- the resolution and expansion of the slice bounds. These
2348 -- can be arbitrary expressions, and the preanalysis that
2349 -- was performed in preparation for the iteration may have
2350 -- generated an itype whose bounds must be fully expanded.
2351 -- We set the parent node to provide a proper insertion
2352 -- point for generated actions, if any.
2354 if Nkind (Iter_Name) = N_Slice
2355 and then Nkind (Discrete_Range (Iter_Name)) = N_Range
2356 and then not Analyzed (Discrete_Range (Iter_Name))
2359 Indx : constant Node_Id :=
2360 Entity (First_Index (Etype (Iter_Name)));
2362 Set_Parent (Indx, Iter_Name);
2363 Resolve (Scalar_Range (Indx), Etype (Indx));
2367 -- The name in the renaming declaration may be a function call.
2368 -- Indicate that it does not come from source, to suppress
2369 -- spurious warnings on renamings of parameterless functions,
2370 -- a common enough idiom in user-defined iterators.
2373 Make_Object_Renaming_Declaration (Loc,
2374 Defining_Identifier => Id,
2375 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
2377 New_Copy_Tree (Iter_Name, New_Sloc => Loc));
2379 Insert_Actions (Parent (Parent (N)), New_List (Decl));
2380 Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
2381 Set_Etype (Id, Typ);
2382 Set_Etype (Name (N), Typ);
2385 -- Container is an entity or an array with uncontrolled components, or
2386 -- else it is a container iterator given by a function call, typically
2387 -- called Iterate in the case of predefined containers, even though
2388 -- Iterate is not a reserved name. What matters is that the return type
2389 -- of the function is an iterator type.
2391 elsif Is_Entity_Name (Iter_Name) then
2392 Analyze (Iter_Name);
2394 if Nkind (Iter_Name) = N_Function_Call then
2396 C : constant Node_Id := Name (Iter_Name);
2401 if not Is_Overloaded (Iter_Name) then
2402 Resolve (Iter_Name, Etype (C));
2405 Get_First_Interp (C, I, It);
2406 while It.Typ /= Empty loop
2407 if Reverse_Present (N) then
2408 if Is_Reversible_Iterator (It.Typ) then
2409 Resolve (Iter_Name, It.Typ);
2413 elsif Is_Iterator (It.Typ) then
2414 Resolve (Iter_Name, It.Typ);
2418 Get_Next_Interp (I, It);
2423 -- Domain of iteration is not overloaded
2426 Resolve (Iter_Name, Etype (Iter_Name));
2429 if not Of_Present (N) then
2430 Check_Reverse_Iteration (Etype (Iter_Name));
2434 -- Get base type of container, for proper retrieval of Cursor type
2435 -- and primitive operations.
2437 Typ := Base_Type (Etype (Iter_Name));
2439 if Is_Array_Type (Typ) then
2440 if Of_Present (N) then
2441 Set_Etype (Def_Id, Component_Type (Typ));
2443 -- The loop variable is aliased if the array components are
2444 -- aliased. Likewise for the independent aspect.
2446 Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ));
2447 Set_Is_Independent (Def_Id, Has_Independent_Components (Typ));
2449 -- AI12-0047 stipulates that the domain (array or container)
2450 -- cannot be a component that depends on a discriminant if the
2451 -- enclosing object is mutable, to prevent a modification of the
2452 -- dowmain of iteration in the course of an iteration.
2454 -- If the object is an expression it has been captured in a
2455 -- temporary, so examine original node.
2457 if Nkind (Original_Node (Iter_Name)) = N_Selected_Component
2458 and then Is_Dependent_Component_Of_Mutable_Object
2459 (Original_Node (Iter_Name))
2462 ("iterable name cannot be a discriminant-dependent "
2463 & "component of a mutable object", N);
2466 Check_Subtype_Indication (Component_Type (Typ));
2468 -- Here we have a missing Range attribute
2472 ("missing Range attribute in iteration over an array", N);
2474 -- In Ada 2012 mode, this may be an attempt at an iterator
2476 if Ada_Version >= Ada_2012 then
2478 ("\if& is meant to designate an element of the array, use OF",
2482 -- Prevent cascaded errors
2484 Set_Ekind (Def_Id, E_Loop_Parameter);
2485 Set_Etype (Def_Id, Etype (First_Index (Typ)));
2488 -- Check for type error in iterator
2490 elsif Typ = Any_Type then
2493 -- Iteration over a container
2496 Set_Ekind (Def_Id, E_Loop_Parameter);
2497 Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N));
2501 if Of_Present (N) then
2502 if Has_Aspect (Typ, Aspect_Iterable) then
2504 Elt : constant Entity_Id :=
2505 Get_Iterable_Type_Primitive (Typ, Name_Element);
2509 ("missing Element primitive for iteration", N);
2511 Set_Etype (Def_Id, Etype (Elt));
2512 Check_Reverse_Iteration (Typ);
2516 Check_Subtype_Indication (Etype (Def_Id));
2518 -- For a predefined container, The type of the loop variable is
2519 -- the Iterator_Element aspect of the container type.
2523 Element : constant Entity_Id :=
2524 Find_Value_Of_Aspect
2525 (Typ, Aspect_Iterator_Element);
2526 Iterator : constant Entity_Id :=
2527 Find_Value_Of_Aspect
2528 (Typ, Aspect_Default_Iterator);
2529 Orig_Iter_Name : constant Node_Id :=
2530 Original_Node (Iter_Name);
2531 Cursor_Type : Entity_Id;
2534 if No (Element) then
2535 Error_Msg_NE ("cannot iterate over&", N, Typ);
2539 Set_Etype (Def_Id, Entity (Element));
2540 Cursor_Type := Get_Cursor_Type (Typ);
2541 pragma Assert (Present (Cursor_Type));
2543 Check_Subtype_Indication (Etype (Def_Id));
2545 -- If the container has a variable indexing aspect, the
2546 -- element is a variable and is modifiable in the loop.
2548 if Has_Aspect (Typ, Aspect_Variable_Indexing) then
2549 Set_Ekind (Def_Id, E_Variable);
2552 -- If the container is a constant, iterating over it
2553 -- requires a Constant_Indexing operation.
2555 if not Is_Variable (Iter_Name)
2556 and then not Has_Aspect (Typ, Aspect_Constant_Indexing)
2559 ("iteration over constant container require "
2560 & "constant_indexing aspect", N);
2562 -- The Iterate function may have an in_out parameter,
2563 -- and a constant container is thus illegal.
2565 elsif Present (Iterator)
2566 and then Ekind (Entity (Iterator)) = E_Function
2567 and then Ekind (First_Formal (Entity (Iterator))) /=
2569 and then not Is_Variable (Iter_Name)
2571 Error_Msg_N ("variable container expected", N);
2574 -- Detect a case where the iterator denotes a component
2575 -- of a mutable object which depends on a discriminant.
2576 -- Note that the iterator may denote a function call in
2577 -- qualified form, in which case this check should not
2580 if Nkind (Orig_Iter_Name) = N_Selected_Component
2582 Present (Entity (Selector_Name (Orig_Iter_Name)))
2584 (Entity (Selector_Name (Orig_Iter_Name)),
2587 and then Is_Dependent_Component_Of_Mutable_Object
2591 ("container cannot be a discriminant-dependent "
2592 & "component of a mutable object", N);
2598 -- IN iterator, domain is a range, or a call to Iterate function
2601 -- For an iteration of the form IN, the name must denote an
2602 -- iterator, typically the result of a call to Iterate. Give a
2603 -- useful error message when the name is a container by itself.
2605 -- The type may be a formal container type, which has to have
2606 -- an Iterable aspect detailing the required primitives.
2608 if Is_Entity_Name (Original_Node (Name (N)))
2609 and then not Is_Iterator (Typ)
2611 if Has_Aspect (Typ, Aspect_Iterable) then
2614 elsif not Has_Aspect (Typ, Aspect_Iterator_Element) then
2616 ("cannot iterate over&", Name (N), Typ);
2619 ("name must be an iterator, not a container", Name (N));
2622 if Has_Aspect (Typ, Aspect_Iterable) then
2626 ("\to iterate directly over the elements of a container, "
2627 & "write `of &`", Name (N), Original_Node (Name (N)));
2629 -- No point in continuing analysis of iterator spec
2635 -- If the name is a call (typically prefixed) to some Iterate
2636 -- function, it has been rewritten as an object declaration.
2637 -- If that object is a selected component, verify that it is not
2638 -- a component of an unconstrained mutable object.
2640 if Nkind (Iter_Name) = N_Identifier
2641 or else (not Expander_Active and Comes_From_Source (Iter_Name))
2644 Orig_Node : constant Node_Id := Original_Node (Iter_Name);
2645 Iter_Kind : constant Node_Kind := Nkind (Orig_Node);
2649 if Iter_Kind = N_Selected_Component then
2650 Obj := Prefix (Orig_Node);
2652 elsif Iter_Kind = N_Function_Call then
2653 Obj := First_Actual (Orig_Node);
2655 -- If neither, the name comes from source
2661 if Nkind (Obj) = N_Selected_Component
2662 and then Is_Dependent_Component_Of_Mutable_Object (Obj)
2665 ("container cannot be a discriminant-dependent "
2666 & "component of a mutable object", N);
2671 -- The result type of Iterate function is the classwide type of
2672 -- the interface parent. We need the specific Cursor type defined
2673 -- in the container package. We obtain it by name for a predefined
2674 -- container, or through the Iterable aspect for a formal one.
2676 if Has_Aspect (Typ, Aspect_Iterable) then
2679 (Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)),
2683 Set_Etype (Def_Id, Get_Cursor_Type (Typ));
2684 Check_Reverse_Iteration (Etype (Iter_Name));
2689 end Analyze_Iterator_Specification;
2695 -- Note: the semantic work required for analyzing labels (setting them as
2696 -- reachable) was done in a prepass through the statements in the block,
2697 -- so that forward gotos would be properly handled. See Analyze_Statements
2698 -- for further details. The only processing required here is to deal with
2699 -- optimizations that depend on an assumption of sequential control flow,
2700 -- since of course the occurrence of a label breaks this assumption.
2702 procedure Analyze_Label (N : Node_Id) is
2703 pragma Warnings (Off, N);
2705 Kill_Current_Values;
2708 --------------------------
2709 -- Analyze_Label_Entity --
2710 --------------------------
2712 procedure Analyze_Label_Entity (E : Entity_Id) is
2714 Set_Ekind (E, E_Label);
2715 Set_Etype (E, Standard_Void_Type);
2716 Set_Enclosing_Scope (E, Current_Scope);
2717 Set_Reachable (E, True);
2718 end Analyze_Label_Entity;
2720 ------------------------------------------
2721 -- Analyze_Loop_Parameter_Specification --
2722 ------------------------------------------
2724 procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is
2725 Loop_Nod : constant Node_Id := Parent (Parent (N));
2727 procedure Check_Controlled_Array_Attribute (DS : Node_Id);
2728 -- If the bounds are given by a 'Range reference on a function call
2729 -- that returns a controlled array, introduce an explicit declaration
2730 -- to capture the bounds, so that the function result can be finalized
2731 -- in timely fashion.
2733 procedure Check_Predicate_Use (T : Entity_Id);
2734 -- Diagnose Attempt to iterate through non-static predicate. Note that
2735 -- a type with inherited predicates may have both static and dynamic
2736 -- forms. In this case it is not sufficent to check the static predicate
2737 -- function only, look for a dynamic predicate aspect as well.
2739 procedure Process_Bounds (R : Node_Id);
2740 -- If the iteration is given by a range, create temporaries and
2741 -- assignment statements block to capture the bounds and perform
2742 -- required finalization actions in case a bound includes a function
2743 -- call that uses the temporary stack. We first preanalyze a copy of
2744 -- the range in order to determine the expected type, and analyze and
2745 -- resolve the original bounds.
2747 --------------------------------------
2748 -- Check_Controlled_Array_Attribute --
2749 --------------------------------------
2751 procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
2753 if Nkind (DS) = N_Attribute_Reference
2754 and then Is_Entity_Name (Prefix (DS))
2755 and then Ekind (Entity (Prefix (DS))) = E_Function
2756 and then Is_Array_Type (Etype (Entity (Prefix (DS))))
2758 Is_Controlled (Component_Type (Etype (Entity (Prefix (DS)))))
2759 and then Expander_Active
2762 Loc : constant Source_Ptr := Sloc (N);
2763 Arr : constant Entity_Id := Etype (Entity (Prefix (DS)));
2764 Indx : constant Entity_Id :=
2765 Base_Type (Etype (First_Index (Arr)));
2766 Subt : constant Entity_Id := Make_Temporary (Loc, 'S');
2771 Make_Subtype_Declaration (Loc,
2772 Defining_Identifier => Subt,
2773 Subtype_Indication =>
2774 Make_Subtype_Indication (Loc,
2775 Subtype_Mark => New_Occurrence_Of (Indx, Loc),
2777 Make_Range_Constraint (Loc, Relocate_Node (DS))));
2778 Insert_Before (Loop_Nod, Decl);
2782 Make_Attribute_Reference (Loc,
2783 Prefix => New_Occurrence_Of (Subt, Loc),
2784 Attribute_Name => Attribute_Name (DS)));
2789 end Check_Controlled_Array_Attribute;
2791 -------------------------
2792 -- Check_Predicate_Use --
2793 -------------------------
2795 procedure Check_Predicate_Use (T : Entity_Id) is
2797 -- A predicated subtype is illegal in loops and related constructs
2798 -- if the predicate is not static, or if it is a non-static subtype
2799 -- of a statically predicated subtype.
2801 if Is_Discrete_Type (T)
2802 and then Has_Predicates (T)
2803 and then (not Has_Static_Predicate (T)
2804 or else not Is_Static_Subtype (T)
2805 or else Has_Dynamic_Predicate_Aspect (T))
2807 -- Seems a confusing message for the case of a static predicate
2808 -- with a non-static subtype???
2810 Bad_Predicated_Subtype_Use
2811 ("cannot use subtype& with non-static predicate for loop "
2812 & "iteration", Discrete_Subtype_Definition (N),
2813 T, Suggest_Static => True);
2815 elsif Inside_A_Generic
2816 and then Is_Generic_Formal (T)
2817 and then Is_Discrete_Type (T)
2819 Set_No_Dynamic_Predicate_On_Actual (T);
2821 end Check_Predicate_Use;
2823 --------------------
2824 -- Process_Bounds --
2825 --------------------
2827 procedure Process_Bounds (R : Node_Id) is
2828 Loc : constant Source_Ptr := Sloc (N);
2831 (Original_Bound : Node_Id;
2832 Analyzed_Bound : Node_Id;
2833 Typ : Entity_Id) return Node_Id;
2834 -- Capture value of bound and return captured value
2841 (Original_Bound : Node_Id;
2842 Analyzed_Bound : Node_Id;
2843 Typ : Entity_Id) return Node_Id
2850 -- If the bound is a constant or an object, no need for a separate
2851 -- declaration. If the bound is the result of previous expansion
2852 -- it is already analyzed and should not be modified. Note that
2853 -- the Bound will be resolved later, if needed, as part of the
2854 -- call to Make_Index (literal bounds may need to be resolved to
2857 if Analyzed (Original_Bound) then
2858 return Original_Bound;
2860 elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
2861 N_Character_Literal)
2862 or else Is_Entity_Name (Analyzed_Bound)
2864 Analyze_And_Resolve (Original_Bound, Typ);
2865 return Original_Bound;
2868 -- Normally, the best approach is simply to generate a constant
2869 -- declaration that captures the bound. However, there is a nasty
2870 -- case where this is wrong. If the bound is complex, and has a
2871 -- possible use of the secondary stack, we need to generate a
2872 -- separate assignment statement to ensure the creation of a block
2873 -- which will release the secondary stack.
2875 -- We prefer the constant declaration, since it leaves us with a
2876 -- proper trace of the value, useful in optimizations that get rid
2877 -- of junk range checks.
2879 if not Has_Sec_Stack_Call (Analyzed_Bound) then
2880 Analyze_And_Resolve (Original_Bound, Typ);
2882 -- Ensure that the bound is valid. This check should not be
2883 -- generated when the range belongs to a quantified expression
2884 -- as the construct is still not expanded into its final form.
2886 if Nkind (Parent (R)) /= N_Loop_Parameter_Specification
2887 or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression
2889 Ensure_Valid (Original_Bound);
2892 Force_Evaluation (Original_Bound);
2893 return Original_Bound;
2896 Id := Make_Temporary (Loc, 'R', Original_Bound);
2898 -- Here we make a declaration with a separate assignment
2899 -- statement, and insert before loop header.
2902 Make_Object_Declaration (Loc,
2903 Defining_Identifier => Id,
2904 Object_Definition => New_Occurrence_Of (Typ, Loc));
2907 Make_Assignment_Statement (Loc,
2908 Name => New_Occurrence_Of (Id, Loc),
2909 Expression => Relocate_Node (Original_Bound));
2911 Insert_Actions (Loop_Nod, New_List (Decl, Assign));
2913 -- Now that this temporary variable is initialized we decorate it
2914 -- as safe-to-reevaluate to inform to the backend that no further
2915 -- asignment will be issued and hence it can be handled as side
2916 -- effect free. Note that this decoration must be done when the
2917 -- assignment has been analyzed because otherwise it will be
2918 -- rejected (see Analyze_Assignment).
2920 Set_Is_Safe_To_Reevaluate (Id);
2922 Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
2924 if Nkind (Assign) = N_Assignment_Statement then
2925 return Expression (Assign);
2927 return Original_Bound;
2931 Hi : constant Node_Id := High_Bound (R);
2932 Lo : constant Node_Id := Low_Bound (R);
2933 R_Copy : constant Node_Id := New_Copy_Tree (R);
2938 -- Start of processing for Process_Bounds
2941 Set_Parent (R_Copy, Parent (R));
2942 Preanalyze_Range (R_Copy);
2943 Typ := Etype (R_Copy);
2945 -- If the type of the discrete range is Universal_Integer, then the
2946 -- bound's type must be resolved to Integer, and any object used to
2947 -- hold the bound must also have type Integer, unless the literal
2948 -- bounds are constant-folded expressions with a user-defined type.
2950 if Typ = Universal_Integer then
2951 if Nkind (Lo) = N_Integer_Literal
2952 and then Present (Etype (Lo))
2953 and then Scope (Etype (Lo)) /= Standard_Standard
2957 elsif Nkind (Hi) = N_Integer_Literal
2958 and then Present (Etype (Hi))
2959 and then Scope (Etype (Hi)) /= Standard_Standard
2964 Typ := Standard_Integer;
2970 New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ);
2971 New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ);
2973 -- Propagate staticness to loop range itself, in case the
2974 -- corresponding subtype is static.
2976 if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then
2977 Rewrite (Low_Bound (R), New_Copy (New_Lo));
2980 if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then
2981 Rewrite (High_Bound (R), New_Copy (New_Hi));
2987 DS : constant Node_Id := Discrete_Subtype_Definition (N);
2988 Id : constant Entity_Id := Defining_Identifier (N);
2992 -- Start of processing for Analyze_Loop_Parameter_Specification
2997 -- We always consider the loop variable to be referenced, since the loop
2998 -- may be used just for counting purposes.
3000 Generate_Reference (Id, N, ' ');
3002 -- Check for the case of loop variable hiding a local variable (used
3003 -- later on to give a nice warning if the hidden variable is never
3007 H : constant Entity_Id := Homonym (Id);
3010 and then Ekind (H) = E_Variable
3011 and then Is_Discrete_Type (Etype (H))
3012 and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id)
3014 Set_Hiding_Loop_Variable (H, Id);
3018 -- Loop parameter specification must include subtype mark in SPARK
3020 if Nkind (DS) = N_Range then
3021 Check_SPARK_05_Restriction
3022 ("loop parameter specification must include subtype mark", N);
3025 -- Analyze the subtype definition and create temporaries for the bounds.
3026 -- Do not evaluate the range when preanalyzing a quantified expression
3027 -- because bounds expressed as function calls with side effects will be
3028 -- incorrectly replicated.
3030 if Nkind (DS) = N_Range
3031 and then Expander_Active
3032 and then Nkind (Parent (N)) /= N_Quantified_Expression
3034 Process_Bounds (DS);
3036 -- Either the expander not active or the range of iteration is a subtype
3037 -- indication, an entity, or a function call that yields an aggregate or
3041 DS_Copy := New_Copy_Tree (DS);
3042 Set_Parent (DS_Copy, Parent (DS));
3043 Preanalyze_Range (DS_Copy);
3045 -- Ada 2012: If the domain of iteration is:
3047 -- a) a function call,
3048 -- b) an identifier that is not a type,
3049 -- c) an attribute reference 'Old (within a postcondition),
3050 -- d) an unchecked conversion or a qualified expression with
3051 -- the proper iterator type.
3053 -- then it is an iteration over a container. It was classified as
3054 -- a loop specification by the parser, and must be rewritten now
3055 -- to activate container iteration. The last case will occur within
3056 -- an expanded inlined call, where the expansion wraps an actual in
3057 -- an unchecked conversion when needed. The expression of the
3058 -- conversion is always an object.
3060 if Nkind (DS_Copy) = N_Function_Call
3062 or else (Is_Entity_Name (DS_Copy)
3063 and then not Is_Type (Entity (DS_Copy)))
3065 or else (Nkind (DS_Copy) = N_Attribute_Reference
3066 and then Nam_In (Attribute_Name (DS_Copy),
3067 Name_Loop_Entry, Name_Old))
3069 or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable)
3071 or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion
3072 or else (Nkind (DS_Copy) = N_Qualified_Expression
3073 and then Is_Iterator (Etype (DS_Copy)))
3075 -- This is an iterator specification. Rewrite it as such and
3076 -- analyze it to capture function calls that may require
3077 -- finalization actions.
3080 I_Spec : constant Node_Id :=
3081 Make_Iterator_Specification (Sloc (N),
3082 Defining_Identifier => Relocate_Node (Id),
3084 Subtype_Indication => Empty,
3085 Reverse_Present => Reverse_Present (N));
3086 Scheme : constant Node_Id := Parent (N);
3089 Set_Iterator_Specification (Scheme, I_Spec);
3090 Set_Loop_Parameter_Specification (Scheme, Empty);
3091 Analyze_Iterator_Specification (I_Spec);
3093 -- In a generic context, analyze the original domain of
3094 -- iteration, for name capture.
3096 if not Expander_Active then
3100 -- Set kind of loop parameter, which may be used in the
3101 -- subsequent analysis of the condition in a quantified
3104 Set_Ekind (Id, E_Loop_Parameter);
3108 -- Domain of iteration is not a function call, and is side-effect
3112 -- A quantified expression that appears in a pre/post condition
3113 -- is preanalyzed several times. If the range is given by an
3114 -- attribute reference it is rewritten as a range, and this is
3115 -- done even with expansion disabled. If the type is already set
3116 -- do not reanalyze, because a range with static bounds may be
3117 -- typed Integer by default.
3119 if Nkind (Parent (N)) = N_Quantified_Expression
3120 and then Present (Etype (DS))
3133 -- Some additional checks if we are iterating through a type
3135 if Is_Entity_Name (DS)
3136 and then Present (Entity (DS))
3137 and then Is_Type (Entity (DS))
3139 -- The subtype indication may denote the completion of an incomplete
3140 -- type declaration.
3142 if Ekind (Entity (DS)) = E_Incomplete_Type then
3143 Set_Entity (DS, Get_Full_View (Entity (DS)));
3144 Set_Etype (DS, Entity (DS));
3147 Check_Predicate_Use (Entity (DS));
3150 -- Error if not discrete type
3152 if not Is_Discrete_Type (Etype (DS)) then
3153 Wrong_Type (DS, Any_Discrete);
3154 Set_Etype (DS, Any_Type);
3157 Check_Controlled_Array_Attribute (DS);
3159 if Nkind (DS) = N_Subtype_Indication then
3160 Check_Predicate_Use (Entity (Subtype_Mark (DS)));
3163 Make_Index (DS, N, In_Iter_Schm => True);
3164 Set_Ekind (Id, E_Loop_Parameter);
3166 -- A quantified expression which appears in a pre- or post-condition may
3167 -- be analyzed multiple times. The analysis of the range creates several
3168 -- itypes which reside in different scopes depending on whether the pre-
3169 -- or post-condition has been expanded. Update the type of the loop
3170 -- variable to reflect the proper itype at each stage of analysis.
3173 or else Etype (Id) = Any_Type
3175 (Present (Etype (Id))
3176 and then Is_Itype (Etype (Id))
3177 and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions
3178 and then Nkind (Original_Node (Parent (Loop_Nod))) =
3179 N_Quantified_Expression)
3181 Set_Etype (Id, Etype (DS));
3184 -- Treat a range as an implicit reference to the type, to inhibit
3185 -- spurious warnings.
3187 Generate_Reference (Base_Type (Etype (DS)), N, ' ');
3188 Set_Is_Known_Valid (Id, True);
3190 -- The loop is not a declarative part, so the loop variable must be
3191 -- frozen explicitly. Do not freeze while preanalyzing a quantified
3192 -- expression because the freeze node will not be inserted into the
3193 -- tree due to flag Is_Spec_Expression being set.
3195 if Nkind (Parent (N)) /= N_Quantified_Expression then
3197 Flist : constant List_Id := Freeze_Entity (Id, N);
3199 if Is_Non_Empty_List (Flist) then
3200 Insert_Actions (N, Flist);
3205 -- Case where we have a range or a subtype, get type bounds
3207 if Nkind_In (DS, N_Range, N_Subtype_Indication)
3208 and then not Error_Posted (DS)
3209 and then Etype (DS) /= Any_Type
3210 and then Is_Discrete_Type (Etype (DS))
3217 if Nkind (DS) = N_Range then
3218 L := Low_Bound (DS);
3219 H := High_Bound (DS);
3222 Type_Low_Bound (Underlying_Type (Etype (Subtype_Mark (DS))));
3224 Type_High_Bound (Underlying_Type (Etype (Subtype_Mark (DS))));
3227 -- Check for null or possibly null range and issue warning. We
3228 -- suppress such messages in generic templates and instances,
3229 -- because in practice they tend to be dubious in these cases. The
3230 -- check applies as well to rewritten array element loops where a
3231 -- null range may be detected statically.
3233 if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then
3235 -- Suppress the warning if inside a generic template or
3236 -- instance, since in practice they tend to be dubious in these
3237 -- cases since they can result from intended parameterization.
3239 if not Inside_A_Generic and then not In_Instance then
3241 -- Specialize msg if invalid values could make the loop
3242 -- non-null after all.
3244 if Compile_Time_Compare
3245 (L, H, Assume_Valid => False) = GT
3247 -- Since we know the range of the loop is null, set the
3248 -- appropriate flag to remove the loop entirely during
3251 Set_Is_Null_Loop (Loop_Nod);
3253 if Comes_From_Source (N) then
3255 ("??loop range is null, loop will not execute", DS);
3258 -- Here is where the loop could execute because of
3259 -- invalid values, so issue appropriate message and in
3260 -- this case we do not set the Is_Null_Loop flag since
3261 -- the loop may execute.
3263 elsif Comes_From_Source (N) then
3265 ("??loop range may be null, loop may not execute",
3268 ("??can only execute if invalid values are present",
3273 -- In either case, suppress warnings in the body of the loop,
3274 -- since it is likely that these warnings will be inappropriate
3275 -- if the loop never actually executes, which is likely.
3277 Set_Suppress_Loop_Warnings (Loop_Nod);
3279 -- The other case for a warning is a reverse loop where the
3280 -- upper bound is the integer literal zero or one, and the
3281 -- lower bound may exceed this value.
3283 -- For example, we have
3285 -- for J in reverse N .. 1 loop
3287 -- In practice, this is very likely to be a case of reversing
3288 -- the bounds incorrectly in the range.
3290 elsif Reverse_Present (N)
3291 and then Nkind (Original_Node (H)) = N_Integer_Literal
3293 (Intval (Original_Node (H)) = Uint_0
3295 Intval (Original_Node (H)) = Uint_1)
3297 -- Lower bound may in fact be known and known not to exceed
3298 -- upper bound (e.g. reverse 0 .. 1) and that's OK.
3300 if Compile_Time_Known_Value (L)
3301 and then Expr_Value (L) <= Expr_Value (H)
3305 -- Otherwise warning is warranted
3308 Error_Msg_N ("??loop range may be null", DS);
3309 Error_Msg_N ("\??bounds may be wrong way round", DS);
3313 -- Check if either bound is known to be outside the range of the
3314 -- loop parameter type, this is e.g. the case of a loop from
3315 -- 20..X where the type is 1..19.
3317 -- Such a loop is dubious since either it raises CE or it executes
3318 -- zero times, and that cannot be useful!
3320 if Etype (DS) /= Any_Type
3321 and then not Error_Posted (DS)
3322 and then Nkind (DS) = N_Subtype_Indication
3323 and then Nkind (Constraint (DS)) = N_Range_Constraint
3326 LLo : constant Node_Id :=
3327 Low_Bound (Range_Expression (Constraint (DS)));
3328 LHi : constant Node_Id :=
3329 High_Bound (Range_Expression (Constraint (DS)));
3331 Bad_Bound : Node_Id := Empty;
3332 -- Suspicious loop bound
3335 -- At this stage L, H are the bounds of the type, and LLo
3336 -- Lhi are the low bound and high bound of the loop.
3338 if Compile_Time_Compare (LLo, L, Assume_Valid => True) = LT
3340 Compile_Time_Compare (LLo, H, Assume_Valid => True) = GT
3345 if Compile_Time_Compare (LHi, L, Assume_Valid => True) = LT
3347 Compile_Time_Compare (LHi, H, Assume_Valid => True) = GT
3352 if Present (Bad_Bound) then
3354 ("suspicious loop bound out of range of "
3355 & "loop subtype??", Bad_Bound);
3357 ("\loop executes zero times or raises "
3358 & "Constraint_Error??", Bad_Bound);
3363 -- This declare block is about warnings, if we get an exception while
3364 -- testing for warnings, we simply abandon the attempt silently. This
3365 -- most likely occurs as the result of a previous error, but might
3366 -- just be an obscure case we have missed. In either case, not giving
3367 -- the warning is perfectly acceptable.
3370 when others => null;
3374 -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)).
3375 -- This check is relevant only when SPARK_Mode is on as it is not a
3376 -- standard Ada legality check.
3378 if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then
3379 Error_Msg_N ("loop parameter cannot be volatile", Id);
3381 end Analyze_Loop_Parameter_Specification;
3383 ----------------------------
3384 -- Analyze_Loop_Statement --
3385 ----------------------------
3387 procedure Analyze_Loop_Statement (N : Node_Id) is
3389 -- The following exception is raised by routine Prepare_Loop_Statement
3390 -- to avoid further analysis of a transformed loop.
3392 function Disable_Constant (N : Node_Id) return Traverse_Result;
3393 -- If N represents an E_Variable entity, set Is_True_Constant To False
3395 procedure Disable_Constants is new Traverse_Proc (Disable_Constant);
3396 -- Helper for Analyze_Loop_Statement, to unset Is_True_Constant on
3397 -- variables referenced within an OpenACC construct.
3399 procedure Prepare_Loop_Statement
3401 Stop_Processing : out Boolean);
3402 -- Determine whether loop statement N with iteration scheme Iter must be
3403 -- transformed prior to analysis, and if so, perform it.
3404 -- If Stop_Processing is set to True, should stop further processing.
3406 ----------------------
3407 -- Disable_Constant --
3408 ----------------------
3410 function Disable_Constant (N : Node_Id) return Traverse_Result is
3412 if Is_Entity_Name (N)
3413 and then Present (Entity (N))
3414 and then Ekind (Entity (N)) = E_Variable
3416 Set_Is_True_Constant (Entity (N), False);
3420 end Disable_Constant;
3422 ----------------------------
3423 -- Prepare_Loop_Statement --
3424 ----------------------------
3426 procedure Prepare_Loop_Statement
3428 Stop_Processing : out Boolean)
3430 function Has_Sec_Stack_Default_Iterator
3431 (Cont_Typ : Entity_Id) return Boolean;
3432 pragma Inline (Has_Sec_Stack_Default_Iterator);
3433 -- Determine whether container type Cont_Typ has a default iterator
3434 -- that requires secondary stack management.
3436 function Is_Sec_Stack_Iteration_Primitive
3437 (Cont_Typ : Entity_Id;
3438 Iter_Prim_Nam : Name_Id) return Boolean;
3439 pragma Inline (Is_Sec_Stack_Iteration_Primitive);
3440 -- Determine whether container type Cont_Typ has an iteration routine
3441 -- described by its name Iter_Prim_Nam that requires secondary stack
3444 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean;
3445 pragma Inline (Is_Wrapped_In_Block);
3446 -- Determine whether arbitrary statement Stmt is the sole statement
3447 -- wrapped within some block, excluding pragmas.
3449 procedure Prepare_Iterator_Loop
3450 (Iter_Spec : Node_Id;
3451 Stop_Processing : out Boolean);
3452 pragma Inline (Prepare_Iterator_Loop);
3453 -- Prepare an iterator loop with iteration specification Iter_Spec
3454 -- for transformation if needed.
3455 -- If Stop_Processing is set to True, should stop further processing.
3457 procedure Prepare_Param_Spec_Loop
3458 (Param_Spec : Node_Id;
3459 Stop_Processing : out Boolean);
3460 pragma Inline (Prepare_Param_Spec_Loop);
3461 -- Prepare a discrete loop with parameter specification Param_Spec
3462 -- for transformation if needed.
3463 -- If Stop_Processing is set to True, should stop further processing.
3465 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean);
3466 pragma Inline (Wrap_Loop_Statement);
3467 -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must
3468 -- be set when the block must mark and release the secondary stack.
3469 -- Should stop further processing after calling this procedure.
3471 ------------------------------------
3472 -- Has_Sec_Stack_Default_Iterator --
3473 ------------------------------------
3475 function Has_Sec_Stack_Default_Iterator
3476 (Cont_Typ : Entity_Id) return Boolean
3478 Def_Iter : constant Node_Id :=
3479 Find_Value_Of_Aspect
3480 (Cont_Typ, Aspect_Default_Iterator);
3484 and then Requires_Transient_Scope (Etype (Def_Iter));
3485 end Has_Sec_Stack_Default_Iterator;
3487 --------------------------------------
3488 -- Is_Sec_Stack_Iteration_Primitive --
3489 --------------------------------------
3491 function Is_Sec_Stack_Iteration_Primitive
3492 (Cont_Typ : Entity_Id;
3493 Iter_Prim_Nam : Name_Id) return Boolean
3495 Iter_Prim : constant Entity_Id :=
3496 Get_Iterable_Type_Primitive
3497 (Cont_Typ, Iter_Prim_Nam);
3501 and then Requires_Transient_Scope (Etype (Iter_Prim));
3502 end Is_Sec_Stack_Iteration_Primitive;
3504 -------------------------
3505 -- Is_Wrapped_In_Block --
3506 -------------------------
3508 function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is
3514 Blk_Id := Current_Scope;
3516 -- The current context is a block. Inspect the statements of the
3517 -- block to determine whether it wraps Stmt.
3519 if Ekind (Blk_Id) = E_Block
3520 and then Present (Block_Node (Blk_Id))
3523 Handled_Statement_Sequence (Parent (Block_Node (Blk_Id)));
3525 -- Skip leading pragmas introduced for invariant and predicate
3528 Blk_Stmt := First (Statements (Blk_HSS));
3529 while Present (Blk_Stmt)
3530 and then Nkind (Blk_Stmt) = N_Pragma
3535 return Blk_Stmt = Stmt and then No (Next (Blk_Stmt));
3539 end Is_Wrapped_In_Block;
3541 ---------------------------
3542 -- Prepare_Iterator_Loop --
3543 ---------------------------
3545 procedure Prepare_Iterator_Loop
3546 (Iter_Spec : Node_Id;
3547 Stop_Processing : out Boolean)
3549 Cont_Typ : Entity_Id;
3554 Stop_Processing := False;
3556 -- The iterator specification has syntactic errors. Transform the
3557 -- loop into an infinite loop in order to safely perform at least
3558 -- some minor analysis. This check must come first.
3560 if Error_Posted (Iter_Spec) then
3561 Set_Iteration_Scheme (N, Empty);
3563 Stop_Processing := True;
3565 -- Nothing to do when the loop is already wrapped in a block
3567 elsif Is_Wrapped_In_Block (N) then
3570 -- Otherwise the iterator loop traverses an array or a container
3571 -- and appears in the form
3573 -- for Def_Id in [reverse] Iterator_Name loop
3574 -- for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop
3577 -- Prepare a copy of the iterated name for preanalysis. The
3578 -- copy is semi inserted into the tree by setting its Parent
3581 Nam := Name (Iter_Spec);
3582 Nam_Copy := New_Copy_Tree (Nam);
3583 Set_Parent (Nam_Copy, Parent (Nam));
3585 -- Determine what the loop is iterating on
3587 Preanalyze_Range (Nam_Copy);
3588 Cont_Typ := Etype (Nam_Copy);
3590 -- The iterator loop is traversing an array. This case does not
3591 -- require any transformation.
3593 if Is_Array_Type (Cont_Typ) then
3596 -- Otherwise unconditionally wrap the loop statement within
3597 -- a block. The expansion of iterator loops may relocate the
3598 -- iterator outside the loop, thus "leaking" its entity into
3599 -- the enclosing scope. Wrapping the loop statement allows
3600 -- for multiple iterator loops using the same iterator name
3601 -- to coexist within the same scope.
3603 -- The block must manage the secondary stack when the iterator
3604 -- loop is traversing a container using either
3606 -- * A default iterator obtained on the secondary stack
3608 -- * Call to Iterate where the iterator is returned on the
3611 -- * Combination of First, Next, and Has_Element where the
3612 -- first two return a cursor on the secondary stack.
3616 (Manage_Sec_Stack =>
3617 Has_Sec_Stack_Default_Iterator (Cont_Typ)
3618 or else Has_Sec_Stack_Call (Nam_Copy)
3619 or else Is_Sec_Stack_Iteration_Primitive
3620 (Cont_Typ, Name_First)
3621 or else Is_Sec_Stack_Iteration_Primitive
3622 (Cont_Typ, Name_Next));
3623 Stop_Processing := True;
3626 end Prepare_Iterator_Loop;
3628 -----------------------------
3629 -- Prepare_Param_Spec_Loop --
3630 -----------------------------
3632 procedure Prepare_Param_Spec_Loop
3633 (Param_Spec : Node_Id;
3634 Stop_Processing : out Boolean)
3640 Rng_Typ : Entity_Id;
3643 Stop_Processing := False;
3644 Rng := Discrete_Subtype_Definition (Param_Spec);
3646 -- Nothing to do when the loop is already wrapped in a block
3648 if Is_Wrapped_In_Block (N) then
3651 -- The parameter specification appears in the form
3653 -- for Def_Id in Subtype_Mark Constraint loop
3655 elsif Nkind (Rng) = N_Subtype_Indication
3656 and then Nkind (Range_Expression (Constraint (Rng))) = N_Range
3658 Rng := Range_Expression (Constraint (Rng));
3660 -- Preanalyze the bounds of the range constraint, setting
3661 -- parent fields to associate the copied bounds with the range,
3662 -- allowing proper tree climbing during preanalysis.
3664 Low := New_Copy_Tree (Low_Bound (Rng));
3665 High := New_Copy_Tree (High_Bound (Rng));
3667 Set_Parent (Low, Rng);
3668 Set_Parent (High, Rng);
3673 -- The bounds contain at least one function call that returns
3674 -- on the secondary stack. Note that the loop must be wrapped
3675 -- only when such a call exists.
3677 if Has_Sec_Stack_Call (Low) or else Has_Sec_Stack_Call (High)
3679 Wrap_Loop_Statement (Manage_Sec_Stack => True);
3680 Stop_Processing := True;
3683 -- Otherwise the parameter specification appears in the form
3685 -- for Def_Id in Range loop
3688 -- Prepare a copy of the discrete range for preanalysis. The
3689 -- copy is semi inserted into the tree by setting its Parent
3692 Rng_Copy := New_Copy_Tree (Rng);
3693 Set_Parent (Rng_Copy, Parent (Rng));
3695 -- Determine what the loop is iterating on
3697 Preanalyze_Range (Rng_Copy);
3698 Rng_Typ := Etype (Rng_Copy);
3700 -- Wrap the loop statement within a block in order to manage
3701 -- the secondary stack when the discrete range is
3703 -- * Either a Forward_Iterator or a Reverse_Iterator
3705 -- * Function call whose return type requires finalization
3708 -- ??? it is unclear why using Has_Sec_Stack_Call directly on
3709 -- the discrete range causes the freeze node of an itype to be
3710 -- in the wrong scope in complex assertion expressions.
3712 if Is_Iterator (Rng_Typ)
3713 or else (Nkind (Rng_Copy) = N_Function_Call
3714 and then Needs_Finalization (Rng_Typ))
3716 Wrap_Loop_Statement (Manage_Sec_Stack => True);
3717 Stop_Processing := True;
3720 end Prepare_Param_Spec_Loop;
3722 -------------------------
3723 -- Wrap_Loop_Statement --
3724 -------------------------
3726 procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is
3727 Loc : constant Source_Ptr := Sloc (N);
3734 Make_Block_Statement (Loc,
3735 Declarations => New_List,
3736 Handled_Statement_Sequence =>
3737 Make_Handled_Sequence_Of_Statements (Loc,
3738 Statements => New_List (Relocate_Node (N))));
3740 Add_Block_Identifier (Blk, Blk_Id);
3741 Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack);
3745 end Wrap_Loop_Statement;
3749 Iter_Spec : constant Node_Id := Iterator_Specification (Iter);
3750 Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter);
3752 -- Start of processing for Prepare_Loop_Statement
3755 Stop_Processing := False;
3757 if Present (Iter_Spec) then
3758 Prepare_Iterator_Loop (Iter_Spec, Stop_Processing);
3760 elsif Present (Param_Spec) then
3761 Prepare_Param_Spec_Loop (Param_Spec, Stop_Processing);
3763 end Prepare_Loop_Statement;
3765 -- Local declarations
3767 Id : constant Node_Id := Identifier (N);
3768 Iter : constant Node_Id := Iteration_Scheme (N);
3769 Loc : constant Source_Ptr := Sloc (N);
3773 -- Start of processing for Analyze_Loop_Statement
3776 if Present (Id) then
3778 -- Make name visible, e.g. for use in exit statements. Loop labels
3779 -- are always considered to be referenced.
3784 -- Guard against serious error (typically, a scope mismatch when
3785 -- semantic analysis is requested) by creating loop entity to
3786 -- continue analysis.
3789 if Total_Errors_Detected /= 0 then
3790 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
3792 raise Program_Error;
3795 -- Verify that the loop name is hot hidden by an unrelated
3796 -- declaration in an inner scope.
3798 elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then
3799 Error_Msg_Sloc := Sloc (Ent);
3800 Error_Msg_N ("implicit label declaration for & is hidden#", Id);
3802 if Present (Homonym (Ent))
3803 and then Ekind (Homonym (Ent)) = E_Label
3805 Set_Entity (Id, Ent);
3806 Set_Ekind (Ent, E_Loop);
3810 Generate_Reference (Ent, N, ' ');
3811 Generate_Definition (Ent);
3813 -- If we found a label, mark its type. If not, ignore it, since it
3814 -- means we have a conflicting declaration, which would already
3815 -- have been diagnosed at declaration time. Set Label_Construct
3816 -- of the implicit label declaration, which is not created by the
3817 -- parser for generic units.
3819 if Ekind (Ent) = E_Label then
3820 Set_Ekind (Ent, E_Loop);
3822 if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
3823 Set_Label_Construct (Parent (Ent), N);
3828 -- Case of no identifier present. Create one and attach it to the
3829 -- loop statement for use as a scope and as a reference for later
3830 -- expansions. Indicate that the label does not come from source,
3831 -- and attach it to the loop statement so it is part of the tree,
3832 -- even without a full declaration.
3835 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
3836 Set_Etype (Ent, Standard_Void_Type);
3837 Set_Identifier (N, New_Occurrence_Of (Ent, Loc));
3838 Set_Parent (Ent, N);
3839 Set_Has_Created_Identifier (N);
3842 -- Determine whether the loop statement must be transformed prior to
3843 -- analysis, and if so, perform it. This early modification is needed
3846 -- * The loop has an erroneous iteration scheme. In this case the
3847 -- loop is converted into an infinite loop in order to perform
3850 -- * The loop is an Ada 2012 iterator loop. In this case the loop is
3851 -- wrapped within a block to provide a local scope for the iterator.
3852 -- If the iterator specification requires the secondary stack in any
3853 -- way, the block is marked in order to manage it.
3855 -- * The loop is using a parameter specification where the discrete
3856 -- range requires the secondary stack. In this case the loop is
3857 -- wrapped within a block in order to manage the secondary stack.
3859 if Present (Iter) then
3861 Stop_Processing : Boolean;
3863 Prepare_Loop_Statement (Iter, Stop_Processing);
3865 if Stop_Processing then
3871 -- Kill current values on entry to loop, since statements in the body of
3872 -- the loop may have been executed before the loop is entered. Similarly
3873 -- we kill values after the loop, since we do not know that the body of
3874 -- the loop was executed.
3876 Kill_Current_Values;
3878 Analyze_Iteration_Scheme (Iter);
3880 -- Check for following case which merits a warning if the type E of is
3881 -- a multi-dimensional array (and no explicit subscript ranges present).
3887 and then Present (Loop_Parameter_Specification (Iter))
3890 LPS : constant Node_Id := Loop_Parameter_Specification (Iter);
3891 DSD : constant Node_Id :=
3892 Original_Node (Discrete_Subtype_Definition (LPS));
3894 if Nkind (DSD) = N_Attribute_Reference
3895 and then Attribute_Name (DSD) = Name_Range
3896 and then No (Expressions (DSD))
3899 Typ : constant Entity_Id := Etype (Prefix (DSD));
3901 if Is_Array_Type (Typ)
3902 and then Number_Dimensions (Typ) > 1
3903 and then Nkind (Parent (N)) = N_Loop_Statement
3904 and then Present (Iteration_Scheme (Parent (N)))
3907 OIter : constant Node_Id :=
3908 Iteration_Scheme (Parent (N));
3909 OLPS : constant Node_Id :=
3910 Loop_Parameter_Specification (OIter);
3911 ODSD : constant Node_Id :=
3912 Original_Node (Discrete_Subtype_Definition (OLPS));
3914 if Nkind (ODSD) = N_Attribute_Reference
3915 and then Attribute_Name (ODSD) = Name_Range
3916 and then No (Expressions (ODSD))
3917 and then Etype (Prefix (ODSD)) = Typ
3919 Error_Msg_Sloc := Sloc (ODSD);
3921 ("inner range same as outer range#??", DSD);
3930 -- Analyze the statements of the body except in the case of an Ada 2012
3931 -- iterator with the expander active. In this case the expander will do
3932 -- a rewrite of the loop into a while loop. We will then analyze the
3933 -- loop body when we analyze this while loop.
3935 -- We need to do this delay because if the container is for indefinite
3936 -- types the actual subtype of the components will only be determined
3937 -- when the cursor declaration is analyzed.
3939 -- If the expander is not active then we want to analyze the loop body
3940 -- now even in the Ada 2012 iterator case, since the rewriting will not
3941 -- be done. Insert the loop variable in the current scope, if not done
3942 -- when analysing the iteration scheme. Set its kind properly to detect
3943 -- improper uses in the loop body.
3945 -- In GNATprove mode, we do one of the above depending on the kind of
3946 -- loop. If it is an iterator over an array, then we do not analyze the
3947 -- loop now. We will analyze it after it has been rewritten by the
3948 -- special SPARK expansion which is activated in GNATprove mode. We need
3949 -- to do this so that other expansions that should occur in GNATprove
3950 -- mode take into account the specificities of the rewritten loop, in
3951 -- particular the introduction of a renaming (which needs to be
3954 -- In other cases in GNATprove mode then we want to analyze the loop
3955 -- body now, since no rewriting will occur. Within a generic the
3956 -- GNATprove mode is irrelevant, we must analyze the generic for
3957 -- non-local name capture.
3960 and then Present (Iterator_Specification (Iter))
3963 and then Is_Iterator_Over_Array (Iterator_Specification (Iter))
3964 and then not Inside_A_Generic
3968 elsif not Expander_Active then
3970 I_Spec : constant Node_Id := Iterator_Specification (Iter);
3971 Id : constant Entity_Id := Defining_Identifier (I_Spec);
3974 if Scope (Id) /= Current_Scope then
3978 -- In an element iterator, The loop parameter is a variable if
3979 -- the domain of iteration (container or array) is a variable.
3981 if not Of_Present (I_Spec)
3982 or else not Is_Variable (Name (I_Spec))
3984 Set_Ekind (Id, E_Loop_Parameter);
3988 Analyze_Statements (Statements (N));
3992 -- Pre-Ada2012 for-loops and while loops
3994 Analyze_Statements (Statements (N));
3997 -- When the iteration scheme of a loop contains attribute 'Loop_Entry,
3998 -- the loop is transformed into a conditional block. Retrieve the loop.
4002 if Subject_To_Loop_Entry_Attributes (Stmt) then
4003 Stmt := Find_Loop_In_Conditional_Block (Stmt);
4006 -- Finish up processing for the loop. We kill all current values, since
4007 -- in general we don't know if the statements in the loop have been
4008 -- executed. We could do a bit better than this with a loop that we
4009 -- know will execute at least once, but it's not worth the trouble and
4010 -- the front end is not in the business of flow tracing.
4012 Process_End_Label (Stmt, 'e', Ent);
4014 Kill_Current_Values;
4016 -- Check for infinite loop. Skip check for generated code, since it
4017 -- justs waste time and makes debugging the routine called harder.
4019 -- Note that we have to wait till the body of the loop is fully analyzed
4020 -- before making this call, since Check_Infinite_Loop_Warning relies on
4021 -- being able to use semantic visibility information to find references.
4023 if Comes_From_Source (Stmt) then
4024 Check_Infinite_Loop_Warning (Stmt);
4027 -- Code after loop is unreachable if the loop has no WHILE or FOR and
4028 -- contains no EXIT statements within the body of the loop.
4030 if No (Iter) and then not Has_Exit (Ent) then
4031 Check_Unreachable_Code (Stmt);
4034 -- Variables referenced within a loop subject to possible OpenACC
4035 -- offloading may be implicitly written to as part of the OpenACC
4036 -- transaction. Clear flags possibly conveying that they are constant,
4037 -- set for example when the code does not explicitly assign them.
4039 if Is_OpenAcc_Environment (Stmt) then
4040 Disable_Constants (Stmt);
4042 end Analyze_Loop_Statement;
4044 ----------------------------
4045 -- Analyze_Null_Statement --
4046 ----------------------------
4048 -- Note: the semantics of the null statement is implemented by a single
4049 -- null statement, too bad everything isn't as simple as this.
4051 procedure Analyze_Null_Statement (N : Node_Id) is
4052 pragma Warnings (Off, N);
4055 end Analyze_Null_Statement;
4057 -------------------------
4058 -- Analyze_Target_Name --
4059 -------------------------
4061 procedure Analyze_Target_Name (N : Node_Id) is
4063 -- A target name has the type of the left-hand side of the enclosing
4066 Set_Etype (N, Etype (Name (Current_Assignment)));
4067 end Analyze_Target_Name;
4069 ------------------------
4070 -- Analyze_Statements --
4071 ------------------------
4073 procedure Analyze_Statements (L : List_Id) is
4078 -- The labels declared in the statement list are reachable from
4079 -- statements in the list. We do this as a prepass so that any goto
4080 -- statement will be properly flagged if its target is not reachable.
4081 -- This is not required, but is nice behavior.
4084 while Present (S) loop
4085 if Nkind (S) = N_Label then
4086 Analyze (Identifier (S));
4087 Lab := Entity (Identifier (S));
4089 -- If we found a label mark it as reachable
4091 if Ekind (Lab) = E_Label then
4092 Generate_Definition (Lab);
4093 Set_Reachable (Lab);
4095 if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
4096 Set_Label_Construct (Parent (Lab), S);
4099 -- If we failed to find a label, it means the implicit declaration
4100 -- of the label was hidden. A for-loop parameter can do this to
4101 -- a label with the same name inside the loop, since the implicit
4102 -- label declaration is in the innermost enclosing body or block
4106 Error_Msg_Sloc := Sloc (Lab);
4108 ("implicit label declaration for & is hidden#",
4116 -- Perform semantic analysis on all statements
4118 Conditional_Statements_Begin;
4121 while Present (S) loop
4124 -- Remove dimension in all statements
4126 Remove_Dimension_In_Statement (S);
4130 Conditional_Statements_End;
4132 -- Make labels unreachable. Visibility is not sufficient, because labels
4133 -- in one if-branch for example are not reachable from the other branch,
4134 -- even though their declarations are in the enclosing declarative part.
4137 while Present (S) loop
4138 if Nkind (S) = N_Label then
4139 Set_Reachable (Entity (Identifier (S)), False);
4144 end Analyze_Statements;
4146 ----------------------------
4147 -- Check_Unreachable_Code --
4148 ----------------------------
4150 procedure Check_Unreachable_Code (N : Node_Id) is
4151 Error_Node : Node_Id;
4155 if Is_List_Member (N) and then Comes_From_Source (N) then
4160 Nxt := Original_Node (Next (N));
4162 -- Skip past pragmas
4164 while Nkind (Nxt) = N_Pragma loop
4165 Nxt := Original_Node (Next (Nxt));
4168 -- If a label follows us, then we never have dead code, since
4169 -- someone could branch to the label, so we just ignore it, unless
4170 -- we are in formal mode where goto statements are not allowed.
4172 if Nkind (Nxt) = N_Label
4173 and then not Restriction_Check_Required (SPARK_05)
4177 -- Otherwise see if we have a real statement following us
4180 and then Comes_From_Source (Nxt)
4181 and then Is_Statement (Nxt)
4183 -- Special very annoying exception. If we have a return that
4184 -- follows a raise, then we allow it without a warning, since
4185 -- the Ada RM annoyingly requires a useless return here.
4187 if Nkind (Original_Node (N)) /= N_Raise_Statement
4188 or else Nkind (Nxt) /= N_Simple_Return_Statement
4190 -- The rather strange shenanigans with the warning message
4191 -- here reflects the fact that Kill_Dead_Code is very good
4192 -- at removing warnings in deleted code, and this is one
4193 -- warning we would prefer NOT to have removed.
4197 -- If we have unreachable code, analyze and remove the
4198 -- unreachable code, since it is useless and we don't
4199 -- want to generate junk warnings.
4201 -- We skip this step if we are not in code generation mode
4202 -- or CodePeer mode.
4204 -- This is the one case where we remove dead code in the
4205 -- semantics as opposed to the expander, and we do not want
4206 -- to remove code if we are not in code generation mode,
4207 -- since this messes up the ASIS trees or loses useful
4208 -- information in the CodePeer tree.
4210 -- Note that one might react by moving the whole circuit to
4211 -- exp_ch5, but then we lose the warning in -gnatc mode.
4213 if Operating_Mode = Generate_Code
4214 and then not CodePeer_Mode
4219 -- Quit deleting when we have nothing more to delete
4220 -- or if we hit a label (since someone could transfer
4221 -- control to a label, so we should not delete it).
4223 exit when No (Nxt) or else Nkind (Nxt) = N_Label;
4225 -- Statement/declaration is to be deleted
4229 Kill_Dead_Code (Nxt);
4233 -- Now issue the warning (or error in formal mode)
4235 if Restriction_Check_Required (SPARK_05) then
4236 Check_SPARK_05_Restriction
4237 ("unreachable code is not allowed", Error_Node);
4240 ("??unreachable code!", Sloc (Error_Node), Error_Node);
4244 -- If the unconditional transfer of control instruction is the
4245 -- last statement of a sequence, then see if our parent is one of
4246 -- the constructs for which we count unblocked exits, and if so,
4247 -- adjust the count.
4252 -- Statements in THEN part or ELSE part of IF statement
4254 if Nkind (P) = N_If_Statement then
4257 -- Statements in ELSIF part of an IF statement
4259 elsif Nkind (P) = N_Elsif_Part then
4261 pragma Assert (Nkind (P) = N_If_Statement);
4263 -- Statements in CASE statement alternative
4265 elsif Nkind (P) = N_Case_Statement_Alternative then
4267 pragma Assert (Nkind (P) = N_Case_Statement);
4269 -- Statements in body of block
4271 elsif Nkind (P) = N_Handled_Sequence_Of_Statements
4272 and then Nkind (Parent (P)) = N_Block_Statement
4274 -- The original loop is now placed inside a block statement
4275 -- due to the expansion of attribute 'Loop_Entry. Return as
4276 -- this is not a "real" block for the purposes of exit
4279 if Nkind (N) = N_Loop_Statement
4280 and then Subject_To_Loop_Entry_Attributes (N)
4285 -- Statements in exception handler in a block
4287 elsif Nkind (P) = N_Exception_Handler
4288 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
4289 and then Nkind (Parent (Parent (P))) = N_Block_Statement
4293 -- None of these cases, so return
4299 -- This was one of the cases we are looking for (i.e. the
4300 -- parent construct was IF, CASE or block) so decrement count.
4302 Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
4306 end Check_Unreachable_Code;
4308 ------------------------
4309 -- Has_Sec_Stack_Call --
4310 ------------------------
4312 function Has_Sec_Stack_Call (N : Node_Id) return Boolean is
4313 function Check_Call (N : Node_Id) return Traverse_Result;
4314 -- Check if N is a function call which uses the secondary stack
4320 function Check_Call (N : Node_Id) return Traverse_Result is
4326 if Nkind (N) = N_Function_Call then
4329 -- Obtain the subprogram being invoked
4332 if Nkind (Nam) = N_Explicit_Dereference then
4333 Nam := Prefix (Nam);
4335 elsif Nkind (Nam) = N_Selected_Component then
4336 Nam := Selector_Name (Nam);
4343 Subp := Entity (Nam);
4345 if Present (Subp) then
4346 Typ := Etype (Subp);
4348 if Requires_Transient_Scope (Typ) then
4351 elsif Sec_Stack_Needed_For_Return (Subp) then
4357 -- Continue traversing the tree
4362 function Check_Calls is new Traverse_Func (Check_Call);
4364 -- Start of processing for Has_Sec_Stack_Call
4367 return Check_Calls (N) = Abandon;
4368 end Has_Sec_Stack_Call;
4370 ----------------------
4371 -- Preanalyze_Range --
4372 ----------------------
4374 procedure Preanalyze_Range (R_Copy : Node_Id) is
4375 Save_Analysis : constant Boolean := Full_Analysis;
4379 Full_Analysis := False;
4380 Expander_Mode_Save_And_Set (False);
4382 -- In addition to the above we must explicitly suppress the generation
4383 -- of freeze nodes that might otherwise be generated during resolution
4384 -- of the range (e.g. if given by an attribute that will freeze its
4387 Set_Must_Not_Freeze (R_Copy);
4389 if Nkind (R_Copy) = N_Attribute_Reference then
4390 Set_Must_Not_Freeze (Prefix (R_Copy));
4395 if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then
4397 -- Apply preference rules for range of predefined integer types, or
4398 -- check for array or iterable construct for "of" iterator, or
4399 -- diagnose true ambiguity.
4404 Found : Entity_Id := Empty;
4407 Get_First_Interp (R_Copy, I, It);
4408 while Present (It.Typ) loop
4409 if Is_Discrete_Type (It.Typ) then
4413 if Scope (Found) = Standard_Standard then
4416 elsif Scope (It.Typ) = Standard_Standard then
4420 -- Both of them are user-defined
4423 ("ambiguous bounds in range of iteration", R_Copy);
4424 Error_Msg_N ("\possible interpretations:", R_Copy);
4425 Error_Msg_NE ("\\} ", R_Copy, Found);
4426 Error_Msg_NE ("\\} ", R_Copy, It.Typ);
4431 elsif Nkind (Parent (R_Copy)) = N_Iterator_Specification
4432 and then Of_Present (Parent (R_Copy))
4434 if Is_Array_Type (It.Typ)
4435 or else Has_Aspect (It.Typ, Aspect_Iterator_Element)
4436 or else Has_Aspect (It.Typ, Aspect_Constant_Indexing)
4437 or else Has_Aspect (It.Typ, Aspect_Variable_Indexing)
4441 Set_Etype (R_Copy, It.Typ);
4444 Error_Msg_N ("ambiguous domain of iteration", R_Copy);
4449 Get_Next_Interp (I, It);
4454 -- Subtype mark in iteration scheme
4456 if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then
4459 -- Expression in range, or Ada 2012 iterator
4461 elsif Nkind (R_Copy) in N_Subexpr then
4463 Typ := Etype (R_Copy);
4465 if Is_Discrete_Type (Typ) then
4468 -- Check that the resulting object is an iterable container
4470 elsif Has_Aspect (Typ, Aspect_Iterator_Element)
4471 or else Has_Aspect (Typ, Aspect_Constant_Indexing)
4472 or else Has_Aspect (Typ, Aspect_Variable_Indexing)
4476 -- The expression may yield an implicit reference to an iterable
4477 -- container. Insert explicit dereference so that proper type is
4478 -- visible in the loop.
4480 elsif Has_Implicit_Dereference (Etype (R_Copy)) then
4485 Disc := First_Discriminant (Typ);
4486 while Present (Disc) loop
4487 if Has_Implicit_Dereference (Disc) then
4488 Build_Explicit_Dereference (R_Copy, Disc);
4492 Next_Discriminant (Disc);
4499 Expander_Mode_Restore;
4500 Full_Analysis := Save_Analysis;
4501 end Preanalyze_Range;