+2014-02-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part): Add
+ local variable Expr. Flag clauses with extra parenthesis as this
+ is not allowed by the syntax of the pragma. Code reformatting.
+
+2014-02-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Alphabetize
+ variables. Rename variabme Tnn to Temp. Do not create a temporary
+ if assertions are disabled. Find enclosing routine _Postconditions
+ and insert the temporary that captures the value of the prefix
+ before the routine.
+ * exp_ch6.adb (Build_Postconditions_Procedure):
+ Insert the generated _Postconditions routine
+ before the first source declaration of the related
+ subprogram.
+ (Insert_After_Last_Declaration): Removed.
+ (Insert_Before_First_Source_Declaration): New routine.
+
+2014-02-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb, exp_util.ads (Within_Internal_Subprogram):
+ Utility to determine whether current expansion is for the body
+ of a predefined primitive operation.
+ (Make_Predicate_Check): Use Within_Internal_Subpgram
+ * checks.adb (Apply_Predicate_Check): Use
+ Within_Internal_Subprogram
+ * sem_ch13.adb (Freeze_Entity_Checks): Ditto.
+
+2014-02-06 Pascal Obry <obry@adacore.com>
+
+ * prj.ads, prj-util.adb: Minor reformatting.
+
2014-02-06 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Subprogram_Contract, Append_Enabled_Item):
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
-with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
with Expander; use Expander;
begin
if Present (Predicate_Function (Typ)) then
- -- A predicate check does not apply within internally generated
- -- subprograms, such as TSS functions.
-
S := Current_Scope;
while Present (S) and then not Is_Subprogram (S) loop
S := Scope (S);
end loop;
- if Present (S) and then Get_TSS_Name (S) /= TSS_Null then
+ -- A predicate check does not apply within internally generated
+ -- subprograms, such as TSS functions.
+
+ if Within_Internal_Subprogram then
return;
-- If the check appears within the predicate function itself, it
-- predicated subtype itself, rather than some covering type. This
-- is likely to be a common error, and thus deserves a warning.
- elsif S = Predicate_Function (Typ) then
+ elsif Present (S) and then S = Predicate_Function (Typ) then
Error_Msg_N
("predicate check includes a function call that "
& "requires a predicate check??", Parent (N));
elsif Serious_Errors_Detected > 0 then
return;
+ -- Never generate discriminant checks for Unchecked_Union types
+
+ elsif Present (Expr_Type)
+ and then Is_Unchecked_Union (Expr_Type)
+ then
+ return;
+
-- Scalar type conversions of the form Target_Type (Expr) require a
-- range check if we cannot be sure that Expr is in the base type of
-- Target_Typ and also that Expr is in the range of Target_Typ. These
declare
Conv_OK : constant Boolean := Conversion_OK (N);
-- If the Conversion_OK flag on the type conversion is set and no
- -- floating point type is involved in the type conversion then
- -- fixed point values must be read as integral values.
+ -- floating-point type is involved in the type conversion then
+ -- fixed-point values must be read as integral values.
Float_To_Int : constant Boolean :=
Is_Floating_Point_Type (Expr_Type)
(Expr, Target_Type, Fixed_Int => Conv_OK);
-- If the target type has predicates, we need to indicate
- -- the need for a check, even if Determine_Range finds
- -- that the value is within bounds. This may be the case
- -- e.g for a division with a constant denominator.
+ -- the need for a check, even if Determine_Range finds that
+ -- the value is within bounds. This may be the case e.g for
+ -- a division with a constant denominator.
if Has_Predicates (Target_Type) then
Enable_Range_Check (Expr);
-- An unconstrained derived type may have inherited discriminant.
-- Build an actual discriminant constraint list using the stored
-- constraint, to verify that the expression of the parent type
- -- satisfies the constraints imposed by the (unconstrained)
- -- derived type. This applies to value conversions, not to view
- -- conversions of tagged types.
+ -- satisfies the constraints imposed by the (unconstrained) derived
+ -- type. This applies to value conversions, not to view conversions
+ -- of tagged types.
declare
Loc : constant Source_Ptr := Sloc (N);
begin
pragma Assert
- (K = N_Component_Declaration
- or else K = N_Discriminant_Specification
- or else K = N_Function_Specification
- or else K = N_Object_Declaration
- or else K = N_Parameter_Specification);
+ (Nkind_In (K, N_Component_Declaration,
+ N_Discriminant_Specification,
+ N_Function_Specification,
+ N_Object_Declaration,
+ N_Parameter_Specification));
if K = N_Function_Specification then
Typ := Etype (Defining_Entity (N));
---------
when Attribute_Old => Old : declare
- Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref);
- Subp : Node_Id;
Asn_Stm : Node_Id;
+ Subp : Node_Id;
+ Temp : Entity_Id;
begin
-- If assertions are disabled, no need to create the declaration
return;
end if;
- -- Find the nearest subprogram body, ignoring _Preconditions
+ Temp := Make_Temporary (Loc, 'T', Pref);
+
+ -- Climb the parent chain looking for subprogram _Postconditions
Subp := N;
- loop
- Subp := Parent (Subp);
+ while Present (Subp) loop
exit when Nkind (Subp) = N_Subprogram_Body
- and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
+ and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
+
+ Subp := Parent (Subp);
end loop;
- -- Insert the initialized object declaration at the start of the
- -- subprogram's declarations.
+ -- 'Old can only appear in a postcondition, the generated body of
+ -- _Postconditions must be in the tree.
+
+ pragma Assert (Present (Subp));
+
+ -- Generate:
+ -- Temp : constant <Pref type> := <Pref>;
Asn_Stm :=
Make_Object_Declaration (Loc,
- Defining_Identifier => Tnn,
+ Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Etype (N), Loc),
Expression => Pref);
- -- Push the subprogram's scope, so that the object will be analyzed
- -- in that context (rather than the context of the Precondition
- -- subprogram) and will have its Scope set properly.
+ -- Push the scope of the related subprogram where _Postcondition
+ -- resides as this ensures that the object will be analyzed in the
+ -- proper context.
- if Present (Corresponding_Spec (Subp)) then
- Push_Scope (Corresponding_Spec (Subp));
- else
- Push_Scope (Defining_Entity (Subp));
- end if;
+ Push_Scope (Scope (Defining_Entity (Subp)));
- if Is_Empty_List (Declarations (Subp)) then
- Set_Declarations (Subp, New_List (Asn_Stm));
- Analyze (Asn_Stm);
- else
- Insert_Action (First (Declarations (Subp)), Asn_Stm);
- end if;
+ -- The object declaration is inserted before the body of subprogram
+ -- _Postconditions. This ensures that any precondition-like actions
+ -- are still executed before any parameter values are captured and
+ -- the multiple 'Old occurrences appear in order of declaration.
+
+ Insert_Before_And_Analyze (Subp, Asn_Stm);
+ Pop_Scope;
-- Ensure that the prefix of attribute 'Old is valid. The check must
-- be inserted after the expansion of the attribute has taken place
Ensure_Valid (Pref);
end if;
- Pop_Scope;
-
- Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
end Old;
----------------------
Stmts : List_Id;
Result : Entity_Id)
is
- procedure Insert_After_Last_Declaration (Stmt : Node_Id);
- -- Insert node Stmt after the last declaration of the subprogram body
+ procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id);
+ -- Insert node Stmt before the first source declaration of the
+ -- related subprogram's body. If no such declaration exists, Stmt
+ -- becomes the last declaration.
- -----------------------------------
- -- Insert_After_Last_Declaration --
- -----------------------------------
+ --------------------------------------------
+ -- Insert_Before_First_Source_Declaration --
+ --------------------------------------------
- procedure Insert_After_Last_Declaration (Stmt : Node_Id) is
- Decls : List_Id := Declarations (N);
+ procedure Insert_Before_First_Source_Declaration (Stmt : Node_Id) is
+ Decls : constant List_Id := Declarations (N);
+ Decl : Node_Id;
begin
+ -- Inspect the declarations of the related subprogram body looking
+ -- for the first source declaration.
+
+ if Present (Decls) then
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Comes_From_Source (Decl) then
+ Insert_Before (Decl, Stmt);
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ -- If we get there, then the subprogram body lacks any source
+ -- declarations. The body of _Postconditions now acts as the
+ -- last declaration.
+
+ Append (Stmt, Decls);
+
-- Ensure that the body has a declaration list
- if No (Decls) then
- Decls := New_List;
- Set_Declarations (N, Decls);
+ else
+ Set_Declarations (N, New_List (Stmt));
end if;
-
- Append_To (Decls, Stmt);
- end Insert_After_Last_Declaration;
+ end Insert_Before_First_Source_Declaration;
-- Local variables
New_Reference_To (Etype (Result), Loc)));
end if;
- -- Insert _Postconditions after the last declaration of the body.
- -- This ensures that the body will not cause any premature freezing
- -- as it may mention types:
+ -- Insert _Postconditions before the first source declaration of the
+ -- body. This ensures that the body will not cause any premature
+ -- freezing as it may mention types:
-- procedure Proc (Obj : Array_Typ) is
-- procedure _postconditions is
-- order reference. The body of _Postconditions must be placed after
-- the declaration of Temp to preserve correct visibility.
- Insert_After_Last_Declaration (
+ Insert_Before_First_Source_Declaration (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
return Make_Null_Statement (Loc);
end if;
+ -- Do not generate a check within an internal subprogram (stream
+ -- functions and the like, including including predicate functions).
+
+ if Within_Internal_Subprogram then
+ return Make_Null_Statement (Loc);
+ end if;
+
-- Compute proper name to use, we need to get this right so that the
-- right set of check policies apply to the Check pragma we are making.
return False;
end Within_Case_Or_If_Expression;
+ --------------------------------
+ -- Within_Internal_Subprogram --
+ --------------------------------
+
+ function Within_Internal_Subprogram return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while Present (S) and then not Is_Subprogram (S) loop
+ S := Scope (S);
+ end loop;
+
+ return Present (S)
+ and then Get_TSS_Name (S) /= TSS_Null
+ and then not Is_Predicate_Function (S);
+ end Within_Internal_Subprogram;
+
----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
+ function Within_Internal_Subprogram return Boolean;
+ -- Indicates that some expansion is taking place within the body of a
+ -- predefined primitive operation. Some expansion activity (e.g. predicate
+ -- checks) is disabled in such.
+
procedure Wrap_Cleanup_Procedure (N : Node_Id);
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call
-- at the start of the statement sequence, and an Abort_Undefer call at the
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
if Sid.Kind = Spec
and then not Sid.Locally_Removed
and then (Project.Standalone_Library = No
- or else Sid.Declared_In_Interfaces)
+ or else Sid.Declared_In_Interfaces)
then
Action (Sid);
-- Indicate that this is a Standalone Library Project File
Lib_Interface_ALIs : String_List_Id := Nil_String;
- -- For Standalone Library Project Files, list of Interface ALI files.
+ -- For Standalone Library Project Files, list of Interface ALI files
Other_Interfaces : String_List_Id := Nil_String;
-- List of non unit based sources in attribute Interfaces
-- Build function declaration
Set_Ekind (SId, E_Function);
+ Set_Is_Internal (SId);
Set_Is_Predicate_Function (SId);
Set_Predicate_Function (Typ, SId);
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
+ -- is not needed in the generic casee, and is not needed within TSS
+ -- subprograms and other predefined primitives.
- if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then
+ if Non_Generic_Case
+ and then Is_Type (E)
+ and then Has_Predicates (E)
+ and then not Within_Internal_Subprogram
+ then
Build_Predicate_Functions (E, N);
end if;
Clause : Node_Id;
Errors : Nat;
+ Expr : Node_Id;
Last_Clause : Node_Id;
Subp_Decl : Node_Id;
-- Dependency clauses appear as component associations of an aggregate
- elsif Nkind (Clause) = N_Aggregate
- and then Present (Component_Associations (Clause))
- then
- Last_Clause := Last (Component_Associations (Clause));
+ elsif Nkind (Clause) = N_Aggregate then
- -- Gather all states, variables and formal parameters that the
- -- subprogram may depend on. These items are obtained from the
- -- parameter profile or pragma [Refined_]Global (if available).
+ -- The aggregate should not have an expression list because a clause
+ -- is always interpreted as a component association. The only way an
+ -- expression list can sneak in is by adding extra parenthesis around
+ -- the individual clauses:
- Collect_Subprogram_Inputs_Outputs
- (Subp_Id => Subp_Id,
- Subp_Inputs => Subp_Inputs,
- Subp_Outputs => Subp_Outputs,
- Global_Seen => Global_Seen);
+ -- Depends (Output => Input) -- proper form
+ -- Depends ((Output => Input)) -- extra parenthesis
- -- Ensure that the formal parameters are visible when analyzing all
- -- clauses. This falls out of the general rule of aspects pertaining
- -- to subprogram declarations. Skip the installation for subprogram
- -- bodies because the formals are already visible.
+ -- Since the extra parenthesis are not allowed by the syntax of the
+ -- pragma, flag them now to avoid emitting misleading errors down the
+ -- line.
- if not In_Open_Scopes (Spec_Id) then
- Restore_Scope := True;
- Push_Scope (Spec_Id);
- Install_Formals (Spec_Id);
+ if Present (Expressions (Clause)) then
+ Expr := First (Expressions (Clause));
+ while Present (Expr) loop
+
+ -- A dependency clause surrounded by extra parenthesis appears
+ -- as an aggregate of component associations with an optional
+ -- Paren_Count set.
+
+ if Nkind (Expr) = N_Aggregate
+ and then Present (Component_Associations (Expr))
+ then
+ Error_Msg_N
+ ("dependency clause contains extra parenthesis", Expr);
+
+ -- Otherwise the expression is a malformed construct
+
+ else
+ Error_Msg_N ("malformed dependency clause", Expr);
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ -- Do not attempt to perform analysis of syntactically illegal
+ -- clauses as this will lead to misleading errors.
+
+ return;
end if;
- Clause := First (Component_Associations (Clause));
- while Present (Clause) loop
- Errors := Serious_Errors_Detected;
+ if Present (Component_Associations (Clause)) then
+ Last_Clause := Last (Component_Associations (Clause));
- -- Normalization may create extra clauses that contain replicated
- -- input and output names. There is no need to reanalyze them.
+ -- Gather all states, variables and formal parameters that the
+ -- subprogram may depend on. These items are obtained from the
+ -- parameter profile or pragma [Refined_]Global (if available).
- if not Analyzed (Clause) then
- Set_Analyzed (Clause);
+ Collect_Subprogram_Inputs_Outputs
+ (Subp_Id => Subp_Id,
+ Subp_Inputs => Subp_Inputs,
+ Subp_Outputs => Subp_Outputs,
+ Global_Seen => Global_Seen);
- Analyze_Dependency_Clause
- (Clause => Clause,
- Is_Last => Clause = Last_Clause);
+ -- Ensure that the formal parameters are visible when analyzing
+ -- all clauses. This falls out of the general rule of aspects
+ -- pertaining to subprogram declarations. Skip the installation
+ -- for subprogram bodies because the formals are already visible.
+
+ if not In_Open_Scopes (Spec_Id) then
+ Restore_Scope := True;
+ Push_Scope (Spec_Id);
+ Install_Formals (Spec_Id);
end if;
- -- Do not normalize an erroneous clause because the inputs and/or
- -- outputs may denote illegal items.
+ Clause := First (Component_Associations (Clause));
+ while Present (Clause) loop
+ Errors := Serious_Errors_Detected;
+
+ -- Normalization may create extra clauses that contain
+ -- replicated input and output names. There is no need to
+ -- reanalyze them.
+
+ if not Analyzed (Clause) then
+ Set_Analyzed (Clause);
+
+ Analyze_Dependency_Clause
+ (Clause => Clause,
+ Is_Last => Clause = Last_Clause);
+ end if;
+
+ -- Do not normalize an erroneous clause because the inputs
+ -- and/or outputs may denote illegal items.
+
+ if Serious_Errors_Detected = Errors then
+ Normalize_Clause (Clause);
+ end if;
+
+ Next (Clause);
+ end loop;
- if Serious_Errors_Detected = Errors then
- Normalize_Clause (Clause);
+ if Restore_Scope then
+ End_Scope;
end if;
- Next (Clause);
- end loop;
+ -- Verify that every input or output of the subprogram appear in a
+ -- dependency.
- if Restore_Scope then
- End_Scope;
- end if;
+ Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
+ Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
+ Check_Function_Return;
- -- Verify that every input or output of the subprogram appear in a
- -- dependency.
+ -- The dependency list is malformed
- Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
- Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
- Check_Function_Return;
+ else
+ Error_Msg_N ("malformed dependency relation", Clause);
+ return;
+ end if;
-- The top level dependency relation is malformed
else
Error_Msg_N ("malformed dependency relation", Clause);
+ return;
end if;
-- Ensure that a state and a corresponding constituent do not appear
projects / thirdparty / gcc.git / commitdiff
