Skip to content

R
riscv-gcc-1
Commit 28e18b4f by Arnaud Charlet
Options

[multiple changes] 

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Complete_Object_Operation): If the type of the
	candidate subprogram is a limited view, use non-limited view
	when available.

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb: Minor change in RM reference.
	* sem_mech.ads: Minor reformatting.
	* einfo.ads: Minor comment fix.
	* types.ads: Minor correction to range given for Mechanism_Type.
	* exp_ch6.adb (Add_Invariant_And_Predicate_Checks): Do not
	check predicate on way out for OUT or IN OUT parameters.
	* par-ch3.adb (P_Constraint_Opt): Handle missing RANGE keyword
	better (P_Range_Constraint): Corresponding fix.
	* checks.ads: Minor comment clarification.

2014-07-29  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch8.adb (Analyze_Object_Renaming): Set the Is_Volatile
	and Treat_As_Volatile flags based on whether the renamed object
	is a volatile object.

From-SVN: r213170
parent f8c79ade
Showing with 132 additions and 101 deletions
gcc/ada/ChangeLog
2014-07-29 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Complete_Object_Operation): If the type of the
candidate subprogram is a limited view, use non-limited view
when available.
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb: Minor change in RM reference.
* sem_mech.ads: Minor reformatting.
* einfo.ads: Minor comment fix.
* types.ads: Minor correction to range given for Mechanism_Type.
* exp_ch6.adb (Add_Invariant_And_Predicate_Checks): Do not
check predicate on way out for OUT or IN OUT parameters.
* par-ch3.adb (P_Constraint_Opt): Handle missing RANGE keyword
better (P_Range_Constraint): Corresponding fix.
* checks.ads: Minor comment clarification.
2014-07-29 Gary Dismukes <dismukes@adacore.com>
* sem_ch8.adb (Analyze_Object_Renaming): Set the Is_Volatile
and Treat_As_Volatile flags based on whether the renamed object
is a volatile object.
2014-07-29 Olivier Hainque <hainque@adacore.com>
* g-debpoo.adb
......
gcc/ada/checks.ads
......@@ -245,8 +245,7 @@ package Checks is
procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
-- N is an expression to which a predicate check may need to be applied
-- for Typ, if Typ has a predicate function. The check is applied only
-- if the type of N does not match Typ.
-- for Typ, if Typ has a predicate function.
procedure Apply_Type_Conversion_Checks (N : Node_Id);
-- N is an N_Type_Conversion node. A type conversion actually involves
......
gcc/ada/einfo.ads
......@@ -3172,9 +3172,9 @@ package Einfo is
-- Mechanism (Uint8) (returned as Mechanism_Type)
-- Defined in functions and non-generic formal parameters. Indicates
-- the mechanism to be used for the function return or for the formal
-- parameter. See separate section on passing mechanisms. This field
-- is also set (to the default value of zero) in a subprogram body
-- entity but not used in this context.
-- parameter. See full description in the spec of Sem_Mech. This field
-- is also set (to the default value of zero = Default_Mechanism) in a
-- subprogram body entity but not used in this context.
-- Modulus (Uint17) [base type only]
-- Defined in modular types. Contains the modulus. For the binary case,
......
gcc/ada/exp_ch6.adb
......@@ -8248,10 +8248,6 @@ package body Exp_Ch6 is
-- subprogram Subp_Id must appear visible from the point of view of
-- the type.
function Predicate_Checks_OK (Typ : Entity_Id) return Boolean;
-- Determine whether type Typ can benefit from predicate checks. To
-- qualify, the type must have at least one checked predicate.
---------------------------------
-- Add_Invariant_Access_Checks --
---------------------------------
......@@ -8414,57 +8410,6 @@ package body Exp_Ch6 is
and then Has_Public_Visibility_Of_Subprogram;
end Invariant_Checks_OK;
-------------------------
-- Predicate_Checks_OK --
-------------------------
function Predicate_Checks_OK (Typ : Entity_Id) return Boolean is
function Has_Checked_Predicate return Boolean;
-- Determine whether type Typ has or inherits at least one
-- predicate aspect or pragma, for which the applicable policy is
-- Checked.
---------------------------
-- Has_Checked_Predicate --
---------------------------
function Has_Checked_Predicate return Boolean is
Anc : Entity_Id;
Pred : Node_Id;
begin
-- Climb the ancestor type chain staring from the input. This
-- is done because the input type may lack aspect/pragma
-- predicate and simply inherit those from its ancestor.
-- Note that predicate pragmas correspond to all three cases
-- of predicate aspects (Predicate, Dynamic_Predicate, and
-- Static_Predicate), so this routine checks for all three
-- cases.
Anc := Typ;
while Present (Anc) loop
Pred := Get_Pragma (Anc, Pragma_Predicate);
if Present (Pred) and then not Is_Ignored (Pred) then
return True;
end if;
Anc := Nearest_Ancestor (Anc);
end loop;
return False;
end Has_Checked_Predicate;
-- Start of processing for Predicate_Checks_OK
begin
return
Has_Predicates (Typ)
and then Present (Predicate_Function (Typ))
and then Has_Checked_Predicate;
end Predicate_Checks_OK;
-- Local variables
Loc : constant Source_Ptr := Sloc (N);
......@@ -8529,12 +8474,11 @@ package body Exp_Ch6 is
Add_Invariant_Access_Checks (Formal);
if Predicate_Checks_OK (Typ) then
Append_Enabled_Item
(Item => Make_Predicate_Check
(Typ, New_Occurrence_Of (Formal, Loc)),
List => Stmts);
end if;
-- Note: we used to add predicate checks for OUT and IN OUT
-- formals here, but that was misguided, since such checks are
-- performed on the caller side, based on the predicate of the
-- actual, rather than the predicate of the formal.
end if;
Next_Formal (Formal);
......
gcc/ada/par-ch3.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
......@@ -1217,19 +1217,13 @@ package body Ch3 is
function P_Constraint_Opt return Node_Id is
begin
if Token = Tok_Range
or else Bad_Spelling_Of (Tok_Range)
then
if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then
return P_Range_Constraint;
elsif Token = Tok_Digits
or else Bad_Spelling_Of (Tok_Digits)
then
elsif Token = Tok_Digits or else Bad_Spelling_Of (Tok_Digits) then
return P_Digits_Constraint;
elsif Token = Tok_Delta
or else Bad_Spelling_Of (Tok_Delta)
then
elsif Token = Tok_Delta or else Bad_Spelling_Of (Tok_Delta) then
return P_Delta_Constraint;
elsif Token = Tok_Left_Paren then
......@@ -1239,6 +1233,31 @@ package body Ch3 is
Ignore (Tok_In);
return P_Constraint_Opt;
-- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword)
elsif Token = Tok_Identifier or else
Token = Tok_Integer_Literal or else
Token = Tok_Real_Literal
then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State); -- at identifier or literal
Scan; -- past identifier or literal
if Token = Tok_Dot_Dot then
Restore_Scan_State (Scan_State);
Error_Msg_BC ("missing RANGE keyword");
return P_Range_Constraint;
else
Restore_Scan_State (Scan_State);
return Empty;
end if;
end;
-- Nothing worked, no constraint there
else
return Empty;
end if;
......@@ -2033,7 +2052,9 @@ package body Ch3 is
-- RANGE_CONSTRAINT ::= range RANGE
-- The caller has checked that the initial token is RANGE
-- The caller has checked that the initial token is RANGE or some
-- misspelling of it, or it may be absent completely (and a message
-- has already been issued).
-- Error recovery: cannot raise Error_Resync
......@@ -2042,7 +2063,13 @@ package body Ch3 is
begin
Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
Scan; -- past RANGE
-- Skip range keyword if present
if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then
Scan; -- past RANGE
end if;
Set_Range_Expression (Range_Node, P_Range);
return Range_Node;
end P_Range_Constraint;
......
gcc/ada/sem_ch13.adb
......@@ -8097,7 +8097,7 @@ package body Sem_Ch13 is
if Has_Static_Predicate_Aspect (Typ) then
if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then
Error_Msg_F
("expression is not predicate-static (RM 4.3.2(16-22))",
("expression is not predicate-static (RM 3.2.4(16-22))",
EN);
else
Error_Msg_F
......
gcc/ada/sem_ch4.adb
......@@ -7542,6 +7542,18 @@ package body Sem_Ch4 is
Save_Interps (Subprog, Node_To_Replace);
else
-- The type of the subprogram may be a limited view obtained
-- transitively from another unit. If full view is available,
-- use it to analyze call.
declare
T : constant Entity_Id := Etype (Subprog);
begin
if From_Limited_With (T) then
Set_Etype (Entity (Subprog), Available_View (T));
end if;
end;
Analyze (Node_To_Replace);
-- If the operation has been rewritten into a call, which may get
......@@ -7587,7 +7599,7 @@ package body Sem_Ch4 is
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
("\possible interpretation "
& "( inherited, with implicit dereference) #", N);
& "(inherited, with implicit dereference) #", N);
else
Error_Msg_N
("\possible interpretation (with implicit dereference) #", N);
......
gcc/ada/sem_ch8.adb
......@@ -1245,17 +1245,17 @@ package body Sem_Ch8 is
elsif Nkind (Original_Node (Nam)) = N_Function_Call
-- When expansion is disabled, attribute reference is not
-- rewritten as function call. Otherwise it may be rewritten
-- as a conversion, so check original node.
-- When expansion is disabled, attribute reference is not rewritten
-- as function call. Otherwise it may be rewritten as a conversion,
-- so check original node.
or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference
and then Is_Function_Attribute_Name
(Attribute_Name (Original_Node (Nam))))
-- Weird but legal, equivalent to renaming a function call.
-- Illegal if the literal is the result of constant-folding an
-- attribute reference that is not a function.
-- Weird but legal, equivalent to renaming a function call. Illegal
-- if the literal is the result of constant-folding an attribute
-- reference that is not a function.
or else (Is_Entity_Name (Nam)
and then Ekind (Entity (Nam)) = E_Enumeration_Literal
......@@ -1296,6 +1296,28 @@ package body Sem_Ch8 is
Set_Is_True_Constant (Id, True);
end if;
-- The entity of the renaming declaration needs to reflect whether the
-- renamed object is volatile. Is_Volatile is set if the renamed object
-- is volatile in the RM legality sense.
Set_Is_Volatile (Id, Is_Volatile_Object (Nam));
-- Treat as volatile if we just set the Volatile flag
if Is_Volatile (Id)
-- Or if we are renaming an entity which was marked this way
-- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ???
or else (Is_Entity_Name (Nam)
and then Treat_As_Volatile (Entity (Nam)))
then
Set_Treat_As_Volatile (Id, True);
end if;
-- Now make the link to the renamed object
Set_Renamed_Object (Id, Nam);
-- Implementation-defined aspect specifications can appear in a renaming
......
gcc/ada/sem_mech.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2014, 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- --
......@@ -36,7 +36,7 @@ package Sem_Mech is
-------------------------------------------------
-- For parameters passed to subprograms, and for function return values,
-- as passing mechanism is defined. The entity attribute Mechanism returns
-- a passing mechanism is defined. The entity attribute Mechanism returns
-- an indication of the mechanism, and Set_Mechanism can be used to set
-- the mechanism. At the program level, there are three ways to explicitly
-- set the mechanism:
......@@ -87,14 +87,14 @@ package Sem_Mech is
-- special information) is determined by the backend in accordance with
-- requirements imposed by the ABI as interpreted for Ada.
By_Descriptor : constant Mechanism_Type := -3;
By_Descriptor_UBS : constant Mechanism_Type := -4;
By_Descriptor_UBSB : constant Mechanism_Type := -5;
By_Descriptor_UBA : constant Mechanism_Type := -6;
By_Descriptor_S : constant Mechanism_Type := -7;
By_Descriptor_SB : constant Mechanism_Type := -8;
By_Descriptor_A : constant Mechanism_Type := -9;
By_Descriptor_NCA : constant Mechanism_Type := -10;
By_Descriptor : constant Mechanism_Type := -3;
By_Descriptor_UBS : constant Mechanism_Type := -4;
By_Descriptor_UBSB : constant Mechanism_Type := -5;
By_Descriptor_UBA : constant Mechanism_Type := -6;
By_Descriptor_S : constant Mechanism_Type := -7;
By_Descriptor_SB : constant Mechanism_Type := -8;
By_Descriptor_A : constant Mechanism_Type := -9;
By_Descriptor_NCA : constant Mechanism_Type := -10;
By_Short_Descriptor : constant Mechanism_Type := -11;
By_Short_Descriptor_UBS : constant Mechanism_Type := -12;
By_Short_Descriptor_UBSB : constant Mechanism_Type := -13;
......@@ -115,10 +115,13 @@ package Sem_Mech is
-- A contiguous array
-- NCA non-contiguous array
--
-- Note: the form with no suffix is used if the Import/Export pragma
-- uses the simple form of the mechanism name where no descriptor
-- type is supplied. In this case the back end assigns a descriptor
-- type based on the Ada type in accordance with the OpenVMS ABI.
-- Note: the form with no suffix is used if the Import/Export pragma uses
-- the simple form of the mechanism name (no descriptor type is supplied).
-- In this case the back end assigns a descriptor type based on the Ada
-- type in accordance with the OpenVMS ABI.
pragma Assert (Mechanism_Type'First = -18);
-- Check definition in types is right!
subtype Descriptor_Codes is Mechanism_Type
range By_Short_Descriptor_NCA .. By_Descriptor;
......
gcc/ada/types.ads
......@@ -795,7 +795,7 @@ package Types is
-- mechanism. See specification of Sem_Mech for full details. The following
-- subtype is used to represent values of this type:
subtype Mechanism_Type is Int range -18 .. Int'Last;
subtype Mechanism_Type is Int range -18 .. 0;
-- Type used to represent a mechanism value. This is a subtype rather than
-- a type to avoid some annoying processing problems with certain routines
-- in Einfo (processing them to create the corresponding C).
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment