This is part of the previous work on getting variant choices that
involve a statically predicated subtype to work. The one gap was
in the generic case, where we were detecting the error on instances
instead of the template (this also called a failure of ACATS test
B49007A, where we had lots such a message).
The following test compiles with the indicated output:
1. PROCEDURE MISSNONSTV IS
2. TYPE INT IS RANGE 1 .. 10;
3. BEGIN
4. DECLARE
5. GENERIC
6. OBJ1 : IN INT;
7. PACKAGE PACK IS
8. TYPE ER_REC (AT1 : INT := 4) IS RECORD
9. CASE AT1 IS
10. WHEN OBJ1 => -- ERROR: (D).
|
>>> choice given in variant part is not static
>>> "OBJ1" is not static constant or named number (RM 4.9(5))
11. TR : INTEGER RANGE 1 .. 10;
12. WHEN OTHERS =>
13. TY : BOOLEAN := TRUE;
14. END CASE;
15. END RECORD;
16. END PACK;
17. BEGIN
18. null;
19. END;
20. end MISSNONSTV;
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-10 Robert Dewar <de...@adacore.com>
* freeze.adb: Minor reformatting.
* sem_ch13.adb (Freeze_Entity_Checks): New procedure
(Analyze_Freeze_Entity): Call Freeze_Entity_Checks
(Analyze_Freeze_Generic_Entity): Call Freeze_Entity_Checks.
* sinfo.ads: Add syntax for sprint for Freeze_Generic_Entity.
* sprint.ads: Add syntax for freeze generic entity node.
Index: sinfo.ads
===================================================================
--- sinfo.ads (revision 203367)
+++ sinfo.ads (working copy)
@@ -7336,6 +7336,8 @@
-- trigger these checks. The Freeze_Generic_Entity node plays no other
-- role, and is ignored by the expander and the back-end.
+ -- Sprint syntax: freeze_generic entity-name
+
-- N_Freeze_Generic_Entity
-- Sloc points near freeze point
-- Entity (Node4-Sem)
Index: freeze.adb
===================================================================
--- freeze.adb (revision 203367)
+++ freeze.adb (working copy)
@@ -1953,8 +1953,8 @@
-----------------------------
function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is
- E : Entity_Id;
- F : Node_Id;
+ E : Entity_Id;
+ F : Node_Id;
Flist : List_Id;
begin
@@ -2793,6 +2793,12 @@
then
return No_List;
+ -- Generic types need no freeze node and have no delayed semantic
+ -- checks.
+
+ elsif Is_Generic_Type (E) then
+ return No_List;
+
-- Do not freeze a global entity within an inner scope created during
-- expansion. A call to subprogram E within some internal procedure
-- (a stream attribute for example) might require freezing E, but the
Index: sprint.ads
===================================================================
--- sprint.ads (revision 203342)
+++ sprint.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,6 +57,7 @@
-- Expression with range check {expression}
-- Free statement free expr [storage_pool = xxx]
-- Freeze entity with freeze actions freeze entityname [ actions ]
+ -- Freeze generic entity freeze_generic entityname
-- Implicit call to run time routine $routine-name
-- Implicit exportation $pragma import (...)
-- Implicit importation $pragma export (...)
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 203367)
+++ sem_ch13.adb (working copy)
@@ -112,6 +112,13 @@
-- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
-- a canonicalized membership operation.
+ procedure Freeze_Entity_Checks (N : Node_Id);
+ -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
+ -- to generate appropriate semantic checks that are delayed until this
+ -- point (they had to be delayed this long for cases of delayed aspects,
+ -- e.g. analysis of statically predicated subtypes in choices, for which
+ -- we have to be sure the subtypes in question are frozen before checking.
+
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
@@ -5072,353 +5079,8 @@
---------------------------
procedure Analyze_Freeze_Entity (N : Node_Id) is
- E : constant Entity_Id := Entity (N);
-
begin
- -- Remember that we are processing a freezing entity. Required to
- -- ensure correct decoration of internal entities associated with
- -- interfaces (see New_Overloaded_Entity).
-
- Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
-
- -- For tagged types covering interfaces add internal entities that link
- -- the primitives of the interfaces with the primitives that cover them.
- -- Note: These entities were originally generated only when generating
- -- code because their main purpose was to provide support to initialize
- -- the secondary dispatch tables. They are now generated also when
- -- compiling with no code generation to provide ASIS the relationship
- -- between interface primitives and tagged type primitives. They are
- -- also used to locate primitives covering interfaces when processing
- -- generics (see Derive_Subprograms).
-
- if Ada_Version >= Ada_2005
- and then Ekind (E) = E_Record_Type
- and then Is_Tagged_Type (E)
- and then not Is_Interface (E)
- and then Has_Interfaces (E)
- then
- -- This would be a good common place to call the routine that checks
- -- overriding of interface primitives (and thus factorize calls to
- -- Check_Abstract_Overriding located at different contexts in the
- -- compiler). However, this is not possible because it causes
- -- spurious errors in case of late overriding.
-
- Add_Internal_Interface_Entities (E);
- end if;
-
- -- Check CPP types
-
- if Ekind (E) = E_Record_Type
- and then Is_CPP_Class (E)
- and then Is_Tagged_Type (E)
- and then Tagged_Type_Expansion
- and then Expander_Active
- then
- if CPP_Num_Prims (E) = 0 then
-
- -- If the CPP type has user defined components then it must import
- -- primitives from C++. This is required because if the C++ class
- -- has no primitives then the C++ compiler does not added the _tag
- -- component to the type.
-
- pragma Assert (Chars (First_Entity (E)) = Name_uTag);
-
- if First_Entity (E) /= Last_Entity (E) then
- Error_Msg_N
- ("'C'P'P type must import at least one primitive from C++??",
- E);
- end if;
- end if;
-
- -- Check that all its primitives are abstract or imported from C++.
- -- Check also availability of the C++ constructor.
-
- declare
- Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
- Elmt : Elmt_Id;
- Error_Reported : Boolean := False;
- Prim : Node_Id;
-
- begin
- Elmt := First_Elmt (Primitive_Operations (E));
- while Present (Elmt) loop
- Prim := Node (Elmt);
-
- if Comes_From_Source (Prim) then
- if Is_Abstract_Subprogram (Prim) then
- null;
-
- elsif not Is_Imported (Prim)
- or else Convention (Prim) /= Convention_CPP
- then
- Error_Msg_N
- ("primitives of 'C'P'P types must be imported from C++ "
- & "or abstract??", Prim);
-
- elsif not Has_Constructors
- and then not Error_Reported
- then
- Error_Msg_Name_1 := Chars (E);
- Error_Msg_N
- ("??'C'P'P constructor required for type %", Prim);
- Error_Reported := True;
- end if;
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
-
- -- Check Ada derivation of CPP type
-
- if Expander_Active
- and then Tagged_Type_Expansion
- and then Ekind (E) = E_Record_Type
- and then Etype (E) /= E
- and then Is_CPP_Class (Etype (E))
- and then CPP_Num_Prims (Etype (E)) > 0
- and then not Is_CPP_Class (E)
- and then not Has_CPP_Constructors (Etype (E))
- then
- -- If the parent has C++ primitives but it has no constructor then
- -- check that all the primitives are overridden in this derivation;
- -- otherwise the constructor of the parent is needed to build the
- -- dispatch table.
-
- declare
- Elmt : Elmt_Id;
- Prim : Node_Id;
-
- begin
- Elmt := First_Elmt (Primitive_Operations (E));
- while Present (Elmt) loop
- Prim := Node (Elmt);
-
- if not Is_Abstract_Subprogram (Prim)
- and then No (Interface_Alias (Prim))
- and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E
- then
- Error_Msg_Name_1 := Chars (Etype (E));
- Error_Msg_N
- ("'C'P'P constructor required for parent type %", E);
- exit;
- end if;
-
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
-
- Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
-
- -- If we have a type with predicates, build predicate function
-
- if Is_Type (E) and then Has_Predicates (E) then
- Build_Predicate_Functions (E, N);
- end if;
-
- -- If type has delayed aspects, this is where we do the preanalysis at
- -- the freeze point, as part of the consistent visibility check. Note
- -- that this must be done after calling Build_Predicate_Functions or
- -- Build_Invariant_Procedure since these subprograms fix occurrences of
- -- the subtype name in the saved expression so that they will not cause
- -- trouble in the preanalysis.
-
- if Has_Delayed_Aspects (E)
- and then Scope (E) = Current_Scope
- then
- -- Retrieve the visibility to the discriminants in order to properly
- -- analyze the aspects.
-
- Push_Scope_And_Install_Discriminants (E);
-
- declare
- Ritem : Node_Id;
-
- begin
- -- Look for aspect specification entries for this entity
-
- Ritem := First_Rep_Item (E);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Aspect_Specification
- and then Entity (Ritem) = E
- and then Is_Delayed_Aspect (Ritem)
- then
- Check_Aspect_At_Freeze_Point (Ritem);
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end;
-
- Uninstall_Discriminants_And_Pop_Scope (E);
- end if;
-
- -- For a record type, deal with variant parts. This has to be delayed
- -- to this point, because of the issue of statically precicated
- -- subtypes, which we have to ensure are frozen before checking
- -- choices, since we need to have the static choice list set.
-
- if Is_Record_Type (E) then
- Check_Variant_Part : declare
- D : constant Node_Id := Declaration_Node (E);
- T : Node_Id;
- C : Node_Id;
- VP : Node_Id;
-
- Others_Present : Boolean;
- pragma Warnings (Off, Others_Present);
- -- Indicates others present, not used in this case
-
- procedure Non_Static_Choice_Error (Choice : Node_Id);
- -- Error routine invoked by the generic instantiation below when
- -- the variant part has a non static choice.
-
- procedure Process_Declarations (Variant : Node_Id);
- -- Processes declarations associated with a variant. We analyzed
- -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
- -- but we still need the recursive call to Check_Choices for any
- -- nested variant to get its choices properly processed. This is
- -- also where we expand out the choices if expansion is active.
-
- package Variant_Choices_Processing is new
- Generic_Check_Choices
- (Process_Empty_Choice => No_OP,
- Process_Non_Static_Choice => Non_Static_Choice_Error,
- Process_Associated_Node => Process_Declarations);
- use Variant_Choices_Processing;
-
- -----------------------------
- -- Non_Static_Choice_Error --
- -----------------------------
-
- procedure Non_Static_Choice_Error (Choice : Node_Id) is
- begin
- Flag_Non_Static_Expr
- ("choice given in variant part is not static!", Choice);
- end Non_Static_Choice_Error;
-
- --------------------------
- -- Process_Declarations --
- --------------------------
-
- procedure Process_Declarations (Variant : Node_Id) is
- CL : constant Node_Id := Component_List (Variant);
- VP : Node_Id;
-
- begin
- -- Check for static predicate present in this variant
-
- if Has_SP_Choice (Variant) then
-
- -- Here we expand. You might expect to find this call in
- -- Expand_N_Variant_Part, but that is called when we first
- -- see the variant part, and we cannot do this expansion
- -- earlier than the freeze point, since for statically
- -- predicated subtypes, the predicate is not known till
- -- the freeze point.
-
- -- Furthermore, we do this expansion even if the expander
- -- is not active, because other semantic processing, e.g.
- -- for aggregates, requires the expanded list of choices.
-
- -- If the expander is not active, then we can't just clobber
- -- the list since it would invalidate the ASIS -gnatct tree.
- -- So we have to rewrite the variant part with a Rewrite
- -- call that replaces it with a copy and clobber the copy.
-
- if not Expander_Active then
- declare
- NewV : constant Node_Id := New_Copy (Variant);
- begin
- Set_Discrete_Choices
- (NewV, New_Copy_List (Discrete_Choices (Variant)));
- Rewrite (Variant, NewV);
- end;
- end if;
-
- Expand_Static_Predicates_In_Choices (Variant);
- end if;
-
- -- We don't need to worry about the declarations in the variant
- -- (since they were analyzed by Analyze_Choices when we first
- -- encountered the variant), but we do need to take care of
- -- expansion of any nested variants.
-
- if not Null_Present (CL) then
- VP := Variant_Part (CL);
-
- if Present (VP) then
- Check_Choices
- (VP, Variants (VP), Etype (Name (VP)), Others_Present);
- end if;
- end if;
- end Process_Declarations;
-
- -- Start of processing for Check_Variant_Part
-
- begin
- -- Find component list
-
- C := Empty;
-
- if Nkind (D) = N_Full_Type_Declaration then
- T := Type_Definition (D);
-
- if Nkind (T) = N_Record_Definition then
- C := Component_List (T);
-
- elsif Nkind (T) = N_Derived_Type_Definition
- and then Present (Record_Extension_Part (T))
- then
- C := Component_List (Record_Extension_Part (T));
- end if;
- end if;
-
- -- Case of variant part present
-
- if Present (C) and then Present (Variant_Part (C)) then
- VP := Variant_Part (C);
-
- -- Check choices
-
- Check_Choices
- (VP, Variants (VP), Etype (Name (VP)), Others_Present);
-
- -- If the last variant does not contain the Others choice,
- -- replace it with an N_Others_Choice node since Gigi always
- -- wants an Others. Note that we do not bother to call Analyze
- -- on the modified variant part, since its only effect would be
- -- to compute the Others_Discrete_Choices node laboriously, and
- -- of course we already know the list of choices corresponding
- -- to the others choice (it's the list we're replacing!)
-
- -- We only want to do this if the expander is active, since
- -- we do not want to clobber the ASIS tree!
-
- if Expander_Active then
- declare
- Last_Var : constant Node_Id :=
- Last_Non_Pragma (Variants (VP));
-
- Others_Node : Node_Id;
-
- begin
- if Nkind (First (Discrete_Choices (Last_Var))) /=
- N_Others_Choice
- then
- Others_Node := Make_Others_Choice (Sloc (Last_Var));
- Set_Others_Discrete_Choices
- (Others_Node, Discrete_Choices (Last_Var));
- Set_Discrete_Choices
- (Last_Var, New_List (Others_Node));
- end if;
- end;
- end if;
- end if;
- end Check_Variant_Part;
- end if;
+ Freeze_Entity_Checks (N);
end Analyze_Freeze_Entity;
-----------------------------------
@@ -5427,8 +5089,7 @@
procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is
begin
- -- Semantic checks here
- null;
+ Freeze_Entity_Checks (N);
end Analyze_Freeze_Generic_Entity;
------------------------------------------
@@ -9203,6 +8864,372 @@
end if;
end Check_Size;
+ --------------------------
+ -- Freeze_Entity_Checks --
+ --------------------------
+
+ procedure Freeze_Entity_Checks (N : Node_Id) is
+ E : constant Entity_Id := Entity (N);
+
+ Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
+ -- True in non-generic case. Some of the processing here is skipped
+ -- for the generic case since it is not needed. Basically in the
+ -- generic case, we only need to do stuff that might generate error
+ -- messages or warnings.
+ begin
+ -- Remember that we are processing a freezing entity. Required to
+ -- ensure correct decoration of internal entities associated with
+ -- interfaces (see New_Overloaded_Entity).
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
+
+ -- For tagged types covering interfaces add internal entities that link
+ -- the primitives of the interfaces with the primitives that cover them.
+ -- Note: These entities were originally generated only when generating
+ -- code because their main purpose was to provide support to initialize
+ -- the secondary dispatch tables. They are now generated also when
+ -- compiling with no code generation to provide ASIS the relationship
+ -- between interface primitives and tagged type primitives. They are
+ -- also used to locate primitives covering interfaces when processing
+ -- generics (see Derive_Subprograms).
+
+ -- This is not needed in the generic case
+
+ if Ada_Version >= Ada_2005
+ and then Non_Generic_Case
+ and then Ekind (E) = E_Record_Type
+ and then Is_Tagged_Type (E)
+ and then not Is_Interface (E)
+ and then Has_Interfaces (E)
+ then
+ -- This would be a good common place to call the routine that checks
+ -- overriding of interface primitives (and thus factorize calls to
+ -- Check_Abstract_Overriding located at different contexts in the
+ -- compiler). However, this is not possible because it causes
+ -- spurious errors in case of late overriding.
+
+ Add_Internal_Interface_Entities (E);
+ end if;
+
+ -- Check CPP types
+
+ if Ekind (E) = E_Record_Type
+ and then Is_CPP_Class (E)
+ and then Is_Tagged_Type (E)
+ and then Tagged_Type_Expansion
+ and then Expander_Active -- why? losing errors in -gnatc mode???
+ then
+ if CPP_Num_Prims (E) = 0 then
+
+ -- If the CPP type has user defined components then it must import
+ -- primitives from C++. This is required because if the C++ class
+ -- has no primitives then the C++ compiler does not added the _tag
+ -- component to the type.
+
+ pragma Assert (Chars (First_Entity (E)) = Name_uTag);
+
+ if First_Entity (E) /= Last_Entity (E) then
+ Error_Msg_N
+ ("'C'P'P type must import at least one primitive from C++??",
+ E);
+ end if;
+ end if;
+
+ -- Check that all its primitives are abstract or imported from C++.
+ -- Check also availability of the C++ constructor.
+
+ declare
+ Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
+ Elmt : Elmt_Id;
+ Error_Reported : Boolean := False;
+ Prim : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (E));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Comes_From_Source (Prim) then
+ if Is_Abstract_Subprogram (Prim) then
+ null;
+
+ elsif not Is_Imported (Prim)
+ or else Convention (Prim) /= Convention_CPP
+ then
+ Error_Msg_N
+ ("primitives of 'C'P'P types must be imported from C++ "
+ & "or abstract??", Prim);
+
+ elsif not Has_Constructors
+ and then not Error_Reported
+ then
+ Error_Msg_Name_1 := Chars (E);
+ Error_Msg_N
+ ("??'C'P'P constructor required for type %", Prim);
+ Error_Reported := True;
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ -- Check Ada derivation of CPP type
+
+ if Expander_Active -- why? losing errors in -gnatc mode???
+ and then Tagged_Type_Expansion
+ and then Ekind (E) = E_Record_Type
+ and then Etype (E) /= E
+ and then Is_CPP_Class (Etype (E))
+ and then CPP_Num_Prims (Etype (E)) > 0
+ and then not Is_CPP_Class (E)
+ and then not Has_CPP_Constructors (Etype (E))
+ then
+ -- If the parent has C++ primitives but it has no constructor then
+ -- check that all the primitives are overridden in this derivation;
+ -- otherwise the constructor of the parent is needed to build the
+ -- dispatch table.
+
+ declare
+ Elmt : Elmt_Id;
+ Prim : Node_Id;
+
+ begin
+ Elmt := First_Elmt (Primitive_Operations (E));
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if not Is_Abstract_Subprogram (Prim)
+ and then No (Interface_Alias (Prim))
+ and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E
+ then
+ Error_Msg_Name_1 := Chars (Etype (E));
+ Error_Msg_N
+ ("'C'P'P constructor required for parent type %", E);
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
+
+ -- If we have a type with predicates, build predicate function. This
+ -- is not needed in the generic casee
+
+ if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then
+ Build_Predicate_Functions (E, N);
+ end if;
+
+ -- If type has delayed aspects, this is where we do the preanalysis at
+ -- the freeze point, as part of the consistent visibility check. Note
+ -- that this must be done after calling Build_Predicate_Functions or
+ -- Build_Invariant_Procedure since these subprograms fix occurrences of
+ -- the subtype name in the saved expression so that they will not cause
+ -- trouble in the preanalysis.
+
+ -- This is also not needed in the generic case
+
+ if Non_Generic_Case
+ and then Has_Delayed_Aspects (E)
+ and then Scope (E) = Current_Scope
+ then
+ -- Retrieve the visibility to the discriminants in order to properly
+ -- analyze the aspects.
+
+ Push_Scope_And_Install_Discriminants (E);
+
+ declare
+ Ritem : Node_Id;
+
+ begin
+ -- Look for aspect specification entries for this entity
+
+ Ritem := First_Rep_Item (E);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Entity (Ritem) = E
+ and then Is_Delayed_Aspect (Ritem)
+ then
+ Check_Aspect_At_Freeze_Point (Ritem);
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+ end;
+
+ Uninstall_Discriminants_And_Pop_Scope (E);
+ end if;
+
+ -- For a record type, deal with variant parts. This has to be delayed
+ -- to this point, because of the issue of statically precicated
+ -- subtypes, which we have to ensure are frozen before checking
+ -- choices, since we need to have the static choice list set.
+
+ if Is_Record_Type (E) then
+ Check_Variant_Part : declare
+ D : constant Node_Id := Declaration_Node (E);
+ T : Node_Id;
+ C : Node_Id;
+ VP : Node_Id;
+
+ Others_Present : Boolean;
+ pragma Warnings (Off, Others_Present);
+ -- Indicates others present, not used in this case
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id);
+ -- Error routine invoked by the generic instantiation below when
+ -- the variant part has a non static choice.
+
+ procedure Process_Declarations (Variant : Node_Id);
+ -- Processes declarations associated with a variant. We analyzed
+ -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
+ -- but we still need the recursive call to Check_Choices for any
+ -- nested variant to get its choices properly processed. This is
+ -- also where we expand out the choices if expansion is active.
+
+ package Variant_Choices_Processing is new
+ Generic_Check_Choices
+ (Process_Empty_Choice => No_OP,
+ Process_Non_Static_Choice => Non_Static_Choice_Error,
+ Process_Associated_Node => Process_Declarations);
+ use Variant_Choices_Processing;
+
+ -----------------------------
+ -- Non_Static_Choice_Error --
+ -----------------------------
+
+ procedure Non_Static_Choice_Error (Choice : Node_Id) is
+ begin
+ Flag_Non_Static_Expr
+ ("choice given in variant part is not static!", Choice);
+ end Non_Static_Choice_Error;
+
+ --------------------------
+ -- Process_Declarations --
+ --------------------------
+
+ procedure Process_Declarations (Variant : Node_Id) is
+ CL : constant Node_Id := Component_List (Variant);
+ VP : Node_Id;
+
+ begin
+ -- Check for static predicate present in this variant
+
+ if Has_SP_Choice (Variant) then
+
+ -- Here we expand. You might expect to find this call in
+ -- Expand_N_Variant_Part, but that is called when we first
+ -- see the variant part, and we cannot do this expansion
+ -- earlier than the freeze point, since for statically
+ -- predicated subtypes, the predicate is not known till
+ -- the freeze point.
+
+ -- Furthermore, we do this expansion even if the expander
+ -- is not active, because other semantic processing, e.g.
+ -- for aggregates, requires the expanded list of choices.
+
+ -- If the expander is not active, then we can't just clobber
+ -- the list since it would invalidate the ASIS -gnatct tree.
+ -- So we have to rewrite the variant part with a Rewrite
+ -- call that replaces it with a copy and clobber the copy.
+
+ if not Expander_Active then
+ declare
+ NewV : constant Node_Id := New_Copy (Variant);
+ begin
+ Set_Discrete_Choices
+ (NewV, New_Copy_List (Discrete_Choices (Variant)));
+ Rewrite (Variant, NewV);
+ end;
+ end if;
+
+ Expand_Static_Predicates_In_Choices (Variant);
+ end if;
+
+ -- We don't need to worry about the declarations in the variant
+ -- (since they were analyzed by Analyze_Choices when we first
+ -- encountered the variant), but we do need to take care of
+ -- expansion of any nested variants.
+
+ if not Null_Present (CL) then
+ VP := Variant_Part (CL);
+
+ if Present (VP) then
+ Check_Choices
+ (VP, Variants (VP), Etype (Name (VP)), Others_Present);
+ end if;
+ end if;
+ end Process_Declarations;
+
+ -- Start of processing for Check_Variant_Part
+
+ begin
+ -- Find component list
+
+ C := Empty;
+
+ if Nkind (D) = N_Full_Type_Declaration then
+ T := Type_Definition (D);
+
+ if Nkind (T) = N_Record_Definition then
+ C := Component_List (T);
+
+ elsif Nkind (T) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (T))
+ then
+ C := Component_List (Record_Extension_Part (T));
+ end if;
+ end if;
+
+ -- Case of variant part present
+
+ if Present (C) and then Present (Variant_Part (C)) then
+ VP := Variant_Part (C);
+
+ -- Check choices
+
+ Check_Choices
+ (VP, Variants (VP), Etype (Name (VP)), Others_Present);
+
+ -- If the last variant does not contain the Others choice,
+ -- replace it with an N_Others_Choice node since Gigi always
+ -- wants an Others. Note that we do not bother to call Analyze
+ -- on the modified variant part, since its only effect would be
+ -- to compute the Others_Discrete_Choices node laboriously, and
+ -- of course we already know the list of choices corresponding
+ -- to the others choice (it's the list we're replacing!)
+
+ -- We only want to do this if the expander is active, since
+ -- we do not want to clobber the ASIS tree!
+
+ if Expander_Active then
+ declare
+ Last_Var : constant Node_Id :=
+ Last_Non_Pragma (Variants (VP));
+
+ Others_Node : Node_Id;
+
+ begin
+ if Nkind (First (Discrete_Choices (Last_Var))) /=
+ N_Others_Choice
+ then
+ Others_Node := Make_Others_Choice (Sloc (Last_Var));
+ Set_Others_Discrete_Choices
+ (Others_Node, Discrete_Choices (Last_Var));
+ Set_Discrete_Choices
+ (Last_Var, New_List (Others_Node));
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Variant_Part;
+ end if;
+ end Freeze_Entity_Checks;
+
-------------------------
-- Get_Alignment_Value --
-------------------------
