[multiple changes]

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.

From-SVN: r145898

gcc/ada/ChangeLog

 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
 
 2009-04-10  Thomas Quinot  <quinot@adacore.com>

gcc/ada/mlib-tgt-specific-xi.adb

@@ -155,8 +155,9 @@ package body MLib.Tgt.Specific is
       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

gcc/ada/seh_init.c

@@ -59,7 +59,7 @@ extern struct Exception_Data _abort_signal;
 extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
 
 
-#ifdef _WIN32
+#if defined (_WIN32) && !defined (_WIN64)
 
 #include <windows.h>
 #include <excpt.h>
@@ -224,7 +224,7 @@ __gnat_install_SEH_handler (void *ER)
   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)
 {

gcc/ada/sem_aux.adb

@@ -107,9 +107,9 @@ package body Sem_Aux is
       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;
@@ -119,9 +119,9 @@ package body Sem_Aux is
       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;
@@ -161,8 +161,8 @@ package body Sem_Aux is
       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;
@@ -314,12 +314,12 @@ package body Sem_Aux is
 
    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
 

gcc/ada/sem_ch3.adb

@@ -726,11 +726,12 @@ package body Sem_Ch3 is
      (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)
@@ -767,9 +768,23 @@ package body Sem_Ch3 is
          --  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;
@@ -947,8 +962,8 @@ package body Sem_Ch3 is
       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

gcc/ada/sem_disp.adb

@@ -83,8 +83,8 @@ package body Sem_Disp is
       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.
 
@@ -185,7 +185,7 @@ package body Sem_Disp is
                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
@@ -236,8 +236,8 @@ package body Sem_Disp is
                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);
@@ -256,14 +256,12 @@ package body Sem_Disp is
          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)
@@ -300,7 +298,7 @@ package body Sem_Disp is
 
       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
@@ -323,8 +321,8 @@ package body Sem_Disp 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;
@@ -399,7 +397,7 @@ package body Sem_Disp is
 
             --  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)
@@ -412,18 +410,19 @@ package body Sem_Disp is
             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
@@ -460,11 +459,11 @@ package body Sem_Disp is
 
                   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);
 
@@ -885,8 +884,8 @@ package body Sem_Disp is
 
       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);
 

gcc/ada/xsnamest.adb

@@ -35,18 +35,24 @@ with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
 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;
@@ -131,7 +137,7 @@ procedure XSnamesT is
 
       if Header_Current_Symbol /= S then
          declare
-            Name2 : Vstring;
+            Name2 : VString;
             Pat : constant Pattern := "#define  "
                                        & Header_Prefix (S).all
                                        & Break (' ') * Name2;
@@ -175,7 +181,7 @@ procedure XSnamesT is
 --  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");
 
@@ -194,8 +200,8 @@ begin
 
    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);