From: Arnaud Charlet Date: Fri, 17 Oct 2014 08:51:08 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=dc06dd83660010f2ed70c6205a0876f91553a30e;p=gcc.git [multiple changes] 2014-10-17 Ed Schonberg * sem_ch13.adb (Add_Invariants): For a class-wide type invariant, preserve semantic information on the invariant expression (typically a function call) because it may be inherited by a type extension in a different unit, and it cannot be resolved by visibility elsewhere because it may refer to local entities. 2014-10-17 Robert Dewar * gnat_rm.texi: Document that string literal can be used for pragma Warnings when operating in Ada 83 mode. 2014-10-17 Ed Schonberg * freeze.adb (Find_Aggregate_Component_Desig_Type): New subsidiary function to Freeze_ Expression, used to determine whether an aggregate for an array of access types also freezes the designated type, when some aggregate components are allocators. 2014-10-17 Ed Schonberg * a-strsea.adb (Find_Token): AI05-031 indicates that the procedure must raise Index_Error when Source is not empty and the From parameter is not within the range of the Source string. 2014-10-17 Robert Dewar * sem_prag.adb (Is_Static_String_Expression): Allow string literal in Ada 83 mode. From-SVN: r216377 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7773970e4c7..0583295e62a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-10-17 Ed Schonberg + + * sem_ch13.adb (Add_Invariants): For a class-wide type invariant, + preserve semantic information on the invariant expression + (typically a function call) because it may be inherited by a + type extension in a different unit, and it cannot be resolved + by visibility elsewhere because it may refer to local entities. + +2014-10-17 Robert Dewar + + * gnat_rm.texi: Document that string literal can be used for + pragma Warnings when operating in Ada 83 mode. + +2014-10-17 Ed Schonberg + + * freeze.adb (Find_Aggregate_Component_Desig_Type): New + subsidiary function to Freeze_ Expression, used to determine + whether an aggregate for an array of access types also freezes the + designated type, when some aggregate components are allocators. + +2014-10-17 Ed Schonberg + + * a-strsea.adb (Find_Token): AI05-031 indicates that the + procedure must raise Index_Error when Source is not empty and + the From parameter is not within the range of the Source string. + +2014-10-17 Robert Dewar + + * sem_prag.adb (Is_Static_String_Expression): Allow string + literal in Ada 83 mode. + 2014-10-17 Vincent Celier * prj-conf.adb (Get_Config_Switches): In CodePeer mode, do diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb index 82acd1a6bf3..f1fb352fe0b 100644 --- a/gcc/ada/a-strsea.adb +++ b/gcc/ada/a-strsea.adb @@ -203,6 +203,12 @@ package body Ada.Strings.Search is Last : out Natural) is begin + -- AI05-031: Raise Index error if Source non-empty and From not in range + + if Source'Length /= 0 and then From not in Source'Range then + raise Index_Error; + end if; + for J in From .. Source'Last loop if Belongs (Source (J), Set, Test) then First := J; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0489baee199..981c7f5e104 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5958,12 +5958,52 @@ package body Freeze is -- may reference entities that have to be frozen before the body and -- obviously cannot be frozen inside the body. + function Find_Aggregate_Component_Desig_Type return Entity_Id; + -- If the expression is an array aggregate, the type of the component + -- expressions is also frozen. If the component type is an access type + -- and the expressions include allocators, the designed type is frozen + -- as well. + function In_Exp_Body (N : Node_Id) return Boolean; -- Given an N_Handled_Sequence_Of_Statements node N, determines whether -- it is the handled statement sequence of an expander-generated -- subprogram (init proc, stream subprogram, or renaming as body). -- If so, this is not a freezing context. + ----------------------------------------- + -- Find_Aggregate_Component_Desig_Type -- + ----------------------------------------- + + function Find_Aggregate_Component_Desig_Type return Entity_Id is + Assoc : Node_Id; + Exp : Node_Id; + + begin + if Present (Expressions (N)) then + Exp := First (Expressions (N)); + while Present (Exp) loop + if Nkind (Exp) = N_Allocator then + return Designated_Type (Component_Type (Etype (N))); + end if; + + Next (Exp); + end loop; + end if; + + if Present (Component_Associations (N)) then + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + if Nkind (Expression (Assoc)) = N_Allocator then + return Designated_Type (Component_Type (Etype (N))); + end if; + + Next (Assoc); + end loop; + end if; + + return Empty; + end Find_Aggregate_Component_Desig_Type; + ----------------- -- In_Exp_Body -- ----------------- @@ -6104,7 +6144,10 @@ package body Freeze is if Is_Array_Type (Etype (N)) and then Is_Access_Type (Component_Type (Etype (N))) then - Desig_Typ := Designated_Type (Component_Type (Etype (N))); + + -- Check whether aggregate includes allocators. + + Desig_Typ := Find_Aggregate_Component_Desig_Type; end if; when N_Selected_Component | diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4258722a939..a824ca9feba 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -7829,6 +7829,9 @@ pragma Warnings (static_string_EXPRESSION [,REASON]); pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]); REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@} + +Note: in Ada 83 mode, a string literal may be used in place of +a static string expression (which does not exist in Ada 83). @end smallexample @noindent diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2a3dc45405c..b486a68fab6 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2947,8 +2947,7 @@ package body Sem_Ch13 is -- evaluation of this aspect should be delayed to the -- freeze point (why???) - if No (Expr) - or else Is_True (Static_Boolean (Expr)) + if No (Expr) or else Is_True (Static_Boolean (Expr)) then Set_Uses_Lock_Free (E); end if; @@ -3621,10 +3620,10 @@ package body Sem_Ch13 is if (Attr = Name_Constant_Indexing and then Present (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) - - or else (Attr = Name_Variable_Indexing - and then Present - (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) + or else + (Attr = Name_Variable_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) then if Debug_Flag_Dot_XX then null; @@ -4269,11 +4268,7 @@ package body Sem_Ch13 is -- Case of address clause for a (non-controlled) object - elsif - Ekind (U_Ent) = E_Variable - or else - Ekind (U_Ent) = E_Constant - then + elsif Ekind_In (U_Ent, E_Variable, E_Constant) then declare Expr : constant Node_Id := Expression (N); O_Ent : Entity_Id; @@ -4295,7 +4290,7 @@ package body Sem_Ch13 is if Present (O_Ent) and then (Has_Controlled_Component (Etype (O_Ent)) - or else Is_Controlled (Etype (O_Ent))) + or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N ("??cannot overlay with controlled object", Expr); @@ -4826,13 +4821,10 @@ package body Sem_Ch13 is -- except from aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent)) - then + if not Is_Concurrent_Type (U_Ent) then Error_Msg_N - ("Interrupt_Priority can only be defined for task" & - "and protected object", - Nam); + ("Interrupt_Priority can only be defined for task " + & "and protected object", Nam); elsif Duplicate_Clause then null; @@ -4985,14 +4977,12 @@ package body Sem_Ch13 is -- aspect specification. if From_Aspect_Specification (N) then - if not (Is_Protected_Type (U_Ent) - or else Is_Task_Type (U_Ent) + if not (Is_Concurrent_Type (U_Ent) or else Ekind (U_Ent) = E_Procedure) then Error_Msg_N - ("Priority can only be defined for task and protected " & - "object", - Nam); + ("Priority can only be defined for task and protected " + & "object", Nam); elsif Duplicate_Clause then null; @@ -5828,6 +5818,7 @@ package body Sem_Ch13 is if Val = No_Uint then Err := True; + elsif Val < Lo or else Hi < Val then Error_Msg_N ("value outside permitted range", Expr); Err := True; @@ -7625,6 +7616,29 @@ package body Sem_Ch13 is Set_Parent (Exp, N); Preanalyze_Assert_Expression (Exp, Standard_Boolean); + -- A class-wide invariant may be inherited in a separate unit, + -- where the corresponding expression cannot be resolved by + -- visibility, because it refers to a local function. Propagate + -- semantic information to the original representation item, to + -- be used when an invariant procedure for a derived type is + -- constructed. + + -- Unclear how to handle class-wide invariants that are not + -- function calls ??? + + if not Inherit + and then Class_Present (Ritem) + and then Nkind (Exp) = N_Function_Call + and then Nkind (Arg2) = N_Indexed_Component + then + Rewrite (Arg2, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Entity (Name (Exp)), Loc), + Parameter_Associations => + New_Copy_List (Expressions (Arg2)))); + end if; + -- In ASIS mode, even if assertions are not enabled, we must -- analyze the original expression in the aspect specification -- because it is part of the original tree. @@ -8501,9 +8515,9 @@ package body Sem_Ch13 is -- at the freeze point. elsif A_Id = Aspect_Input or else - A_Id = Aspect_Output or else - A_Id = Aspect_Read or else - A_Id = Aspect_Write + A_Id = Aspect_Output or else + A_Id = Aspect_Read or else + A_Id = Aspect_Write then Analyze (End_Decl_Expr); Check_Overloaded_Name; @@ -8862,8 +8876,8 @@ package body Sem_Ch13 is and then Has_Discriminants (T)) or else (Is_Access_Type (T) - and then Is_Record_Type (Designated_Type (T)) - and then Has_Discriminants (Designated_Type (T))) + and then Is_Record_Type (Designated_Type (T)) + and then Has_Discriminants (Designated_Type (T))) then Error_Msg_NE ("invalid address clause for initialized object &!", @@ -8954,11 +8968,8 @@ package body Sem_Ch13 is then return; - elsif - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_In_Parameter - then + elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then + -- This is the case where we must have Ent defined before -- U_Ent. Clearly if they are in different units this -- requirement is met since the unit containing Ent is @@ -11132,9 +11143,7 @@ package body Sem_Ch13 is -- need to know such a size, but this routine may be called with a -- generic type as part of normal processing. - elsif Is_Generic_Type (R_Typ) - or else R_Typ = Any_Type - then + elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then return 0; -- Access types (cannot have size smaller than System.Address) @@ -11849,8 +11858,7 @@ package body Sem_Ch13 is (Is_Record_Type (T2) or else Is_Array_Type (T2)) and then (Component_Alignment (T1) /= Component_Alignment (T2) - or else - Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) + or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) then return False; end if; @@ -12739,9 +12747,7 @@ package body Sem_Ch13 is Prim := First (Choices (Assoc)); - if Nkind (Prim) /= N_Identifier - or else Present (Next (Prim)) - then + if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then Error_Msg_N ("illegal name in association", Prim); elsif Chars (Prim) = Name_First then @@ -12858,24 +12864,22 @@ package body Sem_Ch13 is if Warn_On_Unchecked_Conversion and then not In_Predefined_Unit (N) and then RTU_Loaded (Ada_Calendar) - and then - (Chars (Source) = Name_Time - or else - Chars (Target) = Name_Time) + and then (Chars (Source) = Name_Time + or else + Chars (Target) = Name_Time) then -- If Ada.Calendar is loaded and the name of one of the operands is -- Time, there is a good chance that this is Ada.Calendar.Time. declare - Calendar_Time : constant Entity_Id := - Full_View (RTE (RO_CA_Time)); + Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time)); begin pragma Assert (Present (Calendar_Time)); if Source = Calendar_Time or else Target = Calendar_Time then Error_Msg_N - ("?z?representation of 'Time values may change between " & - "'G'N'A'T versions", N); + ("?z?representation of 'Time values may change between " + & "'G'N'A'T versions", N); end if; end; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cf447900f91..c1b9b6e58d0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3201,6 +3201,8 @@ package body Sem_Prag is function Is_Static_String_Expression (Arg : Node_Id) return Boolean; -- Analyzes the argument, and determines if it is a static string -- expression, returns True if so, False if non-static or not String. + -- A special case is that a string literal returns True in Ada 83 mode + -- (which has no such thing as static string expressions). procedure Pragma_Misplaced; pragma No_Return (Pragma_Misplaced); @@ -6220,11 +6222,25 @@ package body Sem_Prag is function Is_Static_String_Expression (Arg : Node_Id) return Boolean is Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Lit : constant Boolean := Nkind (Argx) = N_String_Literal; begin Analyze_And_Resolve (Argx); - return Is_OK_Static_Expression (Argx) - and then Nkind (Argx) = N_String_Literal; + + -- Special case Ada 83, where the expression will never be static, + -- but we will return true if we had a string literal to start with. + + if Ada_Version = Ada_83 then + return Lit; + + -- Normal case, true only if we end up with a string literal that + -- is marked as being the result of evaluating a static expression. + + else + return Is_OK_Static_Expression (Argx) + and then Nkind (Argx) = N_String_Literal; + end if; + end Is_Static_String_Expression; ----------------------