[multiple changes]

2012-06-14  Robert Dewar  <dewar@adacore.com>

	* exp_ch7.adb, exp_util.adb, sem_aux.ads, exp_ch9.adb,
	sem_ch10.adb, freeze.adb, sem_util.adb, exp_ch4.adb,
	s-taprop-dummy.adb: Minor reformatting.

2012-06-14  Vincent Pucci  <pucci@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Lock_Free
	attribute case added.
	* par-prag.adb (Prag): Lock_Free pragma case added.
	* sem_attr.adb (Analyze_Attribute_Reference): Lock_Free attribute
	case added.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Record_Rep_Item
	call added for Aspect_Lock_Free.
	* sem_ch9.adb (Allows_Lock_Free_Implementation): New Lock_Free
	error messages for subprogram bodies.
	(Lock_Free_Disabled): New routine.
	(Analyze_Protected_Body): Call to Lock_Free_Disabled added.
	* sem_prag.adb (Analyze_Pragma): Lock_Free pragma case added.
	* snames.adb-tmpl (Get_Pragma_Id): Name_Lock_Free case added.
	(Is_Pragma_Name): Name_Lock_Free case added.
	* snames.ads-tmpl: Attribute_Lock_Free and Pragma_Lock_Free added.

2012-06-14  Ed Schonberg  <schonberg@adacore.com>

	* a-coorma.adb, a-cborma.adb, a-cbhama.adb, a-ciorma.adb: Add missing
	aliased keyword.

2012-06-14  Bob Duff  <duff@adacore.com>

	* lib.ads, lib.adb, sem.adb (Write_Unit_Info): Move this
	procedure from Sem body to Lib spec, so it can be used for
	debugging elsewhere.

2012-06-14  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Check_Conformance): Add Ada 2012 check on mode
	conformance: "aliased" must apply to both or neither formal
	parameters.

From-SVN: r188609

gcc/ada/ChangeLog

@@ -1,3 +1,44 @@
+2012-06-14  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch7.adb, exp_util.adb, sem_aux.ads, exp_ch9.adb,
+	sem_ch10.adb, freeze.adb, sem_util.adb, exp_ch4.adb,
+	s-taprop-dummy.adb: Minor reformatting.
+
+2012-06-14  Vincent Pucci  <pucci@adacore.com>
+
+	* exp_attr.adb (Expand_N_Attribute_Reference): Lock_Free
+	attribute case added.
+	* par-prag.adb (Prag): Lock_Free pragma case added.
+	* sem_attr.adb (Analyze_Attribute_Reference): Lock_Free attribute
+	case added.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Record_Rep_Item
+	call added for Aspect_Lock_Free.
+	* sem_ch9.adb (Allows_Lock_Free_Implementation): New Lock_Free
+	error messages for subprogram bodies.
+	(Lock_Free_Disabled): New routine.
+	(Analyze_Protected_Body): Call to Lock_Free_Disabled added.
+	* sem_prag.adb (Analyze_Pragma): Lock_Free pragma case added.
+	* snames.adb-tmpl (Get_Pragma_Id): Name_Lock_Free case added.
+	(Is_Pragma_Name): Name_Lock_Free case added.
+	* snames.ads-tmpl: Attribute_Lock_Free and Pragma_Lock_Free added.
+
+2012-06-14  Ed Schonberg  <schonberg@adacore.com>
+
+	* a-coorma.adb, a-cborma.adb, a-cbhama.adb, a-ciorma.adb: Add missing
+	aliased keyword.
+
+2012-06-14  Bob Duff  <duff@adacore.com>
+
+	* lib.ads, lib.adb, sem.adb (Write_Unit_Info): Move this
+	procedure from Sem body to Lib spec, so it can be used for
+	debugging elsewhere.
+
+2012-06-14  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb (Check_Conformance): Add Ada 2012 check on mode
+	conformance: "aliased" must apply to both or neither formal
+	parameters.
+
 2012-06-14  Gary Dismukes  <dismukes@adacore.com>
 
 	* exp_ch9.adb: Minor reformatting.

gcc/ada/a-cbhama.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-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- --
@@ -220,7 +220,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
    end Constant_Reference;
 
    function Constant_Reference
-     (Container : Map;
+     (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type
    is
       Node : constant Count_Type := Key_Ops.Find (Container, Key);

gcc/ada/a-cborma.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-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- --
@@ -432,7 +432,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
    end Constant_Reference;
 
    function Constant_Reference
-     (Container : Map;
+     (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type
    is
       Node : constant Count_Type := Key_Ops.Find (Container, Key);

gcc/ada/a-ciorma.adb

@@ -410,7 +410,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
    end Constant_Reference;
 
    function Constant_Reference
-     (Container : Map;
+     (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type
    is
       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);

gcc/ada/a-coorma.adb

@@ -370,7 +370,7 @@ package body Ada.Containers.Ordered_Maps is
    end Constant_Reference;
 
    function Constant_Reference
-     (Container : Map;
+     (Container : aliased Map;
       Key       : Key_Type) return Constant_Reference_Type
    is
       Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);

gcc/ada/exp_attr.adb

@@ -3065,6 +3065,29 @@ package body Exp_Attr is
          end if;
       end;
 
+      ---------------
+      -- Lock_Free --
+      ---------------
+
+      --  Rewrite the attribute reference with the value of Uses_Lock_Free
+
+      when Attribute_Lock_Free => Lock_Free : declare
+         Val : Entity_Id;
+
+      begin
+         if Uses_Lock_Free (Ptyp) then
+            Val := Standard_True;
+
+         else
+            Val := Standard_False;
+         end if;
+
+         Rewrite (N,
+           New_Occurrence_Of (Val, Loc));
+
+         Analyze_And_Resolve (N, Standard_Boolean);
+      end Lock_Free;
+
       -------------
       -- Machine --
       -------------

gcc/ada/exp_ch4.adb

@@ -4277,8 +4277,7 @@ package body Exp_Ch4 is
       --  is a finalization flag created to service expression Expr.
 
       function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean;
-      --  Determine whether an expression is a rewritten controlled function
+      --  Determine if expression Expr is a rewritten controlled function call
-      --  call.
 
       ------------------------
       -- Create_Alternative --
@@ -4431,7 +4430,8 @@ package body Exp_Ch4 is
             --  handling.
 
             if Is_Controlled_Function_Call (Thenx)
-              or else Is_Controlled_Function_Call (Elsex)
+                 or else
+               Is_Controlled_Function_Call (Elsex)
             then
                Flag_Id := Make_Temporary (Loc, 'F');
 

gcc/ada/exp_ch7.adb

@@ -1892,14 +1892,13 @@ package body Exp_Ch7 is
                then
                   Processing_Actions (Has_No_Init => True);
 
-               --  Processing for intermediate results of conditional
+               --  Process intermediate results of conditional expression with
-               --  expressions where one of the alternatives uses a controlled
+               --  one of the alternatives using a controlled function call.
-               --  function call.
 
                elsif Is_Access_Type (Obj_Typ)
                  and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
                  and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
-                            N_Defining_Identifier
+                                                       N_Defining_Identifier
                  and then Present (Expr)
                  and then Nkind (Expr) = N_Null
                then
@@ -2728,7 +2727,7 @@ package body Exp_Ch7 is
                --    end if;
 
                if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
-                    N_Object_Declaration
+                                                      N_Object_Declaration
                then
                   Fin_Stmts := New_List (
                     Make_If_Statement (Loc,
@@ -2736,12 +2735,11 @@ package body Exp_Ch7 is
                         Make_Op_Ne (Loc,
                           Left_Opnd  => New_Reference_To (Obj_Id, Loc),
                           Right_Opnd => Make_Null (Loc)),
-
                       Then_Statements => Fin_Stmts));
 
-               --  Return objects use a flag to aid their potential
+               --  Return objects use a flag to aid in processing their
-               --  finalization when the enclosing function fails to return
+               --  potential finalization when the enclosing function fails
-               --  properly. Generate:
+               --  to return properly. Generate:
 
                --    if not Flag then
                --       <object finalization statements>

gcc/ada/exp_ch9.adb

@@ -13342,7 +13342,7 @@ package body Exp_Ch9 is
          --  or attribute definition clause, or there is an Interrupt_Priority
          --  rep item and no Priority rep item, and we set the ceiling to
          --  Interrupt_Priority'Last, an implementation-defined value, see
-         --  D.3(10).
+         --  (RM D.3(10)).
 
          if Has_Rep_Item (Ptyp, Name_Priority) then
             declare

gcc/ada/exp_util.adb

@@ -7181,7 +7181,7 @@ package body Exp_Util is
             elsif Is_Access_Type (Obj_Typ)
               and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
               and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
-                         N_Object_Declaration
+                                                      N_Object_Declaration
               and then Is_Finalizable_Transient
                          (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
             then

gcc/ada/freeze.adb

@@ -2168,8 +2168,7 @@ package body Freeze is
 
          --  Deal with Bit_Order aspect specifying a non-default bit order
 
-         ADC :=
+         ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
-           Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
 
          if Present (ADC) and then Base_Type (Rec) = Rec then
             if not Placed_Component then
@@ -2180,7 +2179,7 @@ package body Freeze is
             --  Here is where we do the processing for reversed bit order
 
             elsif Reverse_Bit_Order (Rec)
-                    and then not Reverse_Storage_Order (Rec)
+              and then not Reverse_Storage_Order (Rec)
             then
                Adjust_Record_For_Reverse_Bit_Order (Rec);
 

gcc/ada/lib.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- --
@@ -37,6 +37,7 @@ with Atree;    use Atree;
 with Csets;    use Csets;
 with Einfo;    use Einfo;
 with Fname;    use Fname;
+with Nlists;   use Nlists;
 with Output;   use Output;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
@@ -1155,4 +1156,82 @@ package body Lib is
       Version_Ref.Append (S);
    end Version_Referenced;
 
+   ---------------------
+   -- Write_Unit_Info --
+   ---------------------
+
+   procedure Write_Unit_Info
+     (Unit_Num : Unit_Number_Type;
+      Item     : Node_Id;
+      Prefix   : String := "";
+      Withs    : Boolean := False)
+   is
+   begin
+      Write_Str (Prefix);
+      Write_Unit_Name (Unit_Name (Unit_Num));
+      Write_Str (", unit ");
+      Write_Int (Int (Unit_Num));
+      Write_Str (", ");
+      Write_Int (Int (Item));
+      Write_Str ("=");
+      Write_Str (Node_Kind'Image (Nkind (Item)));
+
+      if Item /= Original_Node (Item) then
+         Write_Str (", orig = ");
+         Write_Int (Int (Original_Node (Item)));
+         Write_Str ("=");
+         Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
+      end if;
+
+      Write_Eol;
+
+      --  Skip the rest if we're not supposed to print the withs
+
+      if not Withs then
+         return;
+      end if;
+
+      declare
+         Context_Item : Node_Id;
+
+      begin
+         Context_Item := First (Context_Items (Cunit (Unit_Num)));
+         while Present (Context_Item)
+           and then (Nkind (Context_Item) /= N_With_Clause
+                      or else Limited_Present (Context_Item))
+         loop
+            Context_Item := Next (Context_Item);
+         end loop;
+
+         if Present (Context_Item) then
+            Indent;
+            Write_Line ("withs:");
+            Indent;
+
+            while Present (Context_Item) loop
+               if Nkind (Context_Item) = N_With_Clause
+                 and then not Limited_Present (Context_Item)
+               then
+                  pragma Assert (Present (Library_Unit (Context_Item)));
+                  Write_Unit_Name
+                    (Unit_Name
+                       (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
+
+                  if Implicit_With (Context_Item) then
+                     Write_Str (" -- implicit");
+                  end if;
+
+                  Write_Eol;
+               end if;
+
+               Context_Item := Next (Context_Item);
+            end loop;
+
+            Outdent;
+            Write_Line ("end withs");
+            Outdent;
+         end if;
+      end;
+   end Write_Unit_Info;
+
 end Lib;

gcc/ada/lib.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- --
@@ -673,6 +673,15 @@ package Lib is
    --  that file not being compiled. The predicate Generic_May_Lack_ALI is
    --  True for those generic units for which missing ALI files are allowed.
 
+   procedure Write_Unit_Info
+     (Unit_Num : Unit_Number_Type;
+      Item     : Node_Id;
+      Prefix   : String := "";
+      Withs    : Boolean := False);
+   --  Print out debugging information about the unit. Prefix precedes the rest
+   --  of the printout. If Withs is True, we print out units with'ed by this
+   --  unit (not counting limited withs).
+
 private
    pragma Inline (Cunit);
    pragma Inline (Cunit_Entity);

gcc/ada/par-prag.adb

@@ -1183,6 +1183,7 @@ begin
            Pragma_Linker_Destructor              |
            Pragma_Linker_Options                 |
            Pragma_Linker_Section                 |
+           Pragma_Lock_Free                      |
            Pragma_Locking_Policy                 |
            Pragma_Long_Float                     |
            Pragma_Machine_Attribute              |

gcc/ada/s-taprop-dummy.adb

@@ -46,27 +46,30 @@ package body System.Task_Primitives.Operations is
    pragma Warnings (Off);
    --  Turn off warnings since so many unreferenced parameters
 
-   --------------------
+   --------------
-   -- Local Packages --
+   -- Specific --
-   --------------------
+   --------------
+
+   --  Package Specific contains target specific routines, and the body of
+   --  this package is target specific.
 
    package Specific is
-
       procedure Set (Self_Id : Task_Id);
       pragma Inline (Set);
       --  Set the self id for the current task
-
    end Specific;
 
    package body Specific is
 
+      ---------
+      -- Set --
+      ---------
+
       procedure Set (Self_Id : Task_Id) is
       begin
          null;
       end Set;
-
    end Specific;
-   --  The body of this package is target specific
 
    ----------------------------------
    -- ATCB allocation/deallocation --

gcc/ada/sem.adb

@@ -91,15 +91,6 @@ package body Sem is
    --  of this unit, since they count as dependences on their parent library
    --  item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
 
-   procedure Write_Unit_Info
-     (Unit_Num : Unit_Number_Type;
-      Item     : Node_Id;
-      Prefix   : String := "";
-      Withs    : Boolean := False);
-   --  Print out debugging information about the unit. Prefix precedes the rest
-   --  of the printout. If Withs is True, we print out units with'ed by this
-   --  unit (not counting limited withs).
-
    -------------
    -- Analyze --
    -------------
@@ -2290,82 +2281,4 @@ package body Sem is
       end loop;
    end Walk_Withs_Immediate;
 
-   ---------------------
-   -- Write_Unit_Info --
-   ---------------------
-
-   procedure Write_Unit_Info
-     (Unit_Num : Unit_Number_Type;
-      Item     : Node_Id;
-      Prefix   : String := "";
-      Withs    : Boolean := False)
-   is
-   begin
-      Write_Str (Prefix);
-      Write_Unit_Name (Unit_Name (Unit_Num));
-      Write_Str (", unit ");
-      Write_Int (Int (Unit_Num));
-      Write_Str (", ");
-      Write_Int (Int (Item));
-      Write_Str ("=");
-      Write_Str (Node_Kind'Image (Nkind (Item)));
-
-      if Item /= Original_Node (Item) then
-         Write_Str (", orig = ");
-         Write_Int (Int (Original_Node (Item)));
-         Write_Str ("=");
-         Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
-      end if;
-
-      Write_Eol;
-
-      --  Skip the rest if we're not supposed to print the withs
-
-      if not Withs then
-         return;
-      end if;
-
-      declare
-         Context_Item : Node_Id;
-
-      begin
-         Context_Item := First (Context_Items (Cunit (Unit_Num)));
-         while Present (Context_Item)
-           and then (Nkind (Context_Item) /= N_With_Clause
-                      or else Limited_Present (Context_Item))
-         loop
-            Context_Item := Next (Context_Item);
-         end loop;
-
-         if Present (Context_Item) then
-            Indent;
-            Write_Line ("withs:");
-            Indent;
-
-            while Present (Context_Item) loop
-               if Nkind (Context_Item) = N_With_Clause
-                 and then not Limited_Present (Context_Item)
-               then
-                  pragma Assert (Present (Library_Unit (Context_Item)));
-                  Write_Unit_Name
-                    (Unit_Name
-                       (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
-
-                  if Implicit_With (Context_Item) then
-                     Write_Str (" -- implicit");
-                  end if;
-
-                  Write_Eol;
-               end if;
-
-               Context_Item := Next (Context_Item);
-            end loop;
-
-            Outdent;
-            Write_Line ("end withs");
-            Outdent;
-         end if;
-      end;
-   end Write_Unit_Info;
-
 end Sem;

gcc/ada/sem_attr.adb

@@ -3569,6 +3569,19 @@ package body Sem_Attr is
          Check_Array_Type;
          Set_Etype (N, Universal_Integer);
 
+      ---------------
+      -- Lock_Free --
+      ---------------
+
+      when Attribute_Lock_Free =>
+         Check_E0;
+         Set_Etype (N, Standard_Boolean);
+
+         if not Is_Protected_Type (P_Type) then
+            Error_Attr_P
+              ("prefix of % attribute must be a protected object");
+         end if;
+
       -------------
       -- Machine --
       -------------
@@ -6767,6 +6780,15 @@ package body Sem_Attr is
               True);
          end if;
 
+      ---------------
+      -- Lock_Free --
+      ---------------
+
+      --  Lock_Free attribute is a Boolean, thus no need to fold here.
+
+      when Attribute_Lock_Free =>
+         null;
+
       ----------
       -- Last --
       ----------

gcc/ada/sem_aux.ads

@@ -163,7 +163,7 @@ package Sem_Aux is
    --  Searches the Rep_Item chain for a given entity E, for an instance of a
    --  rep item (pragma, attribute definition clause, or aspect specification)
    --  whose name matches the given name Nam. If Check_Parents is False then it
-   --  only returns rep item that has been directly specified to E (and not
+   --  only returns rep item that has been directly specified for E (and not
    --  inherited from its parents, if any). If one is found, it is returned,
    --  otherwise Empty is returned. A special case is that when Nam is
    --  Name_Priority, the call will also find Interrupt_Priority.
@@ -172,11 +172,11 @@ package Sem_Aux is
      (E             : Entity_Id;
       Nam           : Name_Id;
       Check_Parents : Boolean := True) return Node_Id;
-   --  Searches the Rep_Item chain for a given entity E, for an instance of a
+   --  Searches the Rep_Item chain for a given entity E, for an instance
-   --  representation pragma whose name matches the given name Nam. If
+   --  of a representation pragma whose name matches the given name Nam. If
    --  Check_Parents is False then it only returns representation pragma that
-   --  has been directly specified to E (and not inherited from its parents, if
+   --  has been directly specified for E (and not inherited from its parents,
-   --  any). If one is found, it is returned, otherwise Empty is returned. A
+   --  if any). If one is found, it is returned, otherwise Empty is returned. A
    --  special case is that when Nam is Name_Priority, the call will also find
    --  Interrupt_Priority.
 
@@ -186,10 +186,10 @@ package Sem_Aux is
       Check_Parents : Boolean := True) return Boolean;
    --  Searches the Rep_Item chain for the given entity E, for an instance of a
    --  rep item (pragma, attribute definition clause, or aspect specification)
-   --  with the given name Nam. If Check_Parents is False then it only returns
+   --  with the given name Nam. If Check_Parents is False then it only checks
-   --  rep item that has been directly specified to E (and not inherited from
+   --  for a rep item that has been directly specified for E (and not inherited
-   --  its parents, if any). If found then True is returned, otherwise False
+   --  from its parents, if any). If found then True is returned, otherwise
-   --  indicates that no matching entry was found.
+   --  False indicates that no matching entry was found.
 
    function Has_Rep_Pragma
      (E             : Entity_Id;
@@ -197,8 +197,8 @@ package Sem_Aux is
       Check_Parents : Boolean := True) return Boolean;
    --  Searches the Rep_Item chain for the given entity E, for an instance of a
    --  representation pragma with the given name Nam. If Check_Parents is False
-   --  then it only returns representation pragma that has been directly
+   --  then it only checks for a representation pragma that has been directly
-   --  specified to E (and not inherited from its parents, if any). If found
+   --  specified for E (and not inherited from its parents, if any). If found
    --  then True is returned, otherwise False indicates that no matching entry
    --  was found.
 

gcc/ada/sem_ch10.adb

@@ -1261,7 +1261,6 @@ package body Sem_Ch10 is
         and then Warn_On_Obsolescent_Feature
         and then Nkind (Unit_Node) not in N_Generic_Instantiation
       then
-
          --  Push current compilation unit as scope, so that the test for
          --  being within an obsolescent unit will work correctly. The check
          --  is not performed within an instantiation, because the warning

gcc/ada/sem_ch13.adb

@@ -1445,6 +1445,8 @@ package body Sem_Ch13 is
                         then
                            Set_Uses_Lock_Free (E);
                         end if;
+
+                        Record_Rep_Item (E, Aspect);
                      end if;
 
                      goto Continue;

gcc/ada/sem_ch6.adb

@@ -5503,6 +5503,18 @@ package body Sem_Ch6 is
             end if;
          end if;
 
+         --  Ada 2012:  mode conformance also requires that formal parameters
+         --  be both aliased, or neither.
+
+         if Ctype >= Mode_Conformant
+           and then Ada_Version >= Ada_2012
+         then
+            if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then
+               Conformance_Error
+                 ("\aliased parameter mismatch!", New_Formal);
+            end if;
+         end if;
+
          if Ctype = Fully_Conformant then
 
             --  Names must match. Error message is more accurate if we do

gcc/ada/sem_ch9.adb

@@ -23,7 +23,6 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Debug;    use Debug;
@@ -263,16 +262,41 @@ package body Sem_Ch9 is
                begin
                   --  Function calls and attribute references must be static
 
-                  if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
+                  if Nkind (N) = N_Attribute_Reference
                     and then not Is_Static_Expression (N)
                   then
+                     if Complain then
+                        Error_Msg_N
+                          ("non-static attribute reference not allowed",
+                           N);
+                     end if;
+
+                     return Abandon;
+
+                  elsif Nkind (N) = N_Function_Call
+                    and then not Is_Static_Expression (N)
+                  then
+                     if Complain then
+                        Error_Msg_N ("non-static function call not allowed",
+                                     N);
+                     end if;
+
                      return Abandon;
 
                   --  Loop statements and procedure calls are prohibited
 
-                  elsif Nkind_In (N, N_Loop_Statement,
+                  elsif Nkind (N) = N_Loop_Statement then
-                                     N_Procedure_Call_Statement)
+                     if Complain then
-                  then
+                        Error_Msg_N ("loop not allowed", N);
+                     end if;
+
+                     return Abandon;
+
+                  elsif Nkind (N) = N_Procedure_Call_Statement then
+                     if Complain then
+                        Error_Msg_N ("procedure call not allowed", N);
+                     end if;
+
                      return Abandon;
 
                   --  References
@@ -295,6 +319,12 @@ package body Sem_Ch9 is
                           and then not Scope_Within_Or_Same (Scope (Id),
                                          Protected_Body_Subprogram (Sub_Id))
                         then
+                           if Complain then
+                              Error_Msg_NE
+                                ("reference to global variable& not allowed",
+                                 N, Id);
+                           end if;
+
                            return Abandon;
 
                         --  Prohibit non-scalar out parameters (scalar
@@ -305,6 +335,12 @@ package body Sem_Ch9 is
                           and then not Is_Elementary_Type (Etype (Id))
                           and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
                         then
+                           if Complain then
+                              Error_Msg_NE
+                                ("non-elementary out parameter& not allowed",
+                                 N, Id);
+                           end if;
+
                            return Abandon;
 
                         --  A protected subprogram may reference only one
@@ -327,6 +363,13 @@ package body Sem_Ch9 is
                                  --  body.
 
                                  elsif Comp /= Id then
+                                    if Complain then
+                                       Error_Msg_N
+                                         ("only one protected component " &
+                                          "allowed",
+                                          N);
+                                    end if;
+
                                     return Abandon;
                                  end if;
                               end if;
@@ -352,6 +395,13 @@ package body Sem_Ch9 is
                                  --  body.
 
                                  elsif Comp /= Prival_Link (Id) then
+                                    if Complain then
+                                       Error_Msg_N
+                                         ("only one protected component " &
+                                          "allowed",
+                                          N);
+                                    end if;
+
                                     return Abandon;
                                  end if;
                               end if;
@@ -1375,7 +1425,6 @@ package body Sem_Ch9 is
 
    procedure Analyze_Protected_Body (N : Node_Id) is
       Body_Id : constant Entity_Id := Defining_Identifier (N);
-      Aspect  : Node_Id;
       Last_E  : Entity_Id;
 
       Spec_Id : Entity_Id;
@@ -1390,6 +1439,50 @@ package body Sem_Ch9 is
       --  differs from Spec_Id in the case of a single protected object, since
       --  Spec_Id is set to the protected type in this case).
 
+      function Lock_Free_Disabled return Boolean;
+      --  This routine returns False if the protected object has a Lock_Free
+      --  aspect specification or a Lock_Free pragma that turns off the
+      --  lock-free implementation (e.g. whose expression is False).
+
+      ------------------------
+      -- Lock_Free_Disabled --
+      ------------------------
+
+      function Lock_Free_Disabled return Boolean is
+         Ritem : constant Node_Id :=
+                   Get_Rep_Item
+                     (Spec_Id, Name_Lock_Free, Check_Parents => False);
+
+      begin
+         if Present (Ritem) then
+            --  Pragma with one argument
+
+            if Nkind (Ritem) = N_Pragma
+              and then Present (Pragma_Argument_Associations (Ritem))
+            then
+               return
+                 Is_False (Static_Boolean
+                  (Expression (First (Pragma_Argument_Associations (Ritem)))));
+
+            --  Aspect Specification with expression present
+
+            elsif Nkind (Ritem) = N_Aspect_Specification
+              and then Present (Expression (Ritem))
+            then
+               return Is_False (Static_Boolean (Expression (Ritem)));
+
+            --  Otherwise, return False
+
+            else
+               return False;
+            end if;
+         end if;
+
+         return False;
+      end Lock_Free_Disabled;
+
+   --  Start of processing for Analyze_Protected_Body
+
    begin
       Tasking_Used := True;
       Set_Ekind (Body_Id, E_Protected_Body);
@@ -1450,37 +1543,21 @@ package body Sem_Ch9 is
       Process_End_Label (N, 't', Ref_Id);
       End_Scope;
 
-      --  Turn on/off the lock-free implementation for the protected object
+      --  When a Lock_Free aspect specification/pragma forces the lock-free
-
+      --  implementation, verify the protected body meets all the restrictions,
-      --  Look for a Lock_Free aspect with a False expression that disables the
+      --  otherwise Allows_Lock_Free_Implementation issues an error message.
-      --  lock-free implementation.
-
-      Aspect := First (Aspect_Specifications (Parent (Spec_Id)));
-
-      while Present (Aspect) loop
-         if Get_Aspect_Id (Chars (Identifier (Aspect))) = Aspect_Lock_Free
-           and then Present (Expression (Aspect))
-           and then Entity (Expression (Aspect)) = Standard_False
-         then
-            return;
-         end if;
-
-         Next (Aspect);
-      end loop;
-
-      --  When a Lock_Free aspect forces the lock-free implementation, verify
-      --  the protected body meets all the restrictions, otherwise
-      --  Allows_Lock_Free_Implementation issues an error message.
 
       if Uses_Lock_Free (Spec_Id) then
          if not Allows_Lock_Free_Implementation (N, Complain => True) then
             return;
          end if;
 
-      --  In other cases, check both the protected declaration and body satisfy
+      --  In other cases, if there is no aspect specification/pragma that
-      --  the lock-free restrictions.
+      --  disables the lock-free implementation, check both the protected
+      --  declaration and body satisfy the lock-free restrictions.
 
-      elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
+      elsif not Lock_Free_Disabled
+        and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
         and then Allows_Lock_Free_Implementation (N)
       then
          Set_Uses_Lock_Free (Spec_Id);

gcc/ada/sem_prag.adb

@@ -11118,6 +11118,54 @@ package body Sem_Prag is
          when Pragma_List =>
             null;
 
+         ---------------
+         -- Lock_Free --
+         ---------------
+
+         --  pragma Lock_Free [(Boolean_EXPRESSION)];
+
+         when Pragma_Lock_Free => Lock_Free : declare
+            P   : constant Node_Id := Parent (N);
+            Arg : Node_Id;
+            Ent : Entity_Id;
+            Val : Boolean;
+
+         begin
+            Check_No_Identifiers;
+            Check_At_Most_N_Arguments (1);
+
+            --  Protected definition case
+
+            if Nkind (P) = N_Protected_Definition then
+               Ent := Defining_Identifier (Parent (P));
+
+               --  One argument
+
+               if Arg_Count = 1 then
+                  Arg := Get_Pragma_Arg (Arg1);
+                  Val := Is_True (Static_Boolean (Arg));
+
+               --  Zero argument. In this case the expression is considered to
+               --  be True.
+
+               else
+                  Val := True;
+               end if;
+
+               --  Check duplicate pragma before we chain the pragma in the Rep
+               --  Item chain of Ent.
+
+               Check_Duplicate_Pragma (Ent);
+               Record_Rep_Item        (Ent, N);
+               Set_Uses_Lock_Free     (Ent, Val);
+
+            --  Anything else is incorrect
+
+            else
+               Pragma_Misplaced;
+            end if;
+         end Lock_Free;
+
          --------------------
          -- Locking_Policy --
          --------------------
@@ -15212,6 +15260,7 @@ package body Sem_Prag is
       Pragma_Linker_Options                 => -1,
       Pragma_Linker_Section                 => -1,
       Pragma_List                           => -1,
+      Pragma_Lock_Free                      => -1,
       Pragma_Locking_Policy                 => -1,
       Pragma_Long_Float                     => -1,
       Pragma_Machine_Attribute              => -1,

gcc/ada/sem_util.adb

@@ -7745,14 +7745,13 @@ package body Sem_Util is
             when N_String_Literal =>
                return Is_Internally_Generated_Renaming (Parent (N));
 
-            --  AI05-0003:  in Ada 2012, a qualified expression is a name.
+            --  AI05-0003: In Ada 2012 a qualified expression is a name.
-            --  This allows disambiguation of function calls and the use of
+            --  This allows disambiguation of function calls and the use
-            --  aggregates in more contexts.
+            --  of aggregates in more contexts.
 
             when N_Qualified_Expression =>
                if Ada_Version <  Ada_2012 then
                   return False;
-
                else
                   return Is_Object_Reference (Expression (N))
                     or else Nkind (Expression (N)) = N_Aggregate;

gcc/ada/snames.adb-tmpl

@@ -219,6 +219,8 @@ package body Snames is
          return Pragma_Interface;
       elsif N = Name_Interrupt_Priority then
          return Pragma_Interrupt_Priority;
+      elsif N = Name_Lock_Free then
+         return Pragma_Lock_Free;
       elsif N = Name_Priority then
          return Pragma_Priority;
       elsif N = Name_Relative_Deadline then
@@ -421,6 +423,7 @@ package body Snames is
         or else N = Name_Fast_Math
         or else N = Name_Interface
         or else N = Name_Interrupt_Priority
+        or else N = Name_Lock_Free
         or else N = Name_Relative_Deadline
         or else N = Name_Priority
         or else N = Name_Storage_Size

gcc/ada/snames.ads-tmpl

@@ -142,7 +142,6 @@ package Snames is
    Name_Dimension                      : constant Name_Id := N + $;
    Name_Dimension_System               : constant Name_Id := N + $;
    Name_Dynamic_Predicate              : constant Name_Id := N + $;
-   Name_Lock_Free                      : constant Name_Id := N + $;
    Name_Post                           : constant Name_Id := N + $;
    Name_Pre                            : constant Name_Id := N + $;
    Name_Static_Predicate               : constant Name_Id := N + $;
@@ -522,6 +521,12 @@ package Snames is
    Name_Linker_Options                 : constant Name_Id := N + $;
    Name_Linker_Section                 : constant Name_Id := N + $; -- GNAT
    Name_List                           : constant Name_Id := N + $;
+
+   --  Note: Lock_Free is not in this list because its name matches the name of
+   --  the corresponding attribute. However, it is included in the definition
+   --  of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id
+   --  correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma.
+
    Name_Machine_Attribute              : constant Name_Id := N + $; -- GNAT
    Name_Main                           : constant Name_Id := N + $; -- GNAT
    Name_Main_Storage                   : constant Name_Id := N + $; -- GNAT
@@ -810,6 +815,7 @@ package Snames is
    Name_Last_Valid                     : constant Name_Id := N + $; -- Ada 12
    Name_Leading_Part                   : constant Name_Id := N + $;
    Name_Length                         : constant Name_Id := N + $;
+   Name_Lock_Free                      : constant Name_Id := N + $; -- GNAT
    Name_Machine_Emax                   : constant Name_Id := N + $;
    Name_Machine_Emin                   : constant Name_Id := N + $;
    Name_Machine_Mantissa               : constant Name_Id := N + $;
@@ -1388,6 +1394,7 @@ package Snames is
       Attribute_Last_Valid,
       Attribute_Leading_Part,
       Attribute_Length,
+      Attribute_Lock_Free,
       Attribute_Machine_Emax,
       Attribute_Machine_Emin,
       Attribute_Machine_Mantissa,
@@ -1774,6 +1781,7 @@ package Snames is
       Pragma_Fast_Math,
       Pragma_Interface,
       Pragma_Interrupt_Priority,
+      Pragma_Lock_Free,
       Pragma_Priority,
       Pragma_Storage_Size,
       Pragma_Storage_Unit,
@@ -1853,8 +1861,8 @@ package Snames is
    function Is_Pragma_Name (N : Name_Id) return Boolean;
    --  Test to see if the name N is the name of a recognized pragma. Note that
    --  pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math,
-   --  Interrupt_Priority, Priority, Storage_Size, and Storage_Unit are
+   --  Interrupt_Priority, Lock_Free, Priority, Storage_Size, and Storage_Unit
-   --  recognized as pragmas by this function even though their names are
+   --  are recognized as pragmas by this function even though their names are
    --  separate from the other pragma names. For this reason, clients should
    --  always use this function, rather than do range tests on Name_Id values.
 
@@ -1895,8 +1903,9 @@ package Snames is
    --  if N is not a name of a known (Ada defined or GNAT-specific) pragma.
    --  Note that the function also works correctly for names of pragmas that
    --  are not included in the main list of pragma Names (AST_Entry, CPU,
-   --  Dispatching_Domain, Interrupt_Priority, Priority, Storage_Size, and
+   --  Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority,
-   --  Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
+   --  Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
+   --  Pragma_Storage_Size).
 
    function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
    --  Returns Id of queuing policy corresponding to given name. It is an error