From 8b8be176b0ca2f1ef7cf073309ea60481fc435f7 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 27 Apr 2016 13:28:30 +0000 Subject: [PATCH] 2016-04-27 Arnaud Charlet * aa_util.adb, aa_util.ads: Removed, no longer used. 2016-04-27 Hristian Kirtchev * sem_prag.adb (Analyze_Pragma): An object renaming declaration resulting from the expansion of an object declaration is a suitable context for pragma Ghost. 2016-04-27 Doug Rupp * init.c: Refine last checkin so the only requirement is the signaling compilation unit is compiled with the same mode as the compilation unit containing the initial landing pad. 2016-04-27 Ed Schonberg * sem_ch13.adb (Valid_Default_Iterator): Better filter of illegal specifications for Default_Iterator, including overloaded cases where no interpretations are legal, and return types that are not iterator types. 2016-04-27 Hristian Kirtchev * exp_ch5.adb (Expand_N_Assignment_Statement): Do not install an accessibility check when the left hand side of the assignment denotes a container cursor. * exp_util.ads, exp_util.adb (Find_Primitive_Operations): Removed. * sem_ch4.adb (Find_Indexing_Operations): New routine. (Try_Container_Indexing): Code cleanup. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@235505 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 32 ++++ gcc/ada/aa_util.adb | 458 --------------------------------------------------- gcc/ada/aa_util.ads | 145 ---------------- gcc/ada/exp_ch5.adb | 5 +- gcc/ada/exp_util.adb | 44 ----- gcc/ada/exp_util.ads | 9 +- gcc/ada/init.c | 8 +- gcc/ada/sem_ch13.adb | 14 ++ gcc/ada/sem_ch4.adb | 273 ++++++++++++++++++++++++++++-- gcc/ada/sem_prag.adb | 12 ++ 10 files changed, 324 insertions(+), 676 deletions(-) delete mode 100644 gcc/ada/aa_util.adb delete mode 100644 gcc/ada/aa_util.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0a0f0390c7e..1fbc5985ad5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,37 @@ 2016-04-27 Arnaud Charlet + * aa_util.adb, aa_util.ads: Removed, no longer used. + +2016-04-27 Hristian Kirtchev + + * sem_prag.adb (Analyze_Pragma): An object + renaming declaration resulting from the expansion of an object + declaration is a suitable context for pragma Ghost. + +2016-04-27 Doug Rupp + + * init.c: Refine last checkin so the only requirement is the + signaling compilation unit is compiled with the same mode as + the compilation unit containing the initial landing pad. + +2016-04-27 Ed Schonberg + + * sem_ch13.adb (Valid_Default_Iterator): Better filter of illegal + specifications for Default_Iterator, including overloaded cases + where no interpretations are legal, and return types that are + not iterator types. + +2016-04-27 Hristian Kirtchev + + * exp_ch5.adb (Expand_N_Assignment_Statement): Do not install + an accessibility check when the left hand side of the assignment + denotes a container cursor. + * exp_util.ads, exp_util.adb (Find_Primitive_Operations): Removed. + * sem_ch4.adb (Find_Indexing_Operations): New routine. + (Try_Container_Indexing): Code cleanup. + +2016-04-27 Arnaud Charlet + * sem_ch10.adb, sem_case.adb: Mark messages udner -gnatwr when needed. 2016-04-27 Hristian Kirtchev diff --git a/gcc/ada/aa_util.adb b/gcc/ada/aa_util.adb deleted file mode 100644 index 6ea4421f570..00000000000 --- a/gcc/ada/aa_util.adb +++ /dev/null @@ -1,458 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAAMP COMPILER COMPONENTS -- --- -- --- A A _ U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2012, AdaCore -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- ------------------------------------------------------------------------------- - -with Sem_Aux; use Sem_Aux; -with Sinput; use Sinput; -with Stand; use Stand; -with Stringt; use Stringt; - -with GNAT.Case_Util; use GNAT.Case_Util; - -package body AA_Util is - - ---------------------- - -- Is_Global_Entity -- - ---------------------- - - function Is_Global_Entity (E : Entity_Id) return Boolean is - begin - return Enclosing_Dynamic_Scope (E) = Standard_Standard; - end Is_Global_Entity; - - ----------------- - -- New_Name_Id -- - ----------------- - - function New_Name_Id (Name : String) return Name_Id is - begin - for J in 1 .. Name'Length loop - Name_Buffer (J) := Name (Name'First + (J - 1)); - end loop; - - Name_Len := Name'Length; - return Name_Find; - end New_Name_Id; - - ----------------- - -- Name_String -- - ----------------- - - function Name_String (Name : Name_Id) return String is - begin - pragma Assert (Name /= No_Name); - return Get_Name_String (Name); - end Name_String; - - ------------------- - -- New_String_Id -- - ------------------- - - function New_String_Id (S : String) return String_Id is - begin - for J in 1 .. S'Length loop - Name_Buffer (J) := S (S'First + (J - 1)); - end loop; - - Name_Len := S'Length; - return String_From_Name_Buffer; - end New_String_Id; - - ------------------ - -- String_Value -- - ------------------ - - function String_Value (Str_Id : String_Id) return String is - begin - -- ??? pragma Assert (Str_Id /= No_String); - - if Str_Id = No_String then - return ""; - end if; - - String_To_Name_Buffer (Str_Id); - - return Name_Buffer (1 .. Name_Len); - end String_Value; - - --------------- - -- Next_Name -- - --------------- - - function Next_Name - (Name_Seq : not null access Name_Sequencer; - Name_Prefix : String) return Name_Id - is - begin - Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1; - - declare - Number_Image : constant String := Name_Seq.Sequence_Number'Img; - begin - return New_Name_Id - (Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last)); - end; - end Next_Name; - - -------------------- - -- Elab_Spec_Name -- - -------------------- - - function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is - begin - return New_Name_Id (Name_String (Module_Name) & "___elabs"); - end Elab_Spec_Name; - - -------------------- - -- Elab_Spec_Name -- - -------------------- - - function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is - begin - return New_Name_Id (Name_String (Module_Name) & "___elabb"); - end Elab_Body_Name; - - -------------------------------- - -- Source_Name_Without_Suffix -- - -------------------------------- - - function File_Name_Without_Suffix (File_Name : String) return String is - Name_Index : Natural := File_Name'Last; - - begin - pragma Assert (File_Name'Length > 0); - - -- We loop in reverse to ensure that file names that follow nonstandard - -- naming conventions that include additional dots are handled properly, - -- preserving dots in front of the main file suffix (for example, - -- main.2.ada => main.2). - - while Name_Index >= File_Name'First - and then File_Name (Name_Index) /= '.' - loop - Name_Index := Name_Index - 1; - end loop; - - -- Return the part of the file name up to but not including the last dot - -- in the name, or return the whole name as is if no dot character was - -- found. - - if Name_Index >= File_Name'First then - return File_Name (File_Name'First .. Name_Index - 1); - - else - return File_Name; - end if; - end File_Name_Without_Suffix; - - ----------------- - -- Source_Name -- - ----------------- - - function Source_Name (Sloc : Source_Ptr) return File_Name_Type is - begin - if Sloc = No_Location or Sloc = Standard_Location then - return No_File; - else - return File_Name (Get_Source_File_Index (Sloc)); - end if; - end Source_Name; - - -------------------------------- - -- Source_Name_Without_Suffix -- - -------------------------------- - - function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is - Src_Name : constant String := - Name_String (Name_Id (Source_Name (Sloc))); - Src_Index : Natural := Src_Name'Last; - - begin - pragma Assert (Src_Name'Length > 0); - - -- Treat the presence of a ".dg" suffix specially, stripping it off - -- in addition to any suffix preceding it. - - if Src_Name'Length >= 4 - and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg" - then - Src_Index := Src_Index - 3; - end if; - - return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index)); - end Source_Name_Without_Suffix; - - ---------------------- - -- Source_Id_String -- - ---------------------- - - function Source_Id_String (Unit_Name : Name_Id) return String is - Unit_String : String := Name_String (Unit_Name); - Name_Last : Positive := Unit_String'Last; - Name_Index : Positive := Unit_String'First; - - begin - To_Mixed (Unit_String); - - -- Replace any embedded sequences of two or more '_' characters - -- with a single '.' character. Note that this will leave any - -- leading or trailing single '_' characters untouched, but those - -- should normally not occur in compilation unit names (and if - -- they do then it's better to leave them as is). - - while Name_Index <= Name_Last loop - if Unit_String (Name_Index) = '_' - and then Name_Index /= Name_Last - and then Unit_String (Name_Index + 1) = '_' - then - Unit_String (Name_Index) := '.'; - Name_Index := Name_Index + 1; - - while Unit_String (Name_Index) = '_' - and then Name_Index <= Name_Last - loop - Unit_String (Name_Index .. Name_Last - 1) - := Unit_String (Name_Index + 1 .. Name_Last); - Name_Last := Name_Last - 1; - end loop; - - else - Name_Index := Name_Index + 1; - end if; - end loop; - - return Unit_String (Unit_String'First .. Name_Last); - end Source_Id_String; - - -- This version of Source_Id_String is obsolescent and is being - -- replaced with the above function. - - function Source_Id_String (Sloc : Source_Ptr) return String is - File_Index : Source_File_Index; - - begin - -- Use an arbitrary artificial 22-character value for package Standard, - -- since Standard doesn't have an associated source file. - - if Sloc <= Standard_Location then - return "20010101010101standard"; - - -- Return the concatentation of the source file's timestamp and - -- its 8-digit hex checksum. - - else - File_Index := Get_Source_File_Index (Sloc); - - return String (Time_Stamp (File_Index)) - & Get_Hex_String (Source_Checksum (File_Index)); - end if; - end Source_Id_String; - - --------------- - -- Source_Id -- - --------------- - - function Source_Id (Unit_Name : Name_Id) return String_Id is - begin - return New_String_Id (Source_Id_String (Unit_Name)); - end Source_Id; - - -- This version of Source_Id is obsolescent and is being - -- replaced with the above function. - - function Source_Id (Sloc : Source_Ptr) return String_Id is - begin - return New_String_Id (Source_Id_String (Sloc)); - end Source_Id; - - ----------- - -- Image -- - ----------- - - function Image (I : Int) return String is - Image_String : constant String := Pos'Image (I); - begin - if Image_String (1) = ' ' then - return Image_String (2 .. Image_String'Last); - else - return Image_String; - end if; - end Image; - - -------------- - -- UI_Image -- - -------------- - - function UI_Image (I : Uint; Format : Integer_Image_Format) return String is - begin - if Format = Decimal then - UI_Image (I, Format => Decimal); - return UI_Image_Buffer (1 .. UI_Image_Length); - - elsif Format = Ada_Hex then - UI_Image (I, Format => Hex); - return UI_Image_Buffer (1 .. UI_Image_Length); - - else - pragma Assert (I >= Uint_0); - - UI_Image (I, Format => Hex); - - pragma Assert (UI_Image_Buffer (1 .. 3) = "16#" - and then UI_Image_Buffer (UI_Image_Length) = '#'); - - -- Declare a string where we will copy the digits from the UI_Image, - -- interspersing '_' characters as 4-digit group separators. The - -- underscores in UI_Image's result are not always at the places - -- where we want them, which is why we do the following copy - -- (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^"). - - declare - Hex_String : String (1 .. UI_Image_Max); - Last_Index : Natural; - Digit_Count : Natural := 0; - UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket - Sep_Count : Natural := 0; - - begin - -- Count up the number of non-underscore characters in the - -- literal value portion of the UI_Image string. - - while UI_Image_Buffer (UI_Image_Index) /= '#' loop - if UI_Image_Buffer (UI_Image_Index) /= '_' then - Digit_Count := Digit_Count + 1; - end if; - - UI_Image_Index := UI_Image_Index + 1; - end loop; - - UI_Image_Index := 4; -- Reset the index past the "16#" bracket - - Last_Index := 1; - - Hex_String (Last_Index) := '^'; - Last_Index := Last_Index + 1; - - -- Copy digits from UI_Image_Buffer to Hex_String, adding - -- underscore separators as appropriate. The initial value - -- of Sep_Count accounts for the leading '^' and being one - -- character ahead after inserting a digit. - - Sep_Count := 2; - - while UI_Image_Buffer (UI_Image_Index) /= '#' loop - if UI_Image_Buffer (UI_Image_Index) /= '_' then - Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index); - - Last_Index := Last_Index + 1; - - -- Add '_' characters to separate groups of four hex - -- digits for readability (grouping from right to left). - - if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then - Hex_String (Last_Index) := '_'; - Last_Index := Last_Index + 1; - Sep_Count := Sep_Count + 1; - end if; - end if; - - UI_Image_Index := UI_Image_Index + 1; - end loop; - - -- Back up before any trailing underscore - - if Hex_String (Last_Index - 1) = '_' then - Last_Index := Last_Index - 1; - end if; - - Hex_String (Last_Index) := '^'; - - return Hex_String (1 .. Last_Index); - end; - end if; - end UI_Image; - - -------------- - -- UR_Image -- - -------------- - - -- Shouldn't this be added to Urealp??? - - function UR_Image (R : Ureal) return String is - - -- The algorithm used here for conversion of Ureal values - -- is taken from the JGNAT back end. - - Num : Long_Long_Float := 0.0; - Den : Long_Long_Float := 0.0; - Sign : Long_Long_Float := 1.0; - Result : Long_Long_Float; - Tmp : Uint; - Index : Integer; - - begin - if UR_Is_Negative (R) then - Sign := -1.0; - end if; - - -- In the following calculus, we consider numbers modulo 2 ** 31, - -- so that we don't have problems with signed Int... - - Tmp := abs (Numerator (R)); - Index := 0; - while Tmp > 0 loop - Num := Num - + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31))) - * (2.0 ** Index); - Tmp := Tmp / Uint_2 ** 31; - Index := Index + 31; - end loop; - - Tmp := abs (Denominator (R)); - if Rbase (R) /= 0 then - Tmp := Rbase (R) ** Tmp; - end if; - - Index := 0; - while Tmp > 0 loop - Den := Den - + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31))) - * (2.0 ** Index); - Tmp := Tmp / Uint_2 ** 31; - Index := Index + 31; - end loop; - - -- If the denominator denotes a negative power of Rbase, - -- then multiply by the denominator. - - if Rbase (R) /= 0 and then Denominator (R) < 0 then - Result := Sign * Num * Den; - - -- Otherwise compute the quotient - - else - Result := Sign * Num / Den; - end if; - - return Long_Long_Float'Image (Result); - end UR_Image; - -end AA_Util; diff --git a/gcc/ada/aa_util.ads b/gcc/ada/aa_util.ads deleted file mode 100644 index 27b6183248e..00000000000 --- a/gcc/ada/aa_util.ads +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAAMP COMPILER COMPONENTS -- --- -- --- A A _ U T I L -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2011, AdaCore -- --- -- --- 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- ------------------------------------------------------------------------------- - --- This package provides various utility operations used by GNAT back-ends --- (e.g. AAMP). - --- This package is a messy grab bag of stuff. These routines should be moved --- to appropriate units (sem_util,sem_aux,exp_util,namet,uintp,urealp). ??? - -with Namet; use Namet; -with Types; use Types; -with Uintp; use Uintp; -with Urealp; use Urealp; - -package AA_Util is - - function Is_Global_Entity (E : Entity_Id) return Boolean; - -- Returns true if and only if E is a library-level entity (excludes - -- entities declared within blocks at the outer level of library packages). - - function New_Name_Id (Name : String) return Name_Id; - -- Returns a Name_Id corresponding to the given name string - - function Name_String (Name : Name_Id) return String; - -- Returns the name string associated with Name - - function New_String_Id (S : String) return String_Id; - -- Returns a String_Id corresponding to the given string - - function String_Value (Str_Id : String_Id) return String; - -- Returns the string associated with Str_Id - - -- Name-generation utilities - - type Name_Sequencer is private; - -- This type is used to support back-end generation of unique symbol - -- (e.g., for string literal objects or labels). By declaring an - -- aliased object of type Name_Sequence and passing that object - -- to the function Next_Name, a series of names with suffixes - -- of the form "__n" will be produced, where n is a string denoting - -- a positive integer. The sequence starts with "__1", and increases - -- by one on each successive call to Next_Name for a given Name_Sequencer. - - function Next_Name - (Name_Seq : not null access Name_Sequencer; - Name_Prefix : String) return Name_Id; - -- Returns the Name_Id for a name composed of the given Name_Prefix - -- concatentated with a unique number suffix of the form "__n", - -- as detemined by the current state of Name_Seq. - - function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id; - -- Returns a name id for the elaboration subprogram to be associated with - -- the specification of the named module. The denoted name is of the form - -- "modulename___elabs". - - function Elab_Body_Name (Module_Name : Name_Id) return Name_Id; - -- Returns a name id for the elaboration subprogram to be associated - -- with the body of the named module. The denoted name is of the form - -- "modulename___elabb". - - function File_Name_Without_Suffix (File_Name : String) return String; - -- Removes the suffix ('.' followed by other characters), if present, from - -- the end of File_Name and returns the shortened name (otherwise simply - -- returns File_Name). - - function Source_Name (Sloc : Source_Ptr) return File_Name_Type; - -- Returns file name corresponding to the source file name associated with - -- the given source position Sloc. - - function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String; - -- Returns a string corresponding to the source file name associated with - -- the given source position Sloc, with its dot-preceded suffix, if any, - -- removed. As examples, the name "main.adb" is mapped to "main" and the - -- name "main.2.ada" is mapped to "main.2". As a special case, file names - -- with a ".dg" suffix will also strip off the ".dg", so "main.adb.dg" - -- becomes simply "main". - - function Source_Id_String (Unit_Name : Name_Id) return String; - -- Returns a string that uniquely identifies the unit with the given - -- Unit_Name. This string is derived from Unit_Name by replacing any - -- multiple underscores with dot ('.') characters and normalizing the - -- casing to mixed case (e.g., "ada__strings" is mapped to ("Ada.Strings"). - - function Source_Id (Unit_Name : Name_Id) return String_Id; - -- Returns a String_Id reference to a string that uniquely identifies - -- the program unit having the given name (as defined for function - -- Source_Id_String). - - function Source_Id_String (Sloc : Source_Ptr) return String; - -- Returns a string that uniquely identifies the source file containing - -- the given source location. This string is constructed from the - -- concatentation of the date and time stamp of the file with a - -- hexadecimal check sum (e.g., "020425143059ABCDEF01"). - - function Source_Id (Sloc : Source_Ptr) return String_Id; - -- Returns a String_Id reference to a string that uniquely identifies the - -- source file containing the given source location (as defined for - -- function Source_Id_String). - - function Image (I : Int) return String; - -- Returns Int'Image (I), but without a leading space in the case where - -- I is nonnegative. Useful for concatenating integers onto other names. - - type Integer_Image_Format is (Decimal, Ada_Hex, AAMP_Hex); - - function UI_Image (I : Uint; Format : Integer_Image_Format) return String; - -- Returns the image of the universal integer I, with no leading spaces - -- and in the format specified. The Format parameter specifies whether - -- the integer representation should be decimal (the default), or Ada - -- hexadecimal (Ada_Hex => "16#xxxxx#" format), or AAMP hexadecimal. - -- In the latter case, the integer will have the form of a sequence of - -- hexadecimal digits bracketed by '^' characters, and will contain '_' - -- characters as separators for groups of four hexadecimal digits - -- (e.g., ^1C_A3CD^). If the format AAMP_Hex is selected, the universal - -- integer must have a nonnegative value. - - function UR_Image (R : Ureal) return String; - -- Returns a decimal image of the universal real value R - -private - - type Name_Sequencer is record - Sequence_Number : Natural := 0; - end record; - -end AA_Util; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 2f7e5d1dad9..f3a6f69f250 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2030,10 +2030,13 @@ package body Exp_Ch5 is end if; -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a - -- stand-alone obj of an anonymous access type. + -- stand-alone obj of an anonymous access type. Do not install the check + -- when the Lhs denotes a container cursor and the Next function employs + -- an access type because this may never result in a dangling pointer. if Is_Access_Type (Typ) and then Is_Entity_Name (Lhs) + and then Ekind (Entity (Lhs)) /= E_Loop_Parameter and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then declare diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 954855d8e2e..b4efc938060 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2793,50 +2793,6 @@ package body Exp_Util is end if; end Find_Optional_Prim_Op; - ------------------------------- - -- Find_Primitive_Operations -- - ------------------------------- - - function Find_Primitive_Operations - (T : Entity_Id; - Name : Name_Id) return Node_Id - is - Prim_Elmt : Elmt_Id; - Prim_Id : Entity_Id; - Ref : Node_Id; - Typ : Entity_Id := T; - - begin - if Is_Class_Wide_Type (Typ) then - Typ := Root_Type (Typ); - end if; - - Typ := Underlying_Type (Typ); - - Ref := Empty; - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); - while Present (Prim_Elmt) loop - Prim_Id := Node (Prim_Elmt); - if Chars (Prim_Id) = Name then - - -- If this is the first primitive operation found, - -- create a reference to it. - - if No (Ref) then - Ref := New_Occurrence_Of (Prim_Id, Sloc (T)); - - -- Otherwise, add interpretation to existing reference - - else - Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id)); - end if; - end if; - Next_Elmt (Prim_Elmt); - end loop; - - return Ref; - end Find_Primitive_Operations; - ------------------ -- Find_Prim_Op -- ------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 5a93ca41b34..1bde973f0e7 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -473,13 +473,6 @@ package Exp_Util is -- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- return the record component containing the tag of Iface. - function Find_Primitive_Operations - (T : Entity_Id; - Name : Name_Id) return Node_Id; - -- Return a reference to a primitive operation with given name. If - -- operation is overloaded, the node carries the corresponding set - -- of overloaded interpretations. - function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 440a068d272..6d51896d137 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -504,9 +504,13 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) /* ARM Bump has to be an even number because of odd/even architecture. */ mcontext->arm_pc+=2; #ifdef __thumb2__ +#define CPSR_THUMB_BIT 5 /* For thumb, the return address much have the low order bit set, otherwise - the unwwinder will reset to "arm" mode upon return. It's a feature. */ - mcontext->arm_pc+=1; + the unwinder will reset to "arm" mode upon return. As long as the + compilation unit containing the landing pad is compiled with the same + mode (arm vs thumb) as the signaling compilation unit, this works. */ + if (mcontext->arm_cpsr & (1<arm_pc+=1; #endif #endif } diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 54cc886a6a5..c6d0dba7a4a 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4323,10 +4323,21 @@ package body Sem_Ch13 is function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is Formal : Entity_Id; + Root_T : constant Entity_Id := Root_Type (Etype (Etype (Subp))); begin if not Check_Primitive_Function (Subp) then return False; + + -- The return type must be derived from a type in an instance + -- of Iterator.Interfaces, and thus its root type must have a + -- predefined name. + + elsif Chars (Root_T) /= Name_Forward_Iterator + and then Chars (Root_T) /= Name_Reversible_Iterator + then + return False; + else Formal := First_Formal (Subp); end if; @@ -4409,6 +4420,9 @@ package body Sem_Ch13 is if Present (Default) then Set_Entity (Expr, Default); Set_Is_Overloaded (Expr, False); + else + Error_Msg_N + ("No interpretation is a valid default iterator!", Expr); end if; end; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 68375299dce..719e4ed0e98 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7214,11 +7214,22 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is + Pref_Typ : constant Entity_Id := Etype (Prefix); + function Constant_Indexing_OK return Boolean; -- Constant_Indexing is legal if there is no Variable_Indexing defined -- for the type, or else node not a target of assignment, or an actual -- for an IN OUT or OUT formal (RM 4.1.6 (11)). + function Find_Indexing_Operations + (T : Entity_Id; + Nam : Name_Id; + Is_Constant : Boolean) return Node_Id; + -- Return a reference to the primitive operation of type T denoted by + -- name Nam. If the operation is overloaded, the reference carries all + -- interpretations. Flag Is_Constant should be set when the context is + -- constant indexing. + -------------------------- -- Constant_Indexing_OK -- -------------------------- @@ -7227,9 +7238,7 @@ package body Sem_Ch4 is Par : Node_Id; begin - if No (Find_Value_Of_Aspect - (Etype (Prefix), Aspect_Variable_Indexing)) - then + if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then return True; elsif not Is_Variable (Prefix) then @@ -7360,7 +7369,7 @@ package body Sem_Ch4 is end if; end; - elsif Nkind ((Par)) in N_Op then + elsif Nkind (Par) in N_Op then return True; end if; @@ -7372,6 +7381,215 @@ package body Sem_Ch4 is return True; end Constant_Indexing_OK; + ------------------------------ + -- Find_Indexing_Operations -- + ------------------------------ + + function Find_Indexing_Operations + (T : Entity_Id; + Nam : Name_Id; + Is_Constant : Boolean) return Node_Id + is + procedure Inspect_Declarations + (Typ : Entity_Id; + Ref : in out Node_Id); + -- Traverse the declarative list where type Typ resides and collect + -- all suitable interpretations in node Ref. + + procedure Inspect_Primitives + (Typ : Entity_Id; + Ref : in out Node_Id); + -- Traverse the list of primitive operations of type Typ and collect + -- all suitable interpretations in node Ref. + + function Is_OK_Candidate + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a suitable indexing + -- operation for type Typ. To qualify as such, the subprogram must + -- be a function, have at least two parameters, and the type of the + -- first parameter must be either Typ, or Typ'Class, or access [to + -- constant] with designated type Typ or Typ'Class. + + procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id); + -- Store subprogram Subp_Id as an interpretation in node Ref + + -------------------------- + -- Inspect_Declarations -- + -------------------------- + + procedure Inspect_Declarations + (Typ : Entity_Id; + Ref : in out Node_Id) + is + Typ_Decl : constant Node_Id := Declaration_Node (Typ); + Decl : Node_Id; + Subp_Id : Entity_Id; + + begin + -- Ensure that the routine is not called with itypes which lack a + -- declarative node. + + pragma Assert (Present (Typ_Decl)); + pragma Assert (Is_List_Member (Typ_Decl)); + + Decl := First (List_Containing (Typ_Decl)); + while Present (Decl) loop + if Nkind (Decl) = N_Subprogram_Declaration then + Subp_Id := Defining_Entity (Decl); + + if Is_OK_Candidate (Subp_Id, Typ) then + Record_Interp (Subp_Id, Ref); + end if; + end if; + + Next (Decl); + end loop; + end Inspect_Declarations; + + ------------------------ + -- Inspect_Primitives -- + ------------------------ + + procedure Inspect_Primitives + (Typ : Entity_Id; + Ref : in out Node_Id) + is + Prim_Elmt : Elmt_Id; + Prim_Id : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Id := Node (Prim_Elmt); + + if Is_OK_Candidate (Prim_Id, Typ) then + Record_Interp (Prim_Id, Ref); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Inspect_Primitives; + + --------------------- + -- Is_OK_Candidate -- + --------------------- + + function Is_OK_Candidate + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean + is + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Param_Typ : Node_Id; + + begin + -- The classify as a suitable candidate, the subprogram must be a + -- function whose name matches the argument of aspect Constant or + -- Variable_Indexing. + + if Ekind (Subp_Id) = E_Function and then Chars (Subp_Id) = Nam then + Formal := First_Formal (Subp_Id); + + -- The candidate requires at least two parameters + + if Present (Formal) and then Present (Next_Formal (Formal)) then + Formal_Typ := Empty; + Param_Typ := Parameter_Type (Parent (Formal)); + + -- Use the designated type when the first parameter is of an + -- access type. + + if Nkind (Param_Typ) = N_Access_Definition + and then Present (Subtype_Mark (Param_Typ)) + then + -- When the context is a constant indexing, the access + -- definition must be access-to-constant. This does not + -- apply to variable indexing. + + if not Is_Constant + or else Constant_Present (Param_Typ) + then + Formal_Typ := Etype (Subtype_Mark (Param_Typ)); + end if; + + -- Otherwise use the parameter type + + else + Formal_Typ := Etype (Param_Typ); + end if; + + if Present (Formal_Typ) then + + -- Use the specific type when the parameter type is + -- class-wide. + + if Is_Class_Wide_Type (Formal_Typ) then + Formal_Typ := Etype (Base_Type (Formal_Typ)); + end if; + + -- Use the full view when the parameter type is private + -- or incomplete. + + if Is_Incomplete_Or_Private_Type (Formal_Typ) + and then Present (Full_View (Formal_Typ)) + then + Formal_Typ := Full_View (Formal_Typ); + end if; + + -- The type of the first parameter must denote the type + -- of the container or acts as its ancestor type. + + return + Formal_Typ = Typ + or else Is_Ancestor (Formal_Typ, Typ); + end if; + end if; + end if; + + return False; + end Is_OK_Candidate; + + ------------------- + -- Record_Interp -- + ------------------- + + procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id) is + begin + if Present (Ref) then + Add_One_Interp (Ref, Subp_Id, Etype (Subp_Id)); + + -- Otherwise this is the first interpretation. Create a reference + -- where all remaining interpretations will be collected. + + else + Ref := New_Occurrence_Of (Subp_Id, Sloc (T)); + end if; + end Record_Interp; + + -- Local variables + + Ref : Node_Id; + Typ : Entity_Id; + + -- Start of processing for Find_Indexing_Operations + + begin + Typ := T; + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Ref := Empty; + Typ := Underlying_Type (Typ); + + Inspect_Primitives (Typ, Ref); + Inspect_Declarations (Typ, Ref); + + return Ref; + end Find_Indexing_Operations; + -- Local variables Loc : constant Source_Ptr := Sloc (N); @@ -7381,6 +7599,11 @@ package body Sem_Ch4 is Func_Name : Node_Id; Indexing : Node_Id; + Is_Constant_Indexing : Boolean := False; + -- This flag reflects the nature of the container indexing. Note that + -- the context may be suited for constant indexing, but the type may + -- lack a Constant_Indexing annotation. + -- Start of processing for Try_Container_Indexing begin @@ -7391,7 +7614,7 @@ package body Sem_Ch4 is return True; end if; - C_Type := Etype (Prefix); + C_Type := Pref_Typ; -- If indexing a class-wide container, obtain indexing primitive from -- specific type. @@ -7400,33 +7623,43 @@ package body Sem_Ch4 is C_Type := Etype (Base_Type (C_Type)); end if; - -- Check whether type has a specified indexing aspect + -- Check whether type the has a specified indexing aspect Func_Name := Empty; + -- The context is suitable for constant indexing, obtain the name of the + -- indexing function from aspect Constant_Indexing. + if Constant_Indexing_OK then Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); + Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing); end if; - if No (Func_Name) then + if Present (Func_Name) then + Is_Constant_Indexing := True; + + -- Otherwise attempt variable indexing + + else Func_Name := - Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); + Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing); end if; - -- If aspect does not exist the expression is illegal. Error is - -- diagnosed in caller. + -- The type is not subject to either form of indexing, therefore the + -- indexed component does not denote container indexing. If this is a + -- true error, it is diagnosed by the caller. if No (Func_Name) then - -- The prefix itself may be an indexing of a container: rewrite as - -- such and re-analyze. + -- The prefix itself may be an indexing of a container. Rewrite it + -- as such and retry. - if Has_Implicit_Dereference (Etype (Prefix)) then - Build_Explicit_Dereference - (Prefix, First_Discriminant (Etype (Prefix))); + if Has_Implicit_Dereference (Pref_Typ) then + Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ)); return Try_Container_Indexing (N, Prefix, Exprs); + -- Otherwise this is definitely not container indexing + else return False; end if; @@ -7445,9 +7678,13 @@ package body Sem_Ch4 is -- are derived from other types with a Reference aspect. elsif Is_Derived_Type (C_Type) - and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) + and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ then - Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name)); + Func_Name := + Find_Indexing_Operations + (T => C_Type, + Nam => Chars (Func_Name), + Is_Constant => Is_Constant_Indexing); end if; Assoc := New_List (Relocate_Node (Prefix)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 613ccdb414c..c02cb0f2e8c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15034,6 +15034,18 @@ package body Sem_Prag is Id := Defining_Entity (Stmt); exit; + -- When pragma Ghost applies to an object declaration which + -- is initialized by means of a function call that returns + -- on the secondary stack, the object declaration becomes a + -- renaming. + + elsif Nkind (Stmt) = N_Object_Renaming_Declaration + and then Comes_From_Source (Orig_Stmt) + and then Nkind (Orig_Stmt) = N_Object_Declaration + then + Id := Defining_Entity (Stmt); + exit; + -- When pragma Ghost applies to an expression function, the -- expression function is transformed into a subprogram. -- 2.11.4.GIT