From 03ad478dc5a08e2f5b20296035ab14fc2019aab4 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 25 Apr 2012 17:17:25 +0200 Subject: [PATCH] [multiple changes] 2012-04-25 Gary Dismukes * exp_ch9.adb: Add comments on the usage of the lock-free data structures. 2012-04-25 Vincent Pucci * exp_intr.adb (Expand_Shift): Convert the left operand and the operator when the type of the call differs from the type of the operator. 2012-04-25 Geert Bosch * stand.ads: Minor comment fix. 2012-04-25 Hristian Kirtchev * sem_ch4.adb (Analyze_Slice): Handle the case where the prefix is a string literal. Retrieve the first index from the base type when slicing a string literal. * sem_ch12.adb (Check_Private_View): Move the initialization of the type inside the loop to reflect the changing index. * sem_eval.adb (Eval_Relational_Op): Retrieve the first index from the base type when dealing with a string literal. * sem_res.adb (Resolve_Slice): Retrieve the first index from the base type when slicing a string literal. * sem_util.adb (Is_Internally_Generated_Renaming): New routine. (Is_Object_Reference): String literals may act as object references only when they are renamed internally. (Proper_First_Index): New routine. * sem_util.ads (Proper_First_Index): New routine. From-SVN: r186829 --- gcc/ada/ChangeLog | 32 +++++++++++++++++++++++++++ gcc/ada/exp_ch9.adb | 20 ++++++++++++----- gcc/ada/exp_intr.adb | 36 ++++++++++++++++++++++-------- gcc/ada/sem_ch12.adb | 3 ++- gcc/ada/sem_ch4.adb | 4 ++-- gcc/ada/sem_eval.adb | 2 +- gcc/ada/sem_res.adb | 2 +- gcc/ada/sem_util.adb | 52 +++++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_util.ads | 5 +++++ gcc/ada/stand.ads | 10 ++++----- 10 files changed, 140 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3831a9e3d23..35f82130730 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2012-04-25 Gary Dismukes + + * exp_ch9.adb: Add comments on the usage of the + lock-free data structures. + +2012-04-25 Vincent Pucci + + * exp_intr.adb (Expand_Shift): Convert the left + operand and the operator when the type of the call differs from + the type of the operator. + +2012-04-25 Geert Bosch + + * stand.ads: Minor comment fix. + +2012-04-25 Hristian Kirtchev + + * sem_ch4.adb (Analyze_Slice): Handle the case where the prefix + is a string literal. Retrieve the first index from the base type + when slicing a string literal. + * sem_ch12.adb (Check_Private_View): Move the initialization + of the type inside the loop to reflect the changing index. + * sem_eval.adb (Eval_Relational_Op): Retrieve the first index + from the base type when dealing with a string literal. + * sem_res.adb (Resolve_Slice): Retrieve the first index from + the base type when slicing a string literal. + * sem_util.adb (Is_Internally_Generated_Renaming): New routine. + (Is_Object_Reference): String literals may act + as object references only when they are renamed internally. + (Proper_First_Index): New routine. + * sem_util.ads (Proper_First_Index): New routine. + 2012-04-25 Robert Dewar * sem_ch3.adb, csinfo.adb, lib-writ.adb, sem_ch12.adb, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d926abe766d..9d21af2accc 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -81,16 +81,24 @@ package body Exp_Ch9 is -- Lock Free Data Structure -- ------------------------------ + -- A lock-free subprogram is a protected routine which references a unique + -- protected scalar component and does not contain statements that cause + -- side effects. Due to this restricted behavior, all references to shared + -- data from within the subprogram can be synchronized through the use of + -- atomic operations rather than relying on locks. + type Lock_Free_Subprogram is record Sub_Body : Node_Id; - Comp_Id : Entity_Id; + -- Reference to the body of a protected subprogram which meets the lock- + -- free requirements. + + Comp_Id : Entity_Id; + -- Reference to the scalar component referenced from within Sub_Body end record; - -- This data structure and its fields must be documented, ALL global - -- data structures must be documented. We never rely on guessing what - -- things mean from their names. - -- The following table establishes a relation between a subprogram body and - -- an unique protected component referenced in this body. + -- This table establishes a relation between a protected subprogram body + -- and a unique component it references. The table is used when building + -- the lock-free versions of a protected subprogram body. package Lock_Free_Subprogram_Table is new Table.Table ( Table_Component_Type => Lock_Free_Subprogram, diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 5df8b371863..50f404e6bc8 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -650,20 +650,20 @@ package body Exp_Intr is -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (N); + Entyp : constant Entity_Id := Etype (E); Left : constant Node_Id := First_Actual (N); + Loc : constant Source_Ptr := Sloc (N); Right : constant Node_Id := Next_Actual (Left); Ltyp : constant Node_Id := Etype (Left); Rtyp : constant Node_Id := Etype (Right); + Typ : constant Entity_Id := Etype (N); Snode : Node_Id; begin Snode := New_Node (K, Loc); - Set_Left_Opnd (Snode, Relocate_Node (Left)); Set_Right_Opnd (Snode, Relocate_Node (Right)); Set_Chars (Snode, Chars (E)); - Set_Etype (Snode, Base_Type (Typ)); + Set_Etype (Snode, Base_Type (Entyp)); Set_Entity (Snode, E); if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) @@ -672,12 +672,30 @@ package body Exp_Intr is Set_Shift_Count_OK (Snode, True); end if; - -- Do the rewrite. Note that we don't call Analyze and Resolve on - -- this node, because it already got analyzed and resolved when - -- it was a function call! + if Typ = Entyp then - Rewrite (N, Snode); - Set_Analyzed (N); + -- Note that we don't call Analyze and Resolve on this node, because + -- it already got analyzed and resolved when it was a function call. + + Set_Left_Opnd (Snode, Relocate_Node (Left)); + Rewrite (N, Snode); + Set_Analyzed (N); + + else + + -- If the context type is not the type of the operator, it is an + -- inherited operator for a derived type. Wrap the node in a + -- conversion so that it is type-consistent for possible further + -- expansion (e.g. within a lock-free protected type). + + Set_Left_Opnd (Snode, + Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left))); + Rewrite (N, Unchecked_Convert_To (Typ, Snode)); + + -- Analyze and resolve result formed by conversion to target type + + Analyze_And_Resolve (N, Typ); + end if; end Expand_Shift; ------------------------ diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4d8320ad052..6f398006d58 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6128,8 +6128,9 @@ package body Sem_Ch12 is begin Indx := First_Index (T); - Typ := Base_Type (Etype (Indx)); while Present (Indx) loop + Typ := Base_Type (Etype (Indx)); + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 55238e2ca11..d6c12b67f41 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4514,9 +4514,9 @@ package body Sem_Ch4 is ("type is not one-dimensional array in slice prefix", N); elsif not - Has_Compatible_Type (D, Etype (First_Index (Array_Type))) + Has_Compatible_Type (D, Etype (Proper_First_Index (Array_Type))) then - Wrong_Type (D, Etype (First_Index (Array_Type))); + Wrong_Type (D, Etype (Proper_First_Index (Array_Type))); else Set_Etype (N, Array_Type); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 18a59af25d0..6cd045823a4 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2747,7 +2747,7 @@ package body Sem_Eval is -- General case - T := Etype (First_Index (Etype (Op))); + T := Etype (Proper_First_Index (Etype (Op))); -- The simple case, both bounds are known at compile time diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ef5f8b4ed50..43e12551175 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9003,7 +9003,7 @@ package body Sem_Res is -- necessary. Else resolve the bounds, and apply needed checks. if not Is_Entity_Name (Drange) then - Index := First_Index (Array_Type); + Index := Proper_First_Index (Array_Type); Resolve (Drange, Base_Type (Etype (Index))); if Nkind (Drange) = N_Range then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b5255177b2c..d7bafb2771d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3573,7 +3573,6 @@ package body Sem_Util is if Present (C) and then Restriction_Check_Required (SPARK) then - declare Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); @@ -7587,6 +7586,34 @@ package body Sem_Util is ------------------------- function Is_Object_Reference (N : Node_Id) return Boolean is + + function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; + -- Determine whether N is the name of an internally-generated renaming + + -------------------------------------- + -- Is_Internally_Generated_Renaming -- + -------------------------------------- + + function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is + P : Node_Id := N; + + begin + while Present (P) loop + if Nkind (P) = N_Object_Renaming_Declaration then + return not Comes_From_Source (P); + + elsif Is_List_Member (P) then + return False; + end if; + + P := Parent (P); + end loop; + + return False; + end Is_Internally_Generated_Renaming; + + -- Start of processing for Is_Object_Reference + begin if Is_Entity_Name (N) then return Present (Entity (N)) and then Is_Object (Entity (N)); @@ -7633,6 +7660,14 @@ package body Sem_Util is when N_Unchecked_Type_Conversion => return True; + -- Allow string literals to act as objects as long as they appear + -- in internally-generated renamings. The expansion of iterators + -- may generate such renamings when the range involves a string + -- literal. + + when N_String_Literal => + return Is_Internally_Generated_Renaming (Parent (N)); + when others => return False; end case; @@ -11619,6 +11654,21 @@ package body Sem_Util is Set_Sloc (Endl, Loc); end Process_End_Label; + ------------------------ + -- Proper_First_Index -- + ------------------------ + + function Proper_First_Index (Array_Typ : Entity_Id) return Entity_Id is + Typ : Entity_Id := Array_Typ; + + begin + if Ekind (Typ) = E_String_Literal_Subtype then + Typ := Base_Type (Typ); + end if; + + return First_Index (Typ); + end Proper_First_Index; + ------------------------------------ -- References_Generic_Formal_Type -- ------------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 607bd8e72e0..8e7d7bd81c6 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1284,6 +1284,11 @@ package Sem_Util is -- parameter Ent gives the entity to which the End_Label refers, -- and to which cross-references are to be generated. + function Proper_First_Index (Array_Typ : Entity_Id) return Entity_Id; + -- Return the First_Index attribute of an arbitrary array type unless it + -- is a string literal subtype in which case return the First_Index of the + -- base type. + function References_Generic_Formal_Type (N : Node_Id) return Boolean; -- Returns True if the expression Expr contains any references to a -- generic type. This can only happen within a generic template. diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index d369b40ac73..16f388d5fe6 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -460,12 +460,12 @@ package Stand is ----------------- procedure Tree_Read; - -- Initializes entity values in this package from the current tree - -- file using Osint.Tree_Read. Note that Tree_Read includes all the - -- initialization that is carried out by Create_Standard. + -- Initializes entity values in this package from the current tree file + -- using Tree_IO. Note that Tree_Read includes all the initialization that + -- is carried out by Create_Standard. procedure Tree_Write; -- Writes out the entity values in this package to the current tree file - -- using Osint.Tree_Write. + -- using Tree_IO. end Stand; -- 2.30.2