+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_eval.adb (Subtypes_Statically_Compatible): Remove duplicated
+ check.
+ (Subtypes_Statically_Match): Remove duplicate check.
+ * sem_prag.adb (Check_Arg_Is_External_Name): Remove duplicate check.
+
+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Replace_Type): Remove the special processing
+ for selected components.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Merge the
+ processing for attributes Fixed_Value and Integer_Value.
+ * exp_util.adb (Side_Effect_Free): Merge the processing for
+ qualified expressions, type conversions, and unchecked type
+ conversions.
+ * g-comlin.adb (Is_In_Config): Merge the processing for No_Space
+ and Optional.
+ * par-ch3.adb (P_Declarative_Items): Merge the processing for
+ tokens function, not, overriding, and procedure.
+ * sem_ch6.adb (Fully_Conformant_Expressions): Merge the processing
+ for qualified expressions, type conversions, and unchecked
+ type conversions.
+ * sem_util.adb (Compile_Time_Constraint_Error): Merge the
+ processing for Ada 83 and instances.
+ (Object_Access_Level): Merge the processing for indexed components
+ and selected components.
+ * uname.adb (Add_Node_Name): Merge the processing for stubs.
+
+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Install_Primitive_Elaboration_Check):
+ Do not generate the check when restriction No_Elaboration_Code
+ is in effect.
+
+2017-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_disp.adb (Build_Class_Wide_Check): New subsidiary
+ of Expand_Dispatching_Call. If the denoted subprogram has a
+ class-wide precondition, this is the only precondition that
+ applies to the call, rather that the class-wide preconditions
+ that may apply to the body that is executed. (This is specified
+ in AI12-0195).
+
2017-04-27 Yannick Moy <moy@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Issue
-----------------------------------------
procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is
-
function Within_Compilation_Unit_Instance
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id appears within an instance which
if ASIS_Mode or GNATprove_Mode then
return;
+ -- Do not generate an elaboration check if such code is not desirable
+
+ elsif Restriction_Active (No_Elaboration_Code) then
+ return;
+
-- Do not generate an elaboration check if the related subprogram is
-- not subjected to accessibility checks.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
and then Root_Type (Etype (N)) = Root_Type (Entity (Prefix (Expr)))
then
if Is_Entity_Name (Lhs) then
- Rewrite (Prefix (Expr),
- New_Occurrence_Of (Entity (Lhs), Loc));
-
- elsif Nkind (Lhs) = N_Selected_Component then
- Rewrite (Expr,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => New_Copy_Tree (Lhs)));
- Set_Analyzed (Parent (Expr), False);
+ Rewrite (Prefix (Expr), New_Occurrence_Of (Entity (Lhs), Loc));
else
Rewrite (Expr,
end if;
end First_Bit_Attr;
- -----------------
- -- Fixed_Value --
- -----------------
+ --------------------------------
+ -- Fixed_Value, Integer_Value --
+ --------------------------------
- -- We transform:
+ -- We transform
-- fixtype'Fixed_Value (integer-value)
+ -- inttype'Fixed_Value (fixed-value)
-- into
- -- fixtype(integer-value)
+ -- fixtype (integer-value)
+ -- inttype (fixed-value)
+
+ -- respectively.
-- We do all the required analysis of the conversion here, because we do
-- not want this to go through the fixed-point conversion circuits. Note
-- that the back end always treats fixed-point as equivalent to the
-- corresponding integer type anyway.
- when Attribute_Fixed_Value =>
+ when Attribute_Fixed_Value
+ | Attribute_Integer_Value
+ =>
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
end if;
end Input;
- -------------------
- -- Integer_Value --
- -------------------
-
- -- We transform
-
- -- inttype'Fixed_Value (fixed-value)
-
- -- into
-
- -- inttype(integer-value))
-
- -- we do all the required analysis of the conversion here, because we do
- -- not want this to go through the fixed-point conversion circuits. Note
- -- that the back end always treats fixed-point as equivalent to the
- -- corresponding integer type anyway.
-
- when Attribute_Integer_Value =>
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
- Expression => Relocate_Node (First (Exprs))));
- Set_Etype (N, Entity (Pref));
- Set_Analyzed (N);
-
- -- Note: it might appear that a properly analyzed unchecked
- -- conversion would be just fine here, but that's not the case, since
- -- the full range check performed by the following call is critical.
-
- Apply_Type_Conversion_Checks (N);
-
-------------------
-- Invalid_Value --
-------------------
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
Eq_Prim_Op : Entity_Id := Empty;
Controlling_Tag : Node_Id;
+ procedure Build_Class_Wide_Check;
+ -- If the denoted subprogram has a class-wide precondition, generate
+ -- a check using that precondition before the dispatching call, because
+ -- this is the only class-wide precondition that applies to the call.
+
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
-- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter.
+ ----------------------------
+ -- Build_Class_Wide_Check --
+ ----------------------------
+
+ procedure Build_Class_Wide_Check is
+ Prec : Node_Id;
+ Cond : Node_Id;
+ Msg : Node_Id;
+ Str_Loc : constant String := Build_Location_String (Loc);
+
+ function Replace_Formals (N : Node_Id) return Traverse_Result;
+ -- Replace occurrences of the formals of the subprogram by the
+ -- corresponding actuals in the call, given that this check is
+ -- performed outside of the body of the subprogram.
+
+ ---------------------
+ -- Replace_Formals --
+ ---------------------
+
+ function Replace_Formals (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Formal (Entity (N))
+ then
+ declare
+ A : Node_Id;
+ F : Entity_Id;
+
+ begin
+ F := First_Formal (Subp);
+ A := First_Actual (Call_Node);
+ while Present (F) loop
+ if F = Entity (N) then
+ Rewrite (N, New_Copy_Tree (A));
+ exit;
+ end if;
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end;
+ end if;
+
+ return OK;
+ end Replace_Formals;
+
+ procedure Update is new Traverse_Proc (Replace_Formals);
+ begin
+
+ -- Locate class-wide precondition, if any
+
+ if Present (Contract (Subp))
+ and then Present (Pre_Post_Conditions (Contract (Subp)))
+ then
+ Prec := Pre_Post_Conditions (Contract (Subp));
+
+ while Present (Prec) loop
+ exit when Pragma_Name (Prec) = Name_Precondition
+ and then Class_Present (Prec);
+ Prec := Next_Pragma (Prec);
+ end loop;
+
+ if No (Prec) then
+ return;
+ end if;
+
+ -- The expression for the precondition is analyzed within the
+ -- generated pragma. The message text is the last parameter
+ -- of the generated pragma, indicating source of precondition.
+
+ Cond := New_Copy_Tree
+ (Expression (First (Pragma_Argument_Associations (Prec))));
+ Update (Cond);
+
+ -- Build message indicating the failed precondition and the
+ -- dispatching call that caused it.
+
+ Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
+ Name_Len := 0;
+ Append (Global_Name_Buffer, Strval (Msg));
+ Append (Global_Name_Buffer, " in dispatching call at ");
+ Append (Global_Name_Buffer, Str_Loc);
+ Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
+
+ Insert_Action (Call_Node,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Cond),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (Msg)))));
+ end if;
+ end Build_Class_Wide_Check;
+
---------------
-- New_Value --
---------------
Subp := Alias (Subp);
end if;
+ Build_Class_Wide_Check;
+
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
if not Tagged_Type_Expansion then
return;
- -- A static conversion to an interface type that is not classwide is
+ -- A static conversion to an interface type that is not class-wide is
-- curious but legal if the interface operation is a null procedure.
-- If the operation is abstract it will be rejected later.
if not Is_Static then
- -- Give error if configurable run time and Displace not available
+ -- Give error if configurable run-time and Displace not available
if not RTE_Available (RE_Displace) then
Error_Msg_CRT ("dynamic interface conversion", N);
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
- -- A type qualification is side effect free if the expression
- -- is side effect free.
+ -- A type qualification, type conversion, or unchecked expression is
+ -- side effect free if the expression is side effect free.
- when N_Qualified_Expression =>
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Expression
+ =>
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A selected component is side effect free only if it is a side
Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
- -- A type conversion is side effect free if the expression to be
- -- converted is side effect free.
-
- when N_Type_Conversion =>
- return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-
-- A unary operator is side effect free if the operand
-- is side effect free.
and then Side_Effect_Free
(Expression (N), Name_Req, Variable_Ref);
- -- An unchecked expression is side effect free if its expression
- -- is side effect free.
-
- when N_Unchecked_Expression =>
- return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-
-- A literal is side effect free
when N_Character_Literal
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2017, 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- --
Found_In_Config := True;
return False;
- when Parameter_No_Space =>
- Callback (Switch, "", Parameter, Index);
- Found_In_Config := True;
- return False;
-
- when Parameter_Optional =>
+ when Parameter_No_Space
+ | Parameter_Optional
+ =>
Callback (Switch, "", Parameter, Index);
Found_In_Config := True;
return False;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
end if;
case Token is
- when Tok_Function =>
+ when Tok_Function
+ | Tok_Not
+ | Tok_Overriding
+ | Tok_Procedure
+ =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Done := False;
P_Identifier_Declarations (Decls, Done, In_Spec);
end if;
- -- Ada 2005: A subprogram declaration can start with "not" or
- -- "overriding". In older versions, "overriding" is handled
- -- like an identifier, with the appropriate messages.
-
- when Tok_Not =>
- Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
- Done := False;
-
- when Tok_Overriding =>
- Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
- Done := False;
-
when Tok_Package =>
Check_Bad_Layout;
Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
Append (P_Pragma, Decls);
Done := False;
- when Tok_Procedure =>
- Check_Bad_Layout;
- Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
- Done := False;
-
when Tok_Protected =>
Check_Bad_Layout;
Scan; -- past PROTECTED
and then FCE (Explicit_Actual_Parameter (E1),
Explicit_Actual_Parameter (E2));
- when N_Qualified_Expression =>
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
return
FCE (Subtype_Mark (E1), Subtype_Mark (E2))
and then
end if;
end;
- when N_Type_Conversion =>
- return
- FCE (Subtype_Mark (E1), Subtype_Mark (E2))
- and then
- FCE (Expression (E1), Expression (E2));
-
when N_Unary_Op =>
return
Entity (E1) = Entity (E2)
and then
FCE (Right_Opnd (E1), Right_Opnd (E2));
- when N_Unchecked_Type_Conversion =>
- return
- FCE (Subtype_Mark (E1), Subtype_Mark (E2))
- and then
- FCE (Expression (E1), Expression (E2));
-
-- All other node types cannot appear in this context. Strictly
-- we should raise a fatal internal error. Instead we just ignore
-- the nodes. This means that if anyone makes a mistake in the
then
return False;
- -- If either type has constraint error bounds, then consider that
- -- they match to avoid junk cascaded errors here.
-
- elsif not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
- then
- return True;
-
-- Base types must match, but we don't check that (should we???) but
-- we do at least check that both types are real, or both types are
-- not real.
begin
if Is_Real_Type (T1) then
return
- (Expr_Value_R (LB1) > Expr_Value_R (HB1))
+ Expr_Value_R (LB1) > Expr_Value_R (HB1)
or else
- (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
- and then
- Expr_Value_R (HB1) <= Expr_Value_R (HB2));
+ (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
+ and then Expr_Value_R (HB1) <= Expr_Value_R (HB2));
else
return
- (Expr_Value (LB1) > Expr_Value (HB1))
+ Expr_Value (LB1) > Expr_Value (HB1)
or else
- (Expr_Value (LB2) <= Expr_Value (LB1)
- and then
- Expr_Value (HB1) <= Expr_Value (HB2));
+ (Expr_Value (LB2) <= Expr_Value (LB1)
+ and then Expr_Value (HB1) <= Expr_Value (HB2));
end if;
end;
end if;
-- Access types
elsif Is_Access_Type (T1) then
- return (not Is_Constrained (T2)
- or else (Subtypes_Statically_Match
- (Designated_Type (T1), Designated_Type (T2))))
+ return
+ (not Is_Constrained (T2)
+ or else Subtypes_Statically_Match
+ (Designated_Type (T1), Designated_Type (T2)))
and then not (Can_Never_Be_Null (T2)
and then not Can_Never_Be_Null (T1));
-- All other cases
else
- return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
- or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
+ return
+ (Is_Composite_Type (T1) and then not Is_Constrained (T2))
+ or else Subtypes_Statically_Match
+ (T1, T2, Formal_Derived_Matching);
end if;
end Subtypes_Statically_Compatible;
else
if not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
+ or else
+ not Is_OK_Static_Subtype (T2)
then
return False;
- -- If either type has constraint error bounds, then say that
- -- they match to avoid junk cascaded errors here.
-
- elsif not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
- then
- return True;
-
elsif Is_Real_Type (T1) then
return
- (Expr_Value_R (LB1) = Expr_Value_R (LB2))
+ Expr_Value_R (LB1) = Expr_Value_R (LB2)
and then
- (Expr_Value_R (HB1) = Expr_Value_R (HB2));
+ Expr_Value_R (HB1) = Expr_Value_R (HB2);
else
return
then
return;
- -- Static expression that raises Constraint_Error. This has
- -- already been flagged, so just exit from pragma processing.
-
- elsif Is_OK_Static_Expression (Argx) then
- raise Pragma_Exit;
-
-- Here we have a real error (non-static expression)
else
Error_Msg_Name_1 := Pname;
+ Flag_Non_Static_Expr
+ (Fix_Error ("argument for pragma% must be a identifier or "
+ & "static string expression!"), Argx);
- declare
- Msg : constant String :=
- "argument for pragma% must be a identifier or "
- & "static string expression!";
- begin
- Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
- raise Pragma_Exit;
- end;
+ raise Pragma_Exit;
end if;
end if;
end Check_Arg_Is_External_Name;
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
if Nkind (Argx) /= N_Identifier then
- Error_Pragma_Arg
- ("argument for pragma% must be identifier", Argx);
+ Error_Pragma_Arg ("argument for pragma% must be identifier", Argx);
end if;
end Check_Arg_Is_Identifier;
Eloc := Sloc (N);
end if;
- -- Copy message to Msgc, converting any ? in the message into
- -- < instead, so that we have an error in GNATprove mode.
+ -- Copy message to Msgc, converting any ? in the message into <
+ -- instead, so that we have an error in GNATprove mode.
Msgl := Msg'Length;
if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
Wmsg := True;
- -- In Ada 83, all messages are warnings. In the private part and
- -- the body of an instance, constraint_checks are only warnings.
- -- We also make this a warning if the Warn parameter is set.
+ -- In Ada 83, all messages are warnings. In the private part and the
+ -- body of an instance, constraint_checks are only warnings. We also
+ -- make this a warning if the Warn parameter is set.
elsif Warn
or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
+ or else In_Instance_Not_Visible
then
Msgl := Msgl + 1;
Msgc (Msgl) := '<';
Msgc (Msgl) := '<';
Wmsg := True;
- elsif In_Instance_Not_Visible then
- Msgl := Msgl + 1;
- Msgc (Msgl) := '<';
- Msgl := Msgl + 1;
- Msgc (Msgl) := '<';
- Wmsg := True;
-
- -- Otherwise we have a real error message (Ada 95 static case)
- -- and we make this an unconditional message. Note that in the
- -- warning case we do not make the message unconditional, it seems
- -- quite reasonable to delete messages like this (about exceptions
- -- that will be raised) in dead code.
+ -- Otherwise we have a real error message (Ada 95 static case) and we
+ -- make this an unconditional message. Note that in the warning case
+ -- we do not make the message unconditional, it seems reasonable to
+ -- delete messages like this (about exceptions that will be raised)
+ -- in dead code.
else
Wmsg := False;
end if;
end if;
- elsif Nkind (Obj) = N_Selected_Component then
- if Is_Access_Type (Etype (Prefix (Obj))) then
- return Type_Access_Level (Etype (Prefix (Obj)));
- else
- return Object_Access_Level (Prefix (Obj));
- end if;
-
- elsif Nkind (Obj) = N_Indexed_Component then
+ elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
if Is_Access_Type (Etype (Prefix (Obj))) then
return Type_Access_Level (Etype (Prefix (Obj)));
else
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
when N_Compilation_Unit =>
Add_Node_Name (Unit (Node));
- when N_Package_Body_Stub =>
- Add_Node_Name (Get_Parent (Node));
- Add_Char ('.');
- Add_Node_Name (Defining_Identifier (Node));
-
- when N_Protected_Body_Stub
+ when N_Package_Body_Stub
+ | N_Protected_Body_Stub
| N_Task_Body_Stub
=>
Add_Node_Name (Get_Parent (Node));
projects / gcc.git / commitdiff