From 4b7fd13182946da2c33fc2c1df6614122e217b59 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Jan 2017 14:20:22 +0100 Subject: [PATCH] [multiple changes] 2017-01-23 Justin Squirek * 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 * scng.adb: Minor reformatting of error message. 2017-01-23 Ed Schonberg * 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 --- gcc/ada/ChangeLog | 20 ++++++++++++++++ gcc/ada/exp_attr.adb | 56 ++++++++++++++++++++++++++++---------------- gcc/ada/exp_strm.adb | 19 +++++++++------ gcc/ada/exp_strm.ads | 21 ++++++++++------- gcc/ada/scng.adb | 2 +- gcc/ada/sem_ch6.adb | 21 ++++++++++++----- 6 files changed, 96 insertions(+), 43 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8a8c290cad9..431885486a0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2017-01-23 Justin Squirek + + * 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 + + * scng.adb: Minor reformatting of error message. + +2017-01-23 Ed Schonberg + + * 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 * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 845b7a3db7e..2655b80e4bb 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3744,18 +3744,26 @@ package body Exp_Attr is -- A special case arises if we have a defined _Read routine, -- since in this case we are required to call this routine. - if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then - Build_Record_Or_Elementary_Input_Function - (Loc, U_Type, Decl, Fname); - Insert_Action (N, Decl); + declare + Typ : Entity_Id := P_Type; + begin + 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 - Rewrite (N, Build_Elementary_Input_Call (N)); - Analyze_And_Resolve (N, P_Type); - return; - end if; + -- For normal cases, we call the I_xxx routine directly + + else + Rewrite (N, Build_Elementary_Input_Call (N)); + Analyze_And_Resolve (N, P_Type); + return; + end if; + end; -- Array type case @@ -4839,18 +4847,26 @@ package body Exp_Attr is -- A special case arises if we have a defined _Write routine, -- since in this case we are required to call this routine. - if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then - Build_Record_Or_Elementary_Output_Procedure - (Loc, U_Type, Decl, Pname); - Insert_Action (N, Decl); + declare + Typ : Entity_Id := P_Type; + begin + 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 - Rewrite (N, Build_Elementary_Write_Call (N)); - Analyze (N); - return; - end if; + -- For normal cases, we call the W_xxx routine directly + + else + Rewrite (N, Build_Elementary_Write_Call (N)); + Analyze (N); + return; + end if; + end; -- Array type case diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 88de827a90d..20a7a7db5d9 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1116,23 +1116,28 @@ package body Exp_Strm is -- an elementary type, then no Cn constants are defined. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; - Decl : out Node_Id; - Fnam : out Entity_Id) + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id; + Use_Underlying : Boolean := True) is - B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); + B_Typ : Entity_Id := Base_Type (Typ); Cn : Name_Id; Constr : List_Id; Decls : List_Id; Discr : Entity_Id; - Discr_Elmt : Elmt_Id := No_Elmt; + Discr_Elmt : Elmt_Id := No_Elmt; J : Pos; Obj_Decl : Node_Id; Odef : Node_Id; Stms : List_Id; begin + if Use_Underlying then + B_Typ := Underlying_Type (B_Typ); + end if; + Decls := New_List; Constr := New_List; diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads index 97cb37bbd3e..397206c93fb 100644 --- a/gcc/ada/exp_strm.ads +++ b/gcc/ada/exp_strm.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -105,14 +105,17 @@ package Exp_Strm is -- the same manner as is done for 'Output. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; - Decl : out Node_Id; - Fnam : out Entity_Id); - -- Build function for Input attribute for record type or for an - -- elementary type (the latter is used only in the case where a - -- user defined Read routine is defined, since in other cases, - -- Input calls the appropriate runtime library routine directly. + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id; + Use_Underlying : Boolean := True); + -- Build function for Input attribute for record type or for an elementary + -- type (the latter is used only in the case where a user defined Read + -- 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 (Loc : Source_Ptr; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index ae09cc8e43b..a46b80ce64b 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1613,7 +1613,7 @@ package body Scng is when '@' => 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; else diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2591aafbb85..5a54515c4b9 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -381,17 +381,26 @@ package body Sem_Ch6 is -- 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. - -- a privte type without a full view, or a type derived from such - -- in an enclosing scope. Except in a generic context, such an - -- incomplete type is an error. + -- a private type without a full view, or a type derived from such + -- in an enclosing scope. Except in a generic context, such use of + -- 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) and then not Is_Generic_Type (Ret_Type) and then not Inside_A_Generic then - Error_Msg_NE - ("premature use of private type&", - Result_Definition (Specification (N)), Ret_Type); + if From_Limited_With (Ret_Type) + and then Present (Non_Limited_View (Ret_Type)) + then + null; + else + Error_Msg_NE + ("premature use of private type&", + Result_Definition (Specification (N)), Ret_Type); + end if; end if; if Is_Access_Type (Etype (Prev)) then -- 2.30.2