Skip to content

R
riscv-gcc-1
Commit 437244c7 by Arnaud Charlet
Options

[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
parent 57323d5b
Showing with 324 additions and 676 deletions
gcc/ada/ChangeLog
2016-04-27 Arnaud Charlet <charlet@adacore.com> 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. * sem_ch10.adb, sem_case.adb: Mark messages udner -gnatwr when needed.
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com> 2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
......
gcc/ada/aa_util.adb deleted 100644 → 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;
gcc/ada/aa_util.ads deleted 100644 → 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;
gcc/ada/exp_ch5.adb
...@@ -2030,10 +2030,13 @@ package body Exp_Ch5 is ...@@ -2030,10 +2030,13 @@ package body Exp_Ch5 is
end if; end if;
-- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a -- 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) if Is_Access_Type (Typ)
and then Is_Entity_Name (Lhs) and then Is_Entity_Name (Lhs)
and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
and then Present (Effective_Extra_Accessibility (Entity (Lhs))) and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
then then
declare declare
......
gcc/ada/exp_util.adb
...@@ -2793,50 +2793,6 @@ package body Exp_Util is ...@@ -2793,50 +2793,6 @@ package body Exp_Util is
end if; end if;
end Find_Optional_Prim_Op; 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 -- -- Find_Prim_Op --
------------------ ------------------
......
gcc/ada/exp_util.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -473,13 +473,6 @@ package Exp_Util is ...@@ -473,13 +473,6 @@ package Exp_Util is
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface, -- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of 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; 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. -- 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 -- This function allows the use of a primitive operation which is not
......
gcc/ada/init.c
...@@ -504,9 +504,13 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) ...@@ -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. */ /* ARM Bump has to be an even number because of odd/even architecture. */
mcontext->arm_pc+=2; mcontext->arm_pc+=2;
#ifdef __thumb2__ #ifdef __thumb2__
#define CPSR_THUMB_BIT 5
/* For thumb, the return address much have the low order bit set, otherwise /* 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. */ the unwinder will reset to "arm" mode upon return. As long as the
mcontext->arm_pc+=1; 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
#endif #endif
} }
......
gcc/ada/sem_ch13.adb
...@@ -4323,10 +4323,21 @@ package body Sem_Ch13 is ...@@ -4323,10 +4323,21 @@ package body Sem_Ch13 is
function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
Formal : Entity_Id; Formal : Entity_Id;
Root_T : constant Entity_Id := Root_Type (Etype (Etype (Subp)));
begin begin
if not Check_Primitive_Function (Subp) then if not Check_Primitive_Function (Subp) then
return False; 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 else
Formal := First_Formal (Subp); Formal := First_Formal (Subp);
end if; end if;
...@@ -4409,6 +4420,9 @@ package body Sem_Ch13 is ...@@ -4409,6 +4420,9 @@ package body Sem_Ch13 is
if Present (Default) then if Present (Default) then
Set_Entity (Expr, Default); Set_Entity (Expr, Default);
Set_Is_Overloaded (Expr, False); Set_Is_Overloaded (Expr, False);
else
Error_Msg_N
("No interpretation is a valid default iterator!", Expr);
end if; end if;
end; end;
end if; end if;
......
gcc/ada/sem_ch4.adb
...@@ -7214,11 +7214,22 @@ package body Sem_Ch4 is ...@@ -7214,11 +7214,22 @@ package body Sem_Ch4 is
Prefix : Node_Id; Prefix : Node_Id;
Exprs : List_Id) return Boolean Exprs : List_Id) return Boolean
is is
Pref_Typ : constant Entity_Id := Etype (Prefix);
function Constant_Indexing_OK return Boolean; function Constant_Indexing_OK return Boolean;
-- Constant_Indexing is legal if there is no Variable_Indexing defined -- 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 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)). -- 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 -- -- Constant_Indexing_OK --
-------------------------- --------------------------
...@@ -7227,9 +7238,7 @@ package body Sem_Ch4 is ...@@ -7227,9 +7238,7 @@ package body Sem_Ch4 is
Par : Node_Id; Par : Node_Id;
begin begin
if No (Find_Value_Of_Aspect if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then
(Etype (Prefix), Aspect_Variable_Indexing))
then
return True; return True;
elsif not Is_Variable (Prefix) then elsif not Is_Variable (Prefix) then
...@@ -7360,7 +7369,7 @@ package body Sem_Ch4 is ...@@ -7360,7 +7369,7 @@ package body Sem_Ch4 is
end if; end if;
end; end;
elsif Nkind ((Par)) in N_Op then elsif Nkind (Par) in N_Op then
return True; return True;
end if; end if;
...@@ -7372,6 +7381,215 @@ package body Sem_Ch4 is ...@@ -7372,6 +7381,215 @@ package body Sem_Ch4 is
return True; return True;
end Constant_Indexing_OK; 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 -- Local variables
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -7381,6 +7599,11 @@ package body Sem_Ch4 is ...@@ -7381,6 +7599,11 @@ package body Sem_Ch4 is
Func_Name : Node_Id; Func_Name : Node_Id;
Indexing : 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 -- Start of processing for Try_Container_Indexing
begin begin
...@@ -7391,7 +7614,7 @@ package body Sem_Ch4 is ...@@ -7391,7 +7614,7 @@ package body Sem_Ch4 is
return True; return True;
end if; end if;
C_Type := Etype (Prefix); C_Type := Pref_Typ;
-- If indexing a class-wide container, obtain indexing primitive from -- If indexing a class-wide container, obtain indexing primitive from
-- specific type. -- specific type.
...@@ -7400,33 +7623,43 @@ package body Sem_Ch4 is ...@@ -7400,33 +7623,43 @@ package body Sem_Ch4 is
C_Type := Etype (Base_Type (C_Type)); C_Type := Etype (Base_Type (C_Type));
end if; end if;
-- Check whether type has a specified indexing aspect -- Check whether type the has a specified indexing aspect
Func_Name := Empty; 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 if Constant_Indexing_OK then
Func_Name := Func_Name :=
Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing); Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing);
end if; end if;
if No (Func_Name) then if Present (Func_Name) then
Is_Constant_Indexing := True;
-- Otherwise attempt variable indexing
else
Func_Name := Func_Name :=
Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing); Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing);
end if; end if;
-- If aspect does not exist the expression is illegal. Error is -- The type is not subject to either form of indexing, therefore the
-- diagnosed in caller. -- indexed component does not denote container indexing. If this is a
-- true error, it is diagnosed by the caller.
if No (Func_Name) then if No (Func_Name) then
-- The prefix itself may be an indexing of a container: rewrite as -- The prefix itself may be an indexing of a container. Rewrite it
-- such and re-analyze. -- as such and retry.
if Has_Implicit_Dereference (Etype (Prefix)) then if Has_Implicit_Dereference (Pref_Typ) then
Build_Explicit_Dereference Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ));
(Prefix, First_Discriminant (Etype (Prefix)));
return Try_Container_Indexing (N, Prefix, Exprs); return Try_Container_Indexing (N, Prefix, Exprs);
-- Otherwise this is definitely not container indexing
else else
return False; return False;
end if; end if;
...@@ -7445,9 +7678,13 @@ package body Sem_Ch4 is ...@@ -7445,9 +7678,13 @@ package body Sem_Ch4 is
-- are derived from other types with a Reference aspect. -- are derived from other types with a Reference aspect.
elsif Is_Derived_Type (C_Type) 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 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; end if;
Assoc := New_List (Relocate_Node (Prefix)); Assoc := New_List (Relocate_Node (Prefix));
......
gcc/ada/sem_prag.adb
...@@ -15034,6 +15034,18 @@ package body Sem_Prag is ...@@ -15034,6 +15034,18 @@ package body Sem_Prag is
Id := Defining_Entity (Stmt); Id := Defining_Entity (Stmt);
exit; 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 -- When pragma Ghost applies to an expression function, the
-- expression function is transformed into a subprogram. -- expression function is transformed into a subprogram.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment