+2009-04-10 Thomas Quinot <quinot@adacore.com>
+
+ * xsnamest.adb: Use XUtil to have uniform line endings (UNIX style) in
+ generated files on all platforms.
+
+2009-04-10 Robert Dewar <dewar@adacore.com>
+
+ * sem_aux.adb: Minor reformatting
+
+2009-04-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Access_Definition): Handle properly the case of a
+ protected function with formals that returns an anonymous access type.
+
+2009-04-10 Thomas Quinot <quinot@adacore.com>
+
+ * sem_disp.adb: Minor reformatting
+
+2009-04-10 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * seh_init.c: Do not use the 32-bit specific implementation of
+ __gnat_install_SEH_handler on 64-bit Windows target (64-bit specific
+ version TBD).
+
+2009-04-10 Jose Ruiz <ruiz@adacore.com>
+
+ * mlib-tgt-specific-xi.adb (Get_Target_Prefix): Target_Name may contain
+ a '/' at the end so we better use the complete target name to determine
+ whether it is a PowerPC 55xx target.
+
2009-04-10 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb: Minor reformatting
elsif Target_Name (Target_Name'First .. Index) = "leon" then
return "leon-elf-";
elsif Target_Name (Target_Name'First .. Index) = "powerpc" then
- if Target_Name'Last - 6 >= Target_Name'First and then
- Target_Name (Target_Name'Last - 6 .. Target_Name'Last) = "eabispe"
+ if Target_Name'Length >= 23 and then
+ Target_Name (Target_Name'First .. Target_Name'First + 22) =
+ "powerpc-unknown-eabispe"
then
return "powerpc-eabispe-";
else
extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
-#ifdef _WIN32
+#if defined (_WIN32) && !defined (_WIN64)
#include <windows.h>
#include <excpt.h>
asm ("mov %ecx,%fs:(0)");
}
-#else /* _WIN32 */
+#else /* defined (_WIN32) && !defined (_WIN64) */
/* For all non Windows targets we provide a dummy SEH install handler. */
void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED)
{
Full_D : Node_Id;
begin
- -- If we have no declaration node, then return no constant value.
- -- Not clear how this can happen, but it does sometimes and this is
- -- the safest approach.
+ -- If we have no declaration node, then return no constant value. Not
+ -- clear how this can happen, but it does sometimes and this is the
+ -- safest approach.
if No (D) then
return Empty;
elsif Nkind (D) = N_Object_Renaming_Declaration then
return Renamed_Object (Ent);
- -- If this is a component declaration whose entity is constant, it
- -- is a prival within a protected function. It does not have
- -- a constant value.
+ -- If this is a component declaration whose entity is constant, it is
+ -- a prival within a protected function. It does not have a constant
+ -- value.
elsif Nkind (D) = N_Component_Declaration then
return Empty;
S : Entity_Id;
begin
- -- The following test is an error defense against some syntax
- -- errors that can leave scopes very messed up.
+ -- The following test is an error defense against some syntax errors
+ -- that can leave scopes very messed up.
if Ent = Standard_Standard then
return Ent;
begin
-- If the base type has no freeze node, it is a type in standard,
- -- and always acts as its own first subtype unless it is one of
- -- the predefined integer types. If the type is formal, it is also
- -- a first subtype, and its base type has no freeze node. On the other
- -- hand, a subtype of a generic formal is not its own first_subtype.
- -- Its base type, if anonymous, is attached to the formal type decl.
- -- from which the first subtype is obtained.
+ -- and always acts as its own first subtype unless it is one of the
+ -- predefined integer types. If the type is formal, it is also a first
+ -- subtype, and its base type has no freeze node. On the other hand, a
+ -- subtype of a generic formal is not its own first_subtype. Its base
+ -- type, if anonymous, is attached to the formal type decl. from which
+ -- the first subtype is obtained.
if No (F) then
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Related_Nod);
- Anon_Type : Entity_Id;
- Anon_Scope : Entity_Id;
- Desig_Type : Entity_Id;
- Decl : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Related_Nod);
+ Anon_Type : Entity_Id;
+ Anon_Scope : Entity_Id;
+ Desig_Type : Entity_Id;
+ Decl : Entity_Id;
+ Enclosing_Prot_Type : Entity_Id := Empty;
begin
if Is_Entry (Current_Scope)
-- is associated with one of the protected operations, and must
-- be available in the scope that encloses the protected declaration.
-- Otherwise the type is in the scope enclosing the subprogram.
+ -- If the function has formals, The return type of a subprogram
+ -- declaration is analyzed in the scope of the subprogram (see
+ -- Process_Formals) and thus the protected type, if present, is
+ -- the scope of the current function scope.
if Ekind (Current_Scope) = E_Protected_Type then
- Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod)));
+ Enclosing_Prot_Type := Current_Scope;
+
+ elsif Ekind (Current_Scope) = E_Function
+ and then Ekind (Scope (Current_Scope)) = E_Protected_Type
+ then
+ Enclosing_Prot_Type := Scope (Current_Scope);
+ end if;
+
+ if Present (Enclosing_Prot_Type) then
+ Anon_Scope := Scope (Enclosing_Prot_Type);
+
else
Anon_Scope := Scope (Defining_Entity (Related_Nod));
end if;
elsif Nkind (Related_Nod) = N_Function_Specification
and then not From_With_Type (Anon_Type)
then
- if Ekind (Current_Scope) = E_Protected_Type then
- Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
+ if Present (Enclosing_Prot_Type) then
+ Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
elsif Is_List_Member (Parent (Related_Nod))
and then Nkind (Parent (N)) /= N_Parameter_Specification
List : constant Elist_Id := Primitive_Operations (Tagged_Type);
begin
- -- The dispatching operation may already be on the list, if it the
- -- wrapper for an inherited function of a null extension (see exp_ch3
+ -- The dispatching operation may already be on the list, if it is the
+ -- wrapper for an inherited function of a null extension (see Exp_Ch3
-- for the construction of function wrappers). The list of primitive
-- operations must not contain duplicates.
Set_Has_Controlling_Result (Subp);
-- Check that result subtype statically matches first subtype
- -- (Ada 2005) : Subp may have a controlling access result.
+ -- (Ada 2005): Subp may have a controlling access result.
if Subtypes_Statically_Match (Typ, Etype (Subp))
or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
Tagged_Type := Base_Type (Designated_Type (T));
end if;
- -- Ada 2005 : an incomplete type can be tagged. An operation with
- -- an access parameter of the type is dispatching.
+ -- Ada 2005: an incomplete type can be tagged. An operation with an
+ -- access parameter of the type is dispatching.
elsif Scope (Designated_Type (T)) = Current_Scope then
Tagged_Type := Designated_Type (T);
end if;
end if;
- if No (Tagged_Type)
- or else Is_Class_Wide_Type (Tagged_Type)
- then
+ if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then
return Empty;
- -- The dispatching type and the primitive operation must be defined
- -- in the same scope, except in the case of internal operations and
- -- formal abstract subprograms.
+ -- The dispatching type and the primitive operation must be defined in
+ -- the same scope, except in the case of internal operations and formal
+ -- abstract subprograms.
elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
and then (not Is_Generic_Type (Tagged_Type)
Static_Tag : Node_Id := Empty;
-- If a controlling formal has a statically tagged actual, the tag of
- -- this actual is to be used for any tag-indeterminate actual
+ -- this actual is to be used for any tag-indeterminate actual.
procedure Check_Dispatching_Context;
-- If the call is tag-indeterminate and the entity being called is
and then not Is_Abstract_Subprogram (Alias (Subp))
and then No (DTC_Entity (Subp))
then
- -- Private overriding of inherited abstract operation,
- -- call is legal.
+ -- Private overriding of inherited abstract operation, call is
+ -- legal.
Set_Entity (Name (N), Alias (Subp));
return;
-- If the formal is controlling but the actual is not, the type
-- of the actual is statically known, and may be used as the
- -- controlling tag for some other-indeterminate actual.
+ -- controlling tag for some other tag-indeterminate actual.
elsif Is_Controlling_Formal (Formal)
and then Is_Entity_Name (Actual)
Next_Formal (Formal);
end loop;
- -- If the call doesn't have a controlling actual but does have
- -- an indeterminate actual that requires dispatching treatment,
- -- then an object is needed that will serve as the controlling
- -- argument for a dispatching call on the indeterminate actual.
- -- This can only occur in the unusual situation of a default
- -- actual given by a tag-indeterminate call and where the type
- -- of the call is an ancestor of the type associated with a
- -- containing call to an inherited operation (see AI-239).
- -- Rather than create an object of the tagged type, which would
- -- be problematic for various reasons (default initialization,
- -- discriminants), the tag of the containing call's associated
- -- tagged type is directly used to control the dispatching.
+ -- If the call doesn't have a controlling actual but does have an
+ -- indeterminate actual that requires dispatching treatment, then an
+ -- object is needed that will serve as the controlling argument for a
+ -- dispatching call on the indeterminate actual. This can only occur
+ -- in the unusual situation of a default actual given by a
+ -- tag-indeterminate call and where the type of the call is an
+ -- ancestor of the type associated with a containing call to an
+ -- inherited operation (see AI-239).
+
+ -- Rather than create an object of the tagged type, which would be
+ -- problematic for various reasons (default initialization,
+ -- discriminants), the tag of the containing call's associated tagged
+ -- type is directly used to control the dispatching.
if No (Control)
and then Indeterm_Ancestor_Call
elsif Is_Tag_Indeterminate (Actual) then
- -- The tag is inherited from the enclosing call (the
- -- node we are currently analyzing). Explicitly expand
- -- the actual, since the previous call to Expand
- -- (from Resolve_Call) had no way of knowing about
- -- the required dispatching.
+ -- The tag is inherited from the enclosing call (the node
+ -- we are currently analyzing). Explicitly expand the
+ -- actual, since the previous call to Expand (from
+ -- Resolve_Call) had no way of knowing about the required
+ -- dispatching.
Propagate_Tag (Control, Actual);
if Present (Old_Subp) then
- -- If the type has interfaces we complete this check after we
- -- set attribute Is_Dispatching_Operation
+ -- If the type has interfaces we complete this check after we set
+ -- attribute Is_Dispatching_Operation.
Check_Subtype_Conformant (Subp, Old_Subp);
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
+with XUtil; use XUtil;
+
procedure XSnamesT is
- InB : File_Type;
- InT : File_Type;
- OutS : File_Type;
- OutB : File_Type;
- InH : File_Type;
- OutH : File_Type;
+ subtype VString is GNAT.Spitbol.VString;
+
+ InS : Ada.Text_IO.File_Type;
+ InB : Ada.Text_IO.File_Type;
+ InH : Ada.Text_IO.File_Type;
+
+ OutS : Ada.Streams.Stream_IO.File_Type;
+ OutB : Ada.Streams.Stream_IO.File_Type;
+ OutH : Ada.Streams.Stream_IO.File_Type;
A, B : VString := Nul;
Line : VString := Nul;
if Header_Current_Symbol /= S then
declare
- Name2 : Vstring;
+ Name2 : VString;
Pat : constant Pattern := "#define "
& Header_Prefix (S).all
& Break (' ') * Name2;
-- Start of processing for XSnames
begin
- Open (InT, In_File, "snames.ads-tmpl");
+ Open (InS, In_File, "snames.ads-tmpl");
Open (InB, In_File, "snames.adb-tmpl");
Open (InH, In_File, "snames.h-tmpl");
Put_Line (OutB, Line);
- LoopN : while not End_Of_File (InT) loop
- Line := Get_Line (InT);
+ LoopN : while not End_Of_File (InS) loop
+ Line := Get_Line (InS);
if not Match (Line, Name_Ref) then
Put_Line (OutS, Line);
projects / gcc.git / commitdiff