Commit 4b7fd131 by Arnaud Charlet

[multiple changes]

2017-01-23  Justin Squirek  <squirek@adacore.com>

	* exp_strm.ads, exp_strm.ads
	(Build_Record_Or_Elementary_Input_Function): Add an extra parameter so
	as to avoid getting the underlying type by default.
	* exp_attr.adb (Expand_N_Attribute_Reference): Remove use of
	underlying type in the Iiput and output attribute cases when
	building their respective functions.

2017-01-23  Gary Dismukes  <dismukes@adacore.com>

	* scng.adb: Minor reformatting of error message.

2017-01-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): Do not attempt
	to freeze the return type of an expression funxtion that is a
	completion, if the type is a limited view and the non-limited
	view is available.

From-SVN: r244805
parent cffcafda
2017-01-23 Justin Squirek <squirek@adacore.com>
* exp_strm.ads, exp_strm.ads
(Build_Record_Or_Elementary_Input_Function): Add an extra parameter so
as to avoid getting the underlying type by default.
* exp_attr.adb (Expand_N_Attribute_Reference): Remove use of
underlying type in the Iiput and output attribute cases when
building their respective functions.
2017-01-23 Gary Dismukes <dismukes@adacore.com>
* scng.adb: Minor reformatting of error message.
2017-01-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Expression_Function): Do not attempt
to freeze the return type of an expression funxtion that is a
completion, if the type is a limited view and the non-limited
view is available.
2017-01-23 Ed Schonberg <schonberg@adacore.com> 2017-01-23 Ed Schonberg <schonberg@adacore.com>
* par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta
......
...@@ -3744,18 +3744,26 @@ package body Exp_Attr is ...@@ -3744,18 +3744,26 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Read routine, -- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine. -- since in this case we are required to call this routine.
if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then declare
Build_Record_Or_Elementary_Input_Function Typ : Entity_Id := P_Type;
(Loc, U_Type, Decl, Fname); begin
Insert_Action (N, Decl); if Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
-- For normal cases, we call the I_xxx routine directly if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
(Loc, Typ, Decl, Fname, Use_Underlying => False);
Insert_Action (N, Decl);
else -- For normal cases, we call the I_xxx routine directly
Rewrite (N, Build_Elementary_Input_Call (N));
Analyze_And_Resolve (N, P_Type); else
return; Rewrite (N, Build_Elementary_Input_Call (N));
end if; Analyze_And_Resolve (N, P_Type);
return;
end if;
end;
-- Array type case -- Array type case
...@@ -4839,18 +4847,26 @@ package body Exp_Attr is ...@@ -4839,18 +4847,26 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Write routine, -- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine. -- since in this case we are required to call this routine.
if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then declare
Build_Record_Or_Elementary_Output_Procedure Typ : Entity_Id := P_Type;
(Loc, U_Type, Decl, Pname); begin
Insert_Action (N, Decl); if Present (Full_View (Typ)) then
Typ := Full_View (Typ);
end if;
-- For normal cases, we call the W_xxx routine directly if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, Typ, Decl, Pname);
Insert_Action (N, Decl);
else -- For normal cases, we call the W_xxx routine directly
Rewrite (N, Build_Elementary_Write_Call (N));
Analyze (N); else
return; Rewrite (N, Build_Elementary_Write_Call (N));
end if; Analyze (N);
return;
end if;
end;
-- Array type case -- Array type case
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1116,23 +1116,28 @@ package body Exp_Strm is ...@@ -1116,23 +1116,28 @@ package body Exp_Strm is
-- an elementary type, then no Cn constants are defined. -- an elementary type, then no Cn constants are defined.
procedure Build_Record_Or_Elementary_Input_Function procedure Build_Record_Or_Elementary_Input_Function
(Loc : Source_Ptr; (Loc : Source_Ptr;
Typ : Entity_Id; Typ : Entity_Id;
Decl : out Node_Id; Decl : out Node_Id;
Fnam : out Entity_Id) Fnam : out Entity_Id;
Use_Underlying : Boolean := True)
is is
B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); B_Typ : Entity_Id := Base_Type (Typ);
Cn : Name_Id; Cn : Name_Id;
Constr : List_Id; Constr : List_Id;
Decls : List_Id; Decls : List_Id;
Discr : Entity_Id; Discr : Entity_Id;
Discr_Elmt : Elmt_Id := No_Elmt; Discr_Elmt : Elmt_Id := No_Elmt;
J : Pos; J : Pos;
Obj_Decl : Node_Id; Obj_Decl : Node_Id;
Odef : Node_Id; Odef : Node_Id;
Stms : List_Id; Stms : List_Id;
begin begin
if Use_Underlying then
B_Typ := Underlying_Type (B_Typ);
end if;
Decls := New_List; Decls := New_List;
Constr := New_List; Constr := New_List;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -105,14 +105,17 @@ package Exp_Strm is ...@@ -105,14 +105,17 @@ package Exp_Strm is
-- the same manner as is done for 'Output. -- the same manner as is done for 'Output.
procedure Build_Record_Or_Elementary_Input_Function procedure Build_Record_Or_Elementary_Input_Function
(Loc : Source_Ptr; (Loc : Source_Ptr;
Typ : Entity_Id; Typ : Entity_Id;
Decl : out Node_Id; Decl : out Node_Id;
Fnam : out Entity_Id); Fnam : out Entity_Id;
-- Build function for Input attribute for record type or for an Use_Underlying : Boolean := True);
-- elementary type (the latter is used only in the case where a -- Build function for Input attribute for record type or for an elementary
-- user defined Read routine is defined, since in other cases, -- type (the latter is used only in the case where a user defined Read
-- Input calls the appropriate runtime library routine directly. -- routine is defined, since in other cases, Input calls the appropriate
-- runtime library routine directly. The flag Use_Underlying controls
-- weither the base type or the underlying type of the base type of Typ is
-- used during construction.
procedure Build_Record_Or_Elementary_Output_Procedure procedure Build_Record_Or_Elementary_Output_Procedure
(Loc : Source_Ptr; (Loc : Source_Ptr;
......
...@@ -1613,7 +1613,7 @@ package body Scng is ...@@ -1613,7 +1613,7 @@ package body Scng is
when '@' => when '@' =>
if Ada_Version < Ada_2020 then if Ada_Version < Ada_2020 then
Error_Msg ("target_name is an Ada2020 feature", Scan_Ptr); Error_Msg ("target_name is an Ada 2020 feature", Scan_Ptr);
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
else else
......
...@@ -381,17 +381,26 @@ package body Sem_Ch6 is ...@@ -381,17 +381,26 @@ package body Sem_Ch6 is
-- An entity can only be frozen if it is complete, so if the type -- An entity can only be frozen if it is complete, so if the type
-- is still unfrozen it must still be incomplete in some way, e.g. -- is still unfrozen it must still be incomplete in some way, e.g.
-- a privte type without a full view, or a type derived from such -- a private type without a full view, or a type derived from such
-- in an enclosing scope. Except in a generic context, such an -- in an enclosing scope. Except in a generic context, such use of
-- incomplete type is an error. -- an incomplete type is an error. On the other hand, if this is a
-- limited view of a type, the type is declared in another unit and
-- frozen there. We must be in a context seeing the nonlimited view
-- of the type, which will be installed when the body is compiled.
if not Is_Frozen (Ret_Type) if not Is_Frozen (Ret_Type)
and then not Is_Generic_Type (Ret_Type) and then not Is_Generic_Type (Ret_Type)
and then not Inside_A_Generic and then not Inside_A_Generic
then then
Error_Msg_NE if From_Limited_With (Ret_Type)
("premature use of private type&", and then Present (Non_Limited_View (Ret_Type))
Result_Definition (Specification (N)), Ret_Type); then
null;
else
Error_Msg_NE
("premature use of private type&",
Result_Definition (Specification (N)), Ret_Type);
end if;
end if; end if;
if Is_Access_Type (Etype (Prev)) then if Is_Access_Type (Etype (Prev)) 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