Skip to content

R
riscv-gcc-1
Commit 0fbcb11c by Ed Schonberg Committed by Arnaud Charlet
Options

sem_aux.adb [...] (Effectively_has_Constrained_Partial_View): Rename subprogram… 

sem_aux.adb [...] (Effectively_has_Constrained_Partial_View): Rename subprogram as Object_Type_Has_Constrained_Partial_View...

2013-04-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View):
	Rename subprogram as Object_Type_Has_Constrained_Partial_View, better
	description of purpose.
	* checks.adb (Apply_Discriminant_Check): Use above renaming.
	* sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View
	of the base type, rather than using the Object_Type predicate.
	* sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming.
	* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto.
	* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto.
	* exp_ch4.adb (Expand_N_Allocator): Ditto.

From-SVN: r198188
parent 20a65dcb
Showing with 106 additions and 95 deletions
gcc/ada/ChangeLog
2013-04-23 Ed Schonberg <schonberg@adacore.com>
* sem_aux.adb sem_aux.ads (Effectively_has_Constrained_Partial_View):
Rename subprogram as Object_Type_Has_Constrained_Partial_View, better
description of purpose.
* checks.adb (Apply_Discriminant_Check): Use above renaming.
* sem_ch4.adb (Analyze_Allocator): Check Has_Constrained_Partial_View
of the base type, rather than using the Object_Type predicate.
* sem_attr.adb (Analyze_Attribute, case 'Access): Use above renaming.
* sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): ditto.
* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained): Ditto.
* exp_ch4.adb (Expand_N_Allocator): Ditto.
2013-04-23 Robert Dewar <dewar@adacore.com>
* exp_prag.adb (Expand_Pragma_Check): Check for Assert rather
......
gcc/ada/checks.adb
......@@ -1479,7 +1479,7 @@ package body Checks is
-- partial view that is constrained.
elsif Ada_Version >= Ada_2005
and then Effectively_Has_Constrained_Partial_View
and then Object_Type_Has_Constrained_Partial_View
(Typ => Base_Type (T_Typ),
Scop => Current_Scope)
then
......
gcc/ada/exp_attr.adb
......@@ -1791,7 +1791,7 @@ package body Exp_Attr is
or else
(Nkind (Obj) = N_Explicit_Dereference
and then
not Effectively_Has_Constrained_Partial_View
not Object_Type_Has_Constrained_Partial_View
(Typ => Base_Type (Etype (Obj)),
Scop => Current_Scope)));
end if;
......@@ -1915,7 +1915,7 @@ package body Exp_Attr is
or else
(Nkind (Pref) = N_Explicit_Dereference
and then
not Effectively_Has_Constrained_Partial_View
not Object_Type_Has_Constrained_Partial_View
(Typ => Base_Type (Ptyp),
Scop => Current_Scope))
or else Is_Constrained (Underlying_Type (Ptyp))
......
gcc/ada/exp_ch4.adb
......@@ -4673,9 +4673,8 @@ package body Exp_Ch4 is
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_2005
or else not
Effectively_Has_Constrained_Partial_View
(Typ => Typ,
Scop => Current_Scope))
Object_Type_Has_Constrained_Partial_View
(Typ, Current_Scope))
then
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
......
gcc/ada/sem_attr.adb
......@@ -9530,7 +9530,7 @@ package body Sem_Attr is
and then
(Ada_Version < Ada_2005
or else
not Effectively_Has_Constrained_Partial_View
not Object_Type_Has_Constrained_Partial_View
(Typ => Designated_Type (Base_Type (Typ)),
Scop => Current_Scope))
then
......
gcc/ada/sem_aux.adb
......@@ -151,25 +151,6 @@ package body Sem_Aux is
end if;
end Constant_Value;
----------------------------------------------
-- Effectively_Has_Constrained_Partial_View --
----------------------------------------------
function Effectively_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean
is
begin
return Has_Constrained_Partial_View (Typ)
or else (In_Generic_Body (Scop)
and then Is_Generic_Type (Base_Type (Typ))
and then Is_Private_Type (Base_Type (Typ))
and then not Is_Tagged_Type (Typ)
and then not (Is_Array_Type (Typ)
and then not Is_Constrained (Typ))
and then Has_Discriminants (Typ));
end Effectively_Has_Constrained_Partial_View;
-----------------------------
-- Enclosing_Dynamic_Scope --
-----------------------------
......@@ -630,25 +611,6 @@ package body Sem_Aux is
return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Pragma;
-------------------------------
-- Initialization_Suppressed --
-------------------------------
function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
begin
return Suppress_Initialization (Typ)
or else Suppress_Initialization (Base_Type (Typ));
end Initialization_Suppressed;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Obsolescent_Warnings.Init;
end Initialize;
---------------------
-- In_Generic_Body --
---------------------
......@@ -686,6 +648,25 @@ package body Sem_Aux is
return False;
end In_Generic_Body;
-------------------------------
-- Initialization_Suppressed --
-------------------------------
function Initialization_Suppressed (Typ : Entity_Id) return Boolean is
begin
return Suppress_Initialization (Typ)
or else Suppress_Initialization (Base_Type (Typ));
end Initialization_Suppressed;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Obsolescent_Warnings.Init;
end Initialize;
---------------------
-- Is_By_Copy_Type --
---------------------
......@@ -828,38 +809,6 @@ package body Sem_Aux is
end if;
end Is_Generic_Formal;
---------------------------
-- Is_Indefinite_Subtype --
---------------------------
function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
K : constant Entity_Kind := Ekind (Ent);
begin
if Is_Constrained (Ent) then
return False;
elsif K in Array_Kind
or else K in Class_Wide_Kind
or else Has_Unknown_Discriminants (Ent)
then
return True;
-- Known discriminants: indefinite if there are no default values
elsif K in Record_Kind
or else Is_Incomplete_Or_Private_Type (Ent)
or else Is_Concurrent_Type (Ent)
then
return (Has_Discriminants (Ent)
and then
No (Discriminant_Default_Value (First_Discriminant (Ent))));
else
return False;
end if;
end Is_Indefinite_Subtype;
-------------------------------
-- Is_Immutably_Limited_Type --
-------------------------------
......@@ -959,6 +908,38 @@ package body Sem_Aux is
end if;
end Is_Immutably_Limited_Type;
---------------------------
-- Is_Indefinite_Subtype --
---------------------------
function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
K : constant Entity_Kind := Ekind (Ent);
begin
if Is_Constrained (Ent) then
return False;
elsif K in Array_Kind
or else K in Class_Wide_Kind
or else Has_Unknown_Discriminants (Ent)
then
return True;
-- Known discriminants: indefinite if there are no default values
elsif K in Record_Kind
or else Is_Incomplete_Or_Private_Type (Ent)
or else Is_Concurrent_Type (Ent)
then
return (Has_Discriminants (Ent)
and then
No (Discriminant_Default_Value (First_Discriminant (Ent))));
else
return False;
end if;
end Is_Indefinite_Subtype;
---------------------
-- Is_Limited_Type --
---------------------
......@@ -1147,6 +1128,25 @@ package body Sem_Aux is
return N;
end Number_Discriminants;
----------------------------------------------
-- Object_Type_Has_Constrained_Partial_View --
----------------------------------------------
function Object_Type_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean
is
begin
return Has_Constrained_Partial_View (Typ)
or else (In_Generic_Body (Scop)
and then Is_Generic_Type (Base_Type (Typ))
and then Is_Private_Type (Base_Type (Typ))
and then not Is_Tagged_Type (Typ)
and then not (Is_Array_Type (Typ)
and then not Is_Constrained (Typ))
and then Has_Discriminants (Typ));
end Object_Type_Has_Constrained_Partial_View;
---------------
-- Tree_Read --
---------------
......
gcc/ada/sem_aux.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
......@@ -105,14 +105,6 @@ package Sem_Aux is
-- constants from the point of view of constant folding. Empty is also
-- returned for variables with no initialization expression.
function Effectively_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean;
-- Return True if Typ has attribute Has_Constrained_Partial_View set to
-- True; in addition, within a generic body, return True if a subtype is
-- a descendant of an untagged generic formal private or derived type, and
-- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- For any entity, Ent, returns the closest dynamic scope in which the
-- entity is declared or Standard_Standard for library-level entities.
......@@ -259,6 +251,12 @@ package Sem_Aux is
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
pragma Inline (Initialization_Suppressed);
-- Returns True if initialization should be suppressed for the given type
-- or subtype. This is true if Suppress_Initialization is set either for
-- the subtype itself, or for the corresponding base type.
function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by copy, as defined in (RM 6.2(3)).
......@@ -329,11 +327,14 @@ package Sem_Aux is
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
function Initialization_Suppressed (Typ : Entity_Id) return Boolean;
pragma Inline (Initialization_Suppressed);
-- Returns True if initialization should be suppressed for the given type
-- or subtype. This is true if Suppress_Initialization is set either for
-- the subtype itself, or for the corresponding base type.
function Object_Type_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id) return Boolean;
-- Return True if type of object has attribute Has_Constrained_Partial_View
-- set to True; in addition, within a generic body, return True if subtype
-- of the object is a descendant of an untagged generic formal private or
-- derived type, and the subtype is not an unconstrained array subtype
-- (RM 3.3(23.10/3)).
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
pragma Inline (Ultimate_Alias);
......
gcc/ada/sem_ch4.adb
......@@ -580,9 +580,7 @@ package body Sem_Ch4 is
-- and the allocated object is unconstrained.
elsif Ada_Version >= Ada_2005
and then Effectively_Has_Constrained_Partial_View
(Typ => Base_Typ,
Scop => Current_Scope)
and then Has_Constrained_Partial_View (Base_Typ)
then
Error_Msg_N
("constraint not allowed when type " &
......
gcc/ada/sem_util.adb
......@@ -7980,7 +7980,7 @@ package body Sem_Util is
-- designated object is known to be constrained.
if Ekind (Prefix_Type) = E_Access_Type
and then not Effectively_Has_Constrained_Partial_View
and then not Object_Type_Has_Constrained_Partial_View
(Typ => Designated_Type (Prefix_Type),
Scop => Current_Scope)
then
......
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