[multiple changes]

2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* freeze.adb (Check_Current_Instance): Issue an
	error when the prefix of 'Unchecked_Access or 'Access does not
	denote a legal aliased view of a type.
	(Freeze_Record_Type): Do not halt the processing of record components
	once the Has_Controlled_Component is set as this bypasses the remaining
	checks.
	(Is_Aliased_View_Of_Type): New routine.

2012-01-23  Thomas Quinot  <quinot@adacore.com>

	* errout.ads, freeze.adb: Minor reformatting.

2012-01-23  Thomas Quinot  <quinot@adacore.com>

	* sem_ch10.adb, sem_prag.adb: Remove redundant apostrophes in error
	messages.

2012-01-23  Olivier Hainque  <hainque@adacore.com>

	* adadecode.c (__gnat_decode): Deal with empty input early,
	preventing potential erroneous memory access later on.

From-SVN: r183407

6 files changed, 140 insertions, 36 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a961439..2e90cfb 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,27 @@
+2012-01-23  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* freeze.adb (Check_Current_Instance): Issue an
+	error when the prefix of 'Unchecked_Access or 'Access does not
+	denote a legal aliased view of a type.
+	(Freeze_Record_Type): Do not halt the processing of record components
+	once the Has_Controlled_Component is set as this bypasses the remaining
+	checks.
+	(Is_Aliased_View_Of_Type): New routine.
+
+2012-01-23  Thomas Quinot  <quinot@adacore.com>
+
+	* errout.ads, freeze.adb: Minor reformatting.
+
+2012-01-23  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch10.adb, sem_prag.adb: Remove redundant apostrophes in error
+	messages.
+
+2012-01-23  Olivier Hainque  <hainque@adacore.com>
+
+	* adadecode.c (__gnat_decode): Deal with empty input early,
+	preventing potential erroneous memory access later on.
+
 2012-01-21  Eric Botcazou  <ebotcazou@adacore.com>
 
 	PR ada/46192
diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c
index 1c48856..2569481 100644
--- a/gcc/ada/adadecode.c
+++ b/gcc/ada/adadecode.c
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *           Copyright (C) 2001-2011, Free Software Foundation, Inc.        *
+ *           Copyright (C) 2001-2012, 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,7 +42,7 @@
 #include <stdio.h>
 #include <ctype.h>
 
-#include "adaint.h"
+#include "adaint.h"  /* for a macro version of xstrdup.  */
 
 #ifndef ISDIGIT
 #define ISDIGIT(c) isdigit(c)
@@ -162,8 +162,20 @@ __gnat_decode (const char *coded_name, char *ada_name, int verbose)
   int in_task = 0;
   int body_nested = 0;
 
+  /* Deal with empty input early.  This allows assuming non-null length
+     later on, simplifying coding.  In principle, it should be our callers
+     business not to call here for empty inputs.  It is easy enough to
+     allow it, however, and might allow simplifications upstream so is not
+     a bad thing per se.  We need a guard in any case.  */
+
+  if (*coded_name == '\0')
+    {
+      *ada_name = '\0';
+      return;
+    }
+
   /* Check for library level subprogram.  */
-  if (has_prefix (coded_name, "_ada_"))
+  else if (has_prefix (coded_name, "_ada_"))
     {
       strcpy (ada_name, coded_name + 5);
       lib_subprog = 1;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index ea83a8a..dc444f0 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -445,7 +445,7 @@ package Errout is
 
    Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level;
    --  Number of levels of qualification required for type name (see the
-   --  description of the } insertion character. Note that this value does
+   --  description of the } insertion character). Note that this value does
    --  note get reset by any Error_Msg call, so the caller is responsible
    --  for resetting it.
 
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 2fcd835..974e08e 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -1592,14 +1592,93 @@ package body Freeze is
 
       procedure Check_Current_Instance (Comp_Decl : Node_Id) is
 
-         Rec_Type : constant Entity_Id :=
-                      Scope (Defining_Identifier (Comp_Decl));
-
-         Decl : constant Node_Id := Parent (Rec_Type);
+         function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean;
+         --  Determine whether Typ is compatible with the rules for aliased
+         --  views of types as defined in RM 3.10 in the various dialects.
 
          function Process (N : Node_Id) return Traverse_Result;
          --  Process routine to apply check to given node
 
+         -----------------------------
+         -- Is_Aliased_View_Of_Type --
+         -----------------------------
+
+         function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is
+            Typ_Decl : constant Node_Id := Parent (Typ);
+
+         begin
+            --  Common case
+
+            if Nkind (Typ_Decl) = N_Full_Type_Declaration
+              and then Limited_Present (Type_Definition (Typ_Decl))
+            then
+               return True;
+
+            --  The following paragraphs describe what a legal aliased view of
+            --  a type is in the various dialects of Ada.
+
+            --  Ada 95
+
+            --  The current instance of a limited type, and a formal parameter
+            --  or generic formal object of a tagged type.
+
+            --  Ada 95 limited type
+            --    * Type with reserved word "limited"
+            --    * A protected or task type
+            --    * A composite type with limited component
+
+            elsif Ada_Version <= Ada_95 then
+               return Is_Limited_Type (Typ);
+
+            --  Ada 2005
+
+            --  The current instance of a limited tagged type, a protected
+            --  type, a task type, or a type that has the reserved word
+            --  "limited" in its full definition ... a formal parameter or
+            --  generic formal object of a tagged type.
+
+            --  Ada 2005 limited type
+            --    * Type with reserved word "limited", "synchronized", "task"
+            --      or "protected"
+            --    * A composite type with limited component
+            --    * A derived type whose parent is a non-interface limited type
+
+            elsif Ada_Version = Ada_2005 then
+               return
+                 (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ))
+                   or else
+                     (Is_Derived_Type (Typ)
+                       and then not Is_Interface (Etype (Typ))
+                       and then Is_Limited_Type (Etype (Typ)));
+
+            --  Ada 2012 and beyond
+
+            --  The current instance of an immutably limited type ... a formal
+            --  parameter or generic formal object of a tagged type.
+
+            --  Ada 2012 limited type
+            --    * Type with reserved word "limited", "synchronized", "task"
+            --      or "protected"
+            --    * A composite type with limited component
+            --    * A derived type whose parent is a non-interface limited type
+            --    * An incomplete view
+
+            --  Ada 2012 immutably limited type
+            --    * Explicitly limited record type
+            --    * Record extension with "limited" present
+            --    * Non-formal limited private type that is either tagged
+            --      or has at least one access discriminant with a default
+            --      expression
+            --    * Task type, protected type or synchronized interface
+            --    * Type derived from immutably limited type
+
+            else
+               return
+                 Is_Immutably_Limited_Type (Typ)
+                   or else Is_Incomplete_Type (Typ);
+            end if;
+         end Is_Aliased_View_Of_Type;
+
          -------------
          -- Process --
          -------------
@@ -1628,24 +1707,15 @@ package body Freeze is
 
          procedure Traverse is new Traverse_Proc (Process);
 
-      --  Start of processing for Check_Current_Instance
-
-      begin
-         --  In Ada 95, the (imprecise) rule is that the current instance
-         --  of a limited type is aliased. In Ada 2005, limitedness must be
-         --  explicit: either a tagged type, or a limited record.
+         --  Local variables
 
-         if Is_Limited_Type (Rec_Type)
-           and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type))
-         then
-            return;
+         Rec_Type : constant Entity_Id :=
+                      Scope (Defining_Identifier (Comp_Decl));
 
-         elsif Nkind (Decl) = N_Full_Type_Declaration
-           and then Limited_Present (Type_Definition (Decl))
-         then
-            return;
+      --  Start of processing for Check_Current_Instance
 
-         else
+      begin
+         if not Is_Aliased_View_Of_Type (Rec_Type) then
             Traverse (Comp_Decl);
          end if;
       end Check_Current_Instance;
@@ -2158,18 +2228,16 @@ package body Freeze is
                                           (Etype (Comp)))))
                then
                   Set_Has_Controlled_Component (Rec);
-                  exit;
                end if;
 
                if Has_Unchecked_Union (Etype (Comp)) then
                   Set_Has_Unchecked_Union (Rec);
                end if;
 
-               if Has_Per_Object_Constraint (Comp) then
-
-                  --  Scan component declaration for likely misuses of current
-                  --  instance, either in a constraint or a default expression.
+               --  Scan component declaration for likely misuses of current
+               --  instance, either in a constraint or a default expression.
 
+               if Has_Per_Object_Constraint (Comp) then
                   Check_Current_Instance (Parent (Comp));
                end if;
 
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 5c65ab0..4d0514d 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -3339,7 +3339,7 @@ package body Sem_Ch10 is
                   procedure License_Error is
                   begin
                      Error_Msg_N
-                       ("?license of with'ed unit & may be inconsistent",
+                       ("?license of withed unit & may be inconsistent",
                         Name (Item));
                   end License_Error;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 8ac54a5..d1e20b6 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -8256,7 +8256,7 @@ package body Sem_Prag is
 
                if Citem = N then
                   Error_Pragma_Arg
-                    ("argument of pragma% is not with'ed unit", Arg);
+                    ("argument of pragma% is not withed unit", Arg);
                end if;
 
                Next (Arg);
@@ -8334,7 +8334,7 @@ package body Sem_Prag is
                if Citem = N then
                   Set_Error_Posted (N);
                   Error_Pragma_Arg
-                    ("argument of pragma% is not with'ed unit", Arg);
+                    ("argument of pragma% is not withed unit", Arg);
                end if;
 
                Next (Arg);
@@ -14203,7 +14203,7 @@ package body Sem_Prag is
 
                   if Citem = N then
                      Error_Pragma_Arg
-                       ("argument of pragma% is not with'ed unit", Arg_Node);
+                       ("argument of pragma% is not withed unit", Arg_Node);
                   end if;
 
                   Next (Arg_Node);