aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@adacore.com>2020-06-08 14:28:52 -0400
committerPierre-Marie de Rodat <derodat@adacore.com>2020-07-16 05:18:07 -0400
commitc6801105e167376e8839007a1539a8167fb09306 (patch)
tree0447df56247bcc32af52b7f46e0b19db876945e5
parent0e35dea645d5303b433061df1a27e3f205129de7 (diff)
downloadgcc-c6801105e167376e8839007a1539a8167fb09306.zip
gcc-c6801105e167376e8839007a1539a8167fb09306.tar.gz
gcc-c6801105e167376e8839007a1539a8167fb09306.tar.bz2
[Ada] AI12-0373 Additional check on Integer_Literal function
gcc/ada/ * sem_ch13.adb (Validate_Literal_Aspect): Ensure that the parameter is not aliased. Minor reformatting. * sem_util.adb (Statically_Names_Object): Update comment.
-rw-r--r--gcc/ada/sem_ch13.adb14
-rw-r--r--gcc/ada/sem_util.adb25
2 files changed, 19 insertions, 20 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 9b7f64e..9a2f1d0 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -16016,10 +16016,12 @@ package body Sem_Ch13 is
Match_Found : Boolean := False;
Is_Match : Boolean;
Match : Interp;
+
begin
if not Is_Type (Typ) then
Error_Msg_N ("aspect can only be specified for a type", ASN);
return;
+
elsif not Is_First_Subtype (Typ) then
Error_Msg_N ("aspect cannot be specified for a subtype", ASN);
return;
@@ -16030,12 +16032,15 @@ package body Sem_Ch13 is
Error_Msg_N ("aspect cannot be specified for a string type", ASN);
return;
end if;
+
Param_Type := Standard_Wide_Wide_String;
+
else
if Is_Numeric_Type (Typ) then
Error_Msg_N ("aspect cannot be specified for a numeric type", ASN);
return;
end if;
+
Param_Type := Standard_String;
end if;
@@ -16059,17 +16064,21 @@ package body Sem_Ch13 is
and then Base_Type (Etype (It.Nam)) = Typ
then
declare
- Params : constant List_Id :=
+ Params : constant List_Id :=
Parameter_Specifications (Parent (It.Nam));
Param_Spec : Node_Id;
Param_Id : Entity_Id;
+
begin
if List_Length (Params) = 1 then
Param_Spec := First (Params);
+
if not More_Ids (Param_Spec) then
Param_Id := Defining_Identifier (Param_Spec);
+
if Base_Type (Etype (Param_Id)) = Param_Type
- and then Ekind (Param_Id) = E_In_Parameter
+ and then Ekind (Param_Id) = E_In_Parameter
+ and then not Is_Aliased (Param_Id)
then
Is_Match := True;
end if;
@@ -16083,6 +16092,7 @@ package body Sem_Ch13 is
Error_Msg_N ("aspect specification is ambiguous", ASN);
return;
end if;
+
Match_Found := True;
Match := It;
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 2ce22e9..b2f41de 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -27054,6 +27054,7 @@ package body Sem_Util is
-----------------------------
-- Statically_Names_Object --
-----------------------------
+
function Statically_Names_Object (N : Node_Id) return Boolean is
begin
if Statically_Denotes_Object (N) then
@@ -27126,28 +27127,16 @@ package body Sem_Util is
then
return False;
end if;
+
declare
Comp : constant Entity_Id :=
Original_Record_Component (Entity (Selector_Name (N)));
begin
- -- In not calling Has_Discriminant_Dependent_Constraint here,
- -- we are anticipating a language definition fixup. The
- -- current definition of "statically names" includes the
- -- wording "the selector_name names a component that does
- -- not depend on a discriminant", which suggests that this
- -- call should not be commented out. But it appears likely
- -- that this wording will be updated to only apply to a
- -- component declared in a variant part. There is no need
- -- to disallow something like
- -- with Post => ... and then
- -- Some_Record.Some_Discrim_Dep_Array_Component'Old (I)
- -- since the evaluation of the 'Old prefix cannot raise an
- -- exception. If the language is not updated, then the call
- -- below to H_D_C_C will need to be uncommented.
-
- if Is_Declared_Within_Variant (Comp)
- -- or else Has_Discriminant_Dependent_Constraint (Comp)
- then
+ -- AI12-0373 confirms that we should not call
+ -- Has_Discriminant_Dependent_Constraint here which would be
+ -- too strong.
+
+ if Is_Declared_Within_Variant (Comp) then
return False;
end if;
end;