From: Arnaud Charlet Date: Thu, 25 Jun 2009 09:34:02 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2a31c32ba59f8772f3bdf62b7f74523d0a0a4583;p=gcc.git [multiple changes] 2009-06-25 Vincent Celier * vms_data.ads: Minor comment change 2009-06-25 Gary Dismukes * exp_ch5.adb (Expand_N_Extended_Return_Statement): Don't build an assignment statement to targeting a caller-provided object when the result type is an interface type. * exp_ch6.adb (Expand_Call): Remove redundant test of Is_Limited_Interface (Is_Inherently_Limited is sufficient). (Is_Build_In_Place_Function): Remove test for Is_Limited_Interface. * sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Add type in call to OK_For_Limited_Init. * sem_aux.adb (Is_Inherently_Limited_Type): Revise limited type condition so that True is returned for all limited interfaces, not just synchronized ones. Ignore components of an interface type when checking for limited components (such a component can be a parent component). * sem_ch3.ads (OK_For_Limited_Init_In_05): Add type parameter. (OK_For_Limited_Init): Add type parameter. * sem_ch3.adb (Check_Initialization): Add type in call to OK_For_Limited_Init. (OK_For_Limited_Init): Add new type param in call to OK_For_Limited_Init_In_05. (OK_For_Limited_Init_In_05): Permit arbitrary expressions of a nonlimited type when the context type is a limited interface. Add type on recursive calls. * sem_ch4.adb (Analyze_Allocator): Add type in call to OK_For_Limited_Init. * sem_ch6.adb (Check_Limited_Return): Add type in call to OK_For_Limited_Init. * sem_ch12.adb (Analyze_Formal_Object_Declaration): Add type in call to OK_For_Limited_Init. (Instantiate_Object): Add type in call to OK_For_Limited_Init. * sem_type.adb (Interface_Present_In_Ancestor): In the case of a class-wide interface, get the base type before applying Etype, in order to account for class-wide subtypes. From-SVN: r148938 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5e92642f334..e8918c4b1e8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2009-06-25 Vincent Celier + + * vms_data.ads: Minor comment change + +2009-06-25 Gary Dismukes + + * exp_ch5.adb (Expand_N_Extended_Return_Statement): Don't build an + assignment statement to targeting a caller-provided object when the + result type is an interface type. + + * exp_ch6.adb (Expand_Call): Remove redundant test of + Is_Limited_Interface (Is_Inherently_Limited is sufficient). + (Is_Build_In_Place_Function): Remove test for Is_Limited_Interface. + + * sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Add type in call + to OK_For_Limited_Init. + + * sem_aux.adb (Is_Inherently_Limited_Type): Revise limited type + condition so that True is returned for all limited interfaces, not + just synchronized ones. Ignore components of an interface type when + checking for limited components (such a component can be a parent + component). + + * sem_ch3.ads (OK_For_Limited_Init_In_05): Add type parameter. + (OK_For_Limited_Init): Add type parameter. + + * sem_ch3.adb (Check_Initialization): Add type in call to + OK_For_Limited_Init. + (OK_For_Limited_Init): Add new type param in call to + OK_For_Limited_Init_In_05. + (OK_For_Limited_Init_In_05): Permit arbitrary expressions of a + nonlimited type when the context type is a limited interface. Add type + on recursive calls. + + * sem_ch4.adb (Analyze_Allocator): Add type in call to + OK_For_Limited_Init. + + * sem_ch6.adb (Check_Limited_Return): Add type in call to + OK_For_Limited_Init. + + * sem_ch12.adb (Analyze_Formal_Object_Declaration): Add type in call to + OK_For_Limited_Init. + (Instantiate_Object): Add type in call to OK_For_Limited_Init. + + * sem_type.adb (Interface_Present_In_Ancestor): In the case of a + class-wide interface, get the base type before applying Etype, in order + to account for class-wide subtypes. + 2009-06-25 Emmanuel Briot * gnatcmd.adb, prj-proc.adb, make.adb, prj.adb, prj.ads, prj-nmsc.adb, diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4cc66304ec9..0659c7ef8f9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2694,10 +2694,21 @@ package body Exp_Ch5 is -- and the declaration isn't marked as No_Initialization, then -- we need to generate an assignment to the object and insert -- it after the declaration before rewriting it as a renaming - -- (otherwise we'll lose the initialization). + -- (otherwise we'll lose the initialization). The case where + -- the result type is an interface (or class-wide interface) + -- is also excluded because the context of the function call + -- must be unconstrained, so the initialization will always + -- be done as part of an allocator evaluation (storage pool + -- or secondary stack), never to a constrained target object + -- passed in by the caller. Besides the assignment being + -- unneeded in this case, it avoids problems with trying to + -- generate a dispatching assignment when the return expression + -- is a nonlimited descendant of a limited interface (the + -- interface has no assignment operation). if Present (Return_Obj_Expr) and then not No_Initialization (Return_Object_Decl) + and then not Is_Interface (Return_Obj_Typ) then Init_Assignment := Make_Assignment_Statement (Loc, @@ -2822,12 +2833,21 @@ package body Exp_Ch5 is if Present (Return_Obj_Expr) and then not No_Initialization (Return_Object_Decl) then + -- Always use the type of the expression for the + -- qualified expression, rather than the result type. + -- In general we cannot always use the result type + -- for the allocator, because the expression might be + -- of a specific type, such as in the case of an + -- aggregate or even a nonlimited object when the + -- result type is a limited class-wide interface type. + Heap_Allocator := Make_Allocator (Loc, Expression => Make_Qualified_Expression (Loc, Subtype_Mark => - New_Reference_To (Return_Obj_Typ, Loc), + New_Reference_To + (Etype (Return_Obj_Expr), Loc), Expression => New_Copy_Tree (Return_Obj_Expr))); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d1a5630ab3e..991783f9415 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3065,7 +3065,6 @@ package body Exp_Ch6 is if Needs_Finalization (Etype (Subp)) and then not Is_Inherently_Limited_Type (Etype (Subp)) - and then not Is_Limited_Interface (Etype (Subp)) then Expand_Ctrl_Function_Call (N); end if; @@ -4653,12 +4652,10 @@ package body Exp_Ch6 is then return False; - -- If the return type is a limited interface it has to be treated - -- as a return in place, even if the actual object is some non- - -- limited descendant. - - elsif Is_Limited_Interface (Etype (E)) then - return True; + -- In Ada 2005 all functions with an inherently limited return type + -- must be handled using a build-in-place profile, including the case + -- of a function with a limited interface result, where the function + -- may return objects of nonlimited descendants. else return Is_Inherently_Limited_Type (Etype (E)) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 66653f643e9..43ed7c01295 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -776,7 +776,7 @@ package body Sem_Aggr is and then Comes_From_Source (Expr) and then not In_Instance_Body then - if not OK_For_Limited_Init (Expr) then + if not OK_For_Limited_Init (Etype (Expr), Expr) then Error_Msg_N ("initialization not allowed for limited types", Expr); Explain_Limited_Type (Etype (Expr), Expr); end if; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index f2f55ce2ba0..6513e73d073 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -594,11 +594,16 @@ package body Sem_Aux is return True; elsif Is_Record_Type (Btype) then + + -- Note that we return True for all limited interfaces, even though + -- (unsynchronized) limited interfaces can have descendants that are + -- nonlimited, because this is a predicate on the type itself, and + -- things like functions with limited interface results need to be + -- handled as build in place even though they might return objects + -- of a type that is not inherently limited. + if Is_Limited_Record (Btype) then - return not Is_Interface (Btype) - or else Is_Protected_Interface (Btype) - or else Is_Synchronized_Interface (Btype) - or else Is_Task_Interface (Btype); + return True; elsif Is_Class_Wide_Type (Btype) then return Is_Inherently_Limited_Type (Root_Type (Btype)); @@ -610,7 +615,16 @@ package body Sem_Aux is begin C := First_Component (Btype); while Present (C) loop - if Is_Inherently_Limited_Type (Etype (C)) then + + -- Don't consider components with interface types (which can + -- only occur in the case of a _parent component anyway). + -- They don't have any components, plus it would cause this + -- function to return true for nonlimited types derived from + -- limited intefaces. + + if not Is_Interface (Etype (C)) + and then Is_Inherently_Limited_Type (Etype (C)) + then return True; end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f7d5a1a6156..9afdb0a5a48 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1884,7 +1884,7 @@ package body Sem_Ch12 is if Present (E) then Preanalyze_Spec_Expression (E, T); - if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then + if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then Error_Msg_N ("initialization not allowed for limited types", E); Explain_Limited_Type (T, E); @@ -8434,7 +8434,7 @@ package body Sem_Ch12 is end if; if Is_Limited_Type (Typ) - and then not OK_For_Limited_Init (Actual) + and then not OK_For_Limited_Init (Typ, Actual) then Error_Msg_N ("initialization not allowed for limited types", Actual); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ff702a6a107..488b300ab69 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8780,7 +8780,7 @@ package body Sem_Ch3 is and then not In_Instance and then not In_Inlined_Body then - if not OK_For_Limited_Init (Exp) then + if not OK_For_Limited_Init (T, Exp) then -- In GNAT mode, this is just a warning, to allow it to be evilly -- turned off. Otherwise it is a real error. @@ -15316,20 +15316,36 @@ package body Sem_Ch3 is -- ???Check all calls of this, and compare the conditions under which it's -- called. - function OK_For_Limited_Init (Exp : Node_Id) return Boolean is + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is begin return Is_CPP_Constructor_Call (Exp) or else (Ada_Version >= Ada_05 and then not Debug_Flag_Dot_L - and then OK_For_Limited_Init_In_05 (Exp)); + and then OK_For_Limited_Init_In_05 (Typ, Exp)); end OK_For_Limited_Init; ------------------------------- -- OK_For_Limited_Init_In_05 -- ------------------------------- - function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean + is begin + -- An object of a limited interface type can be initialized with any + -- expression of a nonlimited descendant type. + + if Is_Class_Wide_Type (Typ) + and then Is_Limited_Interface (Typ) + and then not Is_Limited_Type (Etype (Exp)) + then + return True; + end if; + -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in -- case of limited aggregates (including extension aggregates), and -- function calls. The function call may have been give in prefixed @@ -15341,7 +15357,8 @@ package body Sem_Ch3 is when N_Qualified_Expression => return - OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp))); + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); -- Ada 2005 (AI-251): If a class-wide interface object is initialized -- with a function call, the expander has rewritten the call into an @@ -15354,7 +15371,8 @@ package body Sem_Ch3 is when N_Type_Conversion | N_Unchecked_Type_Conversion => return not Comes_From_Source (Exp) and then - OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp))); + OK_For_Limited_Init_In_05 + (Typ, Expression (Original_Node (Exp))); when N_Indexed_Component | N_Selected_Component => return Nkind (Exp) = N_Function_Call; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 9375070125b..c8fc885e771 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -182,18 +182,24 @@ package Sem_Ch3 is -- wide type is created at the same time, and therefore there is a private -- and a full declaration for the class-wide type as well. - function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean; - -- Presuming Exp is an expression of an inherently limited type, returns - -- True if the expression is allowed in an initialization context by the - -- rules of Ada 2005. We use the rule in RM-7.5(2.1/2), "...it is an - -- aggregate, a function_call, or a parenthesized expression or - -- qualified_expression whose operand is permitted...". Note that in Ada - -- 95 mode, we sometimes wish to give warnings based on whether the - -- program _would_ be legal in Ada 2005. Note that Exp must already have - -- been resolved, so we can know whether it's a function call (as opposed - -- to an indexed component, for example). - - function OK_For_Limited_Init (Exp : Node_Id) return Boolean; + function OK_For_Limited_Init_In_05 + (Typ : Entity_Id; + Exp : Node_Id) return Boolean; + -- Presuming Exp is an expression of an inherently limited type Typ, + -- returns True if the expression is allowed in an initialization context + -- by the rules of Ada 2005. We use the rule in RM-7.5(2.1/2), "...it is an + -- aggregate, a function_call, or a parenthesized expression or qualified + -- expression whose operand is permitted...". Note that in Ada 95 mode, + -- we sometimes wish to give warnings based on whether the program _would_ + -- be legal in Ada 2005. Note that Exp must already have been resolved, + -- so we can know whether it's a function call (as opposed to an indexed + -- component, for example). In the case where Typ is a limited interface's + -- class-wide type, then the expression is allowed to be of any kind if its + -- type is a nonlimited descendant of the interface. + + function OK_For_Limited_Init + (Typ : Entity_Id; + Exp : Node_Id) return Boolean; -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Ada 2005 mode. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e94a3312574..06d075211ff 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -387,7 +387,7 @@ package body Sem_Ch4 is and then Comes_From_Source (N) and then not In_Instance_Body then - if not OK_For_Limited_Init (Expression (E)) then + if not OK_For_Limited_Init (Type_Id, Expression (E)) then Error_Msg_N ("initialization not allowed for limited types", N); Explain_Limited_Type (Type_Id, N); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index dfd0cd424d0..2fa6cf81918 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -464,7 +464,7 @@ package body Sem_Ch6 is if Is_Limited_Type (R_Type) and then Comes_From_Source (N) and then not In_Instance_Body - and then not OK_For_Limited_Init_In_05 (Expr) + and then not OK_For_Limited_Init_In_05 (R_Type, Expr) then -- Error in Ada 2005 diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 0cbce214810..5883e3fe867 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2367,8 +2367,10 @@ package body Sem_Type is -- Start of processing for Interface_Present_In_Ancestor begin + -- Iface might be a class-wide subtype, so we have to apply Base_Type + if Is_Class_Wide_Type (Iface) then - Iface_Typ := Etype (Iface); + Iface_Typ := Etype (Base_Type (Iface)); else Iface_Typ := Iface; end if; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 07047c71b5b..a8565c3d2e2 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -820,12 +820,19 @@ package VMS_Data is -- -- Work quietly, only output warnings and errors. - S_Check_Time : aliased constant S := "/TIME " & - "-t"; + S_Check_Time : aliased constant S := "/TIME " & + "-t"; -- /NOTIME (D) - -- /QUIET + -- /TIME + -- + -- Print out execution time + + S_Check_Log : aliased constant S := "/LOG " & + "-log"; + -- /NOLOG (D) + -- /LOG -- - -- Print out execution time + -- Duplicate all the output sent to Stderr into a log file. S_Check_Sections : aliased constant S := "/SECTIONS=" & "DEFAULT " & @@ -901,6 +908,7 @@ package VMS_Data is S_Check_Project 'Access, S_Check_Quiet 'Access, S_Check_Time 'Access, + S_Check_Log 'Access, S_Check_Sections 'Access, S_Check_Short 'Access, S_Check_Subdirs 'Access,