2010-10-04 Vincent Celier <celier@adacore.com>

	* a-direct.adb (Copy_File): Interpret the Form parameter and call
	System.OS_Lib.Copy_File to do the work accordingly. Raise Use_Error if
	the Form parameter contains an incorrect value for field preserve= or
	mode=.
	* a-direct.ads (Create_Directory, Create_Path): Indicate that the Form
	parameter is ignored.
	(Copy_File): Indicate the interpretation of the Form parameter.

2010-10-04  Vincent Celier  <celier@adacore.com>

	* make.adb (Gnatmake): When there are no foreign languages declared and
	a main in attribute Main of the main project does not exist or is a
	source of another project, fail immediately before attempting
	compilation.

2010-10-04  Javier Miranda  <miranda@adacore.com>

	* exp_disp.ads (Convert_Tag_To_Interface): New function which must be
	used to convert a node referencing a tag to a class-wide interface type.
	* exp_disp.adb (Convert_Tag_To_Interface): New function.
	(Expand_Interface_Conversion): Replace invocation of
	Unchecked_Conversion by new function Convert_Tag_To_Interface.
	(Write_DT): Add support for null primitives.
	* exp_ch3.adb (Expand_N_Object_Declaration): For tagged type objects,
	cleanup code that handles interface conversions and avoid unchecked
	conversion of referenced tag components.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Code cleanup. Avoid
	unrequired conversions when generating a dispatching call to _assign.
	* sprint.adb (Write_Itype): Fix wrong output of not null access itypes.

2010-10-04  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Not): Handle properly both operands when the
	parent is a binary boolean operation and the operand is an unpacked
	array.
	(Build_Boolean_Array_Proc_Call): If the operands are both negations, the
	operands of the rewritten node are the operands of the negations, not
	the negations themselves.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164942 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 382 insertions, 125 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2b1fb983657..7aeb5a7cb64 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,44 @@
+2010-10-04  Vincent Celier  <celier@adacore.com>
+
+	* a-direct.adb (Copy_File): Interpret the Form parameter and call
+	System.OS_Lib.Copy_File to do the work accordingly. Raise Use_Error if
+	the Form parameter contains an incorrect value for field preserve= or
+	mode=.
+	* a-direct.ads (Create_Directory, Create_Path): Indicate that the Form
+	parameter is ignored.
+	(Copy_File): Indicate the interpretation of the Form parameter.
+
+2010-10-04  Vincent Celier  <celier@adacore.com>
+
+	* make.adb (Gnatmake): When there are no foreign languages declared and
+	a main in attribute Main of the main project does not exist or is a
+	source of another project, fail immediately before attempting
+	compilation.
+
+2010-10-04  Javier Miranda  <miranda@adacore.com>
+
+	* exp_disp.ads (Convert_Tag_To_Interface): New function which must be
+	used to convert a node referencing a tag to a class-wide interface type.
+	* exp_disp.adb (Convert_Tag_To_Interface): New function.
+	(Expand_Interface_Conversion): Replace invocation of
+	Unchecked_Conversion by new function Convert_Tag_To_Interface.
+	(Write_DT): Add support for null primitives.
+	* exp_ch3.adb (Expand_N_Object_Declaration): For tagged type objects,
+	cleanup code that handles interface conversions and avoid unchecked
+	conversion of referenced tag components.
+	* exp_ch5.adb (Expand_N_Assignment_Statement): Code cleanup. Avoid
+	unrequired conversions when generating a dispatching call to _assign.
+	* sprint.adb (Write_Itype): Fix wrong output of not null access itypes.
+
+2010-10-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Op_Not): Handle properly both operands when the
+	parent is a binary boolean operation and the operand is an unpacked
+	array.
+	(Build_Boolean_Array_Proc_Call): If the operands are both negations, the
+	operands of the rewritten node are the operands of the negations, not
+	the negations themselves.
+
 2010-10-04  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch13.adb (Set_Biased): New procedure, now used throughout, adds
diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb
index 1013b1514db..c2c19d9142e 100644
--- a/gcc/ada/a-direct.adb
+++ b/gcc/ada/a-direct.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2010, 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- --
@@ -42,6 +42,7 @@ with Ada.Characters.Handling;    use Ada.Characters.Handling;
 with System.CRTL;                use System.CRTL;
 with System.OS_Lib;              use System.OS_Lib;
 with System.Regexp;              use System.Regexp;
+with System.File_IO;             use System.File_IO;
 
 with System;
 
@@ -301,9 +302,11 @@ package body Ada.Directories is
       Target_Name : String;
       Form        : String := "")
    is
-      pragma Unreferenced (Form);
       Success : Boolean;
 
+      Mode     : Copy_Mode := Overwrite;
+      Preserve : Attribute := None;
+
    begin
       --  First, the invalid cases
 
@@ -322,10 +325,70 @@ package body Ada.Directories is
          raise Use_Error with "target """ & Target_Name & """ is a directory";
 
       else
-         --  The implementation uses System.OS_Lib.Copy_File, with parameters
-         --  suitable for all platforms.
+         if Form'Length > 0 then
+            declare
+               Formstr : String (1 .. Form'Length + 1);
+               V1, V2  : Natural;
+
+            begin
+
+               --  Acquire form string, setting required NUL terminator
+
+               Formstr (1 .. Form'Length) := Form;
+               Formstr (Formstr'Last) := ASCII.NUL;
+
+               --  Convert form string to lower case
+
+               for J in Formstr'Range loop
+                  if Formstr (J) in 'A' .. 'Z' then
+                     Formstr (J) :=
+                       Character'Val (Character'Pos (Formstr (J)) + 32);
+                  end if;
+               end loop;
+
+               --  Check Form
+
+               Form_Parameter (Formstr, "mode", V1, V2);
+
+               if V1 = 0 then
+                  Mode := Overwrite;
+
+               elsif Formstr (V1 .. V2) = "copy" then
+                  Mode := Copy;
+
+               elsif Formstr (V1 .. V2) = "overwrite" then
+                  Mode := Overwrite;
+
+               elsif Formstr (V1 .. V2) = "append" then
+                  Mode := Append;
+
+               else
+                  raise Use_Error with "invalid Form";
+               end if;
+
+               Form_Parameter (Formstr, "preserve", V1, V2);
+
+               if V1 = 0 then
+                  Preserve := None;
+
+               elsif Formstr (V1 .. V2) = "timestamps" then
+                  Preserve := Time_Stamps;
+
+               elsif Formstr (V1 .. V2) = "all_attributes" then
+                  Preserve := Full;
+
+               elsif Formstr (V1 .. V2) = "no_attributes" then
+                  Preserve := None;
+
+               else
+                  raise Use_Error with "invalid Form";
+               end if;
+            end;
+         end if;
+
+         --  The implementation uses System.OS_Lib.Copy_File
 
-         Copy_File (Source_Name, Target_Name, Success, Overwrite, None);
+         Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
 
          if not Success then
             raise Use_Error with "copy of """ & Source_Name & """ failed";
diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads
index 25652704f03..ddabed6fc33 100644
--- a/gcc/ada/a-direct.ads
+++ b/gcc/ada/a-direct.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived for use with GNAT from AI-00248,  which is --
 -- expected to be a part of a future expected revised Ada Reference Manual. --
@@ -104,6 +104,8 @@ package Ada.Directories is
    --  identification of a directory. The exception Use_Error is propagated if
    --  the external environment does not support the creation of a directory
    --  with the given name (in the absence of Name_Error) and form.
+   --
+   --  The Form parameter is ignored.
 
    procedure Delete_Directory (Directory : String);
    --  Deletes an existing empty directory with name Directory. The exception
@@ -129,6 +131,8 @@ package Ada.Directories is
    --  The exception Use_Error is propagated if the external environment does
    --  not support the creation of any directories with the given name (in the
    --  absence of Name_Error) and form.
+   --
+   --  The Form parameter is ignored.
 
    procedure Delete_Tree (Directory : String);
    --  Deletes an existing directory with name Directory. The directory and
@@ -172,6 +176,41 @@ package Ada.Directories is
    --  not support the creating of the file with the name given by Target_Name
    --  and form given by Form, or copying of the file with the name given by
    --  Source_Name (in the absence of Name_Error).
+   --
+   --  Interpretation of the Form parameter:
+   --  The Form parameter is case-insensitive.
+   --  Two fields are recognized in the Form parameter:
+   --    preserve=<value>
+   --    mode=<value>
+   --  <value> starts immediatey after the character '=' and ends with the
+   --  character immediatey preceding the next comma (',') or with the last
+   --  character of the parameter.
+   --  The only possible values for preserve= are:
+   --     no_attributes: do not try to preserve any file attributes. This is
+   --                    the default if no preserve= is found in Form.
+   --     all_attributes: try to preserve all file attributes (timestamps,
+   --                     access rights).
+   --     timestamps: preserve the timestamp of the copied file, but not the
+   --                 other file attributes.
+   --  The only possible values for mode= are:
+   --     copy: only do the copy if the destination file does not already
+   --           exist. If it already exist, Copy_File fails.
+   --     overwrite: copy the file in all cases. Overwite an aready existing
+   --                destination file.
+   --     append: append the original file to the destination file. If the
+   --             destination file does not exist, the destination file is
+   --             a copy of the source file.
+   --             When mode=append, the field preserve=, if it exists, is not
+   --             taken into account.
+   --  If the Form parameter includes one or both of the fields and the value
+   --  or values are incorrect, Copy_file fails with Use_Error.
+   --  Examples of correct Forms:
+   --     Form => "preserve=no_attributes,mode=overwrite" (the default)
+   --     Form => "mode=append"
+   --     Form => "mode=copy, preserve=all_attributes"
+   --  Examples of incorrect Forms
+   --     Form => "preserve=junk"
+   --     Form => "mode=internal, preserve=timestamps"
 
    ----------------------------------------
    -- File and directory name operations --
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index ee44dd9e0a7..93e1dfd02fc 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4809,20 +4809,20 @@ package body Exp_Ch3 is
                   Iface    : constant Entity_Id := Root_Type (Typ);
                   Expr_N   : Node_Id := Expr;
                   Expr_Typ : Entity_Id;
-
-                  Decl_1   : Node_Id;
-                  Decl_2   : Node_Id;
                   New_Expr : Node_Id;
+                  Obj_Id   : Entity_Id;
+                  Tag_Comp : Node_Id;
 
                begin
                   --  If the original node of the expression was a conversion
                   --  to this specific class-wide interface type then we
-                  --  restore the original node to generate code that
-                  --  statically displaces the pointer to the interface
-                  --  component.
+                  --  restore the original node because we must copy the object
+                  --  before displacing the pointer to reference the secondary
+                  --  tag component. This code must be kept synchronized with
+                  --  the expansion done by routine Expand_Interface_Conversion
 
                   if not Comes_From_Source (Expr_N)
-                    and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+                    and then Nkind (Expr_N) = N_Explicit_Dereference
                     and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
                     and then Etype (Original_Node (Expr_N)) = Typ
                   then
@@ -4839,6 +4839,7 @@ package body Exp_Ch3 is
                      Set_Expression (N, Expr_N);
                   end if;
 
+                  Obj_Id   := Make_Temporary (Loc, 'D', Expr_N);
                   Expr_Typ := Base_Type (Etype (Expr_N));
 
                   if Is_Class_Wide_Type (Expr_Typ) then
@@ -4849,122 +4850,114 @@ package body Exp_Ch3 is
                   --     CW : I'Class := Obj;
                   --  by
                   --     Tmp : T := Obj;
-                  --     CW  : I'Class renames TiC!(Tmp.I_Tag);
+                  --     type Ityp is not null access I'Class;
+                  --     CW  : I'Class renames Ityp(Tmp.I_Tag'Address).all;
 
                   if Comes_From_Source (Expr_N)
                     and then Nkind (Expr_N) = N_Identifier
                     and then not Is_Interface (Expr_Typ)
+                    and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
                     and then (Expr_Typ = Etype (Expr_Typ)
                                or else not
                               Is_Variable_Size_Record (Etype (Expr_Typ)))
                   then
-                     Decl_1 :=
+                     --  Copy the object
+
+                     Insert_Action (N,
                        Make_Object_Declaration (Loc,
-                         Defining_Identifier =>
-                           Make_Temporary (Loc, 'D', Expr_N),
+                         Defining_Identifier => Obj_Id,
                          Object_Definition =>
                            New_Occurrence_Of (Expr_Typ, Loc),
                          Expression =>
-                           Unchecked_Convert_To (Expr_Typ,
-                             Relocate_Node (Expr_N)));
+                           Relocate_Node (Expr_N)));
 
                      --  Statically reference the tag associated with the
                      --  interface
 
-                     Decl_2 :=
-                       Make_Object_Renaming_Declaration (Loc,
-                         Defining_Identifier => Make_Temporary (Loc, 'D'),
-                         Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
-                         Name                =>
-                           Unchecked_Convert_To (Typ,
-                             Make_Selected_Component (Loc,
-                               Prefix =>
-                                 New_Occurrence_Of
-                                   (Defining_Identifier (Decl_1), Loc),
-                               Selector_Name =>
-                                 New_Reference_To
-                                   (Find_Interface_Tag (Expr_Typ, Iface),
-                                    Loc))));
-
-                  --  General case:
+                     Tag_Comp :=
+                       Make_Selected_Component (Loc,
+                         Prefix => New_Occurrence_Of (Obj_Id, Loc),
+                         Selector_Name =>
+                           New_Reference_To
+                             (Find_Interface_Tag (Expr_Typ, Iface), Loc));
 
                   --  Replace
                   --     IW : I'Class := Obj;
                   --  by
                   --     type Equiv_Record is record ... end record;
                   --     implicit subtype CW is <Class_Wide_Subtype>;
-                  --     Temp : CW := CW!(Obj'Address);
-                  --     IW : I'Class renames Displace (Temp, I'Tag);
+                  --     Tmp : CW := CW!(Obj);
+                  --     type Ityp is not null access I'Class;
+                  --     IW : I'Class renames
+                  --            Ityp!(Displace (Temp'Address, I'Tag)).all;
 
                   else
-                     --  Generate the equivalent record type
+                     --  Generate the equivalent record type and update
+                     --  the subtype indication to reference it
 
                      Expand_Subtype_From_Expr
                        (N             => N,
                         Unc_Type      => Typ,
                         Subtype_Indic => Object_Definition (N),
-                        Exp           => Expression (N));
+                        Exp           => Expr_N);
+
+                     if not Is_Interface (Etype (Expr_N)) then
+                        New_Expr := Relocate_Node (Expr_N);
+
+                     --  For interface types we use 'Address which displaces
+                     --  the pointer to the base of the object (if required)
 
-                     if not Is_Interface (Etype (Expression (N))) then
-                        New_Expr := Relocate_Node (Expression (N));
                      else
                         New_Expr :=
-                          Make_Explicit_Dereference (Loc,
-                            Unchecked_Convert_To (RTE (RE_Tag_Ptr),
-                              Make_Attribute_Reference (Loc,
-                                Prefix => Relocate_Node (Expression (N)),
-                                Attribute_Name => Name_Address)));
+                          Unchecked_Convert_To (Etype (Object_Definition (N)),
+                            Make_Explicit_Dereference (Loc,
+                              Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                                Make_Attribute_Reference (Loc,
+                                  Prefix => Relocate_Node (Expr_N),
+                                  Attribute_Name => Name_Address))));
                      end if;
 
-                     Decl_1 :=
+                     --  Copy the object
+
+                     Insert_Action (N,
                        Make_Object_Declaration (Loc,
-                         Defining_Identifier =>
-                           Make_Temporary (Loc, 'D', New_Expr),
-                         Object_Definition   =>
+                         Defining_Identifier => Obj_Id,
+                         Object_Definition =>
                            New_Occurrence_Of
-                            (Etype (Object_Definition (N)), Loc),
-                         Expression          =>
-                           Unchecked_Convert_To
-                             (Etype (Object_Definition (N)), New_Expr));
-
-                     Decl_2 :=
-                       Make_Object_Renaming_Declaration (Loc,
-                         Defining_Identifier => Make_Temporary (Loc, 'D'),
-                         Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
-                         Name                =>
-                           Unchecked_Convert_To (Typ,
-                             Make_Explicit_Dereference (Loc,
-                               Unchecked_Convert_To (RTE (RE_Tag_Ptr),
-                                 Make_Function_Call (Loc,
-                                   Name =>
-                                     New_Reference_To (RTE (RE_Displace), Loc),
-                                   Parameter_Associations => New_List (
-                                     Make_Attribute_Reference (Loc,
-                                       Prefix =>
-                                         New_Occurrence_Of
-                                          (Defining_Identifier (Decl_1), Loc),
-                                       Attribute_Name => Name_Address),
-
-                                     Unchecked_Convert_To (RTE (RE_Tag),
-                                       New_Reference_To
-                                         (Node
-                                           (First_Elmt
-                                             (Access_Disp_Table (Iface))),
-                                          Loc))))))));
+                             (Etype (Object_Definition (N)), Loc),
+                         Expression => New_Expr));
+
+                     --  Dynamically reference the tag associated with the
+                     --  interface
+
+                     Tag_Comp :=
+                       Make_Function_Call (Loc,
+                         Name => New_Reference_To (RTE (RE_Displace), Loc),
+                         Parameter_Associations => New_List (
+                           Make_Attribute_Reference (Loc,
+                             Prefix => New_Occurrence_Of (Obj_Id, Loc),
+                             Attribute_Name => Name_Address),
+                           New_Reference_To
+                             (Node (First_Elmt (Access_Disp_Table (Iface))),
+                              Loc)));
                   end if;
 
-                  Insert_Action (N, Decl_1);
-                  Rewrite (N, Decl_2);
-                  Analyze (N);
-
-                  --  Replace internal identifier of Decl_2 by the identifier
-                  --  found in the sources. We also have to exchange entities
-                  --  containing their defining identifiers to ensure the
-                  --  correct replacement of the object declaration by this
-                  --  object renaming declaration (because such definings
-                  --  identifier have been previously added by Enter_Name to
-                  --  the current scope). We must preserve the homonym chain
-                  --  of the source entity as well.
+                  Rewrite (N,
+                    Make_Object_Renaming_Declaration (Loc,
+                      Defining_Identifier => Make_Temporary (Loc, 'D'),
+                      Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+                      Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
+
+                  Analyze (N, Suppress => All_Checks);
+
+                  --  Replace internal identifier of rewriten node by the
+                  --  identifier found in the sources. We also have to exchange
+                  --  entities containing their defining identifiers to ensure
+                  --  the correct replacement of the object declaration by this
+                  --  object renaming declaration ---because these identifiers
+                  --  were previously added by Enter_Name to the current scope.
+                  --  We must preserve the homonym chain of the source entity
+                  --  as well.
 
                   Set_Chars (Defining_Identifier (N), Chars (Def_Id));
                   Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 346def7f756..ec5bb320c32 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -255,7 +255,7 @@ package body Exp_Ch4 is
                       Prefix         => Name (N),
                       Attribute_Name => Name_Address);
 
-      Arg1      : constant Node_Id := Op1;
+      Arg1      : Node_Id := Op1;
       Arg2      : Node_Id := Op2;
       Call_Node : Node_Id;
       Proc_Name : Entity_Id;
@@ -321,6 +321,8 @@ package body Exp_Ch4 is
          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
 
          if Nkind (Op1) = N_Op_Not then
+            Arg1 := Right_Opnd (Op1);
+            Arg2 := Right_Opnd (Op2);
             if Kind = N_Op_And then
                Proc_Name := RTE (RE_Vector_Nor);
             elsif Kind = N_Op_Or then
@@ -7032,6 +7034,9 @@ package body Exp_Ch4 is
                if N = Op1 and then Nkind (Op2) = N_Op_Not then
                   return;
 
+               elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
+                  return;
+
                --  A xor (not B) can also be special-cased
 
                elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index fb1888da457..9f7e6c7abf1 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1976,14 +1976,29 @@ package body Exp_Ch5 is
                          Reason => CE_Tag_Check_Failed));
                   end if;
 
-                  Append_To (L,
-                    Make_Procedure_Call_Statement (Loc,
-                      Name => New_Reference_To (Op, Loc),
-                      Parameter_Associations => New_List (
-                        Unchecked_Convert_To (F_Typ,
-                          Duplicate_Subexpr (Lhs)),
-                        Unchecked_Convert_To (F_Typ,
-                          Duplicate_Subexpr (Rhs)))));
+                  declare
+                     Left_N  : Node_Id := Duplicate_Subexpr (Lhs);
+                     Right_N : Node_Id := Duplicate_Subexpr (Rhs);
+
+                  begin
+                     --  In order to dispatch the call to _assign the type of
+                     --  the actuals must match. Add conversion (if required).
+
+                     if Etype (Lhs) /= F_Typ then
+                        Left_N := Unchecked_Convert_To (F_Typ, Left_N);
+                     end if;
+
+                     if Etype (Rhs) /= F_Typ then
+                        Right_N := Unchecked_Convert_To (F_Typ, Right_N);
+                     end if;
+
+                     Append_To (L,
+                       Make_Procedure_Call_Statement (Loc,
+                         Name => New_Reference_To (Op, Loc),
+                         Parameter_Associations => New_List (
+                           Node1 => Left_N,
+                           Node2 => Right_N)));
+                  end;
                end;
 
             else
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index cdb9e880599..392fa7c2eba 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -464,6 +464,57 @@ package body Exp_Disp is
       end if;
    end Build_Static_Dispatch_Tables;
 
+   ------------------------------
+   -- Convert_Tag_To_Interface --
+   ------------------------------
+
+   function Convert_Tag_To_Interface
+     (Typ  : Entity_Id;
+      Expr : Node_Id) return Node_Id
+   is
+      Loc       : constant Source_Ptr := Sloc (Expr);
+      Anon_Type : Entity_Id;
+      Result    : Node_Id;
+
+   begin
+      pragma Assert (Is_Class_Wide_Type (Typ)
+        and then Is_Interface (Typ)
+        and then
+          ((Nkind (Expr) = N_Selected_Component
+              and then Is_Tag (Entity (Selector_Name (Expr))))
+           or else
+           (Nkind (Expr) = N_Function_Call
+              and then RTE_Available (RE_Displace)
+              and then Entity (Name (Expr)) = RTE (RE_Displace))));
+
+      Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
+      Set_Directly_Designated_Type (Anon_Type, Typ);
+      Set_Etype (Anon_Type, Anon_Type);
+      Set_Can_Never_Be_Null (Anon_Type);
+
+      --  Decorate the size and alignment attributes of the anonymous access
+      --  type, as required by gigi.
+
+      Layout_Type (Anon_Type);
+
+      if Nkind (Expr) = N_Selected_Component
+        and then Is_Tag (Entity (Selector_Name (Expr)))
+      then
+         Result :=
+           Make_Explicit_Dereference (Loc,
+             Unchecked_Convert_To (Anon_Type,
+               Make_Attribute_Reference (Loc,
+                 Prefix         => Expr,
+                 Attribute_Name => Name_Address)));
+      else
+         Result :=
+           Make_Explicit_Dereference (Loc,
+             Unchecked_Convert_To (Anon_Type, Expr));
+      end if;
+
+      return Result;
+   end Convert_Tag_To_Interface;
+
    -------------------
    -- CPP_Num_Prims --
    -------------------
@@ -1152,15 +1203,18 @@ package body Exp_Disp is
       pragma Assert (Iface_Tag /= Empty);
 
       --  Keep separate access types to interfaces because one internal
-      --  function is used to handle the null value (see following comment)
+      --  function is used to handle the null value (see following comments)
 
       if not Is_Access_Type (Etype (N)) then
+
+         --  Statically displace the pointer to the object to reference
+         --  the component containing the secondary dispatch table.
+
          Rewrite (N,
-           Unchecked_Convert_To (Etype (N),
+           Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ),
              Make_Selected_Component (Loc,
                Prefix => Relocate_Node (Expression (N)),
-               Selector_Name =>
-                 New_Occurrence_Of (Iface_Tag, Loc))));
+               Selector_Name => New_Occurrence_Of (Iface_Tag, Loc))));
 
       else
          --  Build internal function to handle the case in which the
@@ -7976,6 +8030,11 @@ package body Exp_Disp is
 
             if Present (Interface_Alias (Prim)) then
                Write_Str  (", AI_Alias of ");
+
+               if Is_Null_Interface_Primitive (Interface_Alias (Prim)) then
+                  Write_Str ("null primitive ");
+               end if;
+
                Write_Name
                  (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
                Write_Char (':');
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index 5c3796ba410..823693ba492 100644
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -186,6 +186,33 @@ package Exp_Disp is
    --  bodies they are added to the end of the list of declarations of the
    --  package body.
 
+   function Convert_Tag_To_Interface
+     (Typ : Entity_Id; Expr : Node_Id) return Node_Id;
+   pragma Inline (Convert_Tag_To_Interface);
+   --  This function is used in class-wide interface conversions; the expanded
+   --  code generated to convert a tagged object to a class-wide interface type
+   --  involves referencing the tag component containing the secondary dispatch
+   --  table associated with the interface. Given the expression Expr that
+   --  references a tag component, we cannot generate an unchecked conversion
+   --  to leave the expression decorated with the class-wide interface type Typ
+   --  because an unchecked conversion cannot be seen as a no-op. An unchecked
+   --  conversion is conceptually a function call and therefore the RM allows
+   --  the backend to obtain a copy of the value of the actual object and store
+   --  it in some other place (like a register); in such case the interface
+   --  conversion is not equivalent to a displacement of the pointer to the
+   --  interface and any further displacement fails. Although the functionality
+   --  of this function is simple and could be done directly, the purpose of
+   --  this routine is to leave well documented in the sources these
+   --  occurrences.
+
+   --  If Expr is an N_Selected_Component that references a tag generate:
+   --     type ityp is non null access Typ;
+   --     ityp!(Expr'Address).all
+
+   --  if Expr is an N_Function_Call to Ada.Tags.Displace then generate:
+   --     type ityp is non null access Typ;
+   --     ityp!(Expr).all
+
    function CPP_Num_Prims (Typ : Entity_Id) return Nat;
    --  Return the number of primitives of the C++ part of the dispatch table.
    --  For types that are not derivations of CPP types return 0.
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 46af1ffccd9..1df76a51453 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -4468,29 +4468,41 @@ package body Make is
                      --  language, all the Ada mains.
 
                      while Value /= Prj.Nil_String loop
-                        Get_Name_String
-                          (Project_Tree.String_Elements.Table (Value).Value);
-
                         --  To know if a main is an Ada main, get its project.
                         --  It should be the project specified on the command
                         --  line.
 
-                        if (not Foreign_Language) or else
-                            Prj.Env.Project_Of
-                              (Name_Buffer (1 .. Name_Len),
-                               Main_Project,
-                               Project_Tree) =
-                             Main_Project
-                        then
-                           At_Least_One_Main := True;
-                           Osint.Add_File
-                             (Get_Name_String
-                                (Project_Tree.String_Elements.Table
-                                   (Value).Value),
-                              Index =>
-                                Project_Tree.String_Elements.Table
-                                  (Value).Index);
-                        end if;
+                        Get_Name_String
+                          (Project_Tree.String_Elements.Table (Value).Value);
+
+                        declare
+                           Main_Name : constant String :=
+                              Get_Name_String
+                               (Project_Tree.String_Elements.Table
+                                    (Value).Value);
+                           Proj : constant Project_Id :=
+                             Prj.Env.Project_Of
+                              (Main_Name, Main_Project, Project_Tree);
+                        begin
+
+                           if Proj = Main_Project then
+
+                              At_Least_One_Main := True;
+                              Osint.Add_File
+                                (Get_Name_String
+                                   (Project_Tree.String_Elements.Table
+                                      (Value).Value),
+                                 Index =>
+                                   Project_Tree.String_Elements.Table
+                                     (Value).Index);
+
+                           elsif not Foreign_Language then
+                              Make_Failed
+                                ("""" & Main_Name &
+                                 """ is not a source of project " &
+                                 Get_Name_String (Main_Project.Display_Name));
+                           end if;
+                        end;
 
                         Value := Project_Tree.String_Elements.Table
                                    (Value).Next;
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 3c780b51cd4..c73e7e36b8a 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -3760,12 +3760,15 @@ package body Sprint is
 
                   when Access_Kind =>
                      Write_Header (Ekind (Typ) = E_Access_Type);
+
+                     if Can_Never_Be_Null (Typ) then
+                        Write_Str ("not null ");
+                     end if;
+
                      Write_Str ("access ");
 
                      if Is_Access_Constant (Typ) then
                         Write_Str ("constant ");
-                     elsif Can_Never_Be_Null (Typ) then
-                        Write_Str ("not null ");
                      end if;
 
                      Write_Id (Directly_Designated_Type (Typ));