Skip to content

R
riscv-gcc-1
Commit d63199d8 by Pierre-Marie de Rodat
Options

exp_ch3.adb, [...]: Minor reformatting. 

gcc/ada/

2017-11-09  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb, gnat1drv.adb, namet.adb, namet.ads, sem_aggr.adb,
	sem_ch2.adb, sem_ch4.adb: Minor reformatting.
	* sem_res.adb (Resolve_Entity_Name): Suppress spurious error on read of
	out parameter when in Ada_83 mode, the oarameter is of a composite
	type, and it appears as the prefix of an attribute.

2017-11-09  Bob Duff  <duff@adacore.com>

	* sinfo.ads: Minor comment fix.

2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.ads: Add pragmas Unmodified and Unreferenced to table
	Pragma_Significant_In_SPARK.

gcc/testsuite/

2017-11-09  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat.dg/unreferenced.adb: New testcase.

2017-11-09  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/out_param.adb: New testcase.

From-SVN: r254571
parent dcd5fd67
Showing with 165 additions and 101 deletions
gcc/ada/exp_ch3.adb
......@@ -8717,10 +8717,11 @@ package body Exp_Ch3 is
-- Initialize secondary tags
else
Initialize_Tag (Full_Typ,
Iface => Node (Iface_Elmt),
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
Initialize_Tag
(Typ => Full_Typ,
Iface => Node (Iface_Elmt),
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
end if;
-- Otherwise generate code to initialize the tag
......@@ -8729,10 +8730,11 @@ package body Exp_Ch3 is
if (In_Variable_Pos and then Variable_Comps)
or else (not In_Variable_Pos and then Fixed_Comps)
then
Initialize_Tag (Full_Typ,
Iface => Node (Iface_Elmt),
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
Initialize_Tag
(Typ => Full_Typ,
Iface => Node (Iface_Elmt),
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
end if;
end if;
......
gcc/ada/gnat1drv.adb
......@@ -384,9 +384,10 @@ procedure Gnat1drv is
Relaxed_RM_Semantics := True;
if not Generate_CodePeer_Messages then
-- Suppress compiler warnings by default when generating SCIL for
-- CodePeer, except when combined with -gnateC where we do want
-- to emit GNAT warnings.
-- CodePeer, except when combined with -gnateC where we do want to
-- emit GNAT warnings.
Warning_Mode := Suppress;
end if;
......
gcc/ada/namet.adb
......@@ -175,7 +175,8 @@ package body Namet is
--------------------
procedure Append_Decoded
(Buf : in out Bounded_String; Id : Valid_Name_Id)
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
C : Character;
P : Natural;
......@@ -599,7 +600,8 @@ package body Namet is
------------------------
procedure Append_Unqualified
(Buf : in out Bounded_String; Id : Valid_Name_Id)
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
Temp : Bounded_String;
begin
......@@ -1476,7 +1478,10 @@ package body Namet is
-- Name_Equals --
-----------------
function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean is
function Name_Equals
(N1 : Valid_Name_Id;
N2 : Valid_Name_Id) return Boolean
is
begin
return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
end Name_Equals;
......
gcc/ada/namet.ads
......@@ -358,7 +358,9 @@ package Namet is
-- names, since these are efficiently located without hashing by Name_Find
-- in any case.
function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean;
function Name_Equals
(N1 : Valid_Name_Id;
N2 : Valid_Name_Id) return Boolean;
-- Return whether N1 and N2 denote the same character sequence
function Get_Name_String (Id : Valid_Name_Id) return String;
......
gcc/ada/sem_aggr.adb
......@@ -2765,7 +2765,7 @@ package body Sem_Aggr is
-----------------------------
procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
Base : constant Node_Id := Expression (N);
Base : constant Node_Id := Expression (N);
begin
if not Is_Composite_Type (Typ) then
......@@ -2789,12 +2789,14 @@ package body Sem_Aggr is
procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
Assoc : Node_Id;
Choice : Node_Id;
Index_Type : Entity_Id;
begin
Index_Type := Etype (First_Index (Typ));
Assoc := First (Deltas);
while Present (Assoc) loop
if Nkind (Assoc) = N_Iterated_Component_Association then
......@@ -2843,10 +2845,12 @@ package body Sem_Aggr is
else
Analyze (Choice);
if Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
-- Choice covers a range of values.
-- Choice covers a range of values
if Base_Type (Entity (Choice)) /=
Base_Type (Index_Type)
then
......@@ -2874,28 +2878,17 @@ package body Sem_Aggr is
------------------------------------
procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
Deltas : constant List_Id := Component_Associations (N);
Assoc : Node_Id;
Choice : Node_Id;
Comp_Type : Entity_Id;
-- Variables used to verify that discriminant-dependent components
-- appear in the same variant.
Variant : Node_Id;
Comp_Ref : Entity_Id;
procedure Check_Variant (Id : Entity_Id);
-- If a given component of the delta aggregate appears in a variant
-- part, verify that it is within the same variant as that of previous
-- specified variant components of the delta.
function Nested_In (V1, V2 : Node_Id) return Boolean;
-- Determine whether variant V1 is within variant V2.
function Get_Component_Type (Nam : Node_Id) return Entity_Id;
-- Locate component with a given name and return its type. If none
-- found report error.
-- Locate component with a given name and return its type. If none found
-- report error.
function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
-- Determine whether variant V1 is within variant V2
function Variant_Depth (N : Node_Id) return Integer;
-- Determine the distance of a variant to the enclosing type
......@@ -2907,13 +2900,17 @@ package body Sem_Aggr is
procedure Check_Variant (Id : Entity_Id) is
Comp : Entity_Id;
Comp_Ref : Entity_Id;
Comp_Variant : Node_Id;
Variant : Node_Id;
begin
if not Has_Discriminants (Typ) then
return;
end if;
Variant := Empty;
Comp := First_Entity (Typ);
while Present (Comp) loop
exit when Chars (Comp) = Chars (Id);
......@@ -2937,9 +2934,9 @@ package body Sem_Aggr is
begin
if D1 = D2
or else
(D1 > D2 and then not Nested_In (Variant, Comp_Variant))
(D1 > D2 and then not Nested_In (Variant, Comp_Variant))
or else
(D2 > D1 and then not Nested_In (Comp_Variant, Variant))
(D2 > D1 and then not Nested_In (Comp_Variant, Variant))
then
Error_Msg_Node_2 := Comp_Ref;
Error_Msg_NE
......@@ -2955,18 +2952,45 @@ package body Sem_Aggr is
end if;
end Check_Variant;
------------------------
-- Get_Component_Type --
------------------------
function Get_Component_Type (Nam : Node_Id) return Entity_Id is
Comp : Entity_Id;
begin
Comp := First_Entity (Typ);
while Present (Comp) loop
if Chars (Comp) = Chars (Nam) then
if Ekind (Comp) = E_Discriminant then
Error_Msg_N ("delta cannot apply to discriminant", Nam);
end if;
return Etype (Comp);
end if;
Comp := Next_Entity (Comp);
end loop;
Error_Msg_NE ("type& has no component with this name", Nam, Typ);
return Any_Type;
end Get_Component_Type;
---------------
-- Nested_In --
---------------
function Nested_In (V1, V2 : Node_Id) return Boolean is
Par : Node_Id;
begin
Par := Parent (V1);
while Nkind (Par) /= N_Full_Type_Declaration loop
if Par = V2 then
return True;
end if;
Par := Parent (Par);
end loop;
......@@ -2980,53 +3004,35 @@ package body Sem_Aggr is
function Variant_Depth (N : Node_Id) return Integer is
Depth : Integer;
Par : Node_Id;
begin
Depth := 0;
Par := Parent (N);
while Nkind (Par) /= N_Full_Type_Declaration loop
Depth := Depth + 1;
Par := Parent (Par);
Par := Parent (Par);
end loop;
return Depth;
end Variant_Depth;
------------------------
-- Get_Component_Type --
------------------------
function Get_Component_Type (Nam : Node_Id) return Entity_Id is
Comp : Entity_Id;
begin
Comp := First_Entity (Typ);
while Present (Comp) loop
if Chars (Comp) = Chars (Nam) then
if Ekind (Comp) = E_Discriminant then
Error_Msg_N ("delta cannot apply to discriminant", Nam);
end if;
return Etype (Comp);
end if;
-- Local variables
Comp := Next_Entity (Comp);
end loop;
Deltas : constant List_Id := Component_Associations (N);
Error_Msg_NE ("type& has no component with this name", Nam, Typ);
return Any_Type;
end Get_Component_Type;
Assoc : Node_Id;
Choice : Node_Id;
Comp_Type : Entity_Id;
-- Start of processing for Resolve_Delta_Record_Aggregate
begin
Variant := Empty;
Assoc := First (Deltas);
while Present (Assoc) loop
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Comp_Type := Get_Component_Type (Choice);
if Comp_Type /= Any_Type then
Check_Variant (Choice);
end if;
......
gcc/ada/sem_ch2.adb
......@@ -68,9 +68,7 @@ package body Sem_Ch2 is
-- this is the result of some kind of previous error generating a
-- junk identifier.
if not Is_Valid_Name (Chars (N))
and then Total_Errors_Detected /= 0
then
if not Is_Valid_Name (Chars (N)) and then Total_Errors_Detected /= 0 then
return;
else
Find_Direct_Name (N);
......
gcc/ada/sem_ch4.adb
......@@ -412,12 +412,12 @@ package body Sem_Ch4 is
-- Analyze_Aggregate --
-----------------------
-- Most of the analysis of Aggregates requires that the type be known,
-- and is therefore put off until resolution of the context.
-- Delta aggregates have a base component that determines the type of the
-- enclosing aggregate so its type can be ascertained earlier. This also
-- allows delta aggregates to appear in the context of a record type with
-- a private extension, as per the latest update of AI12-0127.
-- Most of the analysis of Aggregates requires that the type be known, and
-- is therefore put off until resolution of the context. Delta aggregates
-- have a base component that determines the enclosing aggregate type so
-- its type can be ascertained earlier. This also allows delta aggregates
-- to appear in the context of a record type with a private extension, as
-- per the latest update of AI12-0127.
procedure Analyze_Aggregate (N : Node_Id) is
begin
......@@ -425,14 +425,15 @@ package body Sem_Ch4 is
if Nkind (N) = N_Delta_Aggregate then
declare
Base : constant Node_Id := Expression (N);
I : Interp_Index;
It : Interp;
begin
Analyze (Base);
-- If the base is overloaded, propagate interpretations
-- to the enclosing aggregate.
-- If the base is overloaded, propagate interpretations to the
-- enclosing aggregate.
if Is_Overloaded (Base) then
Get_First_Interp (Base, I, It);
......@@ -1533,12 +1534,15 @@ package body Sem_Ch4 is
and then Present (Limited_View (Scope (Etype (N))))
and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N))))
then
Error_Msg_NE ("cannot call function that returns "
& "limited view of}", N, Etype (N));
Error_Msg_NE
("\there must be a regular with_clause for package& "
& "in the current unit, or in some unit in its context",
N, Scope (Etype (N)));
("cannot call function that returns limited view of}",
N, Etype (N));
Error_Msg_NE
("\there must be a regular with_clause for package & in the "
& "current unit, or in some unit in its context",
N, Scope (Etype (N)));
Set_Etype (N, Any_Type);
end if;
end if;
......
gcc/ada/sem_prag.ads
......@@ -191,6 +191,8 @@ package Sem_Prag is
Pragma_Remote_Types => False,
Pragma_Shared_Passive => False,
Pragma_Task_Dispatching_Policy => False,
Pragma_Unmodified => False,
Pragma_Unreferenced => False,
Pragma_Warnings => False,
others => True);
......
gcc/ada/sem_res.adb
......@@ -2442,8 +2442,8 @@ package body Sem_Res is
elsif Nkind_In (N, N_Case_Expression,
N_Character_Literal,
N_If_Expression,
N_Delta_Aggregate)
N_Delta_Aggregate,
N_If_Expression)
then
Set_Etype (N, Expr_Type);
......@@ -5197,11 +5197,11 @@ package body Sem_Res is
-- user about it here.
if Ekind (Typ) = E_Anonymous_Access_Type
and then Is_Controlled_Active (Desig_T)
and then Is_Controlled_Active (Desig_T)
then
Error_Msg_N ("??anonymous access-to-controlled object will "
& "be finalized when its enclosing unit goes out "
& "of scope", N);
Error_Msg_N
("??anonymous access-to-controlled object will be finalized "
& "when its enclosing unit goes out of scope", N);
end if;
end if;
end if;
......@@ -7276,9 +7276,13 @@ package body Sem_Res is
elsif Ekind (E) = E_Generic_Function then
Error_Msg_N ("illegal use of generic function", N);
-- In Ada 83 an OUT parameter cannot be read
-- In Ada 83 an OUT parameter cannot be read, but attributes of
-- array types (i.e. bounds and length) are legal.
elsif Ekind (E) = E_Out_Parameter
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else Is_Scalar_Type (Etype (E)))
and then (Nkind (Parent (N)) in N_Op
or else Nkind (Parent (N)) = N_Explicit_Dereference
or else Is_Assignment_Or_Object_Expression
......
gcc/ada/sinfo.ads
......@@ -38,7 +38,7 @@
-- The tree contains not only the full syntactic representation of the
-- program, but also the results of semantic analysis. In particular, the
-- nodes for defining identifiers, defining character literals and defining
-- nodes for defining identifiers, defining character literals, and defining
-- operator symbols, collectively referred to as entities, represent what
-- would normally be regarded as the symbol table information. In addition a
-- number of the tree nodes contain semantic information.
......@@ -213,7 +213,7 @@ package Sinfo is
-- The Present function tests for Empty, which in this case signals the end
-- of the list. First returns Empty immediately if the list is empty.
-- Present is defined in Atree, First and Next are defined in Nlists.
-- Present is defined in Atree; First and Next are defined in Nlists.
-- The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all
-- contexts, which is handled as described in the previous section, and
......@@ -389,7 +389,7 @@ package Sinfo is
-- In the following node definitions, all fields, both syntactic and
-- semantic, are documented. The one exception is in the case of entities
-- (defining identifiers, character literals and operator symbols), where
-- (defining identifiers, character literals, and operator symbols), where
-- the usage of the fields depends on the entity kind. Entity fields are
-- fully documented in the separate package Einfo.
......@@ -1116,7 +1116,7 @@ package Sinfo is
-- complete a subprogram declaration.
-- Corresponding_Spec_Of_Stub (Node2-Sem)
-- This field is present in subprogram, package, task and protected body
-- This field is present in subprogram, package, task, and protected body
-- stubs where it points to the corresponding spec of the stub. Due to
-- clashes in the structure of nodes, we cannot use Corresponding_Spec.
......@@ -1754,7 +1754,7 @@ package Sinfo is
-- Is_Generic_Contract_Pragma (Flag2-Sem)
-- This flag is present in N_Pragma nodes. It is set when the pragma is
-- a source construct, applies to a generic unit or its body and denotes
-- a source construct, applies to a generic unit or its body, and denotes
-- one of the following contract-related annotations:
-- Abstract_State
-- Contract_Cases
......@@ -1910,7 +1910,7 @@ package Sinfo is
-- nodes which emulate the body of a task unit.
-- Is_Task_Master (Flag5-Sem)
-- A flag set in a Subprogram_Body, Block_Statement or Task_Body node to
-- A flag set in a Subprogram_Body, Block_Statement, or Task_Body node to
-- indicate that the construct is a task master (i.e. has declared tasks
-- or declares an access to a task type).
......@@ -2019,7 +2019,7 @@ package Sinfo is
-- calls to Freeze_Expression.
-- Next_Entity (Node2-Sem)
-- Present in defining identifiers, defining character literals and
-- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope are chained, and this field is used as the forward pointer for
-- this list. See Einfo for further details.
......@@ -2236,7 +2236,7 @@ package Sinfo is
-- because Analyze wants to insert extra actions on this list.
-- Rounded_Result (Flag18-Sem)
-- Present in N_Type_Conversion, N_Op_Divide and N_Op_Multiply nodes.
-- Present in N_Type_Conversion, N_Op_Divide, and N_Op_Multiply nodes.
-- Used in the fixed-point cases to indicate that the result must be
-- rounded as a result of the use of the 'Round attribute. Also used for
-- integer N_Op_Divide nodes to indicate that the result should be
......@@ -2269,7 +2269,7 @@ package Sinfo is
-- operation named (statically) in a dispatching call.
-- Scope (Node3-Sem)
-- Present in defining identifiers, defining character literals and
-- Present in defining identifiers, defining character literals, and
-- defining operator symbols (i.e. in all entities). The entities of a
-- scope all use this field to reference the corresponding scope entity.
-- See Einfo for further details.
......@@ -2341,7 +2341,7 @@ package Sinfo is
-- always set to No_List.
-- Treat_Fixed_As_Integer (Flag14-Sem)
-- This flag appears in operator nodes for divide, multiply, mod and rem
-- This flag appears in operator nodes for divide, multiply, mod, and rem
-- on fixed-point operands. It indicates that the operands are to be
-- treated as integer values, ignoring small values. This flag is only
-- set as a result of expansion of fixed-point operations. Typically a
......@@ -2731,7 +2731,7 @@ package Sinfo is
-- pain to allow these aspects to pervade the pragma syntax, and the
-- representation of pragma nodes internally. So what we do is to
-- replace these ASPECT_MARK forms with identifiers whose name is one
-- of the special internal names _Pre, _Post or _Type_Invariant.
-- of the special internal names _Pre, _Post, or _Type_Invariant.
-- We do a similar replacement of these Aspect_Mark forms in the
-- Expression of a pragma argument association for the cases of
......@@ -3028,8 +3028,8 @@ package Sinfo is
-- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
-- Note: ABSTRACT, LIMITED and record extension part are not permitted
-- in Ada 83 mode
-- Note: ABSTRACT, LIMITED, and record extension part are not permitted
-- in Ada 83 mode.
-- Note: a record extension part is required if ABSTRACT is present
......@@ -3340,7 +3340,7 @@ package Sinfo is
-- Subtype_Indication field or else the Access_Definition field.
-- N_Component_Definition
-- Sloc points to ALIASED, ACCESS or to first token of subtype mark
-- Sloc points to ALIASED, ACCESS, or to first token of subtype mark
-- Aliased_Present (Flag4)
-- Null_Exclusion_Present (Flag11)
-- Subtype_Indication (Node5) (set to Empty if not present)
......@@ -3488,7 +3488,7 @@ package Sinfo is
-- end record
-- | null record
-- Note: the Abstract_Present, Tagged_Present and Limited_Present
-- Note: the Abstract_Present, Tagged_Present, and Limited_Present
-- flags appear only for a record definition appearing in a record
-- type definition.
......@@ -4016,7 +4016,7 @@ package Sinfo is
-- Instead the Attribute_Name and Expressions fields of the parent
-- node (N_Attribute_Reference node) hold the information.
-- Note: if ACCESS, DELTA or DIGITS appears in an attribute
-- Note: if ACCESS, DELTA, or DIGITS appears in an attribute
-- designator, then they are treated as identifiers internally
-- rather than the keywords of the same name.
......@@ -7910,7 +7910,7 @@ package Sinfo is
-- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
-- list is in LIFO fashion.
-- Classifications contains pragmas that either declare, categorize or
-- Classifications contains pragmas that either declare, categorize, or
-- establish dependencies between subprogram or package inputs and
-- outputs. Currently the following pragmas appear in this list:
-- Abstract_States
......@@ -13067,7 +13067,7 @@ package Sinfo is
4 => False, -- unused
5 => False), -- unused
-- Entries for Empty, Error and Unused. Even thought these have a Chars
-- Entries for Empty, Error, and Unused. Even though these have a Chars
-- field for debugging purposes, they are not really syntactic fields, so
-- we mark all fields as unused.
......
gcc/testsuite/ChangeLog
2017-11-09 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/unreferenced.adb: New testcase.
2017-11-09 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/out_param.adb: New testcase.
2017-11-09 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/elab3.adb, gnat.dg/elab3.ads, gnat.dg/elab3_pkg.adb,
gnat.dg/elab3_pkg.ads: New testcase.
......
gcc/testsuite/gnat.dg/out_param.adb 0 → 100644
-- { dg-do compile }
-- { dg-options "-gnat83" }
procedure Out_Param
(Source : in String; Dest : out String; Char_Count : out Natural) is
begin
--| Logic_Step:
--| Copy string Source to string Dest
Dest := (others => ' ');
Char_Count := 0;
if Source'Length > 0 and then Dest'Length > 0 then
if Source'Length > Dest'Length then
Char_Count := Dest'Length;
else
Dest (Dest'First .. (Dest'First + Source'Length - 1)) := Source;
Char_Count := Source'Length;
end if;
else
null;
end if;
end Out_Param;
gcc/testsuite/gnat.dg/unreferenced.adb 0 → 100644
-- { dg-do compile }
-- { dg-options "-gnatd.F" }
procedure Unreferenced is
X : aliased Integer;
Y : access Integer := X'Access;
Z : Integer renames Y.all;
pragma Unreferenced (Z);
begin
null;
end Unreferenced;
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