OSDN Git Service

2009-07-20 Arnaud Charlet <charlet@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 20 Jul 2009 13:27:46 +0000 (13:27 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 20 Jul 2009 13:27:46 +0000 (13:27 +0000)
* gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when
CodePeer_Mode is set, to benefit from full front-end expansion
(e.g. generics).

2009-07-20  Ed Schonberg  <schonberg@adacore.com>

* sem_res.adb: Add guard.

* exp_disp.adb, sem_disp.adb (Make_DT): Check underlying view of type
for possible attribute definition of External_Tag, in case clause
appears in the private part of a package.

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

gcc/ada/ChangeLog
gcc/ada/exp_disp.adb
gcc/ada/gnat1drv.adb
gcc/ada/sem_res.adb

index f80b041..e16a9be 100644 (file)
@@ -1,3 +1,17 @@
+2009-07-20  Arnaud Charlet  <charlet@adacore.com>
+
+       * gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when
+       CodePeer_Mode is set, to benefit from full front-end expansion
+       (e.g. generics).
+
+2009-07-20  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_res.adb: Add guard.
+
+       * exp_disp.adb, sem_disp.adb (Make_DT): Check underlying view of type
+       for possible attribute definition of External_Tag, in case clause
+       appears in the private part of a package.
+
 2009-07-20  Jerome Guitton  <guitton@adacore.com>
 
        * gcc-interface/Makefile.in: cleanup powerpc linux target pairs.
index 99f918b..f60e7bc 100644 (file)
@@ -4405,12 +4405,13 @@ package body Exp_Disp is
       --  specific tagged type, as opposed to one of its ancestors.
       --  If the type is an unconstrained type extension, we are building the
       --  dispatch table of its anonymous base type, so the external tag, if
-      --  any was specified, must be retrieved from the first subtype.
+      --  any was specified, must be retrieved from the first subtype. Go to
+      --  the full view in case the clause is in the private part.
 
       else
          declare
             Def : constant Node_Id := Get_Attribute_Definition_Clause
-                                        (First_Subtype (Typ),
+                                        (Underlying_Type (First_Subtype (Typ)),
                                          Attribute_External_Tag);
 
             Old_Val : String_Id;
index 79065e2..c77d74f 100644 (file)
@@ -184,11 +184,10 @@ procedure Gnat1drv is
 
          Polling_Required := False;
 
-         --  Set operating mode to check semantics with full front-end
-         --  expansion, but no back-end code generation.
+         --  Set operating mode to Generate_Code to benefit from full
+         --  front-end expansion (e.g. generics).
 
-         Operating_Mode := Check_Semantics;
-         Debug_Flag_X   := True;
+         Operating_Mode := Generate_Code;
 
          --  We need SCIL generation of course
 
index 372750b..b8235e5 100644 (file)
@@ -3644,15 +3644,16 @@ package body Sem_Res is
               and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
                          or else (Nkind (A) = N_Attribute_Reference
                                    and then
-                                  Is_Class_Wide_Type (Etype (Prefix (A)))))
+                                     Is_Class_Wide_Type (Etype (Prefix (A)))))
               and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
               and then not Is_Controlling_Formal (F)
 
-              --  Disable these checks in imported C++ subprograms
+              --  Disable these checks for call to imported C++ subprograms
 
-              and then not (Is_Imported (Entity (Name (N)))
-                              and then Convention (Entity (Name (N)))
-                                         = Convention_CPP)
+              and then not
+                (Is_Entity_Name (Name (N))
+                  and then Is_Imported (Entity (Name (N)))
+                  and then Convention (Entity (Name (N))) = Convention_CPP)
             then
                Error_Msg_N
                  ("access to class-wide argument not allowed here!", A);