This patch fixes a regression in the handling of out parameters that appear
as the prefix of an attribute, when compiling in Ada_83 mode. Such implicit
read operations are legal in Ada_83 when the parameter is of an array type
and the attribute yields bound information.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-11-09 Ed Schonberg <schonb...@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.
gcc/testsuite/
2017-11-09 Ed Schonberg <schonb...@adacore.com>
* gnat.dg/out_param.adb: New testcase.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 254566)
+++ exp_ch3.adb (working copy)
@@ -8717,10 +8717,11 @@
-- 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 @@
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;
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb (revision 254568)
+++ gnat1drv.adb (working copy)
@@ -384,9 +384,10 @@
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;
Index: namet.adb
===================================================================
--- namet.adb (revision 254569)
+++ namet.adb (working copy)
@@ -175,7 +175,8 @@
--------------------
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 @@
------------------------
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 @@
-- 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;
Index: namet.ads
===================================================================
--- namet.ads (revision 254569)
+++ namet.ads (working copy)
@@ -358,7 +358,9 @@
-- 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;
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 254563)
+++ sem_aggr.adb (working copy)
@@ -2765,7 +2765,7 @@
-----------------------------
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 @@
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 @@
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,29 +2878,18 @@
------------------------------------
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
-- declaration.
@@ -2907,13 +2900,17 @@
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 @@
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 @@
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 @@
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 --
- ------------------------
+ -- Local variables
- function Get_Component_Type (Nam : Node_Id) return Entity_Id is
- Comp : Entity_Id;
+ Deltas : constant List_Id := Component_Associations (N);
- begin
- Comp := First_Entity (Typ);
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id;
- 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;
-
-- 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;
Index: sem_ch2.adb
===================================================================
--- sem_ch2.adb (revision 254569)
+++ sem_ch2.adb (working copy)
@@ -68,9 +68,7 @@
-- 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);
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 254570)
+++ sem_ch4.adb (working copy)
@@ -412,12 +412,12 @@
-- 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 @@
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 @@
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;
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 254570)
+++ sem_res.adb (working copy)
@@ -2442,8 +2442,8 @@
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 @@
-- 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 @@
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
Index: ../testsuite/gnat.dg/out_param.adb
===================================================================
--- ../testsuite/gnat.dg/out_param.adb (revision 0)
+++ ../testsuite/gnat.dg/out_param.adb (revision 0)
@@ -0,0 +1,21 @@
+-- { 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;
