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