+2015-03-13 Robert Dewar <dewar@adacore.com>
+
+ * exp_unst.adb (Note_Uplevel_Reference): Eliminate duplicate
+ references.
+ (Actual_Ref): New function.
+ (AREC_String): Minor reformatting.
+ (Unnest_Subprogram): Use Actual_Ref.
+ * frontend.adb (Frontend): Turn off Unnest_Subprogram_Mode
+ before call to Instantiate_Bodies.
+
+2015-03-13 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Profile): If the return type of a function
+ being frozen is an untagged limited view and the function is
+ abstract, mark the type as frozen because there is no later
+ point at which the profile of the subprogram will be elaborated.
+
+2015-03-13 Robert Dewar <dewar@adacore.com>
+
+ * einfo.adb, einfo.ads, atree.adb, atree.ads, atree.h: Add seventh
+ component to entities. Add new fields Field36-41 and Node36-41.
+
+2015-03-13 Claire Dross <dross@adacore.com>
+
+ * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Rewrite after review.
+
+2015-03-13 Robert Dewar <dewar@adacore.com>
+
+ * exp_util.adb (Is_Volatile_Reference): Compile time known
+ value is never considered to be a volatile reference.
+
+2015-03-13 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Contract): Suppress "constant
+ cannot be volatile" for internally generated object (such as
+ FIRST and LAST constants).
+
+2015-03-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Validate_Access_Subprogram_Instance): If a
+ convention is specified for the formal parameter, verify that
+ the actual has the same convention.
+ * sem_prag.adb (Set_Convention_From_Pragma): Allow convention
+ pragma to be set on a generic formal type.
+ * sem_util.adb (Set_Convention): Ignore within an instance,
+ as it has already been verified in the generic unit.
+
2015-03-13 Claire Dross <dross@adacore.com>
* inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do not inline
return Nodes.Table (N + 5).Field11;
end Field35;
+ function Field36 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field6;
+ end Field36;
+
+ function Field37 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field7;
+ end Field37;
+
+ function Field38 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field8;
+ end Field38;
+
+ function Field39 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field9;
+ end Field39;
+
+ function Field40 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field10;
+ end Field40;
+
+ function Field41 (N : Node_Id) return Union_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Nodes.Table (N + 6).Field11;
+ end Field41;
+
function Node1 (N : Node_Id) return Node_Id is
begin
pragma Assert (N <= Nodes.Last);
return Node_Id (Nodes.Table (N + 5).Field11);
end Node35;
+ function Node36 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field6);
+ end Node36;
+
+ function Node37 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field7);
+ end Node37;
+
+ function Node38 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field8);
+ end Node38;
+
+ function Node39 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field9);
+ end Node39;
+
+ function Node40 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field10);
+ end Node40;
+
+ function Node41 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 6).Field11);
+ end Node41;
+
function List1 (N : Node_Id) return List_Id is
begin
pragma Assert (N <= Nodes.Last);
Nodes.Table (N + 5).Field11 := Val;
end Set_Field35;
+ procedure Set_Field36 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field6 := Val;
+ end Set_Field36;
+
+ procedure Set_Field37 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field7 := Val;
+ end Set_Field37;
+
+ procedure Set_Field38 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field8 := Val;
+ end Set_Field38;
+
+ procedure Set_Field39 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field9 := Val;
+ end Set_Field39;
+
+ procedure Set_Field40 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field10 := Val;
+ end Set_Field40;
+
+ procedure Set_Field41 (N : Node_Id; Val : Union_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field11 := Val;
+ end Set_Field41;
+
procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N <= Nodes.Last);
Nodes.Table (N + 5).Field11 := Union_Id (Val);
end Set_Node35;
+ procedure Set_Node36 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field6 := Union_Id (Val);
+ end Set_Node36;
+
+ procedure Set_Node37 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field7 := Union_Id (Val);
+ end Set_Node37;
+
+ procedure Set_Node38 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field8 := Union_Id (Val);
+ end Set_Node38;
+
+ procedure Set_Node39 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field9 := Union_Id (Val);
+ end Set_Node39;
+
+ procedure Set_Node40 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field10 := Union_Id (Val);
+ end Set_Node40;
+
+ procedure Set_Node41 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 6).Field11 := Union_Id (Val);
+ end Set_Node41;
+
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N <= Nodes.Last);
-- Size of Entities --
----------------------
- -- Currently entities are composed of 6 sequentially allocated 32-byte
+ -- Currently entities are composed of 7 sequentially allocated 32-byte
-- nodes, considered as a single record. The following definition gives
-- the number of extension nodes.
- Num_Extension_Nodes : Node_Id := 5;
+ Num_Extension_Nodes : Node_Id := 6;
-- This value is increased by one if debug flag -gnatd.N is set. This is
-- for testing performance impact of adding a new extension node. We make
-- this of type Node_Id for easy reference in loops using this value.
-- Elist6 Synonym for Field6 typed as Elist_Id (Empty = No_Elist)
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
- -- Similar definitions for Field7 to Field35 (and also Node7-Node35,
- -- Elist7-Elist35, Uint7-Uint35, Ureal7-Ureal35). Note that not all
+ -- Similar definitions for Field7 to Field41 (and also Node7-Node41,
+ -- Elist7-Elist41, Uint7-Uint41, Ureal7-Ureal41). Note that not all
-- these functions are defined, only the ones that are actually used.
function Last_Node_Id return Node_Id;
-- Field1-5 fields are set to Empty
- -- Field6-35 fields in extended nodes are set to Empty
+ -- Field6-41 fields in extended nodes are set to Empty
-- Parent is set to Empty
-- All Boolean flag fields are set to False
- -- Note: the value Empty is used in Field1-Field35 to indicate a null node.
+ -- Note: the value Empty is used in Field1-Field41 to indicate a null node.
-- The usage varies. The common uses are to indicate absence of an optional
-- clause or a completely unused Field1-35 field.
function Field35 (N : Node_Id) return Union_Id;
pragma Inline (Field35);
+ function Field36 (N : Node_Id) return Union_Id;
+ pragma Inline (Field36);
+
+ function Field37 (N : Node_Id) return Union_Id;
+ pragma Inline (Field37);
+
+ function Field38 (N : Node_Id) return Union_Id;
+ pragma Inline (Field38);
+
+ function Field39 (N : Node_Id) return Union_Id;
+ pragma Inline (Field39);
+
+ function Field40 (N : Node_Id) return Union_Id;
+ pragma Inline (Field40);
+
+ function Field41 (N : Node_Id) return Union_Id;
+ pragma Inline (Field41);
+
function Node1 (N : Node_Id) return Node_Id;
pragma Inline (Node1);
function Node35 (N : Node_Id) return Node_Id;
pragma Inline (Node35);
+ function Node36 (N : Node_Id) return Node_Id;
+ pragma Inline (Node36);
+
+ function Node37 (N : Node_Id) return Node_Id;
+ pragma Inline (Node37);
+
+ function Node38 (N : Node_Id) return Node_Id;
+ pragma Inline (Node38);
+
+ function Node39 (N : Node_Id) return Node_Id;
+ pragma Inline (Node39);
+
+ function Node40 (N : Node_Id) return Node_Id;
+ pragma Inline (Node40);
+
+ function Node41 (N : Node_Id) return Node_Id;
+ pragma Inline (Node41);
+
function List1 (N : Node_Id) return List_Id;
pragma Inline (List1);
procedure Set_Field35 (N : Node_Id; Val : Union_Id);
pragma Inline (Set_Field35);
+ procedure Set_Field36 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field36);
+
+ procedure Set_Field37 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field37);
+
+ procedure Set_Field38 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field38);
+
+ procedure Set_Field39 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field39);
+
+ procedure Set_Field40 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field40);
+
+ procedure Set_Field41 (N : Node_Id; Val : Union_Id);
+ pragma Inline (Set_Field41);
+
procedure Set_Node1 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node1);
procedure Set_Node35 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node35);
+ procedure Set_Node36 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node36);
+
+ procedure Set_Node37 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node37);
+
+ procedure Set_Node38 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node38);
+
+ procedure Set_Node39 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node39);
+
+ procedure Set_Node40 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node40);
+
+ procedure Set_Node41 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node41);
+
procedure Set_List1 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List1);
-- Flags 4-18 for a normal node. Note that Flags 0-3 are stored
-- separately in the Flags array.
- -- The above fields are used as follows in components 2-6 of
- -- an extended node entry.
+ -- The above fields are used as follows in components 2-6 of an
+ -- extended node entry. Currently they are not used in component 7,
+ -- since for now we have all the flags we need, but of course they
+ -- can be used for additional flags when needed in component 7.
-- In_List used as Flag19,Flag40,Flag129,Flag216,Flag287
-- Has_Aspects used as Flag20,Flag41,Flag130,Flag217,Flag288
-- node, this field holds the Node_Kind value. For an extended node,
-- The Nkind field is used as follows:
--
- -- Second entry: holds the Ekind field of the entity
- -- Third entry: holds 8 additional flags (Flag65-Flag72)
- -- Fourth entry: holds 8 additional flags (Flag239-246)
- -- Fifth entry: holds 8 additional flags (Flag247-254)
- -- Sixth entry: holds 8 additional flags (Flag310-317)
+ -- Second entry: holds the Ekind field of the entity
+ -- Third entry: holds 8 additional flags (Flag65-Flag72)
+ -- Fourth entry: holds 8 additional flags (Flag239-246)
+ -- Fifth entry: holds 8 additional flags (Flag247-254)
+ -- Sixth entry: holds 8 additional flags (Flag310-317)
+ -- Seventh entry: currently unused
-- Now finally (on an 32-bit boundary) comes the variant part
-- Field6-11 Holds Field30-Field35
-- Field12 Holds Flag255-Flag286
+ -- In the seventh component, the extension format as described
+ -- above is used to hold additional general fields as follows.
+ -- Flags are also available potentially, but not used now, as
+ -- we are not short of entity flags.
+
+ -- Field6-11 Holds Field36-Field41
+
end case;
end record;
Field5 => Empty_List_Or_Node);
-- Default value used to initialize node extensions (i.e. the second
- -- through sixth components of an extended node). Note we are cheating
- -- a bit here when it comes to Node12, which really holds flags and (for
+ -- through seventh components of an extended node). Note we are cheating
+ -- a bit here when it comes to Node12, which often holds flags and (for
-- the third component), the convention. But it works because Empty,
-- False, Convention_Ada, all happen to be all zero bits.
#define Field33(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field9)
#define Field34(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.field10)
#define Field35(N) (Nodes_Ptr[(N) - First_Node_Id + 5].V.EX.X.field11)
+#define Field36(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field6)
+#define Field37(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field7)
+#define Field38(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field8)
+#define Field39(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field9)
+#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.field10)
+#define Field41(N) (Nodes_Ptr[(N) - First_Node_Id + 6].V.EX.X.field11)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
#define Node34(N) Field34 (N)
#define Node35(N) Field35 (N)
#define Node36(N) Field36 (N)
+#define Node37(N) Field37 (N)
+#define Node38(N) Field38 (N)
+#define Node39(N) Field39 (N)
+#define Node40(N) Field40 (N)
+#define Node41(N) Field41 (N)
#define List1(N) Field1 (N)
#define List2(N) Field2 (N)
-- Import_Pragma Node35
+ -- (unused) Node36
+ -- (unused) Node37
+ -- (unused) Node38
+ -- (unused) Node39
+ -- (unused) Node40
+ -- (unused) Node41
+
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
---------------------------------------------
end case;
end Write_Field35_Name;
+ ------------------------
+ -- Write_Field36_Name --
+ ------------------------
+
+ procedure Write_Field36_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field36??");
+ end case;
+ end Write_Field36_Name;
+
+ ------------------------
+ -- Write_Field37_Name --
+ ------------------------
+
+ procedure Write_Field37_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field37??");
+ end case;
+ end Write_Field37_Name;
+
+ ------------------------
+ -- Write_Field38_Name --
+ ------------------------
+
+ procedure Write_Field38_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field38??");
+ end case;
+ end Write_Field38_Name;
+
+ ------------------------
+ -- Write_Field39_Name --
+ ------------------------
+
+ procedure Write_Field39_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field39??");
+ end case;
+ end Write_Field39_Name;
+
+ ------------------------
+ -- Write_Field40_Name --
+ ------------------------
+
+ procedure Write_Field40_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field40??");
+ end case;
+ end Write_Field40_Name;
+
+ ------------------------
+ -- Write_Field41_Name --
+ ------------------------
+
+ procedure Write_Field41_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field41??");
+ end case;
+ end Write_Field41_Name;
+
-------------------------
-- Iterator Procedures --
-------------------------
procedure Write_Field33_Name (Id : Entity_Id);
procedure Write_Field34_Name (Id : Entity_Id);
procedure Write_Field35_Name (Id : Entity_Id);
+ procedure Write_Field36_Name (Id : Entity_Id);
+ procedure Write_Field37_Name (Id : Entity_Id);
+ procedure Write_Field38_Name (Id : Entity_Id);
+ procedure Write_Field39_Name (Id : Entity_Id);
+ procedure Write_Field40_Name (Id : Entity_Id);
+ procedure Write_Field41_Name (Id : Entity_Id);
-- These routines are used in Treepr to output a nice symbolic name for
-- the given field, depending on the Ekind. No blanks or end of lines are
-- output, just the characters of the field name.
----------------------------
procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is
+ Elmt : Elmt_Id;
+
begin
-- Nothing to do inside a generic (all processing is for instance)
Set_Uplevel_References (Subp, New_Elmt_List);
end if;
+ -- Ignore if node is already in the list. This is a bit inefficient,
+ -- but we can definitely get duplicates that cause trouble!
+
+ Elmt := First_Elmt (Uplevel_References (Subp));
+ while Present (Elmt) loop
+ if N = Node (Elmt) then
+ return;
+ else
+ Next_Elmt (Elmt);
+ end if;
+ end loop;
+
-- Add new entry to Uplevel_References. Each entry is two elements of
-- the list. The first is the actual reference, the second is the
-- enclosing subprogram at the point of reference
-----------------------
procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
+ function Actual_Ref (N : Node_Id) return Node_Id;
+ -- This function is applied to an element in the Uplevel_References
+ -- list, and it finds the actual reference. Often this is just N itself,
+ -- but in some cases it gets rewritten, e.g. as a Type_Conversion, and
+ -- this function digs out the actual reference
+
function AREC_String (Lev : Pos) return String;
-- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
function Subp_Index (Sub : Entity_Id) return SI_Type;
-- Given the entity for a subprogram, return corresponding Subps index
+ ----------------
+ -- Actual_Ref --
+ ----------------
+
+ function Actual_Ref (N : Node_Id) return Node_Id is
+ begin
+ case Nkind (N) is
+
+ -- If we have an entity reference, then this is the actual ref
+
+ when N_Has_Entity =>
+ return N;
+
+ -- For a type conversion, go get the expression
+
+ when N_Type_Conversion =>
+ return Expression (N);
+
+ -- For an explicit dereference, get the prefix
+
+ when N_Explicit_Dereference =>
+ return Prefix (N);
+
+ -- No other possibilities should exist
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Actual_Ref;
+
-----------------
-- AREC_String --
-----------------
function AREC_String (Lev : Pos) return String is
begin
if Lev > 9 then
- return
- AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
+ return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
else
- return
- "AREC" & Character'Val (Lev + 48);
+ return "AREC" & Character'Val (Lev + 48);
end if;
end AREC_String;
declare
Loc : constant Source_Ptr := Sloc (STJ.Bod);
Elmt : Elmt_Id;
+ Nod : Node_Id;
Ent : Entity_Id;
Clist : List_Id;
Comp : Entity_Id;
if Present (STJ.Urefs) then
Elmt := First_Elmt (STJ.Urefs);
while Present (Elmt) loop
- Ent := Entity (Node (Elmt));
+ Nod := Actual_Ref (Node (Elmt));
+ Ent := Entity (Nod);
if not Uplevel_Reference_Noted (Ent) then
Set_Uplevel_Reference_Noted (Ent, True);
Elmt := First_Elmt (STJ.Urefs);
while Present (Elmt) loop
- -- Skip if we have an explicit dereference. This means
- -- that we already did the expansion. There can be
- -- duplicates in ths STJ.Urefs list.
-
- if Nkind (Node (Elmt)) = N_Explicit_Dereference then
- goto Continue;
- end if;
-
- -- Otherwise, rewrite this reference
+ -- Rewrite one reference
declare
- Ref : constant Node_Id := Node (Elmt);
- -- The uplevel reference itself
+ Ref : constant Node_Id := Actual_Ref (Node (Elmt));
+ -- The reference to be rewritten
Loc : constant Source_Ptr := Sloc (Ref);
-- Source location for the reference
-- type Tnn is access all typ;
- Insert_Action (Ref,
+ Insert_Action (Node (Elmt),
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Tnn,
Type_Definition =>
Pop_Scope;
end;
- <<Continue>>
Next_Elmt (Elmt);
Next_Elmt (Elmt);
end loop;
elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
return False;
+ -- Never true for a compile time known constant
+
+ elsif Compile_Time_Known_Value (N) then
+ return False;
+
-- True if object reference with volatile type
elsif Is_Volatile_Object (N) then
R_Type := Full_View (R_Type);
Set_Etype (E, R_Type);
- -- If the return type is a limited view and the non-
- -- limited view is still incomplete, the function has
- -- to be frozen at a later time.
+ -- If the return type is a limited view and the non-limited
+ -- view is still incomplete, the function has to be frozen at a
+ -- later time. If the function is abstract there is no place at
+ -- which the full view will become available, and no code to be
+ -- generated for it, so mark type as frozen.
elsif Ekind (R_Type) = E_Incomplete_Type
and then From_Limited_With (R_Type)
- and then
- Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
+ and then Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
then
- Set_Is_Frozen (E, False);
- Set_Returns_Limited_View (E);
- return False;
+ if Is_Abstract_Subprogram (E) then
+ null;
+ else
+ Set_Is_Frozen (E, False);
+ Set_Returns_Limited_View (E);
+ return False;
+ end if;
end if;
Freeze_And_Append (R_Type, N, Result);
-- Cleanup processing after completing main analysis
+ -- Turn off unnesting of subprograms mode. This is not right
+ -- with respect to instantiations. What needs to happen is that
+ -- we do the unnesting AFTER the call to Instantiate_Bodies. We
+ -- will take care of that later ???
+
+ Opt.Unnest_Subprogram_Mode := False;
+
-- Comment needed for ASIS mode test and GNATprove mode test???
if Operating_Mode = Generate_Code
(Spec_Id : Entity_Id;
Body_Id : Entity_Id) return Boolean
is
- function Has_Parameter_With_Discriminant_Dependent_Fields
+ function Has_Formal_With_Discriminant_Dependent_Fields
(Id : Entity_Id) return Boolean;
- -- Returns true if the subprogram as parameters of an unconstrained
- -- record types with fields whose types depend on a discriminant.
+ -- Returns true if the subprogram has at least one formal parameters of
+ -- an unconstrained record type with per-object constraints on component
+ -- types.
function Has_Some_Contract (Id : Entity_Id) return Boolean;
-- Returns True if subprogram Id has any contract (Pre, Post, Global,
-- Returns True if subprogram Id was defined originally as an expression
-- function.
- ------------------------------------------------------
- -- Has_Parameter_With_Discriminant_Dependent_Fields --
- ------------------------------------------------------
+ ---------------------------------------------------
+ -- Has_Formal_With_Discriminant_Dependent_Fields --
+ ---------------------------------------------------
- function Has_Parameter_With_Discriminant_Dependent_Fields
- (Id : Entity_Id) return Boolean
- is
- E : Entity_Id := Id;
- Spec : Node_Id := Parent (E);
+ function Has_Formal_With_Discriminant_Dependent_Fields
+ (Id : Entity_Id) return Boolean is
- begin
- -- Get the specification of the subprogram. Go through alias if
- -- needed.
+ function Has_Discriminant_Dependent_Component
+ (Typ : Entity_Id) return Boolean;
+ -- Determine whether unconstrained record type Typ has at least
+ -- one component that depends on a discriminant.
- if Nkind (Spec) = N_Defining_Program_Unit_Name then
- Spec := Parent (Spec);
- end if;
+ ------------------------------------------
+ -- Has_Discriminant_Dependent_Component --
+ ------------------------------------------
- while Nkind (Spec) not in N_Subprogram_Specification loop
- pragma Assert (Present (Alias (E)));
- E := Alias (E);
- Spec := Parent (E);
+ function Has_Discriminant_Dependent_Component
+ (Typ : Entity_Id) return Boolean
+ is
+ Comp : Entity_Id;
- if Nkind (Spec) = N_Defining_Program_Unit_Name then
- Spec := Parent (Spec);
- end if;
- end loop;
+ begin
+ -- Inspect all components of the record type looking for one
+ -- that depends on a discriminant.
- declare
- Params : constant List_Id := Parameter_Specifications (Spec);
- Param : Node_Id;
- Param_Ty : Entity_Id;
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Has_Discriminant_Dependent_Constraint (Comp) then
+ return True;
+ end if;
- begin
- if Is_Non_Empty_List (Params) then
- Param := First (Params);
- while Present (Param) loop
- Param_Ty := Etype (Defining_Identifier (Param));
+ Next_Component (Comp);
+ end loop;
- -- If the parameter is an unconstrained record, check if
- -- it has components whose types depend on a discriminant.
+ return False;
+ end Has_Discriminant_Dependent_Component;
- if Is_Record_Type (Param_Ty)
- and then not Is_Constrained (Param_Ty)
- then
- declare
- Comp : Node_Id := First_Component (Param_Ty);
+ -- Local variables
- begin
- while Present (Comp) loop
- if Has_Discriminant_Dependent_Constraint (Comp) then
- return True;
- end if;
+ Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
- Comp := Next_Component (Comp);
- end loop;
- end;
- end if;
+ -- Start of processing for
+ -- Has_Formal_With_Discriminant_Dependent_Component
- Param := Next (Param);
- end loop;
+ begin
+ -- Inspect all parameters of the subprogram looking for a formal
+ -- of an unconstrained record type with at least one discriminant
+ -- dependent component.
+
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+
+ if Is_Record_Type (Formal_Typ)
+ and then not Is_Constrained (Formal_Typ)
+ and then Has_Discriminant_Dependent_Component (Formal_Typ)
+ then
+ return True;
end if;
- end;
+
+ Next_Formal (Formal);
+ end loop;
return False;
- end Has_Parameter_With_Discriminant_Dependent_Fields;
+ end Has_Formal_With_Discriminant_Dependent_Fields;
-----------------------
-- Has_Some_Contract --
-- in record component accesses (in particular with records containing
-- packed arrays).
- elsif Has_Parameter_With_Discriminant_Dependent_Fields (Id) then
+ elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
return False;
-- Otherwise, this is a subprogram declared inside the private part of a
("expect protected access type for formal &",
Actual, Gen_T);
end if;
+
+ -- If the formal has a specified convention (which in most cases
+ -- will be StdCall) verify that the actual has the same convention.
+
+ if Has_Convention_Pragma (A_Gen_T)
+ and then Convention (A_Gen_T) /= Convention (Act_T)
+ then
+ Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T));
+ Error_Msg_NE
+ ("actual for formal & must have convention %", Actual, Gen_T);
+ end if;
end Validate_Access_Subprogram_Instance;
-----------------------------------
if SPARK_Mode = On
and then Is_Effectively_Volatile (Obj_Id)
and then No (Corresponding_Generic_Association (Parent (Obj_Id)))
+
+ -- Don't give this for internally generated entities (such as the
+ -- FIRST and LAST temporaries generated for bounds.
+
+ and then Comes_From_Source (Obj_Id)
then
Error_Msg_N ("constant cannot be volatile", Obj_Id);
end if;
Set_Convention_From_Pragma (E);
if Is_Type (E) then
- Check_First_Subtype (Arg2);
+
+ -- The pragma must apply to a first subtype, but it can also
+ -- apply to a generic type in a generic formal part, in which
+ -- case it will also appear in the corresponding instance.
+
+ if Is_Generic_Type (E) or else In_Instance then
+ null;
+ else
+ Check_First_Subtype (Arg2);
+ end if;
+
Set_Convention_From_Pragma (Base_Type (E));
-- For access subprograms, we must set the convention on the
and then Is_Access_Subprogram_Type (Base_Type (E))
and then Has_Foreign_Convention (E)
then
- Set_Can_Use_Internal_Rep (E, False);
+
+ -- A convention pragma in an instance may apply to the subtype
+ -- created for a formal, in which case we have already verified
+ -- that conventions of actual and formal match and there is nothing
+ -- to flag on the subtype.
+
+ if In_Instance then
+ null;
+ else
+ Set_Can_Use_Internal_Rep (E, False);
+ end if;
end if;
-- If E is an object or component, and the type of E is an anonymous
projects / gcc.git / commitdiff