+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.
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
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
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 --
------------------
-- --
-- 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- --
-- 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
/* 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
}
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;
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;
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 --
--------------------------
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
end if;
end;
- elsif Nkind ((Par)) in N_Op then
+ elsif Nkind (Par) in N_Op then
return True;
end if;
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);
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
return True;
end if;
- C_Type := Etype (Prefix);
+ C_Type := Pref_Typ;
-- If indexing a class-wide container, obtain indexing primitive from
-- specific type.
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;
-- 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));
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.
projects / gcc.git / commitdiff