2011-11-23 Pascal Obry <obry@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 23 Nov 2011 11:00:29 +0000 (11:00 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 23 Nov 2011 11:00:29 +0000 (11:00 +0000)
* sem_prag.adb (Process_Convention): Better error message for
stdcall convention on dispatching calls.

2011-11-23  Gary Dismukes  <dismukes@adacore.com>

* sem_ch4.adb, sem_ch13.adb: Minor reformatting.

2011-11-23  Javier Miranda  <miranda@adacore.com>

* exp_ch6.adb (Expand_Simple_Function_Return): Add missing
implicit type conversion when the returned object is allocated
in the secondary stack and the type of the returned object is
an interface. Done to force generation of displacement of the
"this" pointer.

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

gcc/ada/ChangeLog
gcc/ada/exp_ch6.adb
gcc/ada/sem_ch13.adb
gcc/ada/sem_ch4.adb
gcc/ada/sem_prag.adb

index 673d266..c9169fa 100644 (file)
@@ -1,5 +1,22 @@
 2011-11-23  Pascal Obry  <obry@adacore.com>
 
+       * sem_prag.adb (Process_Convention): Better error message for
+       stdcall convention on dispatching calls.
+
+2011-11-23  Gary Dismukes  <dismukes@adacore.com>
+
+       * sem_ch4.adb, sem_ch13.adb: Minor reformatting.
+
+2011-11-23  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch6.adb (Expand_Simple_Function_Return): Add missing
+       implicit type conversion when the returned object is allocated
+       in the secondary stack and the type of the returned object is
+       an interface. Done to force generation of displacement of the
+       "this" pointer.
+
+2011-11-23  Pascal Obry  <obry@adacore.com>
+
        * impunit.adb: Add g-exptty and g-tty units.
 
 2011-11-23  Robert Dewar  <dewar@adacore.com>
index 9339652..4c94604 100644 (file)
@@ -6700,6 +6700,14 @@ package body Exp_Ch6 is
                  Make_Explicit_Dereference (Loc,
                  Prefix => New_Reference_To (Temp, Loc)));
 
+               --  Ada 2005 (AI-251): If the type of the returned object is
+               --  an interface then add an implicit type conversion to force
+               --  displacement of the "this" pointer.
+
+               if Is_Interface (R_Type) then
+                  Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+               end if;
+
                Analyze_And_Resolve (Exp, R_Type);
             end;
 
index a38cd59..7de3c16 100644 (file)
@@ -161,15 +161,15 @@ package body Sem_Ch13 is
    ----------------------------------------------
 
    --  The following table collects unchecked conversions for validation.
-   --  Entries are made by Validate_Unchecked_Conversion and then the
-   --  call to Validate_Unchecked_Conversions does the actual error
-   --  checking and posting of warnings. The reason for this delayed
-   --  processing is to take advantage of back-annotations of size and
-   --  alignment values performed by the back end.
+   --  Entries are made by Validate_Unchecked_Conversion and then the call
+   --  to Validate_Unchecked_Conversions does the actual error checking and
+   --  posting of warnings. The reason for this delayed processing is to take
+   --  advantage of back-annotations of size and alignment values performed by
+   --  the back end.
 
-   --  Note: the reason we store a Source_Ptr value instead of a Node_Id
-   --  is that by the time Validate_Unchecked_Conversions is called, Sprint
-   --  will already have modified all Sloc values if the -gnatD option is set.
+   --  Note: the reason we store a Source_Ptr value instead of a Node_Id is
+   --  that by the time Validate_Unchecked_Conversions is called, Sprint will
+   --  already have modified all Sloc values if the -gnatD option is set.
 
    type UC_Entry is record
       Eloc   : Source_Ptr; -- node used for posting warnings
@@ -193,13 +193,13 @@ package body Sem_Ch13 is
 
    --    for X'Address use Expr
 
-   --  where Expr is of the form Y'Address or recursively is a reference
-   --  to a constant of either of these forms, and X and Y are entities of
-   --  objects, then if Y has a smaller alignment than X, that merits a
-   --  warning about possible bad alignment. The following table collects
-   --  address clauses of this kind. We put these in a table so that they
-   --  can be checked after the back end has completed annotation of the
-   --  alignments of objects, since we can catch more cases that way.
+   --  where Expr is of the form Y'Address or recursively is a reference to a
+   --  constant of either of these forms, and X and Y are entities of objects,
+   --  then if Y has a smaller alignment than X, that merits a warning about
+   --  possible bad alignment. The following table collects address clauses of
+   --  this kind. We put these in a table so that they can be checked after the
+   --  back end has completed annotation of the alignments of objects, since we
+   --  can catch more cases that way.
 
    type Address_Clause_Check_Record is record
       N : Node_Id;
@@ -8618,8 +8618,8 @@ package body Sem_Ch13 is
       Target := Ancestor_Subtype (Etype (Act_Unit));
 
       --  If either type is generic, the instantiation happens within a generic
-      --  unit, and there is nothing to check. The proper check
-      --  will happen when the enclosing generic is instantiated.
+      --  unit, and there is nothing to check. The proper check will happen
+      --  when the enclosing generic is instantiated.
 
       if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
          return;
@@ -8717,9 +8717,8 @@ package body Sem_Ch13 is
       end if;
 
       --  If unchecked conversion to access type, and access type is declared
-      --  in the same unit as the unchecked conversion, then set the
-      --  No_Strict_Aliasing flag (no strict aliasing is implicit in this
-      --  situation).
+      --  in the same unit as the unchecked conversion, then set the flag
+      --  No_Strict_Aliasing (no strict aliasing is implicit here)
 
       if Is_Access_Type (Target) and then
         In_Same_Source_Unit (Target, N)
@@ -8727,11 +8726,11 @@ package body Sem_Ch13 is
          Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
       end if;
 
-      --  Generate N_Validate_Unchecked_Conversion node for back end in
-      --  case the back end needs to perform special validation checks.
+      --  Generate N_Validate_Unchecked_Conversion node for back end in case
+      --  the back end needs to perform special validation checks.
 
-      --  Shouldn't this be in Exp_Ch13, since the check only gets done
-      --  if we have full expansion and the back end is called ???
+      --  Shouldn't this be in Exp_Ch13, since the check only gets done if we
+      --  have full expansion and the back end is called ???
 
       Vnode :=
         Make_Validate_Unchecked_Conversion (Sloc (N));
index 4b438e1..0f918c0 100644 (file)
@@ -3432,8 +3432,8 @@ package body Sem_Ch4 is
       --  of the high bound.
 
       procedure Check_Universal_Expression (N : Node_Id);
-      --  In Ada83, reject bounds of a universal range that are not literals or
-      --  entity names.
+      --  In Ada 83, reject bounds of a universal range that are not literals
+      --  or entity names.
 
       -----------------------
       -- Check_Common_Type --
index 14961cb..c63e9da 100644 (file)
@@ -3526,30 +3526,37 @@ package body Sem_Prag is
 
          --  Stdcall case
 
-         if C = Convention_Stdcall
+         if C = Convention_Stdcall then
+
+            --  A dispatching call is not allowed. A dispatching subprogram
+            --  cannot be used to interface to the Win32 API, so in fact this
+            --  check does not impose any effective restriction.
+
+            if Is_Dispatching_Operation (E) then
+
+               Error_Pragma
+                 ("dispatching subprograms cannot use Stdcall convention");
 
             --  Subprogram is allowed, but not a generic subprogram, and not a
-            --  dispatching operation. A dispatching subprogram cannot be used
-            --  to interface to the Win32 API, so in fact this check does not
-            --  impose any effective restriction.
+            --  dispatching operation.
 
-           and then
-             ((not Is_Subprogram (E) and then not Is_Generic_Subprogram (E))
-                or else Is_Dispatching_Operation (E))
+            elsif not Is_Subprogram (E)
+              and then not Is_Generic_Subprogram (E)
 
-            --  A variable is OK
+              --  A variable is OK
 
-           and then Ekind (E) /= E_Variable
+              and then Ekind (E) /= E_Variable
 
-           --  An access to subprogram is also allowed
+              --  An access to subprogram is also allowed
 
-           and then not
-             (Is_Access_Type (E)
-               and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-         then
-            Error_Pragma_Arg
-              ("second argument of pragma% must be subprogram (type)",
-               Arg2);
+              and then not
+                (Is_Access_Type (E)
+                  and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+            then
+               Error_Pragma_Arg
+                 ("second argument of pragma% must be subprogram (type)",
+                  Arg2);
+            end if;
          end if;
 
          if not Is_Subprogram (E)