OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-04-27  Arnaud Charlet  <charlet@adacore.com>

	* aa_util.adb, aa_util.ads: Removed, no longer used.

2016-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <rupp@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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.

From-SVN: r235505
This commit is contained in:
Arnaud Charlet 2016-04-27 15:28:30 +02:00
parent 57323d5bd3
commit 437244c773
10 changed files with 324 additions and 676 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2016-04-27 Arnaud Charlet <charlet@adacore.com>
* aa_util.adb, aa_util.ads: Removed, no longer used.
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <rupp@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <kirtchev@adacore.com>
* 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 <charlet@adacore.com>
* sem_ch10.adb, sem_case.adb: Mark messages udner -gnatwr when needed.

458
gcc/ada/aa_util.adb
View File

@ -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;

145
gcc/ada/aa_util.ads
View File

@ -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;

5
gcc/ada/exp_ch5.adb
View File

@ -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

44
gcc/ada/exp_util.adb
View File

@ -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 --
------------------

9
gcc/ada/exp_util.ads
View File

@ -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

8
gcc/ada/init.c
View File

@ -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<<CPSR_THUMB_BIT))
mcontext->arm_pc+=1;
#endif
#endif
}

14
gcc/ada/sem_ch13.adb
View File

@ -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;

273
gcc/ada/sem_ch4.adb
View File

@ -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));

12
gcc/ada/sem_prag.adb
View File

@ -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.