+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads: Minor comment fix.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Do no generate
+ a discriminant check for a type whose partial view has unknown
+ discriminants when the full view has discriminants with defaults.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): When generating C code
+ remove side effect of type conversion of access to unconstrained
+ array type.
+ (Side_Effect_Free): Return false for the type
+ conversion of access to unconstrained array type when generating
+ C code.
+ * sem_res.adb (Resolved_Type_Conversion): Remove side effects
+ of access to unconstrained array type conversion when generating
+ C code.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Build_Predicate_Function_Declaration): New
+ function, to construct the declaration of a predicate function
+ at the end of the current declarative part rather than at the
+ (possibly later) freeze point of the type. This also allows uses
+ of a type with predicates in instantiations elsewhere.
+ (Resolve_Aspect_Expression): New procedure to detect visiblity
+ errors in aspect expressions, at the end of the declarative part
+ that includes the type declaration.
+ * sem_ch3.adb (Complete_Private_Subtype): Propagate properly the
+ predicate function from private to full view.
+ * einfo.adb (Predicate_Function): Refine search for predicate
+ function when type has a full view and predicate function may
+ be defined on either view.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * frontend.adb: Passing the root of the tree to
+ Unnest_Subprograms().
+ * exp_ch6.adb (Expand_N_Subprogram_Body): Remove code that
+ took care of adding subprograms to the Unest_Bodies table since
+ performing such action too early disables the ability to process
+ generic instantiations.
+ (Unnest_Subprograms): Adding parameter.
+ (Search_Unnesting_Subprograms): New subprogram.
+ * exp_ch6.ads (Unnest_Subrograms): Update documentation.
+
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb, freeze.adb, sem_util.adb: Minor reformatting.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- If type is private and has a completion, predicate may be defined
-- on the full view.
- if Is_Private_Type (Id) and then Present (Full_View (Id)) then
+ if Is_Private_Type (Id)
+ and then
+ (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
+ and then Present (Full_View (Id))
+ then
T := Full_View (Id);
+
else
T := Id;
end if;
-- have a full view with discriminants, but those are nameable only
-- in the underlying type, so convert the Rhs to it before potential
-- checking. Convert Lhs as well, otherwise the actual subtype might
- -- not be constructible.
+ -- not be constructible. If the discriminants have defaults the type
+ -- is unconstrained and there is nothing to check.
elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
and then Has_Discriminants (Typ)
+ and then not Has_Defaulted_Discriminants (Typ)
then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
Qualify_Entity_Names (N);
- -- If we are unnesting procedures, and this is an outer level procedure
- -- with nested subprograms, do the unnesting operation now.
-
- if Opt.Unnest_Subprogram_Mode
-
- -- We are only interested in subprograms (not generic subprograms)
-
- and then Is_Subprogram (Spec_Id)
-
- -- Only deal with outer level subprograms. Nested subprograms are
- -- handled as part of dealing with the outer level subprogram in
- -- which they are nested.
-
- and then Enclosing_Subprogram (Spec_Id) = Empty
-
- -- We are only interested in subprograms that have nested subprograms
-
- and then Has_Nested_Subprogram (Spec_Id)
- then
- Unest_Bodies.Append ((Spec_Id, N));
- end if;
-
Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Subprogram_Body;
-- Unnest_Subprograms --
------------------------
- procedure Unnest_Subprograms is
+ procedure Unnest_Subprograms (N : Node_Id) is
+
+ procedure Search_Unnesting_Subprograms (N : Node_Id);
+ -- Search for outer level procedures with nested subprograms and append
+ -- them to the Unnest table.
+
+ ----------------------------------
+ -- Search_Unnesting_Subprograms --
+ ----------------------------------
+
+ procedure Search_Unnesting_Subprograms (N : Node_Id) is
+
+ function Search_Subprograms (N : Node_Id) return Traverse_Result;
+ -- Tree visitor that search for outer level procedures with nested
+ -- subprograms and adds them to the Unnest table.
+
+ ------------------------
+ -- Search_Subprograms --
+ ------------------------
+
+ function Search_Subprograms (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (N, N_Subprogram_Body,
+ N_Subprogram_Body_Stub)
+ then
+ declare
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
+
+ begin
+ -- We are only interested in subprograms (not generic
+ -- subprograms), that have nested subprograms.
+
+ if Is_Subprogram (Spec_Id)
+ and then Has_Nested_Subprogram (Spec_Id)
+ and then Is_Library_Level_Entity (Spec_Id)
+ then
+ Unest_Bodies.Append ((Spec_Id, N));
+ end if;
+ end;
+ end if;
+
+ return OK;
+ end Search_Subprograms;
+
+ ---------------
+ -- Do_Search --
+ ---------------
+
+ procedure Do_Search is new Traverse_Proc (Search_Subprograms);
+ -- Subtree visitor instantiation
+
+ -- Start of processing for Search_Unnesting_Subprograms
+
+ begin
+ if Opt.Unnest_Subprogram_Mode then
+ Do_Search (N);
+ end if;
+ end Search_Unnesting_Subprograms;
+
+ -- Start of processing for Unnest_Subprograms
+
begin
+ if not Opt.Unnest_Subprogram_Mode then
+ return;
+ end if;
+
+ Search_Unnesting_Subprograms (N);
+
for J in Unest_Bodies.First .. Unest_Bodies.Last loop
declare
UBJ : Unest_Entry renames Unest_Bodies.Table (J);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
- procedure Unnest_Subprograms;
- -- Called to unnest subprograms. If we are in unnest subprogram mode, and
- -- subprograms have been gathered in the Unest_Bodies table, this is the
- -- call that causes them to be processed for unnesting.
+ procedure Unnest_Subprograms (N : Node_Id);
+ -- Called to unnest subprograms. If we are in unnest subprogram mode, this
+ -- is the call that traverses the tree N and locates all the library level
+ -- subprograms with nested subprograms to process them.
end Exp_Ch6;
elsif Nkind (Exp) = N_Type_Conversion then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
- goto Leave;
+
+ -- Generating C code the type conversion of an access to constrained
+ -- array type into an access to unconstrained array type involves
+ -- initializing a fat pointer and the expression must be free of
+ -- side effects to safely compute its bounds.
+
+ if Generate_C_Code
+ and then Is_Access_Type (Etype (Exp))
+ and then Is_Array_Type (Designated_Type (Etype (Exp)))
+ and then not Is_Constrained (Designated_Type (Etype (Exp)))
+ then
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
+ Set_Etype (Def_Id, Exp_Type);
+ Res := New_Occurrence_Of (Def_Id, Loc);
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Exp)));
+ else
+ goto Leave;
+ end if;
-- If this is an unchecked conversion that Gigi can't handle, make
-- a copy or a use a renaming to capture the value.
and then Is_Class_Wide_Type (Typ)
then
return True;
+
+ -- Generating C the type conversion of an access to constrained array
+ -- type into an access to unconstrained array type involves initializing
+ -- a fat pointer and the expression cannot be assumed to be free of side
+ -- effects since it must referenced several times to compute its bounds.
+
+ elsif Generate_C_Code
+ and then Nkind (N) = N_Type_Conversion
+ and then Is_Access_Type (Typ)
+ and then Is_Array_Type (Designated_Type (Typ))
+ and then not Is_Constrained (Designated_Type (Typ))
+ then
+ return False;
end if;
-- For other than entity names and compile time known values,
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- At this stage we can unnest subprogram bodies if required
- Exp_Ch6.Unnest_Subprograms;
+ Exp_Ch6.Unnest_Subprograms (Cunit (Main_Unit));
-- List library units if requested
-- that is writable. Returns True if so, False otherwise. Note that this
-- function simply interrogates the file attributes (e.g. using the C
-- function stat), so it does not indicate a situation in which a file may
- -- not actually be writeable due to some other process having exclusive
+ -- not actually be writable due to some other process having exclusive
-- access.
function Locate_Exec_On_Path (Exec_Name : String) return String_Access;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
-- rewritten as a canonicalized membership operation.
+ function Build_Predicate_Function_Declaration
+ (Typ : Entity_Id) return Node_Id;
+ -- Build the declaration for a predicate function. The declaration is built
+ -- at the end of the declarative part containing the type definition, which
+ -- may be before the freeze point of the type. The predicate expression is
+ -- pre-analyzed at this point, to catch visibility errors.
+
procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ),
-- then either there are pragma Predicate entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragma Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes.
- -- This procedure builds the spec and body for the Predicate function that
- -- tests these predicates. N is the freeze node for the type. The spec of
- -- the function is inserted before the freeze node, and the body of the
- -- function is inserted after the freeze node. If the predicate expression
- -- has at least one Raise_Expression, then this procedure also builds the
- -- M version of the predicate function for use in membership tests.
+ -- This procedure builds body for the Predicate function that tests these
+ -- predicates. N is the freeze node for the type. The spec of the function
+ -- is inserted before the freeze node, and the body of the function is
+ -- inserted after the freeze node. If the predicate expression has a least
+ -- one Raise_Expression, then this procedure also builds the M version of
+ -- the predicate function for use in membership tests.
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
-- function. It differs in that raise expressions are marked for
-- special expansion (see Process_REs).
- Object_Name : constant Name_Id := New_Internal_Name ('I');
+ Object_Name : Name_Id;
-- Name for argument of Predicate procedure. Note that we use the same
-- name for both predicate functions. That way the reference within the
-- predicate expression is the same in both functions.
- Object_Entity : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
+ Object_Entity : Entity_Id;
-- Entity for argument of Predicate procedure
- Object_Entity_M : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
- -- Entity for argument of Predicate_M procedure
+ Object_Entity_M : Entity_Id;
+ -- Entity for argument of separate Predicate procedure when exceptions
+ -- are present in expression.
+
+ FDecl : Node_Id;
+ -- The function declaration.
+
+ SId : Entity_Id;
+ -- Its entity.
Raise_Expression_Present : Boolean := False;
-- Set True if Expr has at least one Raise_Expression
begin
-- Return if already built or if type does not have predicates
+ SId := Predicate_Function (Typ);
if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
+ or else (Present (SId) and then Has_Completion (SId))
then
return;
end if;
Expr := Empty;
+ if Present (SId) then
+ FDecl := Unit_Declaration_Node (SId);
+
+ else
+ FDecl := Build_Predicate_Function_Declaration (Typ);
+ SId := Defining_Entity (FDecl);
+ end if;
+
+ -- Recover name of formal parameter of function that replaces references
+ -- to the type in predicate expressions.
+
+ Object_Entity :=
+ Defining_Identifier
+ (First (Parameter_Specifications (Specification (FDecl))));
+
+ Object_Name := Chars (Object_Entity);
+ Object_Entity_M := Make_Defining_Identifier (Loc, Chars => Object_Name);
+
-- Add predicates for ancestor if present. These must come before the
-- ones for the current type, as required by AI12-0071-1.
Add_Call (Atyp);
end if;
end;
-
-- Add Predicates for the current type
Add_Predicates;
-- Build the main predicate function
declare
- SId : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- -- The entity for the function spec
-
SIdB : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
-- The entity for the function body
Spec : Node_Id;
- FDecl : Node_Id;
FBody : Node_Id;
begin
- -- Build function declaration
-
- Set_Ekind (SId, E_Function);
- Set_Is_Internal (SId);
- Set_Is_Predicate_Function (SId);
- Set_Predicate_Function (Typ, SId);
-- The predicate function is shared between views of a type
Set_Is_Ghost_Entity (SId);
end if;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
-
-- Build function body
Spec :=
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
- -- Insert declaration before freeze node and body after
+ -- If declaration has not been analyzed yet, Insert declaration
+ -- before freeze node.
+ -- Insert body after freeze node.
+
+ if not Analyzed (FDecl) then
+ Insert_Before_And_Analyze (N, FDecl);
+ end if;
- Insert_Before_And_Analyze (N, FDecl);
Insert_After_And_Analyze (N, FBody);
-- Static predicate functions are always side-effect free, and
-- The entity for the function body
Spec : Node_Id;
- FDecl : Node_Id;
FBody : Node_Id;
+ FDecl : Node_Id;
BTemp : Entity_Id;
begin
Ghost_Mode := Save_Ghost_Mode;
end Build_Predicate_Functions;
+ ------------------------------------------
+ -- Build_Predicate_Function_Declaration --
+ ------------------------------------------
+
+ function Build_Predicate_Function_Declaration
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I'));
+
+ -- The formal parameter of the function
+
+ SId : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ -- The entity for the function spec
+
+ FDecl : Node_Id;
+ Spec : Node_Id;
+
+ begin
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ Set_Ekind (SId, E_Function);
+ Set_Etype (SId, Standard_Boolean);
+ Set_Is_Internal (SId);
+ Set_Is_Predicate_Function (SId);
+ Set_Predicate_Function (Typ, SId);
+
+ if Comes_From_Source (Typ) then
+ Insert_After (Parent (Typ), FDecl);
+ else
+ Insert_After (Parent (Base_Type (Typ)), FDecl);
+ end if;
+
+ Analyze (FDecl);
+
+ return FDecl;
+ end Build_Predicate_Function_Declaration;
+
-----------------------------------------
-- Check_Aspect_At_End_Of_Declarations --
-----------------------------------------
A_Id : Aspect_Id;
Expr : Node_Id;
+ function Resolve_Name (N : Node_Id) return Traverse_Result;
+ -- Verify that all identifiers in the expression, with the exception
+ -- of references to the current entity, denote visible entities. This
+ -- is done only to detect visibility errors, as the expression will be
+ -- properly analyzed/expanded during analysis of the predicate function
+ -- body.
+
+ ------------------
+ -- Resolve_Name --
+ ------------------
+
+ function Resolve_Name (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ if Nkind (Prefix (N)) = N_Identifier
+ and then Chars (Prefix (N)) /= Chars (E)
+ then
+ Find_Selected_Component (Parent (N));
+ end if;
+ return Skip;
+
+ elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then
+ Find_Direct_Name (N);
+ Set_Entity (N, Empty);
+ end if;
+
+ return OK;
+ end Resolve_Name;
+
+ procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name);
+
begin
ASN := First_Rep_Item (E);
while Present (ASN) loop
when Aspect_Predicate |
Aspect_Predicate_Failure |
- Aspect_Invariant |
- Aspect_Static_Predicate |
- Aspect_Dynamic_Predicate =>
+ Aspect_Invariant =>
null;
+ when Aspect_Static_Predicate |
+ Aspect_Dynamic_Predicate =>
+
+ -- build predicate function specification and preanalyze
+ -- expression after type replacement.
+
+ if No (Predicate_Function (E)) then
+ declare
+ FDecl : constant Node_Id :=
+ Build_Predicate_Function_Declaration (E);
+ pragma Unreferenced (FDecl);
+ begin
+ Resolve_Aspect_Expression (Expr);
+ end;
+ end if;
+
when Pre_Post_Aspects =>
null;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- in particular when the full type is a scalar type for which an
-- anonymous base type is constructed.
+ -- The predicate functions are generated either at the freeze point
+ -- of the type or at the end of the visible part, and we must avoid
+ -- generating them twice.
+
if Has_Predicates (Priv) then
Set_Has_Predicates (Full);
+ if Present (Predicate_Function (Priv))
+ and then No (Predicate_Function (Full))
+ then
+ Set_Predicate_Function (Full, Predicate_Function (Priv));
+ end if;
end if;
if Has_Delayed_Aspects (Priv) then
then
Set_Do_Range_Check (Operand);
end if;
+
+ -- Generating C code a type conversion of an access to constrained
+ -- array type to access to unconstrained array type involves building
+ -- a fat pointer which in general cannot be generated on the fly. We
+ -- remove side effects in order to store the result of the conversion
+ -- into a temporary.
+
+ if Generate_C_Code
+ and then Nkind (N) = N_Type_Conversion
+ and then Nkind (Parent (N)) /= N_Object_Declaration
+ and then Is_Access_Type (Etype (N))
+ and then Is_Array_Type (Designated_Type (Etype (N)))
+ and then not Is_Constrained (Designated_Type (Etype (N)))
+ and then Is_Constrained (Designated_Type (Etype (Expression (N))))
+ then
+ Remove_Side_Effects (N);
+ end if;
end Resolve_Type_Conversion;
----------------------
projects / gcc.git / commitdiff