-- 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;