From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/c7/c760002.a | 489 +++++++++++++++++++++++++++++ 1 file changed, 489 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760002.a (limited to 'gcc/testsuite/ada/acats/tests/c7/c760002.a') diff --git a/gcc/testsuite/ada/acats/tests/c7/c760002.a b/gcc/testsuite/ada/acats/tests/c7/c760002.a new file mode 100644 index 000000000..4601873be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760002.a @@ -0,0 +1,489 @@ +-- C760002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that assignment to an object of a (non-limited) controlled +-- type causes the Adjust operation of the type to be called. +-- Check that Adjust is called after copying the value of the +-- source expression to the target object. +-- +-- Check that Adjust is called for all controlled components when +-- the containing object is assigned. (Test this for the cases +-- where the type of the containing object is controlled and +-- noncontrolled; test this for initialization as well as +-- assignment statements.) +-- +-- Check that for an object of a controlled type with controlled +-- components, Adjust for each of the components is called before +-- the containing object is adjusted. +-- +-- Check that an Adjust procedure for a Limited_Controlled type is +-- not called by the implementation. +-- +-- TEST DESCRIPTION: +-- This test is loosely "derived" from C760001. +-- +-- Visit Tags: +-- D - Default value at declaration +-- d - Default value at declaration, limited root +-- I - initialize at root controlled +-- i - initialize at root limited controlled +-- A - adjust at root controlled +-- X,Y,Z,x,y,z - used in test body +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Correct test assertion logic for Sinister case +-- +--! + +---------------------------------------------------------------- C760002_0 + +with Ada.Finalization; +package C760002_0 is + subtype Unique_ID is Natural; + function Unique_Value return Unique_ID; + -- increments each time it's called + + function Most_Recent_Unique_Value return Unique_ID; + -- returns the same value as the most recent call to Unique_Value + + type Root is tagged record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; -- Default + end record; + + procedure Initialize( R: in out Root ); + procedure Adjust ( R: in out Root ); + + type Root_Controlled is new Ada.Finalization.Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; ---------------------------------------- D + end record; + + procedure Initialize( R: in out Root_Controlled ); + procedure Adjust ( R: in out Root_Controlled ); + + type Root_Limited_Controlled is + new Ada.Finalization.Limited_Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'd'; ---------------------------------------- d + end record; + + procedure Initialize( R: in out Root_Limited_Controlled ); + procedure Adjust ( R: in out Root_Limited_Controlled ); + +end C760002_0; + +with Report; +package body C760002_0 is + + Global_Unique_Counter : Unique_ID := 0; + + function Unique_Value return Unique_ID is + begin + Global_Unique_Counter := Global_Unique_Counter +1; + return Global_Unique_Counter; + end Unique_Value; + + function Most_Recent_Unique_Value return Unique_ID is + begin + return Global_Unique_Counter; + end Most_Recent_Unique_Value; + + procedure Initialize( R: in out Root ) is + begin + Report.Failed("Initialize called for Non_Controlled type"); + end Initialize; + + procedure Adjust ( R: in out Root ) is + begin + Report.Failed("Adjust called for Non_Controlled type"); + end Adjust; + + procedure Initialize( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'I'; --------------------------------------------------- I + end Initialize; + + procedure Adjust( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'A'; --------------------------------------------------- A + end Adjust; + + procedure Initialize( R: in out Root_Limited_Controlled ) is + begin + R.Visit_Tag := 'i'; --------------------------------------------------- i + end Initialize; + + procedure Adjust( R: in out Root_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Limited_Controlled type"); + end Adjust; + +end C760002_0; + +---------------------------------------------------------------- C760002_1 + +with Ada.Finalization; +with C760002_0; +package C760002_1 is + + type Proc_ID is (None, Init, Adj, Fin); + + type Test_Controlled is new C760002_0.Root_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Controlled ); + procedure Adjust ( TC: in out Test_Controlled ); + procedure Finalize ( TC: in out Test_Controlled ); + + type Nested_Controlled is new C760002_0.Root_Controlled with record + Nested : C760002_0.Root_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Controlled ); + procedure Adjust ( TC: in out Nested_Controlled ); + procedure Finalize ( TC: in out Nested_Controlled ); + + type Test_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Limited_Controlled ); + procedure Adjust ( TC: in out Test_Limited_Controlled ); + procedure Finalize ( TC: in out Test_Limited_Controlled ); + + type Nested_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Nested : C760002_0.Root_Limited_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Limited_Controlled ); + procedure Adjust ( TC: in out Nested_Limited_Controlled ); + procedure Finalize ( TC: in out Nested_Limited_Controlled ); + +end C760002_1; + +with Report; +package body C760002_1 is + + procedure Initialize( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Test_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Nested_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + +end C760002_1; + +---------------------------------------------------------------- C760002 + +with Report; +with TCTouch; +with C760002_0; +with C760002_1; +with Ada.Finalization; +procedure C760002 is + + use type C760002_1.Proc_ID; + + -- in the first test, test the simple cases. + -- Also check that assignment causes a call to Adjust for a controlled + -- object. Check that assignment of a non-controlled object does not call + -- an Adjust procedure. + + procedure Check_Simple_Objects is + + A,B : C760002_0.Root; + S,T : C760002_1.Test_Controlled; + Q : C760002_1.Test_Limited_Controlled; -- Adjust call shouldn't happen + begin + + S := T; + + TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj), + "Adjust for simple object"); + TCTouch.Assert((S.My_ID = T.My_ID), + "Assignment failed for simple object"); + + -- Check that adjust was called + TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect"); + + -- Check that Adjust has not been called + TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called"); + + -- Check that Adjust does not get called + A.My_ID := A.My_ID +1; + B := A; -- see: Adjust: Report.Failed + + end Check_Simple_Objects; + + -- in the second test, test a more complex case, check that a controlled + -- component of a controlled object gets processed correctly + + procedure Check_Nested_Objects is + NO1 : C760002_1.Nested_Controlled; + NO2 : C760002_1.Nested_Controlled := NO1; + + begin + + -- NO2 should be flagged with adjust markers + TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj), + "Adjust not called for NO2 enclosure declaration"); + TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'), + "Adjust not called for NO2 enclosed declaration"); + + NO2.Visit_Tag := 'x'; + NO2.Nested.Visit_Tag := 'y'; + + NO1 := NO2; + + -- NO1 should be flagged with adjust markers + TCTouch.Assert((NO1.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosure declaration"); + TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosed declaration"); + + end Check_Nested_Objects; + + procedure Check_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Controlled; + type Array_Nested is array(1..4) of C760002_1.Nested_Controlled; + + Left,Right : Array_Simple; + Overlap : Array_Simple := Left; + + Sinister,Dexter : Array_Nested; + Underlap : Array_Nested := Sinister; + + Now : Natural; + + begin + + -- get a current unique value since initializations + Now := C760002_0.Unique_Value; + + -- check results of declarations + for N in 1..4 loop + TCTouch.Assert(Left(N).My_Id < Now, + "Initialize for array initial value"); + TCTouch.Assert(Overlap(N).My_Id < Now, + "Adjust for nested array (outer) initial value"); + TCTouch.Assert(Sinister(N).Nested.My_Id < Now, + "Initialize for nested array (inner) initial value"); + TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id, + "Initialize for enclosure should be after enclosed"); + TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration"); + TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A', + "Adjust at declaration, nested object"); + end loop; + + -- set visit tags + for O in 1..4 loop + Overlap(O).Visit_Tag := 'X'; + Underlap(O).Visit_Tag := 'Y'; + Underlap(O).Nested.Visit_Tag := 'y'; + end loop; + + -- check that overlapping assignments don't cause odd grief + Overlap(1..3) := Overlap(2..4); + Underlap(2..4) := Underlap(1..3); + + for M in 2..3 loop + TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for overlap"); + TCTouch.Assert(Overlap(M).Visit_Tag = 'A', + "Adjust for overlap ID"); + TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for Underlap"); + TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A', + "Adjust for Underlaps nested ID"); + end loop; + + end Check_Array_Case; + + procedure Check_Access_Case is + type TC_Ref is access C760002_1.Test_Controlled; + type NC_Ref is access C760002_1.Nested_Controlled; + type TL_Ref is access C760002_1.Test_Limited_Controlled; + type NL_Ref is access C760002_1.Nested_Limited_Controlled; + + A,B : TC_Ref; + C,D : NC_Ref; + E : TL_Ref; + F : NL_Ref; + + begin + + A := new C760002_1.Test_Controlled; + B := new C760002_1.Test_Controlled'( A.all ); + + C := new C760002_1.Nested_Controlled; + D := new C760002_1.Nested_Controlled'( C.all ); + + E := new C760002_1.Test_Limited_Controlled; + F := new C760002_1.Nested_Limited_Controlled; + + TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation"); + TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value"); + + TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation"); + TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested"); + TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value"); + TCTouch.Assert(D.Nested.Visit_Tag = 'A', + "NC Allocation, Nested, with value"); + + TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation"); + TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation"); + + A.all := B.all; + C.all := D.all; + + TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment"); + TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment"); + TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested"); + + end Check_Access_Case; + + procedure Check_Access_Limited_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled; + type AS_Ref is access Array_Simple; + type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled; + type AN_Ref is access Array_Nested; + + Simple_Array_Limited : AS_Ref; + + Nested_Array_Limited : AN_Ref; + + begin + + Simple_Array_Limited := new Array_Simple; + + Nested_Array_Limited := new Array_Nested; + + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for array initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for nested array (outer) initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i', + "Initialize for nested array (inner) initial value"); + end loop; + end Check_Access_Limited_Array_Case; + +begin -- Main test procedure. + + Report.Test ("C760002", "Check that assignment causes the Adjust " & + "operation of the type to be called. Check " & + "that Adjust is called after copying the " & + "value of the source expression to the target " & + "object. Check that Adjust is called for all " & + "controlled components when the containing " & + "object is assigned. Check that Adjust is " & + "called for components before the containing " & + "object is adjusted. Check that Adjust is not " & + "called for a Limited_Controlled type by the " & + "implementation" ); + + Check_Simple_Objects; + + Check_Nested_Objects; + + Check_Array_Case; + + Check_Access_Case; + + Check_Access_Limited_Array_Case; + + Report.Result; + +end C760002; -- cgit v1.2.3