+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>
* par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta
-- 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
-- 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
-- --
-- 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- --
-- 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;
-- --
-- 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- --
-- 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;
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
-- 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
projects / gcc.git / commitdiff