[Ada] Ada 2012 accessibility of anonymous access stand-alone objects

This set of changes implements support for AI05-0148, the Ada2012
rules concerting the accessibility of a stand-alone object of an
anonymous access type (hereafter, a "saooaaat").

The Extra_Accessibility attribute was previously only used for a
formal parameter of an anonymous access type. The use of this
attribute is generalized so that this attribute is set for any
Ada-2012 saooaaat which is not declared at library level.

In this case, an object containing the current accessibility
level of the saooaaat is also declared. The Extra_Accessibility
attribute of the saooaaat refers to this object and the
Is_Local_Anonymous_Access attribute is set to False for the
anonymous access type.

When the object is updated (either by an assignment statement or by
parameter copy-back), the associated Extra_Accessibility object is
also updated. An accessibility check is generated to ensure that the
new value is not greater than the (static) accessibility level of
the saooaaat.

When the dynamic accessibility level of the anonymous access type is
needed, the value of the Extra_Accessibility object is used.

The two attributes RM_Size (defined on types) and Extra_Accessibility
(defined on objects) share storage, so it is now more important to
avoid accessing the RM_Size attribute of an object.

The following tests are intended to test these changes.
The first (AI05_0148_Test1) should execute without
producing output; any exceptions raised should be handled
within the program. The second (AI05_0148_Test2) should fail to
compile and the lines ending in "-- illegal" comments should
be flagged as containing errors.

	  procedure AI05_0148_Test1 is

	    subtype Designated is Integer;

	    procedure Assert (Condition : Boolean) is
	        Test_Failed : exception;
	    begin
	        if not Condition then
	            raise Test_Failed;
	        end if;
	    end Assert;

	    Aaa, Bbb : aliased Designated := 123;

	    Ptr1 : access Designated := Aaa'Access;

	    type Named1 is access all Designated;
	    for Named1'Storage_Size use 0;

	    procedure Test_Assignment is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	    begin
	        for Exception_Expected in Boolean loop
	            begin
	                Ptr1 := Ptr2;
	                Assert (not Exception_Expected);
	            exception
	                when Program_Error =>
	                    Assert (Exception_Expected);
	            end;
	            Ptr2 := Ccc'Access;
	        end loop;
	        Assert (Ptr1 = Bbb'Access);
	        Ptr1 := Aaa'Access;
	    end Test_Assignment;

	    procedure Test_Rename_Assignment is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	    begin
	        for Exception_Expected in Boolean loop
	            declare
	                Intermediate_1 : access Designated renames Ptr1;
	                Ptr1_Ren : access Designated renames Intermediate_1;
	                Intermediate_2 : access Designated renames Ptr2;
	                Ptr2_Ren : access Designated renames Intermediate_2;
	            begin
	                Ptr1_Ren := Ptr2_Ren;
	                Assert (not Exception_Expected);
	            exception
	                when Program_Error =>
	                    Assert (Exception_Expected);
	            end;
	            Ptr2 := Ccc'Access;
	        end loop;
	        Assert (Ptr1 = Bbb'Access);
	        Ptr1 := Aaa'Access;
	    end Test_Rename_Assignment;

	    procedure Test_Copy_Back is
	        type Named2 is access all Designated;
	        for Named2'Storage_Size use 0;

	        Ptr2 : access Designated;

	        procedure Assign1 (Lhs1 : out Named1; Rhs1 : Named1) is
	        begin
	            Lhs1 := Rhs1;
	        end Assign1;

	        procedure Assign2 (Lhs2 : out Named2; Rhs2 : Named2) is
	        begin
	            Lhs2 := Rhs2;
	        end Assign2;
	    begin
	        Assign1 (Named1 (Ptr2), Bbb'Access);
	        for Exception_Expected in Boolean loop
	            begin
	                Ptr1 := Ptr2;
	                Assert (not Exception_Expected);
	            exception
	                when Program_Error =>
	                    Assert (Exception_Expected);
	            end;
	            Assign2 (Named2 (Ptr2), Aaa'Access);
	        end loop;
	        Assert (Ptr1 = Bbb'Access);
	        Ptr1 := Aaa'Access;
	    end Test_Copy_Back;

	    procedure Test_Rename_Copy_Back is
	        type Named2 is access all Designated;
	        for Named2'Storage_Size use 0;

	        Ptr2 : access Designated;

	        procedure Assign1 (Lhs1 : out Named1; Rhs1 : Named1) is
	        begin
	            Lhs1 := Rhs1;
	        end Assign1;

	        procedure Assign2 (Lhs2 : out Named2; Rhs2 : Named2) is
	        begin
	            Lhs2 := Rhs2;
	        end Assign2;
	    begin
	        declare
	            Intermediate_1 : access Designated renames Ptr1;
	            Ptr1_Ren : access Designated renames Intermediate_1;
	            Intermediate_2 : access Designated renames Ptr2;
	            Ptr2_Ren : access Designated renames Intermediate_2;
	        begin
	            Assign1 (Named1 (Ptr2_Ren), Bbb'Access);
	            for Exception_Expected in Boolean loop
	                begin
	                    Ptr1_Ren := Ptr2_Ren;
	                    Assert (not Exception_Expected);
	                exception
	                    when Program_Error =>
	                        Assert (Exception_Expected);
	                end;
	                Assign2 (Named2 (Ptr2_Ren), Aaa'Access);
	            end loop;
	            Assert (Ptr1_Ren = Bbb'Access);
	            Ptr1_Ren := Aaa'Access;
	        end;
	    end Test_Rename_Copy_Back;

	    procedure Test_Access_Params is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;

	        procedure Update_Ptr1 (Aap : access Designated) is
	        begin
	            Ptr1 := Aap;
	        end Update_Ptr1;
	    begin
	        for Exception_Expected in Boolean loop
	            begin
	                Update_Ptr1 (Ptr2);
	                Assert (not Exception_Expected);
	            exception
	                when Program_Error =>
	                    Assert (Exception_Expected);
	            end;
	            Ptr2 := Ccc'Access;
	        end loop;
	        Assert (Ptr1 = Bbb'Access);
	        Ptr1 := Aaa'Access;
	    end Test_Access_Params;

	    procedure Test_Rename_Access_Params is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	    begin
	        declare
	            Intermediate_1 : access Designated renames Ptr1;
	            Ptr1_Ren : access Designated renames Intermediate_1;
	            Intermediate_2 : access Designated renames Ptr2;
	            Ptr2_Ren : access Designated renames Intermediate_2;

	            procedure Update_Ptr1 (Aap : access Designated) is
	            begin
	                Ptr1_Ren := Aap;
	            end Update_Ptr1;
	        begin
	            for Exception_Expected in Boolean loop
	                begin
	                    Update_Ptr1 (Ptr2_Ren);
	                    Assert (not Exception_Expected);
	                exception
	                    when Program_Error =>
	                        Assert (Exception_Expected);
	                end;
	                Ptr2_Ren := Ccc'Access;
	            end loop;
	            Assert (Ptr1_Ren = Bbb'Access);
	            Ptr1_Ren := Aaa'Access;
	        end;
	    end Test_Rename_Access_Params;

	    procedure Test_Membership is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	    begin
	        for Ptr2_Not_In_Named1 In Boolean loop
	            Assert ((Ptr2 not in Named1) = Ptr2_Not_In_Named1);
	            Ptr2 := Ccc'Access;
	        end loop;
	    end Test_Membership;

	    procedure Test_Rename_Membership is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	    begin
	        for Ptr2_Not_In_Named1 In Boolean loop
	            declare
	                Intermediate_2 : access Designated renames Ptr2;
	                Ptr2_Ren : access Designated renames Intermediate_2;
	            begin
	                Assert ((Ptr2_Ren not in Named1) = Ptr2_Not_In_Named1);
	                Ptr2_Ren := Ccc'Access;
	            end;
	        end loop;
	    end Test_Rename_Membership;

	    procedure Test_Conversion is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	        Converted : Named1 := Aaa'Access;
	    begin
	        for Exception_Expected in Boolean loop
	            begin
	                Converted := Named1 (Ptr2);
	                Assert (not Exception_Expected);
	            exception
	                when Program_Error =>
	                    Assert (Exception_Expected);
	            end;
	            Ptr2 := Ccc'Access;
	        end loop;
	        Assert (Converted = Bbb'Access);
	    end Test_Conversion;

	    procedure Test_Rename_Conversion is
	        Ccc : aliased Designated := 456;
	        Ptr2 : access Designated := Bbb'Access;
	        Converted : Named1 := Aaa'Access;
	    begin
	        declare
	           Intermediate_1 : Named1 renames Converted;
	           Converted_Ren : Named1 renames Intermediate_1;
	           Intermediate_2 : access Designated renames Ptr2;
	           Ptr2_Ren : access Designated renames Intermediate_2;
	        begin
	            for Exception_Expected in Boolean loop
	                begin
	                    Converted_Ren := Named1 (Ptr2_Ren);
	                    Assert (not Exception_Expected);
	                exception
	                    when Program_Error =>
	                        Assert (Exception_Expected);
	                end;
	                Ptr2_Ren := Ccc'Access;
	            end loop;
	            Assert (Converted_Ren = Bbb'Access);
	        end;
	    end Test_Rename_Conversion;

	  begin
	    Test_Assignment;
	    Test_Copy_Back;
	    Test_Access_Params;
	    Test_Membership;
	    Test_Conversion;

	    Test_Rename_Assignment;
	    Test_Rename_Copy_Back;
	    Test_Rename_Access_Params;
	    Test_Rename_Membership;
	    Test_Rename_Conversion;
	  end AI05_0148_Test1;

	  procedure Ai05_0148_Test2 is
	    subtype Designated is Integer;
	    Ptr1 : access Designated;
	    Var1 : aliased Designated;
	  begin
	    declare
	        Var2 : aliased Designated := 456;
	        type Named2 is access all Designated;
	        for Named2'Storage_Size use 0;
	        Ptr2 : Named2;
	        Intermediate : access Designated renames Ptr1;
	        Ptr1_Ren : access Designated renames Intermediate;

	        procedure Foo (X : out Named2) is
	           begin X := Var2'Access; end Foo;
	    begin
	        Ptr1 := Var2'Access; -- illegal
	        Ptr1_Ren := Var2'Access; -- illegal

	        Ptr1 := Ptr2; -- illegal
	        Ptr1_Ren := Ptr2; -- illegal

	        Foo (Ptr1); -- illegal
	        Foo (Ptr1_Ren); -- illegal
	    end;
	  end Ai05_0148_Test2;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-08-30  Steve Baird  <baird@adacore.com>

	* sem_util.ads (Deepest_Type_Access_Level): New function; for the type
	of a saooaaat (i.e, a stand-alone object of an anonymous access type),
	returns the (static) accessibility level of the object. Otherwise, the
	same as Type_Access_Level.
	(Dynamic_Accessibility_Level): New function; given an expression which
	could occur as the rhs of an assignment to a saooaaat (i.e., an
	expression of an access-to-object type), return the new value for the
	saooaaat's associated Extra_Accessibility object.
	(Effective_Extra_Accessibility): New function; same as
	Einfo.Extra_Accessibility except that object renames are looked through.
	* sem_util.adb 
	(Deepest_Type_Access_Level): New function; see sem_util.ads description.
	(Dynamic_Accessibility_Level): New function; see sem_util.ads
	description.
	(Effective_Extra_Accessibility): New function; see sem_util.ads
	description.
	* einfo.ads (Is_Local_Anonymous_Access): Update comments.
	(Extra_Accessibility): Update comments.
	(Init_Object_Size_Align): New procedure; same as Init_Size_Align
	except RM_Size field (which is only for types) is unaffected.
	* einfo.adb
	(Extra_Accessibility): Expand domain to allow objects, not just formals.
	(Set_Extra_Accessibility): Expand domain to allow objects, not just
	formals.
	(Init_Size): Add assertion that we are not trashing the
	Extra_Accessibility attribute of an object.
	(Init_Size_Align): Add assertion that we are not trashing the
	Extra_Accessibility attribute of an object.
	(Init_Object_Size_Align): New procedure; see einfo.ads description.
	* sem_ch3.adb (Find_Type_Of_Object): Set Is_Local_Anonymous_Access
	differently for the type of a (non-library-level) saooaaat depending
	whether Ada_Version < Ada_2012. This is the only point where Ada_Version
	is queried in this set of changes - everything else (in particular,
	setting of the Extra_Accessibility attribute in exp_ch3.adb) is
	driven off of the setting of the Is_Local_Anonymous_Access attribute.
	The special treatment of library-level saooaaats is an optimization,
	not required for correctnesss. This is based on the observation that the
	Ada2012 rules (static and dynamic) for saooaaats turn out to be
	equivalent to the Ada2005 rules in the case of a library-level saooaaat.
	* exp_ch3.adb
	(Expand_N_Object_Declaration): If Is_Local_Anonymous_Access is
	false for the type of a saooaaat, declare and initialize its
	accessibility level object and set the Extra_Accessibility attribute
	of the saooaaat to refer to this object.
	* checks.adb (Apply_Accessibility_Check): Add Ada 2012 saooaaat support.
	* exp_ch4.adb (Expand_N_In): Replace some Extra_Accessibility calls with
	calls to Effective_Extra_Accessibility in order to support
	renames of saooaaats.
	(Expand_N_Type_Conversion): Add new local function,
	Has_Extra_Accessibility, and call it when determining whether an
	accessibility check is needed.
	It returns True iff Present (Effective_Extra_Accessibility (Id)) would
	evaluate to True (without raising an exception).
	* exp_ch5.adb
	(Expand_N_Assignment_Statement): When assigning to an Ada2012
	saooaaat, update its associated Extra_Accessibility object (if
	it has one). This includes an accessibility check.
	* exp_ch6.adb (Add_Call_By_Copy_Code): When parameter copy-back updates
	a saooaaat, update its Extra_Accessibility object too (if it
	has one).
	(Expand_Call): Replace a couple of calls to Type_Access_Level
	with calls to Dynamic_Access_Level to handle cases where
	passing a literal (any literal) is incorrect.
	* sem_attr.adb (Resolve_Attribute): Handle the static accessibility
	checks associated with "Saooaat := Some_Object'Access;"; this must
	be rejected if Some_Object is declared in a more nested scope
	than Saooaat.
	* sem_ch5.adb (Analyze_Assignment): Force accessibility checking for an
	assignment to a saooaaat even if Is_Local_Anonymous_Access
	returns False for its type (indicating a 2012-style saooaaat).
	* sem_ch8.adb
	(Analyze_Object_Renaming): Replace a call to Init_Size_Align
	(which is only appropriate for objects, not types) with a call
	of Init_Object_Size_Align in order to avoid trashing the
	Extra_Accessibility attribute of a rename (the two attributes
	share storage).
	* sem_res.adb
	(Valid_Conversion) Replace six calls to Type_Access_Level with
	calls to Deepest_Type_Access_Level. This is a bit tricky. For an
	Ada2012 non-library-level saooaaat, the former returns library level
	while the latter returns the (static) accessibility level of the
	saooaaat. A type conversion to the anonymous type of a saooaaat
	can only occur as part of an assignment to the saooaaat, so we
	know that such a conversion must be in a lhs context, so Deepest
	yields the result that we need. If such a conversion could occur,
	say, as the operand of an equality operator, then this might not
	be right. Also add a test so that static accessibilty checks are
	performed for converting to a saooaaat's type even if
	Is_Local_Anonymous_Access yields False for the type.

[Ada] Ada 2012 accessibility of anonymous access stand-alone objects

Commit Message

Patch