OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-old/gcc-4.2.2/gcc/testsuite/ada/acats/tests/c7
    from Rev 154 to Rev 816
    ↔ Reverse comparison
  •

Rev 154 → Rev 816

/c730004.a
0,0 → 1,327
-- C730004.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 for a type declared in a package, descendants of the package
-- use the full view of type. Specifically check that full view of the
-- limited type is visible only in private descendants (children) and in
-- the private parts and bodies of public descendants (children).
-- Check that a limited type may be used as an out parameter outside
-- the package that defines the type.
--
-- TEST DESCRIPTION:
-- This test defines a parent package containing limited private type
-- definitions. Children packages are defined (one public, one private)
-- that use the nonlimited full view of the types defined in the private
-- part of the parent specification.
-- The main declares a procedure with an out parameter that was defined
-- as limited in the specification of the parent package.
--
--
-- CHANGE HISTORY:
-- 15 Sep 95 SAIC Initial prerelease version.
-- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File.
-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report.
--
--!
 
package C730004_0 is
 
-- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are
-- are nonlimited.
 
type File_Descriptor is limited private;
 
type File_Mode is limited private;
 
Active_Mode : constant File_Mode;
 
type File_Name is limited private;
 
type File_Type is limited private;
 
function Next_Available_File return File_Descriptor;
 
private
 
type File_Descriptor is new Integer;
 
Null_File : constant File_Descriptor := 0;
First_File : constant File_Descriptor := 1;
 
type File_Mode is
(Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost);
 
Default_Mode : constant File_Mode := Read_Only;
Active_Mode : constant File_Mode := Read_Write;
 
type File_Name is array (1 .. 6) of Character;
 
Null_String : File_Name := " ";
String1 : File_Name := "ACVC ";
String2 : File_Name := " 1995";
 
type File_Type is
record
Descriptor : File_Descriptor := Null_File;
Mode : File_Mode := Default_Mode;
Name : File_Name := Null_String;
end record;
 
end C730004_0;
 
--=================================================================--
 
package body C730004_0 is
 
File_Count : Integer := 0;
 
function Next_Available_File return File_Descriptor is
begin
File_Count := File_Count + 1;
return (File_Descriptor(File_Count)); -- Type conversion.
end Next_Available_File;
 
end C730004_0;
 
--=================================================================--
 
private
package C730004_0.C730004_1 is -- private child
 
-- Since full view of the nontagged File_Name is nonlimited in the parent
-- package, it is not limited in the private child, so concatenation is
-- available.
 
System_File_Name : constant File_Name
:= String1(1..4) & String2(5..6);
 
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private child, so a default expression
-- is available.
 
function New_File_Validated (File : File_Type
:= (Descriptor => First_File,
Mode => Active_Mode,
Name => System_File_Name))
return Boolean;
 
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private child, so initialization
-- expression in an object declaration is available.
 
System_File : File_Type
:= (Null_File, Read_Only, System_File_Name);
 
 
end C730004_0.C730004_1;
 
--=================================================================--
 
package body C730004_0.C730004_1 is
 
function New_File_Validated (File : File_Type
:= (Descriptor => First_File,
Mode => Active_Mode,
Name => System_File_Name))
return Boolean is
Result : Boolean := False;
begin
if (File.Descriptor > System_File.Descriptor) and
(File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95")
then
Result := True;
end if;
 
return (Result);
 
end New_File_Validated;
 
end C730004_0.C730004_1;
 
--=================================================================--
 
package C730004_0.C730004_2 is -- public child
 
-- File_Type is limited here.
 
procedure Create_File (File : out File_Type);
procedure Modify_File (File : out File_Type);
 
type File_Dir is limited private;
 
-- The following three validation functions provide the capability to
-- check the limited private types defined in the parent and the
-- private child package from within the client program.
function Validate_Create (File : in File_Type) return Boolean;
 
function Validate_Modification (File : in File_Type)
return Boolean;
 
function Validate_Dir (Dir : in File_Dir) return Boolean;
 
private
 
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private part of the public child, so
-- aggregates are available.
 
Child_File : File_Type
:= File_Type'(Descriptor => Null_File,
Mode => Write_Only,
Name => String2);
-- Since full view of the nontagged component File_Type is nonlimited in
-- the parent package, it is not limited in the private part of the public
-- child, so default expressions are available.
 
type File_Dir is
record
Comp : File_Type := Child_File;
end record;
 
end C730004_0.C730004_2;
 
--=================================================================--
 
with C730004_0.C730004_1;
 
package body C730004_0.C730004_2 is
 
procedure Create_File (File : out File_Type) is
New_File : File_Type;
 
begin
New_File.Descriptor := Next_Available_File;
New_File.Mode := Default_Mode;
New_File.Name := C730004_0.C730004_1.System_File_Name;
 
if C730004_0.C730004_1.New_File_Validated (New_File) then
File := New_File;
else
File := (Null_File, Lost, "MISSED");
end if;
 
end Create_File;
 
--------------------------------------------------------------
procedure Modify_File (File : out File_Type) is
begin
File.Descriptor := Next_Available_File;
File.Mode := Active_Mode;
File.Name := String1;
end Modify_File;
 
--------------------------------------------------------------
function Validate_Create (File : in File_Type) return Boolean is
begin
if ((File.Descriptor /= Child_File.Descriptor) and
(File.Mode = Read_Only) and (File.Name = "ACVC95"))
then
return True;
else
return False;
end if;
end Validate_Create;
------------------------------------------------------------------------
function Validate_Modification (File : in File_Type)
return Boolean is
begin
if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and
(File.Mode = Read_Write) and (File.Name = "ACVC "))
then
return True;
else
return False;
end if;
end Validate_Modification;
 
------------------------------------------------------------------------
function Validate_Dir (Dir : in File_Dir) return Boolean is
begin
if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor)
and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2))
then
return True;
else
return False;
end if;
end Validate_Dir;
 
end C730004_0.C730004_2;
 
--=================================================================--
 
with C730004_0.C730004_2;
with Report;
 
procedure C730004 is
 
package File renames C730004_0;
package File_Ops renames C730004_0.C730004_2;
 
Validation_File : File.File_Type;
 
Validation_Dir : File_Ops.File_Dir;
 
------------------------------------------------------------------------
-- Limited File_Type is allowed as an out parameter outside package File.
 
procedure Call_Modify_File (Modified_File : out File.File_Type) is
begin
File_Ops.Modify_File (Modified_File);
end Call_Modify_File;
begin
 
Report.Test ("C730004", "Check that for a type declared in a package, " &
"descendants of the package use the full view " &
"of the type. Specifically check that full " &
"view of the limited type is visible only in " &
"private children and in the private parts and " &
"bodies of public children");
 
File_Ops.Create_File (Validation_File);
 
if not File_Ops.Validate_Create (Validation_File) then
Report.Failed ("Incorrect creation of file");
end if;
 
Call_Modify_File (Validation_File);
 
if not File_Ops.Validate_Modification (Validation_File) then
Report.Failed ("Incorrect modification of file");
end if;
 
if not File_Ops.Validate_Dir (Validation_Dir) then
Report.Failed ("Incorrect creation of directory");
end if;
 
Report.Result;
 
end C730004;
/c760001.a
0,0 → 1,390
-- C760001.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 Initialize is called for objects and components of
-- a controlled type when the objects and components are not
-- assigned explicit initial values. Check this for "simple" controlled
-- objects, controlled record components and arrays with controlled
-- components.
--
-- Check that if an explicit initial value is assigned to an object
-- or component of a controlled type then Initialize is not called.
--
-- TEST DESCRIPTION:
-- This test derives a type for Ada.Finalization.Controlled, and
-- overrides the Initialize and Adjust operations for the type. The
-- intent of the type is that it should carry incremental values
-- indicating the ordering of events with respect to these (and default
-- initialization) operations. The body of the test uses these values
-- to determine that the implicit calls to these subprograms happen
-- (or don't) at the appropriate times.
--
-- The test further derives types from this "root" type, which are the
-- actual types used in the test. One of the types is "simply" derived
-- from the "root" type, the other contains a component of the first
-- type, thus nesting a controlled object as a record component in
-- controlled objects.
--
-- The main program declares objects of these types and checks the
-- values of the components to ascertain that they have been touched
-- as expected.
--
-- Note that Finalization procedures are provided. This test does not
-- test that the calls to Finalization are made correctly. The
-- Finalization procedures are provided to catch an implementation that
-- calls Finalization at an incorrect time.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1
--
--!
 
---------------------------------------------------------------- C760001_0
 
with Ada.Finalization;
package C760001_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_Controlled is new Ada.Finalization.Controlled with record
My_ID : Unique_ID := Unique_Value;
My_Init_ID : Unique_ID := Unique_ID'First;
My_Adj_ID : Unique_ID := Unique_ID'First;
end record;
 
procedure Initialize( R: in out Root_Controlled );
procedure Adjust ( R: in out Root_Controlled );
 
TC_Initialize_Calls_Is_Failing : Boolean := False;
 
end C760001_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760001_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_Controlled ) is
begin
if TC_Initialize_Calls_Is_Failing then
Report.Failed("Initialized incorrectly called");
end if;
R.My_Init_ID := Unique_Value;
end Initialize;
 
procedure Adjust( R: in out Root_Controlled ) is
begin
R.My_Adj_ID := Unique_Value;
end Adjust;
 
end C760001_0;
 
---------------------------------------------------------------- C760001_1
 
with Ada.Finalization;
with C760001_0;
package C760001_1 is
 
type Proc_ID is (None, Init, Adj, Fin);
 
type Test_Controlled is new C760001_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 C760001_0.Root_Controlled with record
Nested : C760001_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 );
 
end C760001_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760001_1 is
 
procedure Initialize( TC: in out Test_Controlled ) is
begin
if TC.Last_Proc_Called /= None then
Report.Failed("Initialize for Test_Controlled");
end if;
TC.Last_Proc_Called := Init;
C760001_0.Initialize(C760001_0.Root_Controlled(TC));
end Initialize;
 
procedure Adjust ( TC: in out Test_Controlled ) is
begin
TC.Last_Proc_Called := Adj;
C760001_0.Adjust(C760001_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
if TC.Last_Proc_Called /= None then
Report.Failed("Initialize for Nested_Controlled");
end if;
TC.Last_Proc_Called := Init;
C760001_0.Initialize(C760001_0.Root_Controlled(TC));
end Initialize;
 
procedure Adjust ( TC: in out Nested_Controlled ) is
begin
TC.Last_Proc_Called := Adj;
C760001_0.Adjust(C760001_0.Root_Controlled(TC));
end Adjust;
 
procedure Finalize ( TC: in out Nested_Controlled ) is
begin
TC.Last_Proc_Called := Fin;
end Finalize;
 
end C760001_1;
 
---------------------------------------------------------------- C760001
 
with Report;
with TCTouch;
with C760001_0;
with C760001_1;
with Ada.Finalization;
procedure C760001 is
 
use type C760001_1.Proc_ID;
 
-- in the first test, test the simple case. Check that a controlled object
-- causes a call to the procedure Initialize.
-- Also check that assignment causes a call to Adjust.
 
procedure Check_Simple_Objects is
S,T : C760001_1.Test_Controlled;
begin
TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
(T.Last_Proc_Called = C760001_1.Init),
"Initialize for simple object");
S := T;
TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
"Adjust for simple object");
TCTouch.Assert((S.My_ID = T.My_ID),
"Simple object My_ID's don't match");
TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
"Simple object My_Init_ID's don't match");
TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
"Simple object My_Adj_ID's in wrong order");
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 : C760001_1.Nested_Controlled;
begin
TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
"Default value order incorrect");
TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
"Initialization call order incorrect");
end Check_Nested_Objects;
 
-- check that objects assigned an initial value at declaration are Adjusted
-- and NOT Initialized
 
procedure Check_Objects_With_Initial_Values is
 
TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
 
A: C760001_1.Test_Controlled :=
( Ada.Finalization.Controlled
with TC_Now,
TC_Now,
TC_Now,
C760001_1.None);
 
B: C760001_1.Nested_Controlled :=
( Ada.Finalization.Controlled
with TC_Now,
TC_Now,
TC_Now,
C760001_0.Root_Controlled(A),
C760001_1.None);
 
begin
-- the implementation may or may not call Adjust for the values
-- assigned into A and B,
-- but should NOT call Initialize.
-- if the value used in the aggregate is overwritten by Initialize,
-- this indicates failure
TCTouch.Assert(A.My_Init_Id = TC_Now,
"Initialize was called for A with initial value");
TCTouch.Assert(B.My_Init_Id = TC_Now,
"Initialize was called for B with initial value");
TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
"Initialize was called for B.Nested initial value");
end Check_Objects_With_Initial_Values;
 
procedure Check_Array_Case is
type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
 
Simple_Array_Default : Array_Simple;
 
Nested_Array_Default : Array_Nested;
 
TC_A_Bit_Later : C760001_0.Unique_ID;
 
begin
TC_A_Bit_Later := C760001_0.Unique_Value;
for N in 1..4 loop
TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
= C760001_1.Init,
"Initialize for array initial value");
 
TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
> C760001_0.Unique_ID'First)
and (Simple_Array_Default(N).My_Init_ID
< TC_A_Bit_Later),
"Initialize timing for simple array");
 
TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
> C760001_0.Unique_ID'First)
and (Nested_Array_Default(N).My_Init_ID
< TC_A_Bit_Later),
"Initialize timing for container array");
 
TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
= C760001_1.Init,
"Initialize for nested array (outer) initial value");
 
TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
> C760001_0.Unique_ID'First)
and (Nested_Array_Default(N).Nested.My_Init_ID
< Nested_Array_Default(N).My_Init_ID),
"Initialize timing for array content");
end loop;
end Check_Array_Case;
 
procedure Check_Array_Case_With_Initial_Values is
 
TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
 
type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
 
Simple_Array_Explicit : Array_Simple := ( 1..4 => (
Ada.Finalization.Controlled
with TC_Now,
TC_Now,
TC_Now,
C760001_1.None ) );
 
A : constant C760001_0.Root_Controlled :=
( Ada.Finalization.Controlled
with others => TC_Now);
 
Nested_Array_Explicit : Array_Nested := ( 1..4 => (
Ada.Finalization.Controlled
with TC_Now,
TC_Now,
TC_Now,
A,
C760001_1.None ) );
 
begin
-- the implementation may or may not call Adjust for the values
-- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
-- but should NOT call Initialize.
-- if the value used in the aggregate is overwritten by Initialize,
-- this indicates failure
for N in 1..4 loop
TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
= TC_Now,
"Initialize was called for array with initial value");
TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
= TC_Now,
"Initialize was called for nested array (outer) with initial value");
TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
"Initialize was called for nested array (inner) with initial value");
end loop;
end Check_Array_Case_With_Initial_Values;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
begin -- Main test procedure.
 
Report.Test ("C760001", "Check that Initialize is called for objects " &
"and components of a controlled type when the " &
"objects and components are not assigned " &
"explicit initial values. Check that if an " &
"explicit initial value is assigned to an " &
"object or component of a controlled type " &
"then Initialize is not called" );
 
Check_Simple_Objects;
 
Check_Nested_Objects;
 
Check_Array_Case;
 
C760001_0.TC_Initialize_Calls_Is_Failing := True;
 
Check_Objects_With_Initial_Values;
 
Check_Array_Case_With_Initial_Values;
 
Report.Result;
 
end C760001;
/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;
/c761010.a
0,0 → 1,447
-- C761010.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. 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 WHATSOVER, 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 the requirements of the new 7.6(17.1/1) from Technical
-- Corrigendum 1 (originally discussed as AI95-00083).
-- This new paragraph requires that the initialization of an object with
-- an aggregate does not involve calls to Adjust.
--
-- TEST DESCRIPTION
-- We include several cases of initialization:
-- - Explicit initialization of an object declared by an
-- object declaration.
-- - Explicit initialization of a heap object.
-- - Default initialization of a record component.
-- - Initialization of a formal parameter during a call.
-- - Initialization of a formal parameter during a call with
-- a defaulted parameter.
-- - Lots of nested records, arrays, and pointers.
-- In this test, Initialize should never be called, because we
-- never declare a default-initialized controlled object (although
-- we do declare default-initialized records containing controlled
-- objects, with default expressions for the components).
-- Adjust should never be called, because every initialization
-- is via an aggregate. Finalize is called, because the objects
-- themselves need to be finalized.
-- Thus, Initialize and Adjust call Failed.
-- In some of the cases, these procedures will not yet be elaborated,
-- anyway.
--
-- CHANGE HISTORY:
-- 29 JUN 1999 RAD Initial Version
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
-- 10 APR 2000 RLB Corrected errors in comments and text, fixed
-- discriminant error. Fixed so that Report.Test
-- is called before any Report.Failed call. Added
-- a marker so that the failed subtest can be
-- determined.
-- 26 APR 2000 RAD Try to defeat optimizations.
-- 04 AUG 2000 RLB Corrected error in Check_Equal.
-- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172).
-- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result.
--
--!
 
with Ada; use Ada;
with Report; use Report; pragma Elaborate_All(Report);
with Ada.Finalization;
package C761010_1 is
pragma Elaborate_Body;
function Square(X: Integer) return Integer;
private
type TC_Control is new Ada.Finalization.Limited_Controlled with null record;
procedure Initialize (Object : in out TC_Control);
procedure Finalize (Object : in out TC_Control);
TC_Finalize_Called : Boolean := False;
end C761010_1;
 
package body C761010_1 is
function Square(X: Integer) return Integer is
begin
return X**2;
end Square;
 
procedure Initialize (Object : in out TC_Control) is
begin
Test("C761010_1",
"Check that Adjust is not called"
& " when aggregates are used to initialize objects");
end Initialize;
 
procedure Finalize (Object : in out TC_Control) is
begin
if not TC_Finalize_Called then
Failed("Var_Strings Finalize never called");
end if;
Result;
end Finalize;
 
TC_Test : TC_Control; -- Starts test; finalization ends test.
end C761010_1;
 
with Ada.Finalization;
package C761010_1.Var_Strings is
type Var_String(<>) is private;
 
Some_String: constant Var_String;
 
function "=" (X, Y: Var_String) return Boolean;
 
procedure Check_Equal(X, Y: Var_String);
-- Calls to this are used to defeat optimizations
-- that might otherwise defeat the purpose of the
-- test. I'm talking about the optimization of removing
-- unused controlled objects.
 
private
 
type String_Ptr is access constant String;
 
type Var_String(Length: Natural) is new Finalization.Controlled with
record
Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');
Comp_2: String_Ptr(1..Length) := null;
Comp_3: String(Length..Length) := (others => '.');
TC_Lab: Character := '1';
end record;
procedure Initialize(X: in out Var_String);
procedure Adjust(X: in out Var_String);
procedure Finalize(X: in out Var_String);
 
Some_String: constant Var_String
:= (Finalization.Controlled with Length => 1,
Comp_1 => null,
Comp_2 => null,
Comp_3 => "x",
TC_Lab => 'A');
 
Another_String: constant Var_String
:= (Finalization.Controlled with Length => 10,
Comp_1 => Some_String.Comp_2,
Comp_2 => new String'("1234567890"),
Comp_3 => "x",
TC_Lab => 'B');
 
end C761010_1.Var_Strings;
 
package C761010_1.Var_Strings.Types is
 
type Ptr is access all Var_String;
Ptr_Const: constant Ptr;
 
type Ptr_Arr is array(Positive range <>) of Ptr;
Ptr_Arr_Const: constant Ptr_Arr;
 
type Ptr_Rec(N_Strings: Natural) is
record
Ptrs: Ptr_Arr(1..N_Strings);
end record;
Ptr_Rec_Const: constant Ptr_Rec;
 
private
 
Ptr_Const: constant Ptr := new Var_String'
(Finalization.Controlled with
Length => 1,
Comp_1 => null,
Comp_2 => null,
Comp_3 => (others => ' '),
TC_Lab => 'C');
 
Ptr_Arr_Const: constant Ptr_Arr :=
(1 => new Var_String'
(Finalization.Controlled with
Length => 1,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'D'));
 
Ptr_Rec_Var: Ptr_Rec :=
(3,
(1..2 => null,
3 => new Var_String'
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'E')));
 
Ptr_Rec_Const: constant Ptr_Rec :=
(3,
(1..2 => null,
3 => new Var_String'
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'F')));
 
type Arr is array(Positive range <>) of Var_String(Length => 2);
 
Arr_Var: Arr :=
(1 => (Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'G'));
 
type Rec(N_Strings: Natural) is
record
Ptrs: Ptr_Rec(N_Strings);
Strings: Arr(1..N_Strings) :=
(others =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'H'));
end record;
 
Default_Init_Rec_Var: Rec(N_Strings => 10);
Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);
 
Rec_Var: Rec(N_Strings => 2) :=
(N_Strings => 2,
Ptrs =>
(2,
(1..1 => null,
2 => new Var_String'
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'J'))),
Strings =>
(1 =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'K'),
others =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'L')));
 
procedure Check_Equal(X, Y: Rec);
 
end C761010_1.Var_Strings.Types;
 
package body C761010_1.Var_Strings.Types is
 
-- Check that parameter passing doesn't create new objects,
-- and therefore doesn't need extra Adjusts or Finalizes.
 
procedure Check_Equal(X, Y: Rec) is
-- We assume that the arguments should be equal.
-- But we cannot assume that pointer values are the same.
begin
if X.N_Strings /= Y.N_Strings then
Failed("Records should be equal (1)");
else
for I in 1 .. X.N_Strings loop
if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then
if X.Ptrs.Ptrs(I) = null or else
Y.Ptrs.Ptrs(I) = null or else
X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then
Failed("Records should be equal (2)");
end if;
end if;
if X.Strings(I) /= Y.Strings(I) then
Failed("Records should be equal (3)");
end if;
end loop;
end if;
end Check_Equal;
 
procedure My_Check_Equal
(X: Rec := Rec_Var;
Y: Rec :=
(N_Strings => 2,
Ptrs =>
(2,
(1..1 => null,
2 => new Var_String'
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'M'))),
Strings =>
(1 =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'N'),
others =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'O'))))
renames Check_Equal;
begin
 
My_Check_Equal;
 
Check_Equal(Rec_Var,
(N_Strings => 2,
Ptrs =>
(2,
(1..1 => null,
2 => new Var_String'
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'P'))),
Strings =>
(1 =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'Q'),
others =>
(Finalization.Controlled with
Length => 2,
Comp_1 => new String'("abcdefghij"),
Comp_2 => null,
Comp_3 => (2..2 => ' '),
TC_Lab => 'R'))));
 
-- Use the objects to avoid optimizations.
 
Check_Equal(Ptr_Const.all, Ptr_Const.all);
Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);
Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,
Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);
Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,
Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);
 
if Report.Equal (3, 2) then
-- Can't get here.
Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));
Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));
end if;
 
end C761010_1.Var_Strings.Types;
 
with C761010_1.Var_Strings;
with C761010_1.Var_Strings.Types;
procedure C761010_1.Main is
begin
-- Report.Test is called by the elaboration of C761010_1, and
-- Report.Result is called by the finalization of C761010_1.
-- This will happen before any objects are created, and after any
-- are finalized.
null;
end C761010_1.Main;
 
with C761010_1.Main;
procedure C761010 is
begin
C761010_1.Main;
end C761010;
 
package body C761010_1.Var_Strings is
 
Some_Error: exception;
 
procedure Initialize(X: in out Var_String) is
begin
Failed("Initialize should never be called");
raise Some_Error;
end Initialize;
 
procedure Adjust(X: in out Var_String) is
begin
Failed("Adjust should never be called - case " & X.TC_Lab);
raise Some_Error;
end Adjust;
 
procedure Finalize(X: in out Var_String) is
begin
Comment("Finalize called - case " & X.TC_Lab);
C761010_1.TC_Finalize_Called := True;
end Finalize;
 
function "=" (X, Y: Var_String) return Boolean is
-- Don't check the TC_Lab component, but do check the contents of the
-- access values.
begin
if X.Length /= Y.Length then
return False;
end if;
if X.Comp_3 /= Y.Comp_3 then
return False;
end if;
if X.Comp_1 /= Y.Comp_1 then
-- Still OK if the values are the same.
if X.Comp_1 = null or else
Y.Comp_1 = null or else
X.Comp_1.all /= Y.Comp_1.all then
return False;
--else OK.
end if;
end if;
if X.Comp_2 /= Y.Comp_2 then
-- Still OK if the values are the same.
if X.Comp_2 = null or else
Y.Comp_2 = null or else
X.Comp_2.all /= Y.Comp_2.all then
return False;
end if;
end if;
return True;
end "=";
 
procedure Check_Equal(X, Y: Var_String) is
begin
if X /= Y then
Failed("Check_Equal of Var_String");
end if;
end Check_Equal;
 
begin
Check_Equal(Another_String, Another_String);
end C761010_1.Var_Strings;
/c761011.a
0,0 → 1,410
-- C761011.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. 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 if a Finalize propagates an exception, other Finalizes due
-- to be performed are performed.
-- Case 1: A Finalize invoked due to the end of execution of
-- a master. (Defect Report 8652/0023, as reflected in Technical
-- Corrigendum 1).
-- Case 2: A Finalize invoked due to finalization of an anonymous
-- object. (Defect Report 8652/0023, as reflected in Technical
-- Corrigendum 1).
-- Case 3: A Finalize invoked due to the transfer of control
-- due to an exit statement.
-- Case 4: A Finalize invoked due to the transfer of control
-- due to a goto statement.
-- Case 5: A Finalize invoked due to the transfer of control
-- due to a return statement.
-- Case 6: A Finalize invoked due to the transfer of control
-- due to raises an exception.
--
--
-- CHANGE HISTORY:
-- 29 JAN 2001 PHL Initial version
-- 15 MAR 2001 RLB Readied for release; added optimization blockers.
-- Added test cases for paragraphs 18 and 19 of the
-- standard (the previous tests were withdrawn).
--
--!
with Ada.Finalization;
use Ada.Finalization;
package C761011_0 is
 
type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
record
Finalized : Boolean := False;
case D is
when False =>
C1 : Integer;
when True =>
C2 : Float;
end case;
end record;
 
function Create (Id : Integer) return Ctrl;
procedure Finalize (Obj : in out Ctrl);
function Was_Finalized (Id : Integer) return Boolean;
procedure Use_It (Obj : in Ctrl);
-- Use Obj to prevent optimization.
 
end C761011_0;
 
with Report;
use Report;
package body C761011_0 is
 
User_Error : exception;
 
Finalize_Called : array (0 .. 50) of Boolean := (others => False);
 
function Create (Id : Integer) return Ctrl is
Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
begin
case Obj.D is
when False =>
Obj.C1 := Ident_Int (Id);
when True =>
Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
end case;
return Obj;
end Create;
 
procedure Finalize (Obj : in out Ctrl) is
begin
if not Obj.Finalized then
Obj.Finalized := True;
if Obj.D then
if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
Ident_Int (3) then
raise User_Error;
else
Finalize_Called (Integer (Obj.C2) / 2) := True;
end if;
else
if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
raise Tasking_Error;
else
Finalize_Called (Obj.C1) := True;
end if;
end if;
end if;
end Finalize;
 
function Was_Finalized (Id : Integer) return Boolean is
begin
return Finalize_Called (Ident_Int (Id));
end Was_Finalized;
 
procedure Use_It (Obj : in Ctrl) is
-- Use Obj to prevent optimization.
begin
case Obj.D is
when True =>
if not Equal (Boolean'Pos(Obj.Finalized),
Boolean'Pos(Obj.Finalized)) then
Failed ("Identity check - 1");
end if;
when False =>
if not Equal (Obj.C1, Obj.C1) then
Failed ("Identity check - 2");
end if;
end case;
end Use_It;
 
end C761011_0;
 
with Ada.Exceptions;
use Ada.Exceptions;
with Ada.Finalization;
with C761011_0;
use C761011_0;
with Report;
use Report;
procedure C761011 is
begin
Test
("C761011",
" Check that if a finalize propagates an exception, other finalizes " &
"due to be performed are performed");
 
Normal: -- Case 1
begin
declare
Obj1 : Ctrl := Create (Ident_Int (1));
Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (2));
Obj3 : Ctrl :=
(Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (Ident_Int
(3))); -- Finalization: User_Error
Obj4 : Ctrl := Create (Ident_Int (4));
begin
Comment ("Finalization of normal object");
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
Use_It (Obj4);
end;
Failed ("No exception raised by finalization of normal object");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (1)) or
not Was_Finalized (Ident_Int (2)) or
not Was_Finalized (Ident_Int (4)) then
Failed ("Missing finalizations - 1");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 1");
end Normal;
 
Anon: -- Case 2
begin
declare
Obj1 : Ctrl := (Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (Ident_Int (5)));
Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (6));
Obj3 : Ctrl := (Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (Ident_Int (7)));
Obj4 : Ctrl := Create (Ident_Int (8));
begin
Comment ("Finalization of anonymous object");
 
-- The finalization of the anonymous object below will raise
-- Tasking_Error.
if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
Failed ("Incorrect construction of an anonymous object");
end if;
Failed ("Anonymous object not finalized at the end of the " &
"enclosing statement");
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
Use_It (Obj4);
end;
Failed ("No exception raised by finalization of an anonymous " &
"object of a function");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (5)) or
not Was_Finalized (Ident_Int (6)) or
not Was_Finalized (Ident_Int (7)) or
not Was_Finalized (Ident_Int (8)) then
Failed ("Missing finalizations - 2");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 2");
end Anon;
 
An_Exit: -- Case 3
begin
for Counter in 1 .. 4 loop
declare
Obj1 : Ctrl := Create (Ident_Int (11));
Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (12));
Obj3 : Ctrl :=
(Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (
Ident_Int(13))); -- Finalization: User_Error
Obj4 : Ctrl := Create (Ident_Int (14));
begin
Comment ("Finalization because of exit of loop");
 
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
Use_It (Obj4);
 
exit when not Ident_Bool (Obj2.D);
 
Failed ("Exit not taken");
end;
end loop;
Failed ("No exception raised by finalization on exit");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (11)) or
not Was_Finalized (Ident_Int (12)) or
not Was_Finalized (Ident_Int (14)) then
Failed ("Missing finalizations - 3");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 3");
end An_Exit;
 
A_Goto: -- Case 4
begin
declare
Obj1 : Ctrl := Create (Ident_Int (15));
Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (0));
-- Finalization: Tasking_Error
Obj3 : Ctrl := Create (Ident_Int (16));
Obj4 : Ctrl := (Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (Ident_Int (17)));
begin
Comment ("Finalization because of goto statement");
 
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
Use_It (Obj4);
 
if Ident_Bool (Obj4.D) then
goto Continue;
end if;
 
Failed ("Goto not taken");
end;
<<Continue>>
Failed ("No exception raised by finalization on goto");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (15)) or
not Was_Finalized (Ident_Int (16)) or
not Was_Finalized (Ident_Int (17)) then
Failed ("Missing finalizations - 4");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 4");
end A_Goto;
 
A_Return: -- Case 5
declare
procedure Do_Something is
Obj1 : Ctrl := Create (Ident_Int (18));
Obj2 : Ctrl := (Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (Ident_Int (19)));
Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (20));
-- Finalization: Tasking_Error
begin
Comment ("Finalization because of return statement");
 
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
 
if not Ident_Bool (Obj3.D) then
return;
end if;
 
Failed ("Return not taken");
end Do_Something;
begin
Do_Something;
Failed ("No exception raised by finalization on return statement");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (18)) or
not Was_Finalized (Ident_Int (19)) then
Failed ("Missing finalizations - 5");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 5");
end A_Return;
 
Except: -- Case 6
declare
Funky_Error : exception;
 
procedure Do_Something is
Obj1 : Ctrl :=
(Ada.Finalization.Controlled with
D => True,
Finalized => Ident_Bool (False),
C2 => 2.0 * Float (
Ident_Int(23))); -- Finalization: User_Error
Obj2 : Ctrl := Create (Ident_Int (24));
Obj3 : Ctrl := Create (Ident_Int (25));
Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
D => False,
Finalized => Ident_Bool (False),
C1 => Ident_Int (26));
begin
Comment ("Finalization because of exception propagation");
 
Use_It (Obj1); -- Prevent optimization of Objects.
Use_It (Obj2); -- (Critical if AI-147 is adopted.)
Use_It (Obj3);
Use_It (Obj4);
 
if not Ident_Bool (Obj4.D) then
raise Funky_Error;
end if;
 
Failed ("Exception not raised");
end Do_Something;
begin
Do_Something;
Failed ("No exception raised by finalization on exception " &
"propagation");
exception
when Program_Error =>
if not Was_Finalized (Ident_Int (24)) or
not Was_Finalized (Ident_Int (25)) or
not Was_Finalized (Ident_Int (26)) then
Failed ("Missing finalizations - 6");
end if;
when Funky_Error =>
Failed ("Wrong exception propagated");
-- Should be Program_Error (7.6.1(19)).
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Message (E) & " - 6");
end Except;
 
Result;
end C761011;
 
/c761012.a
0,0 → 1,151
-- C761012.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. 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 an anonymous object is finalized with its enclosing master if
-- a transfer of control or exception occurs prior to performing its normal
-- finalization. (Defect Report 8652/0023, as reflected in
-- Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
--
-- CHANGE HISTORY:
-- 29 JAN 2001 PHL Initial version.
-- 5 DEC 2001 RLB Reformatted for ACATS.
--
--!
with Ada.Finalization;
use Ada.Finalization;
package C761012_0 is
 
type Ctrl (D : Boolean) is new Controlled with
record
case D is
when False =>
C1 : Integer;
when True =>
C2 : Float;
end case;
end record;
 
function Create return Ctrl;
procedure Finalize (Obj : in out Ctrl);
function Finalize_Was_Called return Boolean;
 
end C761012_0;
 
with Report;
use Report;
package body C761012_0 is
 
Finalization_Flag : Boolean := False;
 
function Create return Ctrl is
Obj : Ctrl (Ident_Bool (True));
begin
Obj.C2 := 3.0;
return Obj;
end Create;
 
procedure Finalize (Obj : in out Ctrl) is
begin
Finalization_Flag := True;
end Finalize;
 
function Finalize_Was_Called return Boolean is
begin
if Finalization_Flag then
Finalization_Flag := False;
return True;
else
return False;
end if;
end Finalize_Was_Called;
 
end C761012_0;
 
with Ada.Exceptions;
use Ada.Exceptions;
with C761012_0;
use C761012_0;
with Report;
use Report;
procedure C761012 is
begin
Test ("C761012",
"Check that an anonymous object is finalized with its enclosing " &
"master if a transfer of control or exception occurs prior to " &
"performing its normal finalization");
 
Excep:
begin
 
declare
I : Integer := Create.C1; -- Raises Constraint_Error
begin
Failed
("Improper component selection did not raise Constraint_Error, I =" &
Integer'Image (I));
exception
when Constraint_Error =>
Failed ("Constraint_Error caught by the wrong handler");
end;
 
Failed ("Transfer of control did not happen correctly");
 
exception
when Constraint_Error =>
if not Finalize_Was_Called then
Failed ("Finalize wasn't called when the master was left " &
"- Constraint_Error");
end if;
when E: others =>
Failed ("Exception " & Exception_Name (E) &
" raised - " & Exception_Information (E));
end Excep;
 
Transfer:
declare
Finalize_Was_Called_Before_Leaving_Exit : Boolean;
begin
 
begin
loop
exit when Create.C2 = 3.0;
end loop;
Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
if Finalize_Was_Called_Before_Leaving_Exit then
Comment ("Finalize called before the transfer of control");
end if;
end;
 
if not Finalize_Was_Called and then
not Finalize_Was_Called_Before_Leaving_Exit then
Failed ("Finalize wasn't called when the master was left " &
"- transfer of control");
end if;
end Transfer;
 
Result;
end C761012;
 
/c760007.a
0,0 → 1,247
-- C760007.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 Adjust is called for the execution of a return
-- statement for a function returning a result of a (non-limited)
-- controlled type.
--
-- Check that Adjust is called when evaluating an aggregate
-- component association for a controlled component.
--
-- Check that Adjust is called for the assignment of the ancestor
-- expression of an extension aggregate when the type of the
-- aggregate is controlled.
--
-- TEST DESCRIPTION:
-- A type is derived from Ada.Finalization.Controlled; the dispatching
-- procedure Adjust is defined for the new type. Structures and
-- subprograms to model the test objectives are used to check that
-- Adjust is called at the right time. For the sake of simplicity,
-- globally accessible data is used to check that the calls are made.
--
--
-- CHANGE HISTORY:
-- 06 DEC 94 SAIC ACVC 2.0
-- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1
-- 05 APR 96 SAIC Add RM reference
-- 06 NOV 96 SAIC Reduce adjust requirement
-- 25 NOV 97 EDS Allowed zero calls to adjust at line 144
--!
 
---------------------------------------------------------------- C760007_0
 
with Ada.Finalization;
package C760007_0 is
 
type Controlled is new Ada.Finalization.Controlled with record
TC_ID : Natural := Natural'Last;
end record;
procedure Adjust( Object: in out Controlled );
 
type Structure is record
Controlled_Component : Controlled;
end record;
 
type Child is new Controlled with record
TC_XX : Natural := Natural'Last;
end record;
procedure Adjust( Object: in out Child );
 
Adjust_Count : Natural := 0;
Child_Adjust_Count : Natural := 0;
 
end C760007_0;
package body C760007_0 is
 
procedure Adjust( Object: in out Controlled ) is
begin
Adjust_Count := Adjust_Count +1;
end Adjust;
 
procedure Adjust( Object: in out Child ) is
begin
Child_Adjust_Count := Child_Adjust_Count +1;
end Adjust;
 
end C760007_0;
 
------------------------------------------------------------------ C760007
 
with Report;
with C760007_0;
procedure C760007 is
 
procedure Check_Adjust_Count(Message: String;
Min: Natural := 1;
Max: Natural := 2) is
begin
 
-- in order to allow for the anonymous objects referred to in
-- the reference manual, the check for calls to Adjust must be
-- in a range. This number must then be further adjusted
-- to allow for the optimization that does not call for an adjust
-- of an aggregate initial value built directly in the object
 
if C760007_0.Adjust_Count not in Min..Max then
Report.Failed(Message
& " = " & Natural'Image(C760007_0.Adjust_Count));
end if;
C760007_0.Adjust_Count := 0;
end Check_Adjust_Count;
 
procedure Check_Child_Adjust_Count(Message: String;
Min: Natural := 1;
Max: Natural := 2) is
begin
-- ditto above
 
if C760007_0.Child_Adjust_Count not in Min..Max then
Report.Failed(Message
& " = " & Natural'Image(C760007_0.Child_Adjust_Count));
end if;
C760007_0.Child_Adjust_Count := 0;
end Check_Child_Adjust_Count;
 
Object : C760007_0.Controlled;
 
-- Check that Adjust is called for the execution of a return
-- statement for a function returning a result of a (non-limited)
-- controlled type or a result of a noncontrolled type with
-- controlled components.
 
procedure Subtest_1 is
function Create return C760007_0.Controlled is
New_Object : C760007_0.Controlled;
begin
return New_Object;
end Create;
 
procedure Examine( Thing : in C760007_0.Controlled ) is
begin
Check_Adjust_Count("Function call passed as parameter",0);
end Examine;
 
begin
-- this assignment must call Adjust:
-- 1: on the value resulting from the function
-- ** unless this is optimized out by building the result directly
-- in the target object.
-- 2: on Object once it's been assigned
-- may call adjust
-- 1: for a anonymous object created in the evaluation of the function
-- 2: for a anonymous object created in the assignment operation
 
Object := Create;
 
Check_Adjust_Count("Function call",1,4);
 
Examine( Create );
 
end Subtest_1;
 
-- Check that Adjust is called when evaluating an aggregate
-- component association for a controlled component.
 
procedure Subtest_2 is
S : C760007_0.Structure;
 
procedure Examine( Thing : in C760007_0.Structure ) is
begin
Check_Adjust_Count("Aggregate passed as parameter");
end Examine;
 
begin
-- this assignment must call Adjust:
-- 1: on the value resulting from the aggregate
-- ** unless this is optimized out by building the result directly
-- in the target object.
-- 2: on Object once it's been assigned
-- may call adjust
-- 1: for a anonymous object created in the evaluation of the aggregate
-- 2: for a anonymous object created in the assignment operation
S := ( Controlled_Component => Object );
Check_Adjust_Count("Aggregate and Assignment", 1, 4);
 
Examine( C760007_0.Structure'(Controlled_Component => Object) );
end Subtest_2;
 
-- Check that Adjust is called for the assignment of the ancestor
-- expression of an extension aggregate when the type of the
-- aggregate is controlled.
 
procedure Subtest_3 is
Bambino : C760007_0.Child;
 
procedure Examine( Thing : in C760007_0.Child ) is
begin
Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
end Examine;
 
begin
-- implementation permissions make all of the following calls to adjust
-- optional:
-- these assignments may call Adjust:
-- 1: on the value resulting from the aggregate
-- 2: on Object once it's been assigned
-- 3: for a anonymous object created in the evaluation of the aggregate
-- 4: for a anonymous object created in the assignment operation
Bambino := ( Object with TC_XX => 10 );
Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
 
Bambino := ( C760007_0.Controlled with TC_XX => 11 );
Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
 
Examine( ( Object with TC_XX => 21 ) );
 
Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
 
end Subtest_3;
 
begin -- Main test procedure.
 
Report.Test ("C760007", "Check that Adjust is called for the " &
"execution of a return statement for a " &
"function returning a result containing a " &
"controlled type. Check that Adjust is " &
"called when evaluating an aggregate " &
"component association for a controlled " &
"component. " &
"Check that Adjust is called for the " &
"assignment of the ancestor expression of an " &
"extension aggregate when the type of the " &
"aggregate is controlled" );
 
Subtest_1;
Subtest_2;
Subtest_3;
 
Report.Result;
 
end C760007;
/c760009.a
0,0 → 1,533
-- C760009.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 for an extension_aggregate whose ancestor_part is a
-- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
-- Initialize is called on all controlled subcomponents of the
-- ancestor part; if the type of the ancestor part is itself controlled,
-- the Initialize procedure of the ancestor type is called, unless that
-- Initialize procedure is abstract.
--
-- Check that the utilization of a controlled type for a generic actual
-- parameter supports the correct behavior in the instantiated package.
--
-- TEST DESCRIPTION:
-- Declares a generic package instantiated to check that controlled
-- types are not impacted by the "generic boundary."
-- This instance is then used to perform the tests of various
-- aggregate formations of the controlled type. After each operation
-- in the main program that should cause implicit calls, the "state" of
-- the software is checked. The "state" of the software is maintained in
-- several variables which count the calls to the Initialize, Adjust and
-- Finalize procedures in each context. Given the nature of the
-- language rules, the test specifies a minimum number of times that
-- these subprograms should have been called. The test also checks cases
-- where the subprograms should not have been called.
--
-- As per the example in AARM 7.6(11a..d);6.0, the distinctions between
-- the presence/absence of default values is tested.
--
-- DATA STRUCTURES
--
-- C760009_3.Master_Control is derived from
-- C760009_2.Control is derived from
-- Ada.Finalization.Controlled
--
-- C760009_1.Simple_Control is derived from
-- Ada.Finalization.Controlled
--
-- C760009_3.Master_Control contains
-- Standard.Integer
--
-- C760009_2.Control contains
-- C760009_1.Simple_Control (default value)
-- C760009_1.Simple_Control (default initialized)
--
--
-- CHANGE HISTORY:
-- 01 MAY 95 SAIC Initial version
-- 19 FEB 96 SAIC Fixed elaboration Initialize count
-- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations
-- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129
-- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0
-- to avoid possible instantiation error
--!
 
---------------------------------------------------------------- C760009_0
 
with Ada.Finalization;
generic
 
type Private_Formal is private;
 
with procedure TC_Validate( APF: in out Private_Formal );
 
package C760009_0 is -- Check_1
 
pragma Elaborate_Body;
procedure TC_Check_1( APF: in Private_Formal );
procedure TC_Check_2( APF: out Private_Formal );
procedure TC_Check_3( APF: in out Private_Formal );
 
end C760009_0;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760009_0 is -- Check_1
 
procedure TC_Check_1( APF: in Private_Formal ) is
Local : Private_Formal;
begin
Local := APF;
TC_Validate( Local );
end TC_Check_1;
 
procedure TC_Check_2( APF: out Private_Formal ) is
Local : Private_Formal; -- initialized by virtue of actual being
-- Controlled
begin
APF := Local;
TC_Validate( APF );
end TC_Check_2;
 
procedure TC_Check_3( APF: in out Private_Formal ) is
Local : Private_Formal;
begin
Local := APF;
TC_Validate( Local );
end TC_Check_3;
 
end C760009_0;
---------------------------------------------------------------- C760009_1
 
with Ada.Finalization;
package C760009_1 is
 
Initialize_Called : Natural := 0;
Adjust_Called : Natural := 0;
Finalize_Called : Natural := 0;
 
procedure Reset_Counters;
 
type Simple_Control is new Ada.Finalization.Controlled with private;
 
procedure Initialize( AV: in out Simple_Control );
procedure Adjust ( AV: in out Simple_Control );
procedure Finalize ( AV: in out Simple_Control );
procedure Validate ( AV: in out Simple_Control );
 
function Item( AV: Simple_Control'Class ) return String;
 
Empty : constant Simple_Control;
 
procedure TC_Trace( Message: String );
 
private
type Simple_Control is new Ada.Finalization.Controlled with record
Item: Natural;
end record;
 
Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );
 
end C760009_1;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760009_1 is
 
-- Maintenance_Mode and TC_Trace are for the test writers and compiler
-- developers to get more information from this test as it executes.
-- Maintenance_Mode is always False for validation purposes.
 
Maintenance_Mode : constant Boolean := False;
 
procedure TC_Trace( Message: String ) is
begin
if Maintenance_Mode then
Report.Comment( Message );
end if;
end TC_Trace;
 
procedure Reset_Counters is
begin
Initialize_Called := 0;
Adjust_Called := 0;
Finalize_Called := 0;
end Reset_Counters;
 
Master_Count : Natural := 100; -- Help distinguish values
 
procedure Initialize( AV: in out Simple_Control ) is
begin
Initialize_Called := Initialize_Called +1;
AV.Item := Master_Count;
Master_Count := Master_Count +100;
TC_Trace( "Initialize _1.Simple_Control" );
end Initialize;
 
procedure Adjust ( AV: in out Simple_Control ) is
begin
Adjust_Called := Adjust_Called +1;
AV.Item := AV.Item +1;
TC_Trace( "Adjust _1.Simple_Control" );
end Adjust;
 
procedure Finalize ( AV: in out Simple_Control ) is
begin
Finalize_Called := Finalize_Called +1;
AV.Item := AV.Item +1;
TC_Trace( "Finalize _1.Simple_Control" );
end Finalize;
 
procedure Validate ( AV: in out Simple_Control ) is
begin
Report.Failed("Attempt to Validate at Simple_Control level");
end Validate;
 
function Item( AV: Simple_Control'Class ) return String is
begin
return Natural'Image(AV.Item);
end Item;
 
end C760009_1;
---------------------------------------------------------------- C760009_2
 
with C760009_1;
with Ada.Finalization;
package C760009_2 is
 
type Control is new Ada.Finalization.Controlled with record
Element_1 : C760009_1.Simple_Control;
Element_2 : C760009_1.Simple_Control := C760009_1.Empty;
end record;
 
procedure Initialize( AV: in out Control );
procedure Finalize ( AV: in out Control );
 
Initialized : Natural := 0;
Finalized : Natural := 0;
 
end C760009_2;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
package body C760009_2 is
 
procedure Initialize( AV: in out Control ) is
begin
Initialized := Initialized +1;
C760009_1.TC_Trace( "Initialize _2.Control" );
end Initialize;
 
procedure Finalize ( AV: in out Control ) is
begin
Finalized := Finalized +1;
C760009_1.TC_Trace( "Finalize _2.Control" );
end Finalize;
 
end C760009_2;
---------------------------------------------------------------- C760009_3
 
with C760009_0;
with C760009_2;
package C760009_3 is
 
type Master_Control is new C760009_2.Control with record
Data: Integer;
end record;
 
procedure Initialize( AC: in out Master_Control );
-- calls C760009_2.Initialize
-- embedded data causes 1 call to C760009_1.Initialize
 
-- Adjusting operation will
-- make 1 call to C760009_2.Adjust
-- make 2 call to C760009_1.Adjust
 
-- Finalize operation will
-- make 1 call to C760009_2.Finalize
-- make 2 call to C760009_1.Finalize
 
procedure Validate( AC: in out Master_Control );
 
package Check_1 is
new C760009_0(Master_Control, Validate);
 
end C760009_3;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with C760009_1;
package body C760009_3 is
 
procedure Initialize( AC: in out Master_Control ) is
begin
AC.Data := 42;
C760009_2.Initialize(C760009_2.Control(AC));
C760009_1.TC_Trace( "Initialize Master_Control" );
end Initialize;
 
procedure Validate( AC: in out Master_Control ) is
begin
if AC.Data not in 0..1000 then
Report.Failed("C760009_3.Control did not Initialize" );
end if;
end Validate;
 
end C760009_3;
--------------------------------------------------------------------- C760009
 
with Report;
with C760009_1;
with C760009_2;
with C760009_3;
procedure C760009 is
 
-- Comment following declaration indicates expected calls in the order:
-- Initialize of a C760009_2 value
-- Finalize of a C760009_2 value
-- Initialize of a C760009_1 value
-- Adjust of a C760009_1 value
-- Finalize of a C760009_1 value
 
Global_Control : C760009_3.Master_Control;
-- 1, 0, 1, 1, 0
 
Parent_Control : C760009_2.Control;
-- 1, 0, 1, 1, 0
 
-- Global_Control is a derived tagged type, the parent type
-- of Master_Control, Control, is derived from Controlled, and contains
-- two components of a Controlled type, Simple_Control. One of these
-- components has a default value, the other does not.
 
procedure Fail( Which: String; Expect, Got: Natural ) is
begin
Report.Failed(Which & " Expected" & Natural'Image(Expect)
& " got" & Natural'Image(Got) );
end Fail;
 
procedure Master_Assertion( Layer_2_Inits : Natural;
Layer_2_Finals : Natural;
Layer_1_Inits : Natural;
Layer_1_Adjs : Natural;
Layer_1_Finals : Natural;
Failing_Message : String ) is
 
begin
 
 
 
if C760009_2.Initialized /= Layer_2_Inits then
Fail("C760009_2.Initialize " & Failing_Message,
Layer_2_Inits, C760009_2.Initialized );
end if;
 
if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then
Fail("C760009_2.Finalize " & Failing_Message,
Layer_2_Finals, C760009_2.Finalized );
end if;
 
if C760009_1.Initialize_Called /= Layer_1_Inits then
Fail("C760009_1.Initialize " & Failing_Message,
Layer_1_Inits,
C760009_1.Initialize_Called );
end if;
 
if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then
Fail("C760009_1.Adjust " & Failing_Message,
Layer_1_Adjs, C760009_1.Adjust_Called );
end if;
 
if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then
Fail("C760009_1.Finalize " & Failing_Message,
Layer_1_Finals, C760009_1.Finalize_Called );
end if;
 
C760009_1.Reset_Counters;
C760009_2.Initialized := 0;
C760009_2.Finalized := 0;
 
end Master_Assertion;
 
procedure Lesser_Assertion( Layer_2_Inits : Natural;
Layer_2_Finals : Natural;
Layer_1_Inits : Natural;
Layer_1_Adjs : Natural;
Layer_1_Finals : Natural;
Failing_Message : String ) is
begin
 
 
if C760009_2.Initialized > Layer_2_Inits then
Fail("C760009_2.Initialize " & Failing_Message,
Layer_2_Inits, C760009_2.Initialized );
end if;
 
if C760009_2.Finalized < Layer_2_Inits
or C760009_2.Finalized > Layer_2_Finals*2 then
Fail("C760009_2.Finalize " & Failing_Message,
Layer_2_Finals, C760009_2.Finalized );
end if;
 
if C760009_1.Initialize_Called > Layer_1_Inits then
Fail("C760009_1.Initialize " & Failing_Message,
Layer_1_Inits,
C760009_1.Initialize_Called );
end if;
 
if C760009_1.Adjust_Called > Layer_1_Adjs*2 then
Fail("C760009_1.Adjust " & Failing_Message,
Layer_1_Adjs, C760009_1.Adjust_Called );
end if;
 
if C760009_1.Finalize_Called < Layer_1_Inits
or C760009_1.Finalize_Called > Layer_1_Finals*2 then
Fail("C760009_1.Finalize " & Failing_Message,
Layer_1_Finals, C760009_1.Finalize_Called );
end if;
 
C760009_1.Reset_Counters;
C760009_2.Initialized := 0;
C760009_2.Finalized := 0;
 
end Lesser_Assertion;
 
begin -- Main test procedure.
 
Report.Test ("C760009", "Check that for an extension_aggregate whose " &
"ancestor_part is a subtype_mark, Initialize " &
"is called on all controlled subcomponents of " &
"the ancestor part. Also check that the " &
"utilization of a controlled type for a generic " &
"actual parameter supports the correct behavior " &
"in the instantiated software" );
 
C760009_1.TC_Trace( "=====> Case 0 <=====" );
 
C760009_1.Reset_Counters;
C760009_2.Initialized := 0;
C760009_2.Finalized := 0;
 
C760009_3.Validate( Global_Control ); -- check that it Initialized correctly
 
C760009_1.TC_Trace( "=====> Case 1 <=====" );
 
C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) );
Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );
-- | | | | + Finalize 2 embedded in aggregate
-- | | | | + Finalize 2 at assignment in TC_Check_1
-- | | | | + Finalize 2 embedded in local variable
-- | | | + Adjust 2 caused by assignment in TC_Check_1
-- | | | + Adjust at declaration in TC_Check_1
-- | | + Initialize at declaration in TC_Check_1
-- | | + Initialize of aggregate object
-- | + Finalize of assignment target
-- | + Finalize of local variable
-- | + Finalize of aggregate object
-- + Initialize of aggregate object
-- + Initialize of local variable
 
 
C760009_1.TC_Trace( "=====> Case 2 <=====" );
 
C760009_3.Check_1.TC_Check_2( Global_Control );
Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );
-- | | | | + Finalize 2 at assignment in TC_Check_2
-- | | | | + Finalize 2 embedded in local variable
-- | | | + Adjust 2 caused by assignment in TC_Check_2
-- | | | + Adjust at declaration in TC_Check_2
-- | | + Initialize at declaration in TC_Check_2
-- | + Finalize of assignment target
-- | + Finalize of local variable
-- + Initialize of local variable
 
 
C760009_1.TC_Trace( "=====> Case 3 <=====" );
 
Global_Control := ( C760009_2.Control with Data => 2 );
Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" );
-- | | | | + Finalize 2 by assignment
-- | | | + Adjust 2 caused by assignment
-- | | | + Adjust in aggregate creation
-- | | + Initialize of aggregate object
-- | + Finalize of assignment target
-- + Initialize of aggregate object
 
 
C760009_1.TC_Trace( "=====> Case 4 <=====" );
 
C760009_3.Check_1.TC_Check_3( Global_Control );
Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );
-- | | | | + Finalize 2 at assignment in TC_Check_3
-- | | | | + Finalize 2 embedded in local variable
-- | | | + Adjust 2 at assignment in TC_Check_3
-- | | | + Adjust in local variable creation
-- | | + Initialize of local variable in TC_Check_3
-- | + Finalize of assignment target
-- | + Finalize of local variable
-- + Initialize of local variable
 
 
C760009_1.TC_Trace( "=====> Case 5 <=====" );
 
Global_Control := ( Parent_Control with Data => 3 );
Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" );
-- | | | | + Finalize 2 by assignment
-- | | | + Adjust 2 caused by assignment
-- | | | + Adjust in aggregate creation
-- | | + Initialize of aggregate object
-- | + Finalize of assignment target
-- + Initialize of aggregate object
 
 
 
C760009_1.TC_Trace( "=====> Case 6 <=====" );
 
-- perform this check a second time to make sure nothing is "remembered"
 
C760009_3.Check_1.TC_Check_3( Global_Control );
Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );
-- | | | | + Finalize 2 at assignment in TC_Check_3
-- | | | | + Finalize 2 embedded in local variable
-- | | | + Adjust 2 at assignment in TC_Check_3
-- | | | + Adjust in local variable creation
-- | | + Initialize of local variable in TC_Check_3
-- | + Finalize of assignment target
-- | + Finalize of local variable
-- + Initialize of local variable
 
 
Report.Result;
 
end C760009;
/c72001b.ada
0,0 → 1,96
-- C72001B.ADA
 
-- 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.
--*
-- CHECK THAT A PACKAGE BODY CAN BE PROVIDED FOR A PACKAGE SPECIFICATION
-- THAT DOES NOT CONTAIN ANY SUBPROGRAM OR TASK DECLARATIONS AND THAT
-- STATEMENTS WITHIN THE PACKAGE BODIES CAN BE USED TO INITIALIZE
-- VARIABLES VISIBLE WITHIN THE PACKAGE BODY.
 
-- RM 04/30/81
-- RM 05/07/81 (TO INCORPORATE OLD TEST OBJECTIVE 7.1/T1 )
-- ABW 6/10/82
-- SPS 11/4/82
-- JBG 9/15/83
 
WITH REPORT;
PROCEDURE C72001B IS
 
USE REPORT;
 
BEGIN
 
TEST( "C72001B" , "CHECK: PACKAGE BODIES CAN INITIALIZE VISIBLE" &
" VARIABLES" );
 
DECLARE
 
 
PACKAGE P5 IS
 
A : CHARACTER := 'B';
B : BOOLEAN := FALSE;
 
PACKAGE P6 IS
I : INTEGER := IDENT_INT(6);
END P6;
 
END P5;
 
 
PACKAGE BODY P5 IS
PACKAGE BODY P6 IS
BEGIN
A := 'C';
I := 17;
B := IDENT_BOOL(TRUE);
END P6;
BEGIN
A := 'A';
END P5;
 
 
USE P5;
USE P6;
 
BEGIN
 
IF A /= 'A' THEN
FAILED ("INITIALIZATIONS NOT CORRECT - 1");
END IF;
 
IF B /= TRUE THEN
FAILED ("INITIALIZATIONS NOT CORRECT - 2");
END IF;
 
IF I /= 17 THEN
FAILED ("INITIALIZATIONS NOT CORRECT - 3");
END IF;
 
END;
 
 
RESULT;
 
 
END C72001B;
/c74211a.ada
0,0 → 1,195
-- C74211A.ADA
 
-- 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.
--*
-- CHECK THAT WITHIN THE PACKAGE SPECIFICATION AND BODY, ANY EXPLICIT
-- DECLARATIONS OF OPERATORS AND SUBPROGRAMS HIDE ANY OPERATIONS WHICH
-- ARE IMPLICITLY DECLARED AT THE POINT OF THE FULL DECLARATION,
-- REGARDLESS OF THE ORDER OF OCCURENCE OF THE DECLARATIONS.
 
-- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS HIDE IMPLICITLY
-- DECLARED PREDEFINED OPERATORS, REGARDLESS OF THE ORDER OF OCCURENCE
-- OF THE DECLARATIONS.
 
-- DSJ 4/28/83
-- JBG 9/23/83
 
-- A) EXPLICIT DECLARATION HIDES LATER IMPLICIT DECL OF PREDEFINED OP.
-- B) " " " LATER " " " DERIVED OP.
-- C) " " " EARLIER " " " PREDEFINED OP.
-- D) " " " EARLIER " " " DERIVED OP.
 
WITH REPORT;
PROCEDURE C74211A IS
 
USE REPORT;
 
BEGIN
 
TEST ("C74211A", "CHECK THAT HIDING OF IMPLICITLY DECLARED " &
"OPERATORS AND DERIVED SUBPROGRAMS IS DONE " &
"CORRECTLY REGARDLESS OF ORDER OF DECL'S");
 
DECLARE
 
PACKAGE P1 IS
TYPE T1 IS RANGE 1 .. 50;
C1 : CONSTANT T1 := T1(IDENT_INT(2));
D1 : CONSTANT T1 := C1 + C1; -- PREDEFINED "+"
FUNCTION "+" (L, R : T1) RETURN T1; -- C) FOR "+".
FUNCTION "-" (L, R : T1) RETURN T1; -- C) FOR "-".
FUNCTION "/" (L, R : T1) RETURN T1;
END P1;
 
USE P1;
 
PACKAGE BODY P1 IS
A,B : T1 := 3;
 
FUNCTION "+" (L, R : T1) RETURN T1 IS
BEGIN
IF L = R THEN
RETURN 1;
ELSE RETURN 2;
END IF;
END "+";
 
FUNCTION "-" (L, R : T1) RETURN T1 IS
BEGIN
IF L = R THEN
RETURN 3;
ELSE RETURN 4;
END IF;
END "-";
 
FUNCTION "/" (L, R : T1) RETURN T1 IS
BEGIN
IF L = R THEN
RETURN T1(IDENT_INT(INTEGER(L)));
ELSE
RETURN T1(IDENT_INT(50));
END IF;
END "/";
 
BEGIN
IF D1 /= 4 THEN
FAILED ("WRONG PREDEFINED OPERATION - '+' ");
END IF;
 
IF D1 + C1 /= 2 THEN
FAILED ("IMPLICIT '+' NOT HIDDEN BY EXPLICIT '+'");
END IF;
 
IF A + B /= 1 THEN
FAILED ("IMPLICIT DECLARATION NOT HIDDEN " &
"BY EXPLICIT DECLARATION - '+' ");
END IF;
 
IF A - B /= 3 THEN
FAILED ("IMPLICIT DECLARATION NOT HIDDEN " &
"BY EXPLICIT DECLARATION - '-' ");
END IF;
 
IF A * B /= 9 THEN
FAILED ("WRONG PREDEFINED OPERATION - '*' ");
END IF;
 
IF B / A /= T1(IDENT_INT(3)) THEN
FAILED ("NOT REDEFINED '/' ");
END IF;
END P1;
 
PACKAGE P2 IS
TYPE T2 IS PRIVATE;
X , Y : CONSTANT T2;
FUNCTION "+" (L, R : T2) RETURN T2; -- B)
FUNCTION "*" (L, R : T2) RETURN T2; -- A)
PRIVATE
TYPE T2 IS NEW T1; -- B) +; A) *
Z : T2 := T2(IDENT_INT(3))/4; -- Z = 50 USING
-- DERIVED /
FUNCTION "/" (L, R : T2) RETURN T2; -- D) FOR /
X , Y : CONSTANT T2 := 3;
END P2;
 
PACKAGE BODY P2 IS
FUNCTION "+" (L, R : T2) RETURN T2 IS
BEGIN
IF L = R THEN
RETURN T2(IDENT_INT(5));
ELSE RETURN T2(IDENT_INT(6));
END IF;
END "+";
 
FUNCTION "*" (L, R : T2) RETURN T2 IS
BEGIN
IF L = R THEN
RETURN T2(IDENT_INT(7));
ELSE RETURN T2(IDENT_INT(8));
END IF;
END "*";
 
FUNCTION "/" (L, R : T2) RETURN T2 IS
BEGIN
IF L = R THEN
RETURN T2(IDENT_INT(9));
ELSE RETURN T2(IDENT_INT(10));
END IF;
END "/";
BEGIN
IF X + Y /= 5 THEN
FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
"EXPLICIT DECLARATION - '+' ");
END IF;
 
IF Y - X /= 3 THEN
FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
"DERIVED SUBPROGRAM - '-' ");
END IF;
 
IF X * Y /= 7 THEN
FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
"EXPLICIT DECLARATION - '*' ");
END IF;
 
IF Y / X /= T2(IDENT_INT(9)) THEN
FAILED ("DERIVED OPERATOR NOT HIDDEN BY " &
"EXPLICIT DECLARATION - '/' ");
END IF;
 
IF Z /= 50 THEN
FAILED ("DERIVED OPERATOR HIDDEN PREMATURELY " &
" BY REDECLARED OPERATOR");
END IF;
 
END P2;
 
BEGIN
 
NULL;
 
END;
 
RESULT;
 
END C74211A;
/c74302a.ada
0,0 → 1,81
-- C74302A.ADA
 
-- 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.
--*
-- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR DEFERRED CONSTANT
-- DECLARATIONS, EVEN IF THE FULL DECLARATIONS ARE GIVEN INDIVIDUALLY.
 
-- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR THE FULL
-- DECLARATIONS, EVEN IF THE DEFERRED CONSTANT DECLARATIONS ARE GIVEN
-- INDIVIDUALLY.
 
 
-- DSJ 5/09/83
-- SPS 10/24/83
-- EG 12/19/83
-- JRK 12/20/83
 
-- DTN 11/19/91 DELETED SUBPART (C).
 
WITH REPORT;
PROCEDURE C74302A IS
 
USE REPORT;
 
BEGIN
 
TEST("C74302A", "CHECK THAT MULTIPLE DECLARATIONS MAY BE USED " &
"FOR DEFERRED CONSTANT DECLARATIONS");
 
DECLARE
 
PACKAGE PACK1 IS
 
TYPE T IS PRIVATE;
 
B, E : CONSTANT T;
 
F : CONSTANT T;
PRIVATE
 
TYPE T IS NEW INTEGER;
 
E : CONSTANT T := T(IDENT_INT(4));
 
B, F : CONSTANT T := T(IDENT_INT(2));
 
END PACK1;
 
USE PACK1;
 
BEGIN
 
IF B/=F THEN
FAILED("VALUES OF DEFERRED CONSTANTS B AND F NOT EQUAL");
END IF;
 
END;
 
RESULT;
 
END C74302A;
/c74211b.ada
0,0 → 1,156
-- C74211B.ADA
 
-- 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.
--*
-- CHECK THAT IMPLICITLY DECLARED INEQUALITY WHICH ACCOMPANIES AN
-- EXPLICIT DECLARATION OF EQUALITY HIDES OTHER IMPLICITLY DECLARED
-- HOMOGRAPHS, AND THAT DERIVED INEQUALITY HIDES PREDEFINED INEQUALITY.
 
-- DSJ 4/29/83
-- JBG 9/23/83
 
WITH REPORT;
PROCEDURE C74211B IS
 
USE REPORT;
 
BEGIN
 
TEST( "C74211B", "CHECK THAT HIDING OF IMPLICITLY DECLARED " &
"OPERATORS AND DERIVED SUBPROGRAMS IS DONE " &
"CORRECTLY REGARDLESS OF ORDER OF DECL'S");
 
DECLARE
 
PACKAGE P1 IS
TYPE LT1 IS LIMITED PRIVATE;
FUNCTION "="(L, R : LT1) RETURN BOOLEAN;
FUNCTION LT1_VALUE_2 RETURN LT1;
FUNCTION LT1_VALUE_4 RETURN LT1;
TYPE LT2 IS LIMITED PRIVATE;
PRIVATE
TYPE LT1 IS RANGE 1 .. 10;
TYPE LT2 IS RANGE 1 .. 10;
END P1;
 
USE P1;
 
PACKAGE P2 IS
TYPE LT3 IS LIMITED PRIVATE;
TYPE LT4 IS NEW LT1;
PRIVATE
FUNCTION "=" (L, R : LT3) RETURN BOOLEAN;
TYPE LT3 IS NEW LT1;
END P2;
 
USE P2;
 
PACKAGE BODY P1 IS
A , B : CONSTANT LT1 := 4;
C , D : CONSTANT LT2 := 6;
 
FUNCTION "=" (L, R : LT1) RETURN BOOLEAN IS
BEGIN
RETURN INTEGER(L) /= INTEGER(R);
END "=";
 
FUNCTION LT1_VALUE_2 RETURN LT1 IS
BEGIN
RETURN 2;
END LT1_VALUE_2;
 
FUNCTION LT1_VALUE_4 RETURN LT1 IS
BEGIN
RETURN 4;
END LT1_VALUE_4;
 
BEGIN
IF A = B THEN
FAILED ("PREDEFINED EQUALITY NOT HIDDEN BY " &
"EXPLICIT DECLARATION - LT1");
END IF;
 
IF C /= D THEN
FAILED ("WRONG PREDEFINED OPERATION - T2");
END IF;
END P1;
 
PACKAGE BODY P2 IS
FUNCTION U RETURN LT3 IS
BEGIN
RETURN LT1_VALUE_2;
END U;
 
FUNCTION V RETURN LT3 IS
BEGIN
RETURN LT1_VALUE_4;
END V;
 
FUNCTION W RETURN LT4 IS
BEGIN
RETURN LT1_VALUE_2;
END W;
 
FUNCTION X RETURN LT4 IS
BEGIN
RETURN LT1_VALUE_4;
END X;
 
FUNCTION "=" (L, R : LT3) RETURN BOOLEAN IS
BEGIN
RETURN NOT (LT1(L) = LT1(R));
END "=";
 
BEGIN
IF NOT (U /= V) THEN
FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
"IMPLICITLY DECLARED INEQUALITY " &
"FROM EXPLICITLY DECLARED EQUALITY");
END IF;
 
IF NOT (LT3(W) = U) THEN
FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " &
"EXPLICIT DECLARATION - '=' ");
END IF;
 
IF W /= X THEN
FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
"DERIVED SUBPROGRAM - '/=' ");
END IF;
 
IF NOT ( X = W ) THEN
FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " &
"DERIVED SUBPROGRAM - '=' ");
END IF;
 
END P2;
 
BEGIN
 
NULL;
 
END;
 
RESULT;
 
END C74211B;
/c74203a.ada
0,0 → 1,263
-- C74203A.ADA
 
-- 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 MEMBERSHIP TESTS, QUALIFICATION, AND EXPLICIT
-- CONVERSION ARE AVAILABLE FOR LIMITED AND NON-LIMITED PRIVATE
-- TYPES. INCLUDE TYPES WITH DISCRIMINANTS AND TYPES
-- WITH LIMITED COMPONENTS.
 
-- HISTORY:
-- BCB 03/10/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74203A IS
 
PACKAGE PP IS
TYPE LIM IS LIMITED PRIVATE;
PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER);
 
TYPE A IS PRIVATE;
SUBTYPE SUBA IS A;
A1 : CONSTANT A;
 
TYPE B IS LIMITED PRIVATE;
B1 : CONSTANT B;
 
TYPE C IS PRIVATE;
C1 : CONSTANT C;
 
TYPE D IS LIMITED PRIVATE;
D1 : CONSTANT D;
 
TYPE E (DISC1 : INTEGER := 5) IS PRIVATE;
SUBTYPE SUBE IS E;
E1 : CONSTANT E;
 
TYPE F (DISC2 : INTEGER := 15) IS LIMITED PRIVATE;
F1 : CONSTANT F;
 
TYPE G (DISC3 : INTEGER) IS PRIVATE;
G1 : CONSTANT G;
 
TYPE H (DISC4 : INTEGER) IS LIMITED PRIVATE;
H1 : CONSTANT H;
 
TYPE I IS RECORD
COMPI : LIM;
END RECORD;
SUBTYPE SUBI IS I;
 
TYPE J IS ARRAY(1..5) OF LIM;
SUBTYPE SUBJ IS J;
 
TYPE S1 IS (VINCE, TOM, PHIL, JODIE, ROSA, TERESA);
TYPE S2 IS (THIS, THAT, THESE, THOSE, THEM);
TYPE S3 IS RANGE 1 .. 100;
TYPE S4 IS RANGE 1 .. 100;
PRIVATE
TYPE LIM IS RANGE 1 .. 100;
 
TYPE A IS (RED, BLUE, GREEN, YELLOW, BLACK, WHITE);
A1 : CONSTANT A := BLUE;
 
TYPE B IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
B1 : CONSTANT B := THREE;
 
TYPE C IS RANGE 1 .. 100;
C1 : CONSTANT C := 50;
 
TYPE D IS RANGE 1 .. 100;
D1 : CONSTANT D := 50;
 
TYPE E (DISC1 : INTEGER := 5) IS RECORD
COMPE : S1;
END RECORD;
E1 : CONSTANT E := (DISC1 => 5, COMPE => TOM);
 
TYPE F (DISC2 : INTEGER := 15) IS RECORD
COMPF : S2;
END RECORD;
F1 : CONSTANT F := (DISC2 => 15, COMPF => THAT);
 
TYPE G (DISC3 : INTEGER) IS RECORD
COMPG : S3;
END RECORD;
G1 : CONSTANT G := (DISC3 => 25, COMPG => 50);
 
TYPE H (DISC4 : INTEGER) IS RECORD
COMPH : S4;
END RECORD;
H1 : CONSTANT H := (DISC4 => 30, COMPH => 50);
END PP;
 
USE PP;
 
AVAR : SUBA := A1;
EVAR : SUBE := E1;
 
IVAR : SUBI;
JVAR : SUBJ;
 
PACKAGE BODY PP IS
PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER) IS
BEGIN
Z1 := LIM (Z2);
END INIT;
BEGIN
NULL;
END PP;
 
PROCEDURE QUAL_PRIV (W : A) IS
BEGIN
NULL;
END QUAL_PRIV;
 
PROCEDURE QUAL_LIM_PRIV (X : B) IS
BEGIN
NULL;
END QUAL_LIM_PRIV;
 
PROCEDURE EXPL_CONV_PRIV_1 (Y : C) IS
BEGIN
NULL;
END EXPL_CONV_PRIV_1;
 
PROCEDURE EXPL_CONV_LIM_PRIV_1 (Z : D) IS
BEGIN
NULL;
END EXPL_CONV_LIM_PRIV_1;
 
PROCEDURE EXPL_CONV_PRIV_2 (Y2 : G) IS
BEGIN
NULL;
END EXPL_CONV_PRIV_2;
 
PROCEDURE EXPL_CONV_LIM_PRIV_2 (Z2 : H) IS
BEGIN
NULL;
END EXPL_CONV_LIM_PRIV_2;
 
PROCEDURE EXPL_CONV_PRIV_3 (Y3 : I) IS
BEGIN
NULL;
END EXPL_CONV_PRIV_3;
 
PROCEDURE EXPL_CONV_PRIV_4 (Y4 : J) IS
BEGIN
NULL;
END EXPL_CONV_PRIV_4;
 
BEGIN
TEST ("C74203A", "CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, " &
"AND EXPLICIT CONVERSION ARE AVAILABLE FOR " &
"LIMITED AND NON-LIMITED PRIVATE TYPES. " &
"INCLUDE TYPES WITH DISCRIMINANTS AND " &
"TYPES WITH LIMITED COMPONENTS");
 
INIT (IVAR.COMPI, 50);
 
FOR K IN IDENT_INT (1) .. IDENT_INT (5) LOOP
INIT (JVAR(K), 25);
END LOOP;
 
IF NOT (AVAR IN A) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"PRIVATE TYPE - 1");
END IF;
 
IF (AVAR NOT IN A) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"PRIVATE TYPE - 1");
END IF;
 
IF NOT (B1 IN B) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"LIMITED PRIVATE TYPE - 1");
END IF;
 
IF (B1 NOT IN B) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"LIMITED PRIVATE TYPE - 1");
END IF;
 
QUAL_PRIV (A'(AVAR));
 
QUAL_LIM_PRIV (B'(B1));
 
EXPL_CONV_PRIV_1 (C(C1));
 
EXPL_CONV_LIM_PRIV_1 (D(D1));
 
IF NOT (EVAR IN E) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"PRIVATE TYPE - 2");
END IF;
 
IF (EVAR NOT IN E) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"PRIVATE TYPE - 2");
END IF;
 
IF NOT (F1 IN F) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"LIMITED PRIVATE TYPE - 2");
END IF;
 
IF (F1 NOT IN F) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"LIMITED PRIVATE TYPE - 2");
END IF;
 
EXPL_CONV_PRIV_2 (G(G1));
 
EXPL_CONV_LIM_PRIV_2 (H(H1));
 
IF NOT (IVAR IN I) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"PRIVATE TYPE - 3");
END IF;
 
IF (IVAR NOT IN I) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"PRIVATE TYPE - 3");
END IF;
 
EXPL_CONV_PRIV_3 (I(IVAR));
 
IF NOT (JVAR IN J) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
"PRIVATE TYPE - 4");
END IF;
 
IF (JVAR NOT IN J) THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
"PRIVATE TYPE - 4");
END IF;
 
EXPL_CONV_PRIV_4 (J(JVAR));
 
RESULT;
END C74203A;
/c74302b.ada
0,0 → 1,308
-- C74302B.ADA
 
-- 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 WHEN THE FULL DECLARATION OF A DEFERRED CONSTANT IS
-- GIVEN AS A MULTIPLE DECLARATION, THE INITIALIZATION EXPRESSION
-- IS EVALUATED ONCE FOR EACH DEFERRED CONSTANT. (USE ENUMERATION,
-- INTEGER, FIXED POINT, FLOATING POINT, ARRAY, RECORD (INCLUDING
-- USE OF DEFAULT EXPRESSIONS FOR COMPONENTS), ACCESS, AND PRIVATE
-- TYPES AS FULL DECLARATION OF PRIVATE TYPE)
 
-- HISTORY:
-- BCB 07/25/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74302B IS
 
TYPE ARR_RAN IS RANGE 1..2;
 
BUMP : INTEGER := IDENT_INT(0);
 
GENERIC
TYPE DT IS (<>);
FUNCTION F1 RETURN DT;
 
GENERIC
TYPE FE IS DELTA <>;
FUNCTION F2 RETURN FE;
 
GENERIC
TYPE FLE IS DIGITS <>;
FUNCTION F3 RETURN FLE;
 
GENERIC
TYPE CA IS ARRAY(ARR_RAN) OF INTEGER;
FUNCTION F4 RETURN CA;
 
GENERIC
TYPE GP IS LIMITED PRIVATE;
FUNCTION F5 (V : GP) RETURN GP;
 
GENERIC
TYPE GP1 IS LIMITED PRIVATE;
FUNCTION F6 (V1 : GP1) RETURN GP1;
 
GENERIC
TYPE AC IS ACCESS INTEGER;
FUNCTION F7 RETURN AC;
 
GENERIC
TYPE PP IS PRIVATE;
FUNCTION F8 (P1 : PP) RETURN PP;
 
FUNCTION F1 RETURN DT IS
BEGIN
BUMP := BUMP + 1;
RETURN DT'VAL(BUMP);
END F1;
 
FUNCTION F2 RETURN FE IS
BEGIN
BUMP := BUMP + 1;
RETURN FE(BUMP);
END F2;
 
FUNCTION F3 RETURN FLE IS
BEGIN
BUMP := BUMP + 1;
RETURN FLE(BUMP);
END F3;
 
FUNCTION F4 RETURN CA IS
BEGIN
BUMP := BUMP + 1;
RETURN ((BUMP,BUMP-1));
END F4;
 
FUNCTION F5 (V : GP) RETURN GP IS
BEGIN
BUMP := BUMP + 1;
RETURN V;
END F5;
 
FUNCTION F6 (V1 : GP1) RETURN GP1 IS
BEGIN
BUMP := BUMP + 1;
RETURN V1;
END F6;
 
FUNCTION F7 RETURN AC IS
VAR : AC;
BEGIN
BUMP := BUMP + 1;
VAR := NEW INTEGER'(BUMP);
RETURN VAR;
END F7;
 
FUNCTION F8 (P1 : PP) RETURN PP IS
BEGIN
BUMP := BUMP + 1;
RETURN P1;
END F8;
 
PACKAGE PACK IS
TYPE SP IS PRIVATE;
CONS : CONSTANT SP;
PRIVATE
TYPE SP IS RANGE 1 .. 100;
CONS : CONSTANT SP := 50;
END PACK;
 
USE PACK;
 
PACKAGE P IS
TYPE INT IS PRIVATE;
TYPE ENUM IS PRIVATE;
TYPE FIX IS PRIVATE;
TYPE FLT IS PRIVATE;
TYPE CON_ARR IS PRIVATE;
TYPE REC IS PRIVATE;
TYPE REC1 IS PRIVATE;
TYPE ACC IS PRIVATE;
TYPE PRIV IS PRIVATE;
 
GENERIC
TYPE LP IS PRIVATE;
FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN;
 
I1, I2, I3, I4 : CONSTANT INT;
E1, E2, E3, E4 : CONSTANT ENUM;
FI1, FI2, FI3, FI4 : CONSTANT FIX;
FL1, FL2, FL3, FL4 : CONSTANT FLT;
CA1, CA2, CA3, CA4 : CONSTANT CON_ARR;
R1, R2, R3, R4 : CONSTANT REC;
R1A, R2A, R3A, R4A : CONSTANT REC1;
A1, A2, A3, A4 : CONSTANT ACC;
PR1, PR2, PR3, PR4 : CONSTANT PRIV;
PRIVATE
TYPE INT IS RANGE 1 .. 100;
 
TYPE ENUM IS (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE);
 
TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0;
 
TYPE FLT IS DIGITS 5 RANGE -100.0 .. 100.0;
 
TYPE CON_ARR IS ARRAY(ARR_RAN) OF INTEGER;
 
TYPE REC IS RECORD
COMP1 : INTEGER;
COMP2 : INTEGER;
COMP3 : BOOLEAN;
END RECORD;
 
TYPE REC1 IS RECORD
COMP1 : INTEGER := 10;
COMP2 : INTEGER := 20;
COMP3 : BOOLEAN := FALSE;
END RECORD;
 
TYPE ACC IS ACCESS INTEGER;
 
TYPE PRIV IS NEW SP;
 
FUNCTION DDT IS NEW F1 (INT);
FUNCTION EDT IS NEW F1 (ENUM);
FUNCTION FDT IS NEW F2 (FIX);
FUNCTION FLDT IS NEW F3 (FLT);
FUNCTION CADT IS NEW F4 (CON_ARR);
FUNCTION RDT IS NEW F5 (REC);
FUNCTION R1DT IS NEW F6 (REC1);
FUNCTION ADT IS NEW F7 (ACC);
FUNCTION PDT IS NEW F8 (PRIV);
 
REC_OBJ : REC := (1,2,TRUE);
REC1_OBJ : REC1 := (3,4,FALSE);
 
I1, I2, I3, I4 : CONSTANT INT := DDT;
E1, E2, E3, E4 : CONSTANT ENUM := EDT;
FI1, FI2, FI3, FI4 : CONSTANT FIX := FDT;
FL1, FL2, FL3, FL4 : CONSTANT FLT := FLDT;
CA1, CA2, CA3, CA4 : CONSTANT CON_ARR := CADT;
R1, R2, R3, R4 : CONSTANT REC := RDT(REC_OBJ);
R1A, R2A, R3A, R4A : CONSTANT REC1 := R1DT(REC1_OBJ);
A1, A2, A3, A4 : CONSTANT ACC := ADT;
PR1, PR2, PR3, PR4 : CONSTANT PRIV := PDT(PRIV(CONS));
END P;
 
PACKAGE BODY P IS
AVAR1 : ACC := NEW INTEGER'(29);
AVAR2 : ACC := NEW INTEGER'(30);
AVAR3 : ACC := NEW INTEGER'(31);
AVAR4 : ACC := NEW INTEGER'(32);
 
FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN IS
BEGIN
RETURN Z1 = Z2;
END GEN_EQUAL;
 
FUNCTION INT_EQUAL IS NEW GEN_EQUAL (INT);
FUNCTION ENUM_EQUAL IS NEW GEN_EQUAL (ENUM);
FUNCTION FIX_EQUAL IS NEW GEN_EQUAL (FIX);
FUNCTION FLT_EQUAL IS NEW GEN_EQUAL (FLT);
FUNCTION ARR_EQUAL IS NEW GEN_EQUAL (CON_ARR);
FUNCTION REC_EQUAL IS NEW GEN_EQUAL (REC);
FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1);
FUNCTION ACC_EQUAL IS NEW GEN_EQUAL (INTEGER);
FUNCTION PRIV_EQUAL IS NEW GEN_EQUAL (PRIV);
BEGIN
TEST ("C74302B", "CHECK THAT WHEN THE FULL DECLARATION OF " &
"A DEFERRED CONSTANT IS GIVEN AS A " &
"MULTIPLE DECLARATION, THE INITIALIZATION " &
"EXPRESSION IS EVALUATED ONCE FOR EACH " &
"DEFERRED CONSTANT");
 
IF NOT EQUAL(BUMP,36) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED CONSTANTS IN A MULIPLE DECLARATION");
END IF;
 
IF NOT INT_EQUAL(I1,1) OR NOT INT_EQUAL(I2,2) OR
NOT INT_EQUAL(I3,3) OR NOT INT_EQUAL(I4,4) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED INTEGER CONSTANTS");
END IF;
 
IF NOT ENUM_EQUAL(E1,SIX) OR NOT ENUM_EQUAL(E2,SEVEN) OR
NOT ENUM_EQUAL(E3,EIGHT) OR NOT ENUM_EQUAL(E4,NINE) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED ENUMERATION CONSTANTS");
END IF;
 
IF NOT FIX_EQUAL(FI1,9.0) OR NOT FIX_EQUAL(FI2,10.0) OR
NOT FIX_EQUAL(FI3,11.0) OR NOT FIX_EQUAL(FI4,12.0) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED FIXED POINT CONSTANTS");
END IF;
 
IF NOT FLT_EQUAL(FL1,13.0) OR NOT FLT_EQUAL(FL2,14.0) OR
NOT FLT_EQUAL(FL3,15.0) OR NOT FLT_EQUAL(FL4,16.0) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED FLOATING POINT CONSTANTS");
END IF;
 
IF NOT ARR_EQUAL(CA1,(17,16)) OR NOT ARR_EQUAL(CA2,(18,17))
OR NOT ARR_EQUAL(CA3,(19,18)) OR NOT ARR_EQUAL(CA4,(20,19))
THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED ARRAY CONSTANTS");
END IF;
 
IF NOT REC_EQUAL(R1,REC_OBJ) OR NOT REC_EQUAL(R2,REC_OBJ)
OR NOT REC_EQUAL(R3,REC_OBJ) OR NOT REC_EQUAL(R4,REC_OBJ)
THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED RECORD CONSTANTS");
END IF;
 
IF NOT REC1_EQUAL(R1A,REC1_OBJ) OR NOT REC1_EQUAL(R2A,
REC1_OBJ) OR NOT REC1_EQUAL(R3A,REC1_OBJ) OR NOT
REC1_EQUAL(R4A,REC1_OBJ) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED RECORD CONSTANTS WITH DEFAULT " &
"EXPRESSIONS");
END IF;
 
IF NOT ACC_EQUAL(A1.ALL,AVAR1.ALL) OR NOT ACC_EQUAL(A2.ALL,
AVAR2.ALL) OR NOT ACC_EQUAL(A3.ALL,AVAR3.ALL) OR NOT
ACC_EQUAL(A4.ALL,AVAR4.ALL) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED ACCESS CONSTANTS");
END IF;
 
IF NOT PRIV_EQUAL(PR1,PRIV(CONS)) OR NOT PRIV_EQUAL(PR2,
PRIV(CONS)) OR NOT PRIV_EQUAL(PR3,PRIV(CONS)) OR NOT
PRIV_EQUAL(PR4,PRIV(CONS)) THEN
FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " &
"DEFERRED PRIVATE CONSTANTS");
END IF;
 
RESULT;
END P;
 
USE P;
 
BEGIN
NULL;
END C74302B;
/c74401d.ada
0,0 → 1,111
-- C74401D.ADA
 
-- 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.
--*
-- CHECK THAT AN OUT PARAMETER HAVING A LIMITED TYPE IS ALLOWED FOR
-- FORMAL SUBPROGRAM PARAMETERS. (ONLY THE CASE OF PRACTICAL INTEREST,
-- NAMELY, LIMITED PRIVATE TYPES, IS CHECKED HERE.)
 
-- CHECK THAT AN OUT PARAMETER IN A RENAMING DECLARATION CAN HAVE A
-- LIMITED PRIVATE TYPE WHEN IT RENAMES A GENERIC FORMAL SUBPROGRAM.
 
-- JBG 5/1/85
 
WITH REPORT; USE REPORT;
PROCEDURE C74401D IS
 
PACKAGE P IS
TYPE LP IS LIMITED PRIVATE;
PROCEDURE P1 (X : OUT LP);
PROCEDURE P2 (X : OUT LP);
FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
VAL1 : CONSTANT LP;
VAL2 : CONSTANT LP;
PRIVATE
TYPE LP IS NEW INTEGER;
VAL1 : CONSTANT LP := LP(IDENT_INT(3));
VAL2 : CONSTANT LP := LP(IDENT_INT(-3));
END P;
 
PACKAGE BODY P IS
PROCEDURE P1 (X : OUT LP) IS
BEGIN
X := 3;
END P1;
 
PROCEDURE P2 (X : OUT LP) IS
BEGIN
X := -3;
END P2;
 
FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN L = R;
END EQ;
END P;
 
GENERIC
WITH PROCEDURE P3 (Y : OUT P.LP);
TYPE GLP IS LIMITED PRIVATE;
WITH PROCEDURE P4 (Y : OUT GLP);
VAL_P3 : IN OUT P.LP;
VAL_P4 : IN OUT GLP;
PACKAGE GPACK IS
PROCEDURE RENAMED (X : OUT GLP) RENAMES P4; -- OK. RENAMING.
END GPACK;
 
PACKAGE BODY GPACK IS
BEGIN
P3 (VAL_P3);
P4 (VAL_P4);
END GPACK;
 
BEGIN
 
TEST ("C74401D", "CHECK THAT GENERIC FORMAL SUBPROGRAMS CAN HAVE "&
"LIMITED PRIVATE OUT PARAMETERS");
 
DECLARE
VAR1 : P.LP;
VAR2 : P.LP;
PACKAGE PACK IS NEW GPACK (P.P1, P.LP, P.P2, VAR1, VAR2);
BEGIN
IF NOT P.EQ (VAR1, P.VAL1) THEN
FAILED ("P1 INVOCATION INCORRECT");
END IF;
 
IF NOT P.EQ (VAR2, P.VAL2) THEN
FAILED ("P2 INVOCATION INCORRECT");
END IF;
 
P.P1 (VAR2); -- RESET VALUE OF VAR2.
PACK.RENAMED (VAR2);
 
IF NOT P.EQ (VAR2, P.VAL2) THEN
FAILED ("RENAMED INVOCATION INCORRECT");
END IF;
END;
 
RESULT;
 
END C74401D;
/c74306a.ada
0,0 → 1,279
-- C74306A.ADA
 
-- 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:
-- AFTER THE FULL DECLARATION OF A DEFERRED CONSTANT, THE VALUE OF
-- THE CONSTANT MAY BE USED IN ANY EXPRESSION, PARTICULARLY
-- EXPRESSIONS IN WHICH THE USE WOULD BE ILLEGAL BEFORE THE FULL
-- DECLARATION.
 
-- HISTORY:
-- BCB 03/14/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74306A IS
 
GENERIC
TYPE GENERAL_PURPOSE IS LIMITED PRIVATE;
Y : IN OUT GENERAL_PURPOSE;
FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE;
 
FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS
BEGIN
IF EQUAL(3,3) THEN
RETURN X;
END IF;
RETURN Y;
END IDENT;
 
PACKAGE P IS
TYPE T IS PRIVATE;
C : CONSTANT T;
PRIVATE
TYPE T IS RANGE 1 .. 100;
 
TYPE A IS ARRAY(1..2) OF T;
 
TYPE B IS ARRAY(INTEGER RANGE <>) OF T;
 
TYPE D (DISC : T) IS RECORD
NULL;
END RECORD;
 
C : CONSTANT T := 50;
 
PARAM : T := 99;
 
FUNCTION IDENT_T IS NEW IDENT (T, PARAM);
 
FUNCTION F (X : T := C) RETURN T;
 
SUBTYPE RAN IS T RANGE 1 .. C;
 
SUBTYPE IND IS B(1..INTEGER(C));
 
SUBTYPE DIS IS D (DISC => C);
 
OBJ : T := C;
 
CON : CONSTANT T := C;
 
ARR : A := (5, C);
 
PAR : T := IDENT_T (C);
 
RANOBJ : T RANGE 1 .. C := C;
 
INDOBJ : B(1..INTEGER(C));
 
DIS_VAL : DIS;
 
REN : T RENAMES C;
 
GENERIC
FOR_PAR : T := C;
PACKAGE GENPACK IS
VAL : T;
END GENPACK;
 
GENERIC
IN_PAR : IN T;
PACKAGE NEWPACK IS
IN_VAL : T;
END NEWPACK;
END P;
 
USE P;
 
PACKAGE BODY P IS
TYPE A1 IS ARRAY(1..2) OF T;
 
TYPE B1 IS ARRAY(INTEGER RANGE <>) OF T;
 
TYPE D1 (DISC1 : T) IS RECORD
NULL;
END RECORD;
 
SUBTYPE RAN1 IS T RANGE 1 .. C;
 
SUBTYPE IND1 IS B1(1..INTEGER(C));
 
SUBTYPE DIS1 IS D1 (DISC1 => C);
 
OBJ1 : T := C;
 
FUNCVAR : T;
 
CON1 : CONSTANT T := C;
 
ARR1 : A1 := (5, C);
 
PAR1 : T := IDENT_T (C);
 
RANOBJ1 : T RANGE 1 .. C := C;
 
INDOBJ1 : B1(1..INTEGER(C));
 
DIS_VAL1 : DIS1;
 
REN1 : T RENAMES C;
 
FUNCTION F (X : T := C) RETURN T IS
BEGIN
RETURN C;
END F;
 
PACKAGE BODY GENPACK IS
BEGIN
VAL := FOR_PAR;
END GENPACK;
 
PACKAGE BODY NEWPACK IS
BEGIN
IN_VAL := IN_PAR;
END NEWPACK;
 
PACKAGE PACK IS NEW GENPACK (FOR_PAR => C);
 
PACKAGE NPACK IS NEW NEWPACK (IN_PAR => C);
BEGIN
TEST ("C74306A", "AFTER THE FULL DECLARATION OF A DEFERRED " &
"CONSTANT, THE VALUE OF THE CONSTANT MAY " &
"BE USED IN ANY EXPRESSION, PARTICULARLY " &
"EXPRESSIONS IN WHICH THE USE WOULD BE " &
"ILLEGAL BEFORE THE FULL DECLARATION");
 
IF OBJ /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR OBJ");
END IF;
 
IF CON /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR CON");
END IF;
 
IF ARR /= (IDENT_T(5), IDENT_T(50)) THEN
FAILED ("IMPROPER VALUES FOR ARR");
END IF;
 
IF PAR /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR PAR");
END IF;
 
IF OBJ1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR OBJ1");
END IF;
 
IF CON1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR CON1");
END IF;
 
IF ARR1 /= (IDENT_T(5), IDENT_T(50)) THEN
FAILED ("IMPROPER VALUES FOR ARR1");
END IF;
 
IF PAR1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR PAR1");
END IF;
 
IF PACK.VAL /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR PACK.VAL");
END IF;
 
IF NPACK.IN_VAL /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR NPACK.IN_VAL");
END IF;
 
IF RAN'LAST /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR RAN'LAST");
END IF;
 
IF RANOBJ /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR RANOBJ");
END IF;
 
IF IND'LAST /= IDENT_INT(50) THEN
FAILED ("IMPROPER VALUE FOR IND'LAST");
END IF;
 
IF INDOBJ'LAST /= IDENT_INT(50) THEN
FAILED ("IMPROPER VALUE FOR INDOBJ'LAST");
END IF;
 
IF DIS_VAL.DISC /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR DIS_VAL.DISC");
END IF;
 
IF REN /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR REN");
END IF;
 
IF RAN1'LAST /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR RAN1'LAST");
END IF;
 
IF RANOBJ1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR RANOBJ1");
END IF;
 
IF IND1'LAST /= IDENT_INT(50) THEN
FAILED ("IMPROPER VALUE FOR IND1'LAST");
END IF;
 
IF INDOBJ1'LAST /= IDENT_INT(50) THEN
FAILED ("IMPROPER VALUE FOR INDOBJ1'LAST");
END IF;
 
IF DIS_VAL1.DISC1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR DIS_VAL1.DISC1");
END IF;
 
IF REN1 /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR REN1");
END IF;
 
FUNCVAR := F(C);
 
IF FUNCVAR /= IDENT_T(50) THEN
FAILED ("IMPROPER VALUE FOR FUNCVAR");
END IF;
 
RESULT;
END P;
 
BEGIN
DECLARE
TYPE ARR IS ARRAY(1..2) OF T;
 
VAL1 : T := C;
 
VAL2 : ARR := (C, C);
 
VAL3 : T RENAMES C;
BEGIN
NULL;
END;
 
NULL;
END C74306A;
/c74401e.ada
0,0 → 1,120
-- C74401E.ADA
 
-- 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.
--*
-- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE
-- DECLARED IN A PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES
-- NESTED IN A VISIBLE PART.
 
-- CHECK THAT A RENAMING DECLARATION CAN RENAME A PROCEDURE DECLARED
-- WITH AN OUT PARAMETER.
 
-- JBG 5/1/85
 
WITH REPORT; USE REPORT;
PROCEDURE C74401E IS
 
PACKAGE PKG IS
TYPE LP IS LIMITED PRIVATE;
PROCEDURE P20 (X : OUT LP); -- OK.
PROCEDURE RESET (X : OUT LP);
FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
VAL1 : CONSTANT LP;
 
PACKAGE NESTED IS
PROCEDURE NEST1 (X : OUT LP);
PRIVATE
PROCEDURE NEST2 (X : OUT LP);
END NESTED;
PRIVATE
TYPE LP IS NEW INTEGER;
VAL1 : CONSTANT LP := LP(IDENT_INT(3));
END PKG;
 
VAR : PKG.LP;
 
PACKAGE BODY PKG IS
PROCEDURE P20 (X : OUT LP) IS
BEGIN
X := 3;
END P20;
 
PROCEDURE RESET (X : OUT LP) IS
BEGIN
X := LP(IDENT_INT(0));
END RESET;
 
FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN L = R;
END EQ;
 
PACKAGE BODY NESTED IS
PROCEDURE NEST1 (X : OUT LP) IS
BEGIN
X := 3;
END NEST1;
 
PROCEDURE NEST2 (X : OUT LP) IS
BEGIN
X := LP(IDENT_INT(3));
END NEST2;
END NESTED;
BEGIN
VAR := LP(IDENT_INT(0));
END PKG;
 
PACKAGE PKG1 IS
PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20; -- OK:
-- RENAMING.
END PKG1;
 
BEGIN
 
TEST ("C74401E", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
"PARAMETER WITH A LIMITED PRIVATE TYPE");
 
PKG.RESET (VAR);
PKG.P20 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("DIRECT CALL NOT CORRECT");
END IF;
 
PKG.RESET (VAR);
PKG1.P21 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("RENAMED CALL NOT CORRECT");
END IF;
 
PKG.RESET (VAR);
PKG.NESTED.NEST1 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("NESTED CALL NOT CORRECT");
END IF;
 
RESULT;
 
END C74401E;
/c74207b.ada
0,0 → 1,75
-- C74207B.ADA
 
-- 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.
--*
-- CHECK THAT 'CONSTRAINED CAN BE APPLIED AFTER THE FULL DECLARATION OF
-- A PRIVATE TYPE THAT IS DERIVED FROM A PRIVATE TYPE.
 
-- BHS 6/18/84
 
WITH REPORT;
USE REPORT;
PROCEDURE C74207B IS
BEGIN
TEST ("C74207B", "AFTER THE FULL DECLARATION OF A PRIVATE " &
"TYPE DERIVED FROM A PRIVATE TYPE, " &
"'CONSTRAINED MAY BE APPLIED");
 
DECLARE
PACKAGE P1 IS
TYPE PREC (D : INTEGER) IS PRIVATE;
TYPE P IS PRIVATE;
PRIVATE
TYPE PREC (D : INTEGER) IS RECORD
NULL;
END RECORD;
TYPE P IS NEW INTEGER;
END P1;
 
PACKAGE P2 IS
TYPE LP1 IS LIMITED PRIVATE;
TYPE LP2 IS LIMITED PRIVATE;
PRIVATE
TYPE LP1 IS NEW P1.PREC(3);
TYPE LP2 IS NEW P1.P;
B1 : BOOLEAN := LP1'CONSTRAINED;
B2 : BOOLEAN := LP2'CONSTRAINED;
END P2;
 
PACKAGE BODY P2 IS
BEGIN
IF NOT IDENT_BOOL(B1) THEN
FAILED ("WRONG VALUE FOR LP1'CONSTRAINED");
END IF;
IF NOT IDENT_BOOL(B2) THEN
FAILED ("WRONG VALUE FOR LP2'CONSTRAINED");
END IF;
END P2;
 
BEGIN
NULL;
END;
 
RESULT;
 
END C74207B;
/c731001.a
0,0 → 1,407
-- C731001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
-- F08630-91-C-0015, 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 WHATSOVER, 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 inherited operations can be overridden, even when they are
-- inherited in a body.
-- The test cases here are inspired by the AARM examples given in
-- the discussion of AARM-7.3.1(7.a-7.v).
-- This discussion was confirmed by AI95-00035.
--
-- TEST DESCRIPTION
-- See AARM-7.3.1.
--
-- CHANGE HISTORY:
-- 29 JUN 1999 RAD Initial Version
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
-- 20 AUG 2001 RLB Corrected 'verbose' flag.
--
--!
 
with Report; use Report; pragma Elaborate_All(Report);
package C731001_1 is
pragma Elaborate_Body;
private
procedure Check_String(X, Y: String);
function Check_String(X, Y: String) return String;
-- This one is a function, so we can call it in package specs.
end C731001_1;
 
package body C731001_1 is
 
Verbose: Boolean := False;
 
procedure Check_String(X, Y: String) is
begin
if Verbose then
Comment("""" & X & """ = """ & Y & """?");
end if;
if X /= Y then
Failed("""" & X & """ should be """ & Y & """");
end if;
end Check_String;
 
function Check_String(X, Y: String) return String is
begin
Check_String(X, Y);
return X;
end Check_String;
 
end C731001_1;
 
private package C731001_1.Parent is
 
procedure Call_Main;
 
type Root is tagged null record;
subtype Renames_Root is Root;
subtype Root_Class is Renames_Root'Class;
function Make return Root;
function Op1(X: Root) return String;
function Call_Op2(X: Root'Class) return String;
private
function Op2(X: Root) return String;
end C731001_1.Parent;
 
procedure C731001_1.Parent.Main;
 
with C731001_1.Parent.Main;
package body C731001_1.Parent is
 
procedure Call_Main is
begin
Main;
end Call_Main;
 
function Make return Root is
Result: Root;
begin
return Result;
end Make;
 
function Op1(X: Root) return String is
begin
return "Parent.Op1 body";
end Op1;
 
function Op2(X: Root) return String is
begin
return "Parent.Op2 body";
end Op2;
 
function Call_Op2(X: Root'Class) return String is
begin
return Op2(X);
end Call_Op2;
 
begin
 
Check_String(Op1(Root'(Make)), "Parent.Op1 body");
Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
 
Check_String(Op2(Root'(Make)), "Parent.Op2 body");
Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
 
end C731001_1.Parent;
 
with C731001_1.Parent; use C731001_1.Parent;
private package C731001_1.Unrelated is
 
type T2 is new Root with null record;
subtype T2_Class is T2'Class;
function Make return T2;
function Op2(X: T2) return String;
end C731001_1.Unrelated;
 
with C731001_1.Parent; use C731001_1.Parent;
pragma Elaborate(C731001_1.Parent);
package body C731001_1.Unrelated is
 
function Make return T2 is
Result: T2;
begin
return Result;
end Make;
 
function Op2(X: T2) return String is
begin
return "Unrelated.Op2 body";
end Op2;
begin
 
Check_String(Op1(T2'(Make)), "Parent.Op1 body");
Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
 
Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
 
end C731001_1.Unrelated;
 
package C731001_1.Parent.Child is
pragma Elaborate_Body;
 
type T3 is new Root with null record;
subtype T3_Class is T3'Class;
function Make return T3;
 
T3_Obj: T3;
T3_Class_Obj: T3_Class := T3_Obj;
T3_Root_Class_Obj: Root_Class := T3_Obj;
 
X3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 
package Nested is
type T4 is new Root with null record;
subtype T4_Class is T4'Class;
function Make return T4;
 
T4_Obj: T4;
T4_Class_Obj: T4_Class := T4_Obj;
T4_Root_Class_Obj: Root_Class := T4_Obj;
 
X4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
private
 
XX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
end Nested;
 
use Nested;
 
XXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
private
 
XX3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 
XXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
end C731001_1.Parent.Child;
 
with C731001_1.Unrelated; use C731001_1.Unrelated;
pragma Elaborate(C731001_1.Unrelated);
package body C731001_1.Parent.Child is
 
XXX3: constant String :=
Check_String(Op1(T3_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T3_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 
XXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
function Make return T3 is
Result: T3;
begin
return Result;
end Make;
 
package body Nested is
function Make return T4 is
Result: T4;
begin
return Result;
end Make;
 
XXXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
end Nested;
 
type T5 is new T2 with null record;
subtype T5_Class is T5'Class;
function Make return T5;
 
function Make return T5 is
Result: T5;
begin
return Result;
end Make;
 
XXXXXXX4: constant String :=
Check_String(Op1(T4_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
 
Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
end C731001_1.Parent.Child;
 
procedure C731001_1.Main;
 
with C731001_1.Parent;
procedure C731001_1.Main is
begin
C731001_1.Parent.Call_Main;
end C731001_1.Main;
 
with C731001_1.Parent.Child;
use C731001_1.Parent;
use C731001_1.Parent.Child;
use C731001_1.Parent.Child.Nested;
with C731001_1.Unrelated; use C731001_1.Unrelated;
procedure C731001_1.Parent.Main is
 
Root_Obj: Root := Make;
Root_Class_Obj: Root_Class := Root'(Make);
 
T2_Obj: T2 := Make;
T2_Class_Obj: T2_Class := T2_Obj;
T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
 
T3_Obj: T3 := Make;
T3_Class_Obj: T3_Class := T3_Obj;
T3_Root_Class_Obj: Root_Class := T3_Obj;
 
T4_Obj: T4 := Make;
T4_Class_Obj: T4_Class := T4_Obj;
T4_Root_Class_Obj: Root_Class := T4_Obj;
 
begin
Test("C731001_1", "Check that inherited operations can be overridden, even"
& " when they are inherited in a body");
 
Check_String(Op1(Root_Obj), "Parent.Op1 body");
Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
 
Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
 
Check_String(Op1(T2_Obj), "Parent.Op1 body");
Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
 
Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
 
Check_String(Op1(T3_Obj), "Parent.Op1 body");
Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
 
Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
 
Check_String(Op1(T4_Obj), "Parent.Op1 body");
Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
 
Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
 
Result;
end C731001_1.Parent.Main;
 
with C731001_1.Main;
procedure C731001 is
begin
C731001_1.Main;
end C731001;
/c74209a.ada
0,0 → 1,224
-- C74209A.ADA
 
-- 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.
--*
-- CHECK THAT OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED
-- PRIVATE TYPES IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE
-- THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A
-- LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION
-- SUBPROGRAMS).
 
-- RM 07/14/81
 
 
WITH REPORT;
PROCEDURE C74209A IS
 
USE REPORT;
 
BEGIN
 
TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " &
"PRIVATE TYPES" );
 
DECLARE
 
PACKAGE PACK IS
 
TYPE LIM_PRIV IS LIMITED PRIVATE;
TYPE PRIV IS PRIVATE;
PRIV_CONST_IN : CONSTANT PRIV;
PRIV_CONST_OUT : CONSTANT PRIV;
FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV;
FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ;
PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV );
 
PRIVATE
 
TYPE LIM_PRIV IS NEW INTEGER;
TYPE PRIV IS NEW STRING( 1..5 );
PRIV_CONST_IN : CONSTANT PRIV := "ABCDE";
PRIV_CONST_OUT : CONSTANT PRIV := "FGHIJ";
 
END PACK;
 
 
PRIV_VAR_1 , PRIV_VAR_2 : PACK.PRIV;
LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2 : PACK.LIM_PRIV;
 
 
USE PACK;
 
 
PACKAGE BODY PACK IS
 
FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV IS
BEGIN
RETURN LIM_PRIV(X);
END PACKAGED;
 
FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN IS
BEGIN
RETURN X = Y ;
END EQUALS;
 
PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV) IS
BEGIN
Y := X;
END ASSIGN;
 
END PACK;
 
 
PROCEDURE PROC1( X : IN OUT PACK.PRIV;
Y : IN PACK.PRIV := PACK.PRIV_CONST_IN;
Z : OUT PACK.PRIV;
U : PACK.PRIV ) IS
BEGIN
 
IF X /= PACK.PRIV_CONST_IN OR
Y /= PACK.PRIV_CONST_IN OR
U /= PACK.PRIV_CONST_IN
THEN
FAILED( "WRONG INPUT VALUES - PROC1" );
END IF;
 
X := PACK.PRIV_CONST_OUT;
Z := PACK.PRIV_CONST_OUT;
 
END PROC1;
 
 
PROCEDURE PROC2( X : IN OUT LIM_PRIV;
Y : IN LIM_PRIV;
Z : IN OUT LIM_PRIV;
U : LIM_PRIV ) IS
BEGIN
 
IF NOT(EQUALS( X , PACKAGED(17) )) OR
NOT(EQUALS( Y , PACKAGED(17) )) OR
NOT(EQUALS( U , PACKAGED(17) ))
THEN
FAILED( "WRONG INPUT VALUES - PROC2" );
END IF;
 
ASSIGN( PACKAGED(13) , X );
ASSIGN( PACKAGED(13) , Z );
 
END PROC2;
 
 
FUNCTION FUNC1( Y : IN PRIV := PRIV_CONST_IN;
U : PRIV ) RETURN PRIV IS
BEGIN
 
IF Y /= PRIV_CONST_IN OR
U /= PRIV_CONST_IN
THEN
FAILED( "WRONG INPUT VALUES - FUNC1" );
END IF;
 
RETURN PRIV_CONST_OUT;
 
END FUNC1;
 
 
FUNCTION FUNC2( Y : IN LIM_PRIV;
U : LIM_PRIV ) RETURN LIM_PRIV IS
BEGIN
 
IF NOT(EQUALS( Y , PACKAGED(17) )) OR
NOT(EQUALS( U , PACKAGED(17) ))
THEN
FAILED( "WRONG INPUT VALUES - FUNC2" );
END IF;
 
RETURN PACKAGED(13);
 
END FUNC2;
 
 
BEGIN
 
--------------------------------------------------------------
 
PRIV_VAR_1 := PRIV_CONST_IN;
PRIV_VAR_2 := PRIV_CONST_IN;
 
PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN );
 
IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT OR
PRIV_VAR_2 /= PACK.PRIV_CONST_OUT
THEN
FAILED( "WRONG OUTPUT VALUES - PROC1" );
END IF;
 
--------------------------------------------------------------
 
ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
 
PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) ,
LIM_PRIV_VAR_2 , PACKAGED(17) );
 
IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) OR
NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) ))
THEN
FAILED( "WRONG OUTPUT VALUES - PROC2" );
END IF;
 
--------------------------------------------------------------
 
PRIV_VAR_1 := PRIV_CONST_IN;
PRIV_VAR_2 := PRIV_CONST_IN;
 
PRIV_VAR_1 :=
FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN );
 
IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT
THEN
FAILED( "WRONG OUTPUT VALUES - FUNC1" );
END IF;
 
--------------------------------------------------------------
 
ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 );
ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 );
 
ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) ,
LIM_PRIV_VAR_1 );
 
IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) ))
THEN
FAILED( "WRONG OUTPUT VALUES - FUNC2" );
END IF;
 
--------------------------------------------------------------
 
END;
 
 
RESULT;
 
 
END C74209A;
/c74407b.ada
0,0 → 1,195
-- C74407B.ADA
 
-- 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, FOR A LIMITED PRIVATE TYPE, THAT PRE-DEFINED EQUALITY AND
-- ASSIGNMENT ARE DEFINED AND AVAILABLE WITHIN THE PRIVATE PART AND
-- THE BODY OF A PACKAGE, AFTER THE FULL DECLARATION, IF THE FULL
-- DECLARATION IS NOT LIMITED.
 
-- HISTORY:
-- BCB 07/15/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74407B IS
 
PACKAGE PP IS
TYPE PRIV IS PRIVATE;
C1 : CONSTANT PRIV;
C2 : CONSTANT PRIV;
PRIVATE
TYPE PRIV IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
C1 : CONSTANT PRIV := ONE;
C2 : CONSTANT PRIV := TWO;
END PP;
 
USE PP;
 
PACKAGE P IS
TYPE INT IS LIMITED PRIVATE;
TYPE COMP IS LIMITED PRIVATE;
TYPE DER IS LIMITED PRIVATE;
PRIVATE
TYPE INT IS RANGE 1 .. 100;
TYPE COMP IS ARRAY(1..5) OF INTEGER;
TYPE DER IS NEW PRIV;
D, E : INT := 10;
F : INT := 20;
CONS_INT1 : CONSTANT INT := 30;
G : BOOLEAN := D = E;
H : BOOLEAN := D /= F;
CONS_BOOL1 : CONSTANT BOOLEAN := D = E;
CONS_BOOL2 : CONSTANT BOOLEAN := D /= F;
I : COMP := (1,2,3,4,5);
CONS_COMP1 : CONSTANT COMP := (6,7,8,9,10);
J : DER := DER(C1);
CONS_DER1 : CONSTANT DER := DER(C2);
END P;
 
PACKAGE BODY P IS
A, B, C : INT;
X, Y, Z : COMP;
L, M, N : DER;
CONS_INT2 : CONSTANT INT := 10;
CONS_COMP2 : CONSTANT COMP := (1,2,3,4,5);
CONS_DER2 : CONSTANT DER := DER(C1);
BEGIN
TEST ("C74407B", "CHECK, FOR A LIMITED PRIVATE TYPE, THAT " &
"PRE-DEFINED EQUALITY AND ASSIGNMENT ARE " &
"DEFINED AND AVAILABLE WITHIN THE PRIVATE " &
"PART AND THE BODY OF A PACKAGE, AFTER " &
"THE FULL DECLARATION, IF THE FULL " &
"DECLARATION IS NOT LIMITED");
 
A := 10;
 
B := 10;
 
C := 20;
 
IF A = C THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 1");
END IF;
 
IF A /= B THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 1");
END IF;
 
IF CONS_INT2 = C THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 2");
END IF;
 
IF CONS_INT2 /= B THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 2");
END IF;
 
IF NOT G THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PRIVATE PART OF THE " &
"PACKAGE - 1");
END IF;
 
IF NOT H THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PRIVATE PART OF THE " &
"PACKAGE - 1");
END IF;
 
IF NOT CONS_BOOL1 THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PRIVATE PART OF THE " &
"PACKAGE - 2");
END IF;
 
IF NOT CONS_BOOL2 THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PRIVATE PART OF THE " &
"PACKAGE - 2");
END IF;
 
X := (1,2,3,4,5);
 
Y := (1,2,3,4,5);
 
Z := (5,4,3,2,1);
 
IF X = Z THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 3");
END IF;
 
IF X /= Y THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 3");
END IF;
 
IF CONS_COMP2 = Z THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 4");
END IF;
 
IF CONS_COMP2 /= Y THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 4");
END IF;
 
L := DER(C1);
 
M := DER(C1);
 
N := DER(C2);
 
IF L = N THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 5");
END IF;
 
IF L /= M THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 5");
END IF;
 
IF CONS_DER2 = N THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 6");
END IF;
 
IF CONS_DER2 /= M THEN
FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " &
"OPERATION WITHIN THE PACKAGE BODY - 6");
END IF;
 
RESULT;
END P;
 
USE P;
 
BEGIN
NULL;
END C74407B;
/c760010.a
0,0 → 1,418
-- C760010.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 explicit calls to Initialize, Adjust and Finalize
-- procedures that raise exceptions propagate the exception raised,
-- not Program_Error. Check this for both a user defined exception
-- and a language defined exception. Check that implicit calls to
-- initialize procedures that raise an exception propagate the
-- exception raised, not Program_Error;
--
-- Check that the utilization of a controlled type as the actual for
-- a generic formal tagged private parameter supports the correct
-- behavior in the instantiated software.
--
-- TEST DESCRIPTION:
-- Declares a generic package instantiated to check that controlled
-- types are not impacted by the "generic boundary."
-- This instance is then used to perform the tests of various calls to
-- the procedures. After each operation in the main program that should
-- cause implicit calls where an exception is raised, the program handles
-- Program_Error. After each explicit call, the program handles the
-- Expected_Error. Handlers for the opposite exception are provided to
-- catch the obvious failure modes. The predefined exception
-- Tasking_Error is used to be certain that some other reason has not
-- raised a predefined exception.
--
--
-- DATA STRUCTURES
--
-- C760010_1.Simple_Control is derived from
-- Ada.Finalization.Controlled
--
-- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
-- by way of generic instantiation
--
--
-- CHANGE HISTORY:
-- 01 MAY 95 SAIC Initial version
-- 23 APR 96 SAIC Fix visibility problem for 2.1
-- 14 NOV 96 SAIC Revisit for 2.1 release
-- 26 JUN 98 EDS Added pragma Elaborate_Body to
-- package C760010_0.Check_Formal_Tagged
-- to avoid possible instantiation error
--!
 
---------------------------------------------------------------- C760010_0
 
package C760010_0 is
 
User_Defined_Exception : exception;
 
type Actions is ( No_Action,
Init_Raise_User_Defined, Init_Raise_Standard,
Adj_Raise_User_Defined, Adj_Raise_Standard,
Fin_Raise_User_Defined, Fin_Raise_Standard );
 
Action : Actions := No_Action;
 
function Unique return Natural;
 
end C760010_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
package body C760010_0 is
 
Value : Natural := 101;
 
function Unique return Natural is
begin
Value := Value +1;
return Value;
end Unique;
 
end C760010_0;
 
---------------------------------------------------------------- C760010_0
------------------------------------------------------ Check_Formal_Tagged
 
generic
 
type Formal_Tagged is tagged private;
 
package C760010_0.Check_Formal_Tagged is
 
pragma Elaborate_Body;
 
type Embedded_Derived is new Formal_Tagged with record
TC_Meaningless_Value : Natural := Unique;
end record;
 
procedure Initialize( ED: in out Embedded_Derived );
procedure Adjust ( ED: in out Embedded_Derived );
procedure Finalize ( ED: in out Embedded_Derived );
 
end C760010_0.Check_Formal_Tagged;
 
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760010_0.Check_Formal_Tagged is
 
 
procedure Initialize( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Init_Raise_User_Defined => raise User_Defined_Exception;
when Init_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Initialize;
 
procedure Adjust ( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Adj_Raise_User_Defined => raise User_Defined_Exception;
when Adj_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Adjust;
 
procedure Finalize ( ED: in out Embedded_Derived ) is
begin
ED.TC_Meaningless_Value := Unique;
case Action is
when Fin_Raise_User_Defined => raise User_Defined_Exception;
when Fin_Raise_Standard => raise Tasking_Error;
when others => null;
end case;
end Finalize;
 
end C760010_0.Check_Formal_Tagged;
---------------------------------------------------------------- C760010_1
 
with Ada.Finalization;
package C760010_1 is
 
procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
procedure Reset_Counters;
 
type Simple_Control is new Ada.Finalization.Controlled with record
Item: Integer;
end record;
procedure Initialize( AV: in out Simple_Control );
procedure Adjust ( AV: in out Simple_Control );
procedure Finalize ( AV: in out Simple_Control );
 
end C760010_1;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760010_1 is
 
Initialize_Called : Natural;
Adjust_Called : Natural;
Finalize_Called : Natural;
 
procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
begin
if Init /= Initialize_Called then
Report.Failed("Initialize mismatch " & Message);
end if;
if Adj /= Adjust_Called then
Report.Failed("Adjust mismatch " & Message);
end if;
if Fin /= Finalize_Called then
Report.Failed("Finalize mismatch " & Message);
end if;
end Check_Counters;
 
procedure Reset_Counters is
begin
Initialize_Called := 0;
Adjust_Called := 0;
Finalize_Called := 0;
end Reset_Counters;
 
procedure Initialize( AV: in out Simple_Control ) is
begin
Initialize_Called := Initialize_Called +1;
AV.Item := 0;
end Initialize;
 
procedure Adjust ( AV: in out Simple_Control ) is
begin
Adjust_Called := Adjust_Called +1;
AV.Item := AV.Item +1;
end Adjust;
 
procedure Finalize ( AV: in out Simple_Control ) is
begin
Finalize_Called := Finalize_Called +1;
AV.Item := AV.Item +1;
end Finalize;
 
end C760010_1;
---------------------------------------------------------------- C760010_2
 
with C760010_0.Check_Formal_Tagged;
with C760010_1;
package C760010_2 is
new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
---------------------------------------------------------------------------
 
with Report;
with C760010_0;
with C760010_1;
with C760010_2;
procedure C760010 is
 
use type C760010_0.Actions;
 
procedure Case_Failure(Message: String) is
begin
Report.Failed(Message & " for case "
& C760010_0.Actions'Image(C760010_0.Action) );
end Case_Failure;
 
procedure Check_Implicit_Initialize is
Item : C760010_2.Embedded_Derived; -- exception here propagates to
Gadget : C760010_2.Embedded_Derived; -- caller
begin
if C760010_0.Action
in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
then
Case_Failure("Anticipated exception at implicit init");
end if;
begin
Item := Gadget; -- exception here handled locally
if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
.. C760010_0.Fin_Raise_Standard then
Case_Failure ("Anticipated exception at assignment");
end if;
exception
when Program_Error =>
if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
.. C760010_0.Fin_Raise_Standard then
Report.Failed("Program_Error in Check_Implicit_Initialize");
end if;
when Tasking_Error =>
Report.Failed("Tasking_Error in Check_Implicit_Initialize");
when C760010_0.User_Defined_Exception =>
Report.Failed("User_Error in Check_Implicit_Initialize");
when others =>
Report.Failed("Wrong exception Check_Implicit_Initialize");
end;
end Check_Implicit_Initialize;
 
---------------------------------------------------------------------------
 
Global_Item : C760010_2.Embedded_Derived;
 
---------------------------------------------------------------------------
 
procedure Check_Explicit_Initialize is
begin
begin
C760010_2.Initialize( Global_Item );
if C760010_0.Action
in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
then
Case_Failure("Anticipated exception at explicit init");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Initialize");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Init_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Initialize");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Initialize");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Initialize");
end;
end Check_Explicit_Initialize;
 
---------------------------------------------------------------------------
 
procedure Check_Explicit_Adjust is
begin
begin
C760010_2.Adjust( Global_Item );
if C760010_0.Action
in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
then
Case_Failure("Anticipated exception at explicit Adjust");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Adjust");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Adjust");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Adjust");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Adjust");
end;
end Check_Explicit_Adjust;
 
---------------------------------------------------------------------------
 
procedure Check_Explicit_Finalize is
begin
begin
C760010_2.Finalize( Global_Item );
if C760010_0.Action
in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
then
Case_Failure("Anticipated exception at explicit Finalize");
end if;
exception
when Program_Error =>
Report.Failed("Program_Error in Check_Explicit_Finalize");
when Tasking_Error =>
if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
Report.Failed("Tasking_Error in Check_Explicit_Finalize");
end if;
when C760010_0.User_Defined_Exception =>
if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
Report.Failed("User_Error in Check_Explicit_Finalize");
end if;
when others =>
Report.Failed("Wrong exception in Check_Explicit_Finalize");
end;
end Check_Explicit_Finalize;
 
---------------------------------------------------------------------------
 
begin -- Main test procedure.
 
Report.Test ("C760010", "Check that explicit calls to finalization " &
"procedures that raise exceptions propagate " &
"the exception raised. Check the utilization " &
"of a controlled type as the actual for a " &
"generic formal tagged private parameter" );
 
for Act in C760010_0.Actions loop
C760010_1.Reset_Counters;
C760010_0.Action := Act;
 
begin
Check_Implicit_Initialize;
if Act in
C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
Case_Failure("No exception at Check_Implicit_Initialize");
end if;
exception
when Tasking_Error =>
if Act /= C760010_0.Init_Raise_Standard then
Case_Failure("Tasking_Error at Check_Implicit_Initialize");
end if;
when C760010_0.User_Defined_Exception =>
if Act /= C760010_0.Init_Raise_User_Defined then
Case_Failure("User_Error at Check_Implicit_Initialize");
end if;
when Program_Error =>
-- If finalize raises an exception, all other object are finalized
-- first and Program_Error is raised upon leaving the master scope.
-- 7.6.1:14
if Act not in C760010_0.Fin_Raise_User_Defined..
C760010_0.Fin_Raise_Standard then
Case_Failure("Program_Error at Check_Implicit_Initialize");
end if;
when others =>
Case_Failure("Wrong exception at Check_Implicit_Initialize");
end;
 
Check_Explicit_Initialize;
Check_Explicit_Adjust;
Check_Explicit_Finalize;
 
C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
 
end loop;
 
-- Set to No_Action to avoid exception in finalizing Global_Item
C760010_0.Action := C760010_0.No_Action;
 
Report.Result;
 
end C760010;
/c761001.a
0,0 → 1,117
-- C761001.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 controlled objects declared immediately within a library
-- package are finalized following the completion of the environment
-- task (and prior to termination of the program).
--
-- TEST DESCRIPTION:
-- This test derives a type from Ada.Finalization.Controlled, and
-- declares an object of that type in the body of a library package.
-- The dispatching procedure Finalize is redefined for the derived
-- type to perform a check that it has been called only once, and in
-- turn calls Report.Result. This test may fail by not calling
-- Report.Result. This test may also fail by calling Report.Result
-- twice, the first call will report a false pass.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 13 Nov 95 SAIC Updated for ACVC 2.0.1
--
--!
 
with Ada.Finalization;
package C761001_0 is
 
type Global is new Ada.Finalization.Controlled with null record;
procedure Finalize( It: in out Global );
 
end C761001_0;
 
package C761001_1 is
 
task Library_Task is
entry Never_Called;
end Library_Task;
 
end C761001_1;
 
with Report;
with C761001_1;
package body C761001_0 is
 
My_Object : Global;
 
Done : Boolean := False;
 
procedure Finalize( It: in out Global ) is
begin
if not C761001_1.Library_Task'Terminated then
Report.Failed("Library task not terminated before finalize");
end if;
if Done then -- checking included "just in case"
Report.Comment("Test FAILED, even if previously reporting passed");
Report.Failed("Unwarranted multiple call to finalize");
end if;
Report.Result;
Done := True;
end Finalize;
 
end C761001_0;
 
with Report;
package body C761001_1 is
 
task body Library_Task is
begin
if Report.Ident_Int( 1 ) /= 1 then
Report.Failed( "Baseline failure in Library_Task");
end if;
end Library_Task;
 
end C761001_1;
 
with Report;
with C761001_0;
 
procedure C761001 is
 
begin -- Main test procedure.
 
Report.Test ("C761001", "Check that controlled objects declared "
& "immediately within a library package are "
& "finalized following the completion of the "
& "environment task (and prior to termination "
& "of the program)");
 
-- note that if the test DOES call report twice, the first will report a
-- false pass, the second call will correctly fail the test.
 
-- not calling Report.Result;
-- Result is called as part of the finalization of C761001_0.My_Object.
 
end C761001;
/c760011.a
0,0 → 1,291
-- C760011.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 the anonymous objects of a controlled type associated with
-- function results and aggregates are finalized no later than the
-- end of the innermost enclosing declarative_item or statement. Also
-- check this for function calls and aggregates of a noncontrolled type
-- with controlled components.
--
-- TEST DESCRIPTION:
-- This test defines a controlled type with a discriminant, the
-- discriminant is use as an index into a global table to indicate that
-- the object has been finalized. The controlled type is used as the
-- component of a non-controlled type, and the non-controlled type is
-- used for the same set of tests. Following is a table of the tests
-- performed and their associated tag character.
--
-- 7.6(21) allows for the optimizations that remove these temporary
-- objects from ever existing. As such this test checks that in the
-- case the object was initialized (the only access we have to
-- determining if it ever existed) it must subsequently be finalized.
--
-- CASE TABLE:
-- A - aggregate test, controlled
-- B - aggregate test, controlled
-- C - aggregate test, non_controlled
-- D - function test, controlled
-- E - function test, non_controlled
-- F - formal parameter function test, controlled
-- G - formal parameter aggregate test, controlled
-- H - formal parameter function test, non_controlled
-- I - formal parameter aggregate test, non_controlled
--
-- X - scratch object, not consequential to the objective
-- Y - scratch object, not consequential to the objective
-- Z - scratch object, not consequential to the objective
--
--
-- CHANGE HISTORY:
-- 22 MAY 95 SAIC Initial version
-- 24 APR 96 SAIC Minor doc fixes, visibility patch
-- 14 NOV 96 SAIC Revised for release 2.1
--
--!
 
------------------------------------------------------------------- C760011_0
 
with Ada.Finalization;
package C760011_0 is
type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
 
Initialized : Tracking_Array := (others => False);
Finalized : Tracking_Array := (others => False);
 
type Controlled_Type(Tag : Character) is
new Ada.Finalization.Controlled with record
TC_Component : String(1..4) := "ACVC";
end record;
procedure Initialize( It: in out Controlled_Type );
procedure Finalize ( It: in out Controlled_Type );
function Create(With_Tag: Character) return Controlled_Type;
 
type Non_Controlled(Tag : Character := 'Y') is record
Controlled_Component : Controlled_Type(Tag);
end record;
procedure Initialize( It: in out Non_Controlled );
procedure Finalize ( It: in out Non_Controlled );
function Create(With_Tag: Character) return Non_Controlled;
 
Under_Debug : constant Boolean := False; -- construction lines
 
end C760011_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
package body C760011_0 is
 
procedure Initialize( It: in out Controlled_Type ) is
begin
It.TC_Component := (others => It.Tag);
if It.Tag in Tracking_Array'Range then
Initialized(It.Tag) := True;
end if;
if Under_Debug then
Report.Comment("Initializing Tag: " & It.Tag );
end if;
end Initialize;
procedure Finalize( It: in out Controlled_Type ) is
begin
if Under_Debug then
Report.Comment("Finalizing for Tag: " & It.Tag );
end if;
if It.Tag in Finalized'Range then
Finalized(It.Tag) := True;
end if;
end Finalize;
 
function Create(With_Tag: Character) return Controlled_Type is
begin
return Controlled_Type'(Ada.Finalization.Controlled
with Tag => With_Tag,
TC_Component => "*CON" );
end Create;
 
procedure Initialize( It: in out Non_Controlled ) is
begin
Report.Failed("Called Initialize for Non_Controlled");
end Initialize;
procedure Finalize( It: in out Non_Controlled ) is
begin
Report.Failed("Called Finalize for Non_Controlled");
end Finalize;
 
function Create(With_Tag: Character) return Non_Controlled is
begin
return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
Ada.Finalization.Controlled
with Tag => With_Tag,
TC_Component => "#NON" ) );
end Create;
 
end C760011_0;
 
--------------------------------------------------------------------- C760011
 
with Report;
with TCTouch;
with C760011_0;
with Ada.Finalization; -- needed to be able to create extension aggregates
procedure C760011 is
 
use type C760011_0.Controlled_Type;
use type C760011_0.Controlled_Type'Class;
use type C760011_0.Non_Controlled;
 
subtype AFC is Ada.Finalization.Controlled;
 
procedure Check_Result( Tag : Character; Message : String ) is
-- make allowance for 7.6(21) optimizations
begin
if C760011_0.Initialized(Tag) then
TCTouch.Assert(C760011_0.Finalized(Tag),Message);
elsif C760011_0.Under_Debug then
Report.Comment("Optimized away: " & Tag );
end if;
end Check_Result;
 
procedure Subtest_1 is
 
 
procedure Subtest_1_Local_1 is
An_Object : C760011_0.Controlled_Type'Class
:= C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
-- initialize An_Object
begin
if C760011_0.Controlled_Type(An_Object)
= C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
Report.Failed("Comparison bad"); -- A = X !!!
end if;
end Subtest_1_Local_1;
-- An_Object must be Finalized by this point.
 
procedure Subtest_1_Local_2 is
An_Object : C760011_0.Controlled_Type('B');
begin
An_Object := (AFC with 'B', "TWO!" );
if Report.Ident_Char(An_Object.Tag) /= 'B' then
Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
end if;
exception
when others => Report.Failed("Bad controlled assignment");
end Subtest_1_Local_2;
-- An_Object must be Finalized by this point.
 
procedure Subtest_1_Local_3 is
An_Object : C760011_0.Non_Controlled('C');
begin
TCTouch.Assert_Not(C760011_0.Finalized('C'),
"Non_Controlled declaration C");
An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
=> (AFC with 'C', "TEE!"));
if Report.Ident_Char(An_Object.Tag) /= 'C' then
Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
end if;
end Subtest_1_Local_3;
-- Only controlled components of An_Object must be finalized; it is an
-- error to call Finalize for An_Object
 
begin
Subtest_1_Local_1;
Check_Result( 'A', "Aggregate in subprogram 1" );
 
Subtest_1_Local_2;
Check_Result( 'B', "Aggregate in subprogram 2" );
 
Subtest_1_Local_3;
Check_Result( 'C', "Embedded aggregate in subprogram 3" );
end Subtest_1;
 
 
procedure Subtest_2 is
-- using 'Z' for both evades order issues
Con_Object : C760011_0.Controlled_Type('Z');
Non_Object : C760011_0.Non_Controlled('Z');
begin
if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
Report.Failed("Con_Object catastrophe");
end if;
-- Controlled function result should be finalized by now
Check_Result( 'D', "Function Result" );
 
if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
Report.Failed("Non_Object catastrophe");
end if;
-- Controlled component of function result should be finalized by now
Check_Result( 'E', "Function Result" );
end Subtest_2;
 
 
procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
begin
if Con.Tag not in 'F'..'G' then
Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
& Report.Ident_Str(Con.TC_Component));
end if;
end Subtest_3;
 
 
procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
begin
if Non.Tag not in 'H'..'I' then
Report.Failed("Bad value passed to subtest 4 "
& Non.Tag & ' '
& Report.Ident_Str(Non.Controlled_Component.TC_Component));
end if;
end Subtest_4;
 
 
begin -- Main test procedure.
 
Report.Test ("C760011", "Check that anonymous objects of controlled " &
"types or types containing controlled types " &
"are finalized no later than the end of the " &
"innermost enclosing declarative_item or " &
"statement" );
 
Subtest_1;
 
Subtest_2;
 
Subtest_3(C760011_0.Create('F'));
Check_Result( 'F', "Function as formal F" );
 
Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
Check_Result( 'G', "Aggregate as formal G" );
 
Subtest_4(C760011_0.Create('H'));
Check_Result( 'H', "Function as formal H" );
 
Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
Check_Result( 'I', "Aggregate as formal I" );
 
Report.Result;
 
end C760011;
/c74409b.ada
0,0 → 1,93
-- C74409B.ADA
 
-- 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.
--*
-- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE SAME PACKAGE
-- AS A LIMITED PRIVATE TYPE AND HAS A COMPONENT OF THAT TYPE,
-- THE COMPOSITE TYPE IS TREATED AS A LIMITED TYPE UNTIL THE
-- EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION
-- OF THE COMPOSITE TYPE AND AFTER THE FULL DECLARATION OF THE
-- LIMITED PRIVATE TYPE
 
-- DSJ 5/5/83
-- JBG 9/23/83
 
WITH REPORT;
PROCEDURE C74409B IS
 
USE REPORT;
 
BEGIN
 
TEST("C74409B", "CHECK THAT A COMPOSITE TYPE WITH A LIMITED " &
"PRIVATE COMPONENT IS TREATED AS A LIMITED " &
"TYPE UNTIL ASSIGNMENT AND EQUALITY ARE BOTH " &
"AVAILABLE FOR THE COMPOSITE TYPE");
 
DECLARE
 
PACKAGE P IS
TYPE LP IS LIMITED PRIVATE;
PACKAGE Q IS
TYPE LP_ARRAY IS ARRAY (1 .. 2) OF LP;
END Q;
PRIVATE
TYPE LP IS NEW INTEGER;
END P;
 
PACKAGE BODY P IS
USE Q;
FUNCTION "=" (L,R : LP_ARRAY) RETURN BOOLEAN IS -- LEGAL
BEGIN
RETURN TRUE;
END;
 
GENERIC
TYPE T IS PRIVATE; -- NOTE: NOT LIMITED PRIVATE
C, D : T;
PACKAGE A IS
-- IRRELEVANT DETAILS
END A;
 
PACKAGE BODY A IS
BEGIN
IF C = D THEN
FAILED ("USED WRONG EQUALITY OPERATOR");
END IF;
END A;
 
PACKAGE BODY Q IS
PACKAGE ANOTHER_NEW_A IS
NEW A (LP_ARRAY, (2,3), (4,5)); -- LEGAL
END Q;
END P;
 
BEGIN
 
NULL;
 
END;
 
RESULT;
 
END C74409B;
/c761002.a
0,0 → 1,245
-- C761002.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 objects of a controlled type that are created
-- by an allocator are finalized at the appropriate time. In
-- particular, check that such objects are not finalized due to
-- completion of the master in which they were allocated if the
-- corresponding access type is declared outside of that master.
--
-- Check that Unchecked_Deallocation of a controlled
-- object causes finalization of that object.
--
-- TEST DESCRIPTION:
-- This test derives a type from Ada.Finalization.Controlled, and
-- declares access types to that type in various scope scenarios.
-- The dispatching procedure Finalize is redefined for the derived
-- type to perform a check that it has been called at the
-- correct time. This is accomplished using a global variable
-- which indicates what state the software is currently
-- executing. The test utilizes the TCTouch facilities to
-- verify that Finalize is called the correct number of times, at
-- the correct times. Several calls are made to validate passing
-- the null string to check that Finalize has NOT been called at
-- that point.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with Ada.Finalization;
package C761002_0 is
type Global is new Ada.Finalization.Controlled with null record;
procedure Finalize( It: in out Global );
type Second is new Ada.Finalization.Limited_Controlled with null record;
procedure Finalize( It: in out Second );
end C761002_0;
 
with Report;
with TCTouch;
package body C761002_0 is
 
procedure Finalize( It: in out Global ) is
begin
TCTouch.Touch('F'); ------------------------------------------------- F
end Finalize;
 
procedure Finalize( It: in out Second ) is
begin
TCTouch.Touch('S'); ------------------------------------------------- S
end Finalize;
end C761002_0;
 
with Report;
with TCTouch;
with C761002_0;
with Unchecked_Deallocation;
procedure C761002 is
 
-- check the straightforward case
procedure Subtest_1 is
type Access_1 is access C761002_0.Global;
V1 : Access_1;
procedure Allocate is
V2 : Access_1;
begin
V2 := new C761002_0.Global;
V1 := V2; -- "dead" assignment must not be optimized away due to
-- finalization "side effects", many more of these follow
end Allocate;
begin
Allocate;
-- no calls to Finalize should have occurred at this point
TCTouch.Validate("","Allocated nested, retained");
end Subtest_1;
-- check Unchecked_Deallocation
procedure Subtest_2 is
type Access_2 is access C761002_0.Global;
procedure Free is
new Unchecked_Deallocation(C761002_0.Global, Access_2);
V1 : Access_2;
V2 : Access_2;
 
procedure Allocate is
begin
V1 := new C761002_0.Global;
V2 := new C761002_0.Global;
end Allocate;
 
begin
Allocate;
-- no calls to Finalize should have occurred at this point.
TCTouch.Validate("","Allocated nested, non-local");
Free(V1); -- instance of Unchecked_Deallocation
-- should cause the finalization of V1.all
TCTouch.Validate("F","Unchecked Deallocation");
end Subtest_2; -- leaving this scope should cause the finalization of V2.all
-- check various master-exit scenarios
-- the "Fake" parameters are used to avoid unwanted optimizations
procedure Subtest_3 is
procedure With_Local_Block is
type Access_3 is access C761002_0.Global;
V1 : Access_3;
begin
declare
V2 : Access_3 := new C761002_0.Global;
begin
V1 := V2;
end;
TCTouch.Validate("","Local Block, normal exit");
-- the allocated object should be finalized on leaving this scope
end With_Local_Block;
procedure With_Local_Block_Return(Fake: Integer) is
type Access_4 is access C761002_0.Global;
V1 : Access_4 := new C761002_0.Global;
begin
if Fake = 0 then
declare
V2 : Access_4;
begin
V2 := new C761002_0.Global;
return; -- the two allocated objects should be finalized
end; -- upon leaving this scope
else
V1 := null;
end if;
end With_Local_Block_Return;
 
procedure With_Goto(Fake: Integer) is
type Access_5 is access C761002_0.Global;
V1 : Access_5 := new C761002_0.Global;
V2 : Access_5;
V3 : Access_5;
begin
if Fake = 0 then
declare
type Access_6 is access C761002_0.Second;
V6 : Access_6;
begin
V6 := new C761002_0.Second;
goto check;
end;
else
V2 := V1;
end if;
V3 := V2;
<<check>>
TCTouch.Validate("S","goto past master end");
end With_Goto;
 
begin
With_Local_Block;
TCTouch.Validate("F","Local Block, normal exit, after master");
 
With_Local_Block_Return( Report.Ident_Int(0) );
TCTouch.Validate("FF","Local Block, return from block");
 
With_Goto( Report.Ident_Int(0) );
TCTouch.Validate("F","With Goto");
 
end Subtest_3;
 
procedure Subtest_4 is
 
Oops : exception;
procedure Alley( Fake: Integer ) is
type Access_1 is access C761002_0.Global;
V1 : Access_1;
begin
V1 := new C761002_0.Global;
if Fake = 1 then
raise Oops;
end if;
V1 := null;
end Alley;
begin
Catch: begin
Alley( Report.Ident_Int(1) );
exception
when Oops => TCTouch.Validate("F","leaving via exception");
when others => Report.Failed("Wrong exception");
end Catch;
end Subtest_4;
 
begin -- Main test procedure.
 
Report.Test ("C761002", "Check that objects of a controlled type created "
& "by an allocator are finalized appropriately. "
& "Check that Unchecked_Deallocation of a "
& "controlled object causes finalization "
& "of that object" );
Subtest_1;
-- leaving the scope of the access type should finalize the
-- collection
TCTouch.Validate("F","Allocated nested, Subtest 1");
Subtest_2;
-- Unchecked_Deallocation already finalized one of the two
-- objects allocated, the other should be the only one finalized
-- at leaving the scope of the access type.
TCTouch.Validate("F","Allocated non-local");
 
Subtest_3;
-- there should be no remaining finalizations from this subtest
TCTouch.Validate("","Localized objects");
 
Subtest_4;
-- there should be no remaining finalizations from this subtest
TCTouch.Validate("","Exception testing");
 
Report.Result;
 
end C761002;
/c760012.a
0,0 → 1,256
-- C760012.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 record components that have per-object access discriminant
-- constraints are initialized in the order of their component
-- declarations, and after any components that are not so constrained.
--
-- Check that record components that have per-object access discriminant
-- constraints are finalized in the reverse order of their component
-- declarations, and before any components that are not so constrained.
--
-- TEST DESCRIPTION:
-- The type List_Item is the "container" type. It holds two fields that
-- have per-object access discriminant constraints, and two fields that
-- are not discriminated. These four fields are all controlled types.
-- A fifth field is a pointer used to maintain a linked list of these
-- data objects. Each component is of a unique type which allows for
-- the test to simply track the order of initialization and finalization.
--
-- The types and their purpose are:
-- Constrained_First - a controlled discriminated type
-- Constrained_Second - a controlled discriminated type
-- Simple_First - a controlled type with no discriminant
-- Simple_Second - a controlled type with no discriminant
--
-- The required order of operations:
-- Initialize
-- ( Simple_First | Simple_Second ) -- no "internal order" required
-- Constrained_First
-- Constrained_Second
-- Finalize
-- Constrained_Second
-- Constrained_First
-- ( Simple_First | Simple_Second ) -- must be inverse of init.
--
--
-- CHANGE HISTORY:
-- 23 MAY 95 SAIC Initial version
-- 02 MAY 96 SAIC Reorganized for 2.1
-- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check
-- 31 DEC 97 EDS Remove references to and uses of
-- Initialization_Sequence
--!
 
---------------------------------------------------------------- C760012_0
 
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
package C760012_0 is
 
type List_Item;
 
type List is access all List_Item;
 
package Firsts is -- distinguish first from second
type Constrained_First(Container : access List_Item) is
new Ada.Finalization.Limited_Controlled with null record;
procedure Initialize( T : in out Constrained_First );
procedure Finalize ( T : in out Constrained_First );
 
type Simple_First is new Ada.Finalization.Controlled with
record
My_Init_Seq_Number : Natural;
end record;
procedure Initialize( T : in out Simple_First );
procedure Finalize ( T : in out Simple_First );
 
end Firsts;
 
type Constrained_Second(Container : access List_Item) is
new Ada.Finalization.Limited_Controlled with null record;
procedure Initialize( T : in out Constrained_Second );
procedure Finalize ( T : in out Constrained_Second );
 
type Simple_Second is new Ada.Finalization.Controlled with
record
My_Init_Seq_Number : Natural;
end record;
procedure Initialize( T : in out Simple_Second );
procedure Finalize ( T : in out Simple_Second );
 
-- by 3.8(18);6.0 the following type contains components constrained
-- by per-object expressions
 
 
type List_Item is new Ada.Finalization.Limited_Controlled
with record
ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
SimpleA : Firsts.Simple_First; -- A T
SimpleB : Simple_Second; -- A T
ContentB : Constrained_Second( List_Item'Access ); -- D R
Next : List; -- | |
end record; -- | |
procedure Initialize( L : in out List_Item ); ------------------+ |
procedure Finalize ( L : in out List_Item ); --------------------+
 
-- the tags are the same for SimpleA and SimpleB due to the fact that
-- the language does not specify an ordering with respect to this
-- component pair. 7.6(12) does specify the rest of the ordering.
 
procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
 
end C760012_0;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
package body C760012_0 is
 
package body Firsts is
 
procedure Initialize( T : in out Constrained_First ) is
begin
TCTouch.Touch('C'); ----------------------------------------------- C
end Initialize;
 
procedure Finalize ( T : in out Constrained_First ) is
begin
TCTouch.Touch('S'); ----------------------------------------------- S
end Finalize;
 
procedure Initialize( T : in out Simple_First ) is
begin
T.My_Init_Seq_Number := 0;
TCTouch.Touch('A'); ----------------------------------------------- A
end Initialize;
 
procedure Finalize ( T : in out Simple_First ) is
begin
TCTouch.Touch('T'); ----------------------------------------------- T
end Finalize;
 
end Firsts;
 
procedure Initialize( T : in out Constrained_Second ) is
begin
TCTouch.Touch('D'); ------------------------------------------------- D
end Initialize;
 
procedure Finalize ( T : in out Constrained_Second ) is
begin
TCTouch.Touch('R'); ------------------------------------------------- R
end Finalize;
 
 
procedure Initialize( T : in out Simple_Second ) is
begin
T.My_Init_Seq_Number := 0;
TCTouch.Touch('A'); ------------------------------------------------- A
end Initialize;
 
procedure Finalize ( T : in out Simple_Second ) is
begin
TCTouch.Touch('T'); ------------------------------------------------- T
end Finalize;
 
procedure Initialize( L : in out List_Item ) is
begin
TCTouch.Touch('F'); ------------------------------------------------- F
end Initialize;
 
procedure Finalize ( L : in out List_Item ) is
begin
TCTouch.Touch('Q'); ------------------------------------------------- Q
end Finalize;
 
end C760012_0;
--------------------------------------------------------------------- C760012
 
with Report;
with TCTouch;
with C760012_0;
procedure C760012 is
 
use type C760012_0.List;
 
procedure Subtest_1 is
-- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
-- 7.6.1(9);6.0 dictates the order of finalization of the components
 
One_Of_Them : C760012_0.List_Item;
begin
if One_Of_Them.Next /= null then -- just to hold the subtest in place
Report.Failed("No default value for Next");
end if;
end Subtest_1;
 
List : C760012_0.List;
 
procedure Subtest_2 is
begin
 
List := new C760012_0.List_Item;
 
List.Next := new C760012_0.List_Item;
 
end Subtest_2;
 
procedure Subtest_3 is
begin
 
C760012_0.Deallocate( List.Next );
 
C760012_0.Deallocate( List );
 
end Subtest_3;
begin -- Main test procedure.
 
Report.Test ("C760012", "Check that record components that have " &
"per-object access discriminant constraints " &
"are initialized in the order of their " &
"component declarations, and after any " &
"components that are not so constrained. " &
"Check that record components that have " &
"per-object access discriminant constraints " &
"are finalized in the reverse order of their " &
"component declarations, and before any " &
"components that are not so constrained" );
 
Subtest_1;
TCTouch.Validate("AACDFQRSTT", "One object");
 
Subtest_2;
TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
 
Subtest_3;
TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
 
Report.Result;
 
end C760012;
/c74401k.ada
0,0 → 1,136
-- C74401K.ADA
 
-- 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.
--*
-- CHECK THAT OUT PARAMETERS OF AN ENTRY DECLARATION CAN HAVE A LIMITED
-- PRIVATE TYPE IF THE ENTRY DECLARATION OCCURS IN THE VISIBLE PART OF A
-- PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE
-- PART.
 
-- CHECK THAT A RENAMING DECLARATION CAN RENAME AN ENTRY DECLARED
-- WITH AN OUT PARAMETER.
 
-- JBG 5/1/85
 
WITH REPORT; USE REPORT;
PROCEDURE C74401K IS
 
PACKAGE PKG IS
TYPE LP IS LIMITED PRIVATE;
TASK P20 IS
ENTRY TP20 (X : OUT LP); -- OK.
ENTRY RESET (X : OUT LP);
END P20;
FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
VAL1 : CONSTANT LP;
 
PACKAGE NESTED IS
TASK NEST1 IS
ENTRY TNEST1 (X : OUT LP);
END NEST1;
PRIVATE
TASK NEST2 IS
ENTRY TNEST2 (X : OUT LP);
END NEST2;
END NESTED;
PRIVATE
TYPE LP IS NEW INTEGER;
VAL1 : CONSTANT LP := LP(IDENT_INT(3));
END PKG;
 
VAR : PKG.LP;
 
PACKAGE BODY PKG IS
TASK BODY P20 IS
BEGIN
LOOP
SELECT
ACCEPT TP20 (X : OUT LP) DO
X := 3;
END TP20;
OR
ACCEPT RESET (X : OUT LP) DO
X := 0;
END RESET;
OR
TERMINATE;
END SELECT;
END LOOP;
END P20;
 
FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN L = R;
END EQ;
 
PACKAGE BODY NESTED IS
TASK BODY NEST1 IS
BEGIN
ACCEPT TNEST1 (X : OUT LP) DO
X := 3;
END TNEST1;
END NEST1;
 
TASK BODY NEST2 IS
BEGIN
NULL;
END NEST2;
END NESTED;
BEGIN
VAR := LP(IDENT_INT(0));
END PKG;
 
PACKAGE PKG1 IS
PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20.TP20; -- OK:
-- RENAMING.
END PKG1;
 
BEGIN
 
TEST ("C74401K", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
"PARAMETER WITH A LIMITED PRIVATE TYPE");
 
PKG.P20.RESET (VAR);
PKG.P20.TP20 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("DIRECT CALL NOT CORRECT");
END IF;
 
PKG.P20.RESET (VAR);
PKG1.P21 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("RENAMED CALL NOT CORRECT");
END IF;
 
PKG.P20.RESET (VAR);
PKG.NESTED.NEST1.TNEST1 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("NESTED CALL NOT CORRECT");
END IF;
 
RESULT;
 
END C74401K;
/c761003.a
0,0 → 1,447
-- C761003.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 an object of a controlled type is finalized when the
-- enclosing master is complete.
-- Check this for controlled types where the derived type has a
-- discriminant.
-- Check this for subprograms of abstract types derived from the
-- types in Ada.Finalization.
--
-- Check that finalization of controlled objects is
-- performed in the correct order. In particular, check that if
-- multiple objects of controlled types are declared immediately
-- within the same declarative part then type are finalized in the
-- reverse order of their creation.
--
-- TEST DESCRIPTION:
-- This test checks these conditions for subprograms and
-- block statements; both variables and constants of controlled
-- types; cases of a controlled component of a record type, as
-- well as an array with controlled components.
--
-- The base controlled types used for the test are defined
-- with a character discriminant. The initialize procedure for
-- the types will record the order of creation in a globally
-- accessible array, the finalize procedure for the types will call
-- TCTouch with that tag character. The test can then check that
-- the order of finalization is indeed the reverse of the order of
-- creation (assuming that the implementation calls Initialize in
-- the order that the objects are created).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 02 Nov 95 SAIC ACVC 2.0.1
--
--!
 
------------------------------------------------------------ C761003_Support
 
package C761003_Support is
function Pick_Char return Character;
-- successive calls to Pick_Char return distinct characters which may
-- be assigned to objects to track an order sequence. These characters
-- are then used in calls to TCTouch.Touch.
 
procedure Validate(Initcount : Natural;
Testnumber : Natural;
Check_Order : Boolean := True);
-- does a little extra processing prior to calling TCTouch.Validate,
-- specifically, it reverses the stored string of characters, and checks
-- for a correct count.
 
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
 
end C761003_Support;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with TCTouch;
package body C761003_Support is
type Pick_Rotation is mod 52;
type Pick_String is array(Pick_Rotation) of Character;
 
From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
& "abcdefghijklmnopqrstuvwxyz";
Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
 
function Pick_Char return Character is
begin
Recent_Pick := Recent_Pick +1;
return From(Recent_Pick);
end Pick_Char;
 
function Invert(S:String) return String is
T: String(1..S'Length);
begin
for SI in reverse S'Range loop
T(S'Last - SI + 1) := S(SI);
end loop;
return T;
end Invert;
 
procedure Validate(Initcount : Natural;
Testnumber : Natural;
Check_Order : Boolean := True) is
Number : constant String := Natural'Image(Testnumber);
begin
if Inits_Called /= Initcount then
Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected"
& Natural'Image(Initcount) & ", Subtest " & Number);
TCTouch.Flush;
else
TCTouch.Validate(
Invert(Inits_Order(1..Inits_Called)),
"Subtest " & Number, Order_Meaningful => Check_Order );
end if;
Inits_Called := 0; -- reset for the next batch
end Validate;
 
end C761003_Support;
 
------------------------------------------------------------------ C761003_0
 
with Ada.Finalization;
package C761003_0 is
 
type Global(Tag: Character) is new Ada.Finalization.Controlled
with null record;
 
procedure Initialize( It: in out Global );
procedure Finalize ( It: in out Global );
 
Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1');
 
type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled
with null record;
 
procedure Initialize( It: in out Second );
procedure Finalize ( It: in out Second );
 
end C761003_0;
 
------------------------------------------------------------------ C761003_1
 
with Ada.Finalization;
package C761003_1 is
 
type Global is abstract new Ada.Finalization.Controlled with record
Tag: Character;
end record;
 
procedure Initialize( It: in out Global );
procedure Finalize ( It: in out Global );
 
type Second is abstract new Ada.Finalization.Limited_Controlled with record
Tag: Character;
end record;
 
procedure Initialize( It: in out Second );
procedure Finalize ( It: in out Second );
 
end C761003_1;
 
------------------------------------------------------------------ C761003_2
 
with C761003_1;
package C761003_2 is
 
type Global is new C761003_1.Global with null record;
-- inherits Initialize and Finalize
 
type Second is new C761003_1.Second with null record;
-- inherits Initialize and Finalize
 
end C761003_2;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0
 
with TCTouch;
with C761003_Support;
package body C761003_0 is
 
package Sup renames C761003_Support;
 
procedure Initialize( It: in out Global ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
 
procedure Finalize( It: in out Global ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
 
procedure Initialize( It: in out Second ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
 
procedure Finalize( It: in out Second ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
 
end C761003_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1
 
with TCTouch;
with C761003_Support;
package body C761003_1 is
 
package Sup renames C761003_Support;
 
procedure Initialize( It: in out Global ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
 
procedure Finalize( It: in out Global ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
 
procedure Initialize( It: in out Second ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
 
procedure Finalize( It: in out Second ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
 
end C761003_1;
 
-------------------------------------------------------------------- C761003
 
with Report;
with TCTouch;
with C761003_0;
with C761003_2;
with C761003_Support;
procedure C761003 is
 
package Sup renames C761003_Support;
 
---------------------------------------------------------------- Subtest_1
 
Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous
 
procedure Subtest_1 is
 
-- the constant will take its constraint from the value.
-- must be declared first to be finalized last (and take the
-- initialize from before calling subtest_1)
Item_1 : constant C761003_0.Global := C761003_0.Null_Global;
 
-- Item_2, declared second, should be finalized second to last.
Item_2 : C761003_0.Global(Sup.Pick_Char);
 
-- Item_3 and Item_4 will be created in the order of the
-- list.
Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char);
 
-- Item_5 will be finalized first.
Item_5 : C761003_0.Second(Sup.Pick_Char);
 
begin
if Item_3.Tag >= Item_4.Tag then
Report.Failed("Controlled objects created by list in wrong order");
end if;
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 1 body");
end Subtest_1;
 
---------------------------------------------------------------- Subtest_2
 
-- These declarations should cause calls to initialize and
-- finalize. The expected operations are the subprograms associated
-- with the abstract types. Note that for these objects, the
-- Initialize and Finalize are visible only by inheritance.
 
Subtest_2_Inits_Expected : constant := 4;
 
procedure Subtest_2 is
 
Item_1 : C761003_2.Global;
Item_2, Item_3 : C761003_2.Global;
Item_4 : C761003_2.Second;
 
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 2 body");
end Subtest_2;
 
---------------------------------------------------------------- Subtest_3
 
-- Test for controlled objects embedded in arrays. Using structures
-- that will cause a checkable order.
 
Subtest_3_Inits_Expected : constant := 8;
 
procedure Subtest_3 is
 
type Global_List is array(Natural range <>)
of C761003_0.Global(Sup.Pick_Char);
 
Items : Global_List(1..4); -- components have the same tag
 
type Second_List is array(Natural range <>)
of C761003_0.Second(Sup.Pick_Char);
 
Second_Items : Second_List(1..4); -- components have the same tag,
-- distinct from the tag used in Items
 
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 3 body");
end Subtest_3;
 
---------------------------------------------------------------- Subtest_4
 
-- These declarations should cause dispatching calls to initialize and
-- finalize. The expected operations are the subprograms associated
-- with the abstract types.
 
Subtest_4_Inits_Expected : constant := 2;
 
procedure Subtest_4 is
 
type Global_Rec is record
Item1: C761003_0.Global(Sup.Pick_Char);
end record;
 
type Second_Rec is record
Item2: C761003_2.Second;
end record;
 
G : Global_Rec;
S : Second_Rec;
 
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 4 body");
end Subtest_4;
 
---------------------------------------------------------------- Subtest_5
 
-- Test for controlled objects embedded in arrays. In these cases, the
-- order of the finalization of the components is not defined by the
-- language.
 
Subtest_5_Inits_Expected : constant := 8;
 
procedure Subtest_5 is
 
 
type Another_Global_List is array(Natural range <>)
of C761003_2.Global;
 
More_Items : Another_Global_List(1..4);
 
type Another_Second_List is array(Natural range <>)
of C761003_2.Second;
 
Second_More_Items : Another_Second_List(1..4);
 
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 5 body");
end Subtest_5;
 
---------------------------------------------------------------- Subtest_6
 
-- These declarations should cause dispatching calls to initialize and
-- finalize. The expected operations are the subprograms associated
-- with the abstract types.
 
Subtest_6_Inits_Expected : constant := 2;
 
procedure Subtest_6 is
 
type Global_Rec is record
Item2: C761003_2.Global;
end record;
 
type Second_Rec is record
Item1: C761003_0.Second(Sup.Pick_Char);
end record;
 
G : Global_Rec;
S : Second_Rec;
 
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 6 body");
end Subtest_6;
 
begin -- Main test procedure.
 
Report.Test ("C761003", "Check that an object of a controlled type "
& "is finalized when the enclosing master is "
& "complete, left by a transfer of control, "
& "and performed in the correct order" );
 
-- adjust for optional adjusts and initializes for C761003_0.Null_Global
TCTouch.Flush; -- clear the optional adjust
if Sup.Inits_Called /= 1 then
-- C761003_0.Null_Global did not get "initialized"
C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump
end if;
 
Subtest_1;
Sup.Validate(Subtest_1_Inits_Expected, 1);
 
Subtest_2;
Sup.Validate(Subtest_2_Inits_Expected, 2);
 
Subtest_3;
Sup.Validate(Subtest_3_Inits_Expected, 3);
 
Subtest_4;
Sup.Validate(Subtest_4_Inits_Expected, 4);
 
Subtest_5;
Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False);
 
Subtest_6;
Sup.Validate(Subtest_6_Inits_Expected, 6);
 
Report.Result;
 
end C761003;
/c760013.a
0,0 → 1,108
-- C760013.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. 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 Initialize is not called for default-initialized subcomponents
-- of the ancestor type of an extension aggregate. (Defect Report
-- 8652/0021, Technical Corrigendum 7.6(11/1)).
--
-- CHANGE HISTORY:
-- 25 JAN 2001 PHL Initial version.
-- 29 JUN 2001 RLB Reformatted for ACATS.
--
--!
with Ada.Finalization;
use Ada.Finalization;
package C760013_0 is
 
type Ctrl1 is new Controlled with
record
C : Integer := 0;
end record;
type Ctrl2 is new Controlled with
record
C : Integer := 0;
end record;
 
procedure Initialize (Obj1 : in out Ctrl1);
procedure Initialize (Obj2 : in out Ctrl2);
 
end C760013_0;
 
with Report;
use Report;
package body C760013_0 is
 
procedure Initialize (Obj1 : in out Ctrl1) is
begin
Obj1.C := Ident_Int (47);
end Initialize;
 
procedure Initialize (Obj2 : in out Ctrl2) is
begin
Failed ("Initialize called for type Ctrl2");
end Initialize;
 
end C760013_0;
 
with Ada.Finalization;
with C760013_0;
use C760013_0;
with Report;
use Report;
procedure C760013 is
 
type T is tagged
record
C1 : Ctrl1;
C2 : Ctrl2 := (Ada.Finalization.Controlled with
C => Ident_Int (23));
end record;
 
type Nt is new T with
record
C3 : Float;
end record;
 
X : Nt;
 
begin
Test ("C760013",
"Check that Initialize is not called for " &
"default-initialized subcomponents of the ancestor type of an " &
"extension aggregate");
 
X := (T with C3 => 5.0);
 
if X.C1.C /= Ident_Int (47) then
Failed ("Initialize not called for type Ctrl1");
end if;
if X.C2.C /= Ident_Int (23) then
Failed ("Initial value not assigned for type Ctrl2");
end if;
 
Result;
end C760013;
 
/c761004.a
0,0 → 1,305
-- C761004.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 an object of a controlled type is finalized with the
-- enclosing master is complete.
-- Check that finalization occurs in the case where the master is
-- left by a transfer of control.
-- Specifically check for types where the derived types do not have
-- discriminants.
--
-- Check that finalization of controlled objects is
-- performed in the correct order. In particular, check that if
-- multiple objects of controlled types are declared immediately
-- within the same declarative part then they are finalized in the
-- reverse order of their creation.
--
-- TEST DESCRIPTION:
-- This test checks these conditions for subprograms and
-- block statements; both variables and constants of controlled
-- types; cases of a controlled component of a record type, as
-- well as an array with controlled components.
--
-- The base controlled types used for the test are defined
-- with a character discriminant. The initialize procedure for
-- the types will record the order of creation in a globally
-- accessible array, the finalize procedure for the types will call
-- TCTouch with that tag character. The test can then check that
-- the order of finalization is indeed the reverse of the order of
-- creation (assuming that the implementation calls Initialize in
-- the order that the objects are created).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
--
--!
 
package C761004_Support is
function Pick_Char return Character;
-- successive calls to Pick_Char return distinct characters which may
-- be assigned to objects to track an order sequence. These characters
-- are then used in calls to TCTouch.Touch.
 
procedure Validate(Initcount: Natural; Testnumber:Natural);
-- does a little extra processing prior to calling TCTouch.Validate,
-- specifically, it reverses the stored string of characters, and checks
-- for a correct count.
 
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
 
end C761004_Support;
 
with Report;
with TCTouch;
package body C761004_Support is
type Pick_Rotation is mod 52;
type Pick_String is array(Pick_Rotation) of Character;
 
From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
& "abcdefghijklmnopqrstuvwxyz";
Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
 
function Pick_Char return Character is
begin
Recent_Pick := Recent_Pick +1;
return From(Recent_Pick);
end Pick_Char;
 
function Invert(S:String) return String is
T: String(1..S'Length);
TI: Positive := 1;
begin
for SI in reverse S'Range loop
T(TI) := S(SI);
TI := TI +1;
end loop;
return T;
end Invert;
 
procedure Validate(Initcount: Natural; Testnumber:Natural) is
Number : constant String := Natural'Image(Testnumber);
begin
if Inits_Called /= Initcount then
Report.Failed("Wrong number of inits, Subtest " & Number);
TCTouch.Flush;
else
TCTouch.Validate(
Invert(Inits_Order(1..Inits_Called)),
"Subtest " & Number, True);
end if;
end Validate;
 
end C761004_Support;
 
----------------------------------------------------------------- C761004_0
 
with Ada.Finalization;
package C761004_0 is
type Global is new Ada.Finalization.Controlled with record
Tag : Character;
end record;
procedure Initialize( It: in out Global );
procedure Finalize ( It: in out Global );
 
type Second is new Ada.Finalization.Limited_Controlled with record
Tag : Character;
end record;
procedure Initialize( It: in out Second );
procedure Finalize ( It: in out Second );
 
end C761004_0;
 
with TCTouch;
with C761004_Support;
package body C761004_0 is
package Sup renames C761004_Support;
 
procedure Initialize( It: in out Global ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Global ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
 
procedure Initialize( It: in out Second ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Second ) is
begin
TCTouch.Touch(It.Tag); --------------------------------------------- Tag
end Finalize;
end C761004_0;
 
------------------------------------------------------------------- C761004
 
with Report;
with TCTouch;
with C761004_0;
with C761004_Support;
with Ada.Finalization; -- needed to be able to create extension aggregates
procedure C761004 is
 
Verbose : constant Boolean := False;
 
package Sup renames C761004_Support;
 
-- Subtest 1, general case. Check that several objects declared in a
-- subprogram are created, and finalized in opposite order.
 
Subtest_1_Expected_Inits : constant := 3;
 
procedure Subtest_1 is
Item_1 : C761004_0.Global;
Item_2, Item_3 : C761004_0.Global;
begin
if Item_2.Tag = Item_3.Tag then -- not germane to the test
Report.Failed("Duplicate tag");-- but helps prevent code elimination
end if;
end Subtest_1;
 
-- Subtest 2, extension of the general case. Check that several objects
-- created identically on the stack (via a recursive procedure) are
-- finalized in the opposite order of their creation.
Subtest_2_Expected_Inits : constant := 12;
User_Exception : exception;
procedure Subtest_2 is
Item_1 : C761004_0.Global;
 
-- combine recursion and exit by exception:
 
procedure Nested(Recurs: Natural) is
Item_3 : C761004_0.Global;
begin
if Verbose then
Report.Comment("going in: " & Item_3.Tag);
end if;
if Recurs = 1 then
raise User_Exception;
else
Nested(Recurs -1);
end if;
end Nested;
Item_2 : C761004_0.Global;
begin
Nested(10);
end Subtest_2;
 
-- subtest 3, check the case of objects embedded in structures:
-- an array
-- a record
Subtest_3_Expected_Inits : constant := 3;
procedure Subtest_3 is
type G_List is array(Positive range <>) of C761004_0.Global;
type Pandoras_Box is record
G : G_List(1..1);
end record;
 
procedure Nested(Recursions: Natural) is
Merlin : Pandoras_Box;
begin
if Recursions > 1 then
Nested(Recursions-1);
else
TCTouch.Validate("","Final Nested call");
end if;
end Nested;
 
begin
Nested(3);
end Subtest_3;
 
-- subtest 4, check the case of objects embedded in structures:
-- an array
-- a record
Subtest_4_Expected_Inits : constant := 3;
procedure Subtest_4 is
type S_List is array(Positive range <>) of C761004_0.Second;
type Pandoras_Box is record
S : S_List(1..1);
end record;
 
procedure Nested(Recursions: Natural) is
Merlin : Pandoras_Box;
begin
if Recursions > 1 then
Nested(Recursions-1);
else
TCTouch.Validate("","Final Nested call");
end if;
end Nested;
 
begin
Nested(3);
end Subtest_4;
 
begin -- Main test procedure.
 
Report.Test ("C761004", "Check that an object of a controlled type "
& "is finalized when the enclosing master is "
& "complete, left by a transfer of control, "
& "and performed in the correct order" );
 
Subtest_1;
Sup.Validate(Subtest_1_Expected_Inits,1);
 
Subtest_2_Frame: begin
Sup.Inits_Called := 0;
Subtest_2;
exception
when User_Exception => null;
when others => Report.Failed("Wrong Exception, Subtest 2");
end Subtest_2_Frame;
Sup.Validate(Subtest_2_Expected_Inits,2);
Sup.Inits_Called := 0;
Subtest_3;
Sup.Validate(Subtest_3_Expected_Inits,3);
Sup.Inits_Called := 0;
Subtest_4;
Sup.Validate(Subtest_4_Expected_Inits,4);
Report.Result;
 
end C761004;
/c761005.a
0,0 → 1,288
-- C761005.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 deriving abstract types from the types in Ada.Finalization
-- does not negatively impact the implicit operations.
-- Check that an object of a controlled type is finalized when the
-- enclosing master is complete.
-- Check that finalization occurs in the case where the master is
-- left by a transfer of control.
-- Check this for controlled types where the derived type has a
-- discriminant.
-- Check this for cases where the type is defined as private,
-- and the full type is derived from the types in Ada.Finalization.
--
-- Check that finalization of controlled objects is
-- performed in the correct order. In particular, check that if
-- multiple objects of controlled types are declared immediately
-- within the same declarative part then type are finalized in the
-- reverse order of their creation.
--
-- TEST DESCRIPTION:
-- This test checks these conditions for subprograms and
-- block statements; both variables and constants of controlled
-- types; cases of a controlled component of a record type, as
-- well as an array with controlled components.
--
-- The base controlled types used for the test are defined
-- with a character discriminant. The initialize procedure for
-- the types will record the order of creation in a globally
-- accessible array, the finalize procedure for the types will call
-- TCTouch with that tag character. The test can then check that
-- the order of finalization is indeed the reverse of the order of
-- creation (assuming that the implementation calls Initialize in
-- the order that the objects are created).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 10 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
--
--!
 
package C761005_Support is
function Pick_Char return Character;
procedure Validate(Initcount: Natural; Testnumber:Natural);
 
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
 
end C761005_Support;
 
with Report;
with TCTouch;
package body C761005_Support is
type Pick_Rotation is mod 52;
type Pick_String is array(Pick_Rotation) of Character;
 
From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
& "abcdefghijklmnopqrstuvwxyz";
Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
 
function Pick_Char return Character is
begin
Recent_Pick := Recent_Pick +1;
return From(Recent_Pick);
end Pick_Char;
 
function Invert(S:String) return String is
T: String(1..S'Length);
TI: Positive := 1;
begin
for SI in reverse S'Range loop
T(TI) := S(SI);
TI := TI +1;
end loop;
return T;
end Invert;
 
procedure Validate(Initcount: Natural; Testnumber:Natural) is
Number : constant String := Natural'Image(Testnumber);
begin
if Inits_Called /= Initcount then
Report.Failed("Wrong number of inits, Subtest " & Number);
else
TCTouch.Validate(
Invert(Inits_Order(1..Inits_Called)),
"Subtest " & Number, True);
end if;
Inits_Called := 0;
end Validate;
 
end C761005_Support;
 
-----------------------------------------------------------------------------
with Ada.Finalization;
package C761005_0 is
type Final_Root(Tag: Character) is private;
 
type Ltd_Final_Root(Tag: Character) is limited private;
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
private
type Final_Root(Tag: Character) is new Ada.Finalization.Controlled
with null record;
procedure Initialize( It: in out Final_Root );
procedure Finalize ( It: in out Final_Root );
type Ltd_Final_Root(Tag: Character) is new
Ada.Finalization.Limited_Controlled
with null record;
procedure Initialize( It: in out Ltd_Final_Root );
procedure Finalize ( It: in out Ltd_Final_Root );
end C761005_0;
 
-----------------------------------------------------------------------------
with Ada.Finalization;
package C761005_1 is
type Final_Abstract is abstract tagged private;
 
type Ltd_Final_Abstract_Child is abstract tagged limited private;
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
 
private
type Final_Abstract is abstract new Ada.Finalization.Controlled with record
Tag: Character;
end record;
procedure Initialize( It: in out Final_Abstract );
procedure Finalize ( It: in out Final_Abstract );
 
type Ltd_Final_Abstract_Child is
abstract new Ada.Finalization.Limited_Controlled with record
Tag: Character;
end record;
procedure Initialize( It: in out Ltd_Final_Abstract_Child );
procedure Finalize ( It: in out Ltd_Final_Abstract_Child );
 
end C761005_1;
 
-----------------------------------------------------------------------------
with C761005_1;
package C761005_2 is
type Final_Child is new C761005_1.Final_Abstract with null record;
type Ltd_Final_Child is
new C761005_1.Ltd_Final_Abstract_Child with null record;
 
end C761005_2;
 
-----------------------------------------------------------------------------
with Report;
with TCTouch;
with C761005_Support;
package body C761005_0 is
 
package Sup renames C761005_Support;
 
procedure Initialize( It: in out Final_Root ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Final_Root ) is
begin
TCTouch.Touch(It.Tag);
end Finalize;
 
procedure Initialize( It: in out Ltd_Final_Root ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Ltd_Final_Root ) is
begin
TCTouch.Touch(It.Tag);
end Finalize;
end C761005_0;
 
-----------------------------------------------------------------------------
with Report;
with TCTouch;
with C761005_Support;
package body C761005_1 is
 
package Sup renames C761005_Support;
 
procedure Initialize( It: in out Final_Abstract ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Final_Abstract ) is
begin
TCTouch.Touch(It.Tag);
end Finalize;
 
procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is
begin
Sup.Inits_Called := Sup.Inits_Called +1;
It.Tag := Sup.Pick_Char;
Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
end Initialize;
procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is
begin
TCTouch.Touch(It.Tag);
end Finalize;
end C761005_1;
 
-----------------------------------------------------------------------------
with Report;
with TCTouch;
with C761005_0;
with C761005_2;
with C761005_Support;
procedure C761005 is
 
package Sup renames C761005_Support;
 
Subtest_1_Inits_Expected : constant := 4;
procedure Subtest_1 is
Item_1 : C761005_0.Final_Root(Sup.Pick_Char);
Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char);
Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char);
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 1 body");
end Subtest_1;
 
-- These declarations should cause calls to initialize and
-- finalize. The expected operations are the subprograms associated
-- with the abstract types.
Subtest_2_Inits_Expected : constant := 4;
procedure Subtest_2 is
Item_1 : C761005_2.Final_Child;
Item_2, Item_3 : C761005_2.Final_Child;
Item_4 : C761005_2.Ltd_Final_Child;
begin
-- check that nothing has happened yet!
TCTouch.Validate("","Subtest 2 body");
end Subtest_2;
 
begin -- Main test procedure.
 
Report.Test ("C761005", "Check that an object of a controlled type "
& "is finalized when the enclosing master is "
& "complete, left by a transfer of control, "
& "and performed in the correct order" );
 
Subtest_1;
Sup.Validate(Subtest_1_Inits_Expected,1);
Subtest_2;
Sup.Validate(Subtest_2_Inits_Expected,2);
 
Report.Result;
 
end C761005;
/c761006.a
0,0 → 1,425
-- C761006.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 Program_Error is raised when:
-- * an exception is raised if Finalize invoked as part of an
-- assignment operation; or
-- * an exception is raised if Adjust invoked as part of an assignment
-- operation, after any other adjustment due to be performed are
-- performed; or
-- * an exception is raised if Finalize invoked as part of a call on
-- Unchecked_Deallocation, after any other finalizations to be
-- performed are performed.
--
-- TEST DESCRIPTION:
-- This test defines these four controlled types:
-- Good
-- Bad_Initialize
-- Bad_Adjust
-- Bad_Finalize
-- The type name conveys the associated failure. The operations in type
-- good will "touch" the boolean array indicating correct path
-- utilization for the purposes of checking "other <operations> are
-- performed", where <operations> ::= initialization, adjusting, and
-- finalization
--
--
--
-- CHANGE HISTORY:
-- 12 APR 94 SAIC Initial version
-- 02 MAY 96 SAIC Visibility fixed for 2.1
-- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286
-- 01 DEC 97 EDS Made correction wrt RM 7.6(21)
-- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with
-- RM 7.6.1(16/1) from Technical Corrigendum 1.
--
--!
 
------------------------------------------------------------- C761006_Support
 
package C761006_Support is
 
type Events is ( Good_Initialize, Good_Adjust, Good_Finalize );
 
type Event_Array is array(Events) of Boolean;
 
Events_Occurring : Event_Array := (others => False);
 
Propagating_Exception : exception;
 
procedure Raise_Propagating_Exception(Do_It: Boolean);
 
function Unique_Value return Natural;
 
end C761006_Support;
 
------------------------------------------------------------- C761006_Support
 
with Report;
package body C761006_Support is
 
procedure Raise_Propagating_Exception(Do_It: Boolean) is
begin
if Report.Ident_Bool(Do_It) then
raise Propagating_Exception;
end if;
end Raise_Propagating_Exception;
 
Seed : Natural := 0;
 
function Unique_Value return Natural is
begin
Seed := Seed +1;
return Seed;
end Unique_Value;
 
end C761006_Support;
 
------------------------------------------------------------------- C761006_0
 
with Ada.Finalization;
with C761006_Support;
package C761006_0 is
 
type Good is new Ada.Finalization.Controlled
with record
Initialized : Boolean := False;
Adjusted : Boolean := False;
Unique : Natural := C761006_Support.Unique_Value;
end record;
 
procedure Initialize( It: in out Good );
procedure Adjust ( It: in out Good );
procedure Finalize ( It: in out Good );
 
type Bad_Initialize is private;
 
type Bad_Adjust is private;
 
type Bad_Finalize is private;
 
Inits_Order : String(1..255);
Inits_Called : Natural := 0;
private
type Bad_Initialize is new Ada.Finalization.Controlled
with null record;
procedure Initialize( It: in out Bad_Initialize );
 
type Bad_Adjust is new Ada.Finalization.Controlled
with null record;
procedure Adjust ( It: in out Bad_Adjust );
 
type Bad_Finalize is
new Ada.Finalization.Controlled with null record;
procedure Finalize ( It: in out Bad_Finalize );
end C761006_0;
 
------------------------------------------------------------------- C761006_1
 
with Ada.Finalization;
with C761006_0;
package C761006_1 is
 
type Init_Check_Root is new Ada.Finalization.Controlled with record
Good_Component : C761006_0.Good;
Init_Fails : C761006_0.Bad_Initialize;
end record;
 
type Adj_Check_Root is new Ada.Finalization.Controlled with record
Good_Component : C761006_0.Good;
Adj_Fails : C761006_0.Bad_Adjust;
end record;
 
type Fin_Check_Root is new Ada.Finalization.Controlled with record
Good_Component : C761006_0.Good;
Fin_Fails : C761006_0.Bad_Finalize;
end record;
 
end C761006_1;
 
------------------------------------------------------------------- C761006_2
 
with C761006_1;
package C761006_2 is
 
type Init_Check is new C761006_1.Init_Check_Root with null record;
type Adj_Check is new C761006_1.Adj_Check_Root with null record;
type Fin_Check is new C761006_1.Fin_Check_Root with null record;
 
end C761006_2;
 
------------------------------------------------------------------- C761006_0
 
with Report;
with C761006_Support;
package body C761006_0 is
 
package Sup renames C761006_Support;
 
procedure Initialize( It: in out Good ) is
begin
Sup.Events_Occurring( Sup.Good_Initialize ) := True;
It.Initialized := True;
end Initialize;
 
procedure Adjust ( It: in out Good ) is
begin
Sup.Events_Occurring( Sup.Good_Adjust ) := True;
It.Adjusted := True;
It.Unique := C761006_Support.Unique_Value;
end Adjust;
 
procedure Finalize ( It: in out Good ) is
begin
Sup.Events_Occurring( Sup.Good_Finalize ) := True;
end Finalize;
 
procedure Initialize( It: in out Bad_Initialize ) is
begin
Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
end Initialize;
 
procedure Adjust( It: in out Bad_Adjust ) is
begin
Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
end Adjust;
 
procedure Finalize( It: in out Bad_Finalize ) is
begin
Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
end Finalize;
 
end C761006_0;
 
--------------------------------------------------------------------- C761006
 
with Report;
with C761006_0;
with C761006_2;
with C761006_Support;
with Ada.Exceptions;
with Ada.Finalization;
with Unchecked_Deallocation;
procedure C761006 is
 
package Sup renames C761006_Support;
use type Sup.Event_Array;
 
type Procedure_Handle is access procedure;
 
type Test_ID is ( Simple, Initialize, Adjust, Finalize );
 
Sub_Tests : array(Test_ID) of Procedure_Handle;
 
procedure Simple_Test is
A_Good_Object : C761006_0.Good; -- should call Initialize
begin
if not A_Good_Object.Initialized then
Report.Failed("Good object not initialized");
end if;
 
-- should call Adjust
A_Good_Object := ( Ada.Finalization.Controlled
with Unique => 0, others => False );
if not A_Good_Object.Adjusted then
Report.Failed("Good object not adjusted");
end if;
 
-- should call Finalize before end of scope
end Simple_Test;
 
procedure Initialize_Test is
begin
declare
This_Object_Fails_In_Initialize : C761006_2.Init_Check;
begin
Report.Failed("Exception in Initialize did not occur");
exception
when others =>
Report.Failed("Initialize caused exception at wrong lex");
end;
 
Report.Failed("Error in execution sequence");
 
exception
when Sup.Propagating_Exception => -- this is correct
if not Sup.Events_Occurring(Sup.Good_Initialize) then
Report.Failed("Initialization of Good Component did not occur");
end if;
end Initialize_Test;
 
procedure Adjust_Test is
This_Object_OK : C761006_2.Adj_Check;
This_Object_Target : C761006_2.Adj_Check;
begin
 
Check_Adjust_Due_To_Assignment: begin
This_Object_Target := This_Object_OK;
Report.Failed("Adjust did not propagate any exception");
exception
when Program_Error => -- expected case
if not This_Object_Target.Good_Component.Adjusted then
Report.Failed("other adjustment not performed");
end if;
when others =>
Report.Failed("Adjust propagated wrong exception");
end Check_Adjust_Due_To_Assignment;
 
C761006_Support.Events_Occurring := (True, False, False);
 
Check_Adjust_Due_To_Initial_Assignment: declare
Another_Target : C761006_2.Adj_Check := This_Object_OK;
begin
Report.Failed("Adjust did not propagate any exception");
exception
when others => Report.Failed("Adjust caused exception at wrong lex");
end Check_Adjust_Due_To_Initial_Assignment;
 
exception
when Program_Error => -- expected case
if Sup.Events_Occurring(Sup.Good_Finalize) /=
Sup.Events_Occurring(Sup.Good_Adjust) then
-- RM 7.6.1(16/1) says that the good Adjust may or may not
-- be performed; but if it is, then the Finalize must be
-- performed; and if it is not, then the Finalize must not
-- performed.
if Sup.Events_Occurring(Sup.Good_Finalize) then
Report.Failed("Good adjust not performed with bad adjust, " &
"but good finalize was");
else
Report.Failed("Good adjust performed with bad adjust, " &
"but good finalize was not");
end if;
end if;
when others =>
Report.Failed("Adjust propagated wrong exception");
end Adjust_Test;
 
procedure Finalize_Test is
 
Fin_Not_Perf : constant String := "other finalizations not performed";
 
procedure Finalize_15 is
Item : C761006_2.Fin_Check;
Target : C761006_2.Fin_Check;
begin
 
Item := Target;
-- finalization of Item should cause PE
-- ARM7.6:21 allows the implementation to omit the assignment of the
-- value into an anonymous object, which is the point at which Adjust
-- is normally called. However, this would result in Program_Error's
-- being raised before the call to Adjust, with the consequence that
-- Adjust is never called.
 
exception
when Program_Error => -- expected case
if not Sup.Events_Occurring(Sup.Good_Finalize) then
Report.Failed("Assignment: " & Fin_Not_Perf);
end if;
when others =>
Report.Failed("Other exception in Finalize_15");
 
-- finalization of Item/Target should cause PE
end Finalize_15;
 
-- check failure in finalize due to Unchecked_Deallocation
 
type Shark is access C761006_2.Fin_Check;
 
procedure Catch is
new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
 
procedure Finalize_17 is
White : Shark := new C761006_2.Fin_Check;
begin
Catch( White );
exception
when Program_Error =>
if not Sup.Events_Occurring(Sup.Good_Finalize) then
Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
end if;
end Finalize_17;
 
begin
 
Exception_In_Finalization: begin
Finalize_15;
exception
when Program_Error => null; -- anticipated
end Exception_In_Finalization;
 
Use_Of_Unchecked_Deallocation: begin
Finalize_17;
exception
when others =>
Report.Failed("Unchecked_Deallocation check, unwanted exception");
end Use_Of_Unchecked_Deallocation;
 
end Finalize_Test;
 
begin -- Main test procedure.
 
Report.Test ("C761006", "Check that exceptions raised in Initialize, " &
"Adjust and Finalize are processed correctly" );
 
Sub_Tests := (Simple_Test'Access, Initialize_Test'Access,
Adjust_Test'Access, Finalize_Test'Access);
 
for Test in Sub_Tests'Range loop
begin
 
Sup.Events_Occurring := (others => False);
 
Sub_Tests(Test).all;
 
case Test is
when Simple | Adjust =>
if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then
Report.Failed ( "Other operation missing in " &
Test_ID'Image ( Test ) );
end if;
when Initialize =>
null;
when Finalize =>
-- Note that for Good_Adjust, we may get either True or False
if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
Sup.Events_Occurring ( Sup.Good_Finalize ) = False
then
Report.Failed ( "Other operation missing in " &
Test_ID'Image ( Test ) );
end if;
end case;
 
exception
when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
& " from " & Test_ID'Image( Test ) );
end;
end loop;
 
Report.Result;
 
end C761006;
/c761007.a
0,0 → 1,419
-- C761007.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 if a finalize procedure invoked by a transfer of control
-- due to selection of a terminate alternative attempts to propagate an
-- exception, the exception is ignored, but any other finalizations due
-- to be performed are performed.
--
--
-- TEST DESCRIPTION:
-- This test declares a nested controlled data type, and embeds an object
-- of that type within a protected type. Objects of the protected type
-- are created and destroyed, and the actions of the embedded controlled
-- object are checked. The container controlled type causes an exception
-- as the last part of it's finalization operation.
--
-- This test utilizes several tasks to accomplish the objective. The
-- tasks contain delays to ensure that the expected order of processing
-- is indeed accomplished.
--
-- Subtest 1:
-- local task object runs to normal completion
--
-- Subtest 2:
-- local task aborts a nested task to cause finalization
--
-- Subtest 3:
-- local task sleeps long enough to allow procedure started
-- asynchronously to go into infinite loop. Procedure is then aborted
-- via ATC, causing finalization of objects.
--
-- Subtest 4:
-- local task object takes terminate alternative, causing finalization
--
--
-- CHANGE HISTORY:
-- 06 JUN 95 SAIC Initial version
-- 05 APR 96 SAIC Documentation changes
-- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test
-- 02 DEC 97 EDS Remove duplicate characters from check string.
--!
 
---------------------------------------------------------------- C761007_0
 
with Ada.Finalization;
package C761007_0 is
 
type Internal is new Ada.Finalization.Controlled
with record
Effect : Character;
end record;
 
procedure Finalize( I: in out Internal );
 
Side_Effect : String(1..80); -- way bigger than needed
Side_Effect_Finger : Natural := 0;
 
end C761007_0;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
package body C761007_0 is
 
procedure Finalize( I : in out Internal ) is
Previous_Side_Effect : Boolean := False;
begin
-- look to see if this character has been finalized yet
for SEI in 1..Side_Effect_Finger loop
Previous_Side_Effect := Previous_Side_Effect
or Side_Effect(Side_Effect_Finger) = I.Effect;
end loop;
 
-- if not, then tack it on to the string, and touch the character
if not Previous_Side_Effect then
Side_Effect_Finger := Side_Effect_Finger +1;
Side_Effect(Side_Effect_Finger) := I.Effect;
TCTouch.Touch(I.Effect);
end if;
 
end Finalize;
 
end C761007_0;
 
---------------------------------------------------------------- C761007_1
 
with C761007_0;
with Ada.Finalization;
package C761007_1 is
 
type Container is new Ada.Finalization.Controlled
with record
Effect : Character;
Content : C761007_0.Internal;
end record;
 
procedure Finalize( C: in out Container );
 
Side_Effect : String(1..80); -- way bigger than needed
Side_Effect_Finger : Natural := 0;
 
This_Exception_Is_Supposed_To_Be_Ignored : exception;
 
end C761007_1;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
package body C761007_1 is
 
procedure Finalize( C: in out Container ) is
Previous_Side_Effect : Boolean := False;
begin
-- look to see if this character has been finalized yet
for SEI in 1..Side_Effect_Finger loop
Previous_Side_Effect := Previous_Side_Effect
or Side_Effect(Side_Effect_Finger) = C.Effect;
end loop;
 
-- if not, then tack it on to the string, and touch the character
if not Previous_Side_Effect then
Side_Effect_Finger := Side_Effect_Finger +1;
Side_Effect(Side_Effect_Finger) := C.Effect;
TCTouch.Touch(C.Effect);
end if;
 
raise This_Exception_Is_Supposed_To_Be_Ignored;
 
end Finalize;
 
end C761007_1;
---------------------------------------------------------------- C761007_2
with C761007_1;
package C761007_2 is
 
protected type Prot_W_Fin_Obj is
procedure Set_Effects( Container, Filling: Character );
private
The_Data_Under_Test : C761007_1.Container;
-- finalization for this will occur when the Prot_W_Fin_Obj object
-- "goes out of existence" for whatever reason.
end Prot_W_Fin_Obj;
 
end C761007_2;
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
package body C761007_2 is
 
protected body Prot_W_Fin_Obj is
procedure Set_Effects( Container, Filling: Character ) is
begin
The_Data_Under_Test.Effect := Container; -- A, etc.
The_Data_Under_Test.Content.Effect := Filling; -- B, etc.
end Set_Effects;
end Prot_W_Fin_Obj;
 
end C761007_2;
 
------------------------------------------------------------------ C761007
 
with Report;
with Impdef;
with TCTouch;
with C761007_0;
with C761007_1;
with C761007_2;
procedure C761007 is
 
task type Subtests( Outer, Inner : Character) is
entry Ready;
entry Complete;
end Subtests;
 
task body Subtests is
Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj;
begin
Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner );
 
accept Ready;
 
select
accept Complete;
or terminate; -- used in Subtest 4
end select;
exception
-- the exception caused by the finalization of Local_Prot_W_Fin_Obj
-- should never be visible to this scope.
when others => Report.Failed("Exception in a Subtest object "
& Outer & Inner);
end Subtests;
 
procedure Subtest_1 is
-- check the case where "nothing special" happens.
 
This_Subtest : Subtests( 'A', 'B' );
begin
 
This_Subtest.Ready;
This_Subtest.Complete;
 
while not This_Subtest'Terminated loop -- wait for finalization
delay Impdef.Clear_Ready_Queue;
end loop;
 
-- in the finalization of This_Subtest, the controlled object embedded in
-- the Prot_W_Fin_Obj will finalize. An exception is raised in the
-- container object, after "touching" it's tag character.
-- The finalization of the contained controlled object must be performed.
 
 
TCTouch.Validate( "AB", "Item embedded in task" );
 
 
exception
when others => Report.Failed("Undesirable exception in Subtest_1");
 
end Subtest_1;
 
procedure Subtest_2 is
-- check for explicit abort
 
task Subtest_Task is
entry Complete;
end Subtest_Task;
 
task body Subtest_Task is
 
task Nesting;
task body Nesting is
Deep_Nesting : Subtests( 'E', 'F' );
begin
if Report.Ident_Bool( True ) then
-- controlled objects have been created in the elaboration of
-- Deep_Nesting. Deep_Nesting must call the Set_Effects operation
-- in the Prot_W_Fin_Obj, and then hang waiting for the Complete
-- entry call.
Deep_Nesting.Ready;
abort Deep_Nesting;
else
Report.Failed("Dead code in Nesting");
end if;
exception
when others => Report.Failed("Exception in Subtest_Task.Nesting");
end Nesting;
 
Local_2 : C761007_2.Prot_W_Fin_Obj;
 
begin
-- Nesting has activated at this point, which implies the activation
-- of Deep_Nesting as well.
 
Local_2.Set_Effects( 'C', 'D' );
 
-- wait for Nesting to terminate
 
while not Nesting'Terminated loop
delay Impdef.Clear_Ready_Queue;
end loop;
 
accept Complete;
 
exception
when others => Report.Failed("Exception in Subtest_Task");
end Subtest_Task;
 
begin
 
-- wait for everything in Subtest_Task to happen
Subtest_Task.Complete;
 
while not Subtest_Task'Terminated loop -- wait for finalization
delay Impdef.Clear_Ready_Queue;
end loop;
 
TCTouch.Validate( "EFCD", "Aborted nested task" );
 
exception
when others => Report.Failed("Undesirable exception in Subtest_2");
end Subtest_2;
 
procedure Subtest_3 is
-- check abort caused by asynchronous transfer of control
 
task Subtest_3_Task is
entry Complete;
end Subtest_3_Task;
 
procedure Check_Atc_Operation is
Check_Atc : C761007_2.Prot_W_Fin_Obj;
begin
 
Check_Atc.Set_Effects( 'G', 'H' );
 
 
while Report.Ident_Bool( True ) loop -- wait to be aborted
if Report.Ident_Bool( True ) then
Impdef.Exceed_Time_Slice;
delay Impdef.Switch_To_New_Task;
else
Report.Failed("Optimization prevention");
end if;
end loop;
 
Report.Failed("Check_Atc_Operation loop completed");
 
end Check_Atc_Operation;
 
task body Subtest_3_Task is
task Nesting is
entry Complete;
end Nesting;
 
task body Nesting is
Nesting_3 : C761007_2.Prot_W_Fin_Obj;
begin
Nesting_3.Set_Effects( 'G', 'H' );
 
-- give Check_Atc_Operation sufficient time to perform it's
-- Set_Effects on it's local Prot_W_Fin_Obj object
delay Impdef.Clear_Ready_Queue;
 
accept Complete;
exception
when others => Report.Failed("Exception in Subtest_3_Task.Nesting");
end Nesting;
 
Local_3 : C761007_2.Prot_W_Fin_Obj;
 
begin -- Subtest_3_Task
 
Local_3.Set_Effects( 'I', 'J' );
 
select
Nesting.Complete;
then abort ---------------------------------------------------- cause KL
Check_ATC_Operation;
end select;
 
accept Complete;
 
exception
when others => Report.Failed("Exception in Subtest_3_Task");
end Subtest_3_Task;
 
begin -- Subtest_3
Subtest_3_Task.Complete;
 
while not Subtest_3_Task'Terminated loop -- wait for finalization
delay Impdef.Clear_Ready_Queue;
end loop;
 
TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" );
 
exception
when others => Report.Failed("Undesirable exception in Subtest_3");
end Subtest_3;
 
procedure Subtest_4 is
-- check the case where transfer is caused by terminate alternative
-- highly similar to Subtest_1
 
This_Subtest : Subtests( 'M', 'N' );
begin
 
This_Subtest.Ready;
-- don't call This_Subtest.Complete;
 
exception
when others => Report.Failed("Undesirable exception in Subtest_4");
 
end Subtest_4;
 
begin -- Main test procedure.
 
Report.Test ("C761007", "Check that if a finalize procedure invoked by " &
"a transfer of control or selection of a " &
"terminate alternative attempts to propagate " &
"an exception, the exception is ignored, but " &
"any other finalizations due to be performed " &
"are performed" );
 
Subtest_1; -- checks internal
 
Subtest_2; -- checks internal
 
Subtest_3; -- checks internal
 
Subtest_4;
TCTouch.Validate( "MN", "transfer due to terminate alternative" );
 
Report.Result;
 
end C761007;
/c74401q.ada
0,0 → 1,119
-- C74401Q.ADA
 
-- 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.
--*
-- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE
-- DECLARED FOR A GENERIC SUBPROGRAM IN A PACKAGE SPECIFICATION,
-- INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE PART.
 
-- JBG 5/1/85
 
WITH REPORT; USE REPORT;
PROCEDURE C74401Q IS
 
PACKAGE PKG IS
TYPE LP IS LIMITED PRIVATE;
 
GENERIC
PROCEDURE P20 (X : OUT LP); -- OK.
PROCEDURE RESET (X : OUT LP);
FUNCTION EQ (L, R : LP) RETURN BOOLEAN;
VAL1 : CONSTANT LP;
 
PACKAGE NESTED IS
GENERIC
PROCEDURE NEST1 (X : OUT LP);
PRIVATE
GENERIC
PROCEDURE NEST2 (X : OUT LP);
END NESTED;
PRIVATE
TYPE LP IS NEW INTEGER;
VAL1 : CONSTANT LP := LP(IDENT_INT(3));
END PKG;
 
VAR : PKG.LP;
 
PACKAGE BODY PKG IS
PROCEDURE P20 (X : OUT LP) IS
BEGIN
X := 3;
END P20;
 
PROCEDURE RESET (X : OUT LP) IS
BEGIN
X := 0;
END RESET;
 
FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS
BEGIN
RETURN L = R;
END EQ;
 
PACKAGE BODY NESTED IS
PROCEDURE NEST1 (X : OUT LP) IS
BEGIN
X := 3;
END NEST1;
 
PROCEDURE NEST2 (X : OUT LP) IS
BEGIN
X := LP(IDENT_INT(3));
END NEST2;
END NESTED;
BEGIN
VAR := LP(IDENT_INT(0));
END PKG;
 
PACKAGE INSTANCES IS
PROCEDURE NP20 IS NEW PKG.P20;
PROCEDURE NNEST1 IS NEW PKG.NESTED.NEST1;
END INSTANCES;
USE INSTANCES;
 
PACKAGE PKG1 IS
PROCEDURE P21 (X : OUT PKG.LP) RENAMES INSTANCES.NP20;
END PKG1;
 
BEGIN
 
TEST ("C74401Q", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " &
"PARAMETER WITH A LIMITED PRIVATE TYPE");
 
PKG.RESET (VAR);
NP20 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("DIRECT CALL NOT CORRECT");
END IF;
 
PKG.RESET (VAR);
PKG1.P21 (VAR);
 
IF NOT PKG.EQ (VAR, PKG.VAL1) THEN
FAILED ("RENAMED CALL NOT CORRECT");
END IF;
 
RESULT;
 
END C74401Q;
/c730a01.a
0,0 → 1,176
-- C730A01.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 a tagged type declared in a package specification
-- may be passed as a generic formal (tagged) private type to a generic
-- package declaration. Check that the formal type may be extended with
-- a private extension in the generic package.
--
-- Check that, in the instance, the private extension inherits the
-- user-defined primitive subprograms of the tagged actual.
--
-- TEST DESCRIPTION:
-- Declare a tagged type and an associated primitive subprogram in a
-- package specification (foundation code). Declare a generic package
-- which takes a tagged type as a formal parameter, and then extends
-- it with a private extension (foundation code).
--
-- Instantiate the generic package with the tagged type from the first
-- package (the "generic" extension should now have inherited
-- the primitive subprogram of the tagged type from the first
-- package).
--
-- In the main program, call the primitive subprogram inherited by the
-- "generic" extension, and verify the correctness of the components.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- F730A000.A
-- F730A001.A
-- => C730A01.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
 
with F730A001; -- Book definitions.
package C730A01_0 is -- Raw data to be used in creating book elements.
 
 
Book_Count : constant := 3;
 
subtype Number_Of_Books is Integer range 1 .. Book_Count;
 
type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
 
Title_List : Data_List := (new String'("Wuthering Heights"),
new String'("Heart of Darkness"),
new String'("Ulysses"));
 
Author_List : Data_List := (new String'("Bronte, Emily"),
new String'("Conrad, Joseph"),
new String'("Joyce, James"));
 
end C730A01_0;
 
 
--==================================================================--
 
 
 
 
--==================================================================--
 
 
-- Library-level instantiation. Actual parameter is tagged record.
 
with F730A001; -- Book definitions.
with F730A000; -- Singly-linked list abstraction.
package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type);
 
 
--==================================================================--
 
 
with Report;
 
with F730A001; -- Book definitions.
with C730A01_0; -- Raw book data.
with C730A01_1; -- Instance.
 
use F730A001; -- Primitive operations of Book_Type directly visible.
use C730A01_1; -- Operations inherited by Node_Type directly visible.
 
procedure C730A01 is
 
 
List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
 
 
--========================================================--
 
 
procedure Create_List (Title, Author : in C730A01_0.Data_List;
Head : in out Priv_Node_Ptr) is
 
Book : Priv_Node_Type; -- Object of extended type.
Book_Ptr : Priv_Node_Ptr;
 
begin
for I in C730A01_0.Number_Of_Books loop
Create_Book (Title (I), Author (I), Book); -- Call inherited
-- operation.
Book_Ptr := new Priv_Node_Type'(Book);
Add (Book_Ptr, Head);
end loop;
end Create_List;
 
 
--========================================================--
 
 
function Bad_List_Contents return Boolean is
Book1_Ptr : Priv_Node_Ptr;
Book2_Ptr : Priv_Node_Ptr;
Book3_Ptr : Priv_Node_Ptr;
begin
Remove (List_Of_Books, Book1_Ptr);
Remove (List_Of_Books, Book2_Ptr);
Remove (List_Of_Books, Book3_Ptr);
return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
Book1_Ptr.Author.all /= "Joyce, James" or -- components
Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in
Book3_Ptr.Title.all /= "Wuthering Heights" or -- private
Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension.
 
end Bad_List_Contents;
 
 
--========================================================--
 
 
begin -- Main program.
 
Report.Test ("C730A01", "Inheritance of primitive operations: private " &
"extension of formal tagged private type; actual is " &
"an ultimate ancestor type");
 
-- Create linked list using inherited operation:
Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books);
 
-- Verify results:
if Bad_List_Contents then
Report.Failed ("Wrong values after call to inherited operation");
end if;
 
Report.Result;
 
end C730A01;
/c730a02.a
0,0 → 1,252
-- C730A02.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 a private extension (declared in a package specification) of
-- a tagged type (declared in a different package specification) may be
-- passed as a generic formal (tagged) private type to a generic package
-- declaration. Check that the formal type may be further extended with a
-- private extension in the generic package.
--
-- Check that the (visible) components inherited by the "generic"
-- extension are visible outside the generic package.
--
-- Check that, in the instance, the private extension inherits the
-- user-defined primitive subprograms of the tagged actual, including
-- those inherited by the actual from its parent.
--
-- TEST DESCRIPTION:
-- Declare a tagged type and an associated primitive subprogram in a
-- package specification (foundation code). Declare a private extension
-- of the tagged type and an associated primitive subprogram in a second
-- package specification. Declare a generic package which takes a tagged
-- type as a formal parameter, and then extends it with a private
-- extension (foundation code).
--
-- Instantiate the generic package with the private extension from the
-- second package (the "generic" extension should now have inherited
-- the primitive subprograms of the private extension from the second
-- package).
--
-- In the main program, call the primitive subprograms inherited by the
-- "generic" extension. There are two: (1) Create_Book, declared for
-- the root tagged type in the first package (inherited by the private
-- extension of the second package, and then in turn by the "generic"
-- extension), and (2) Update_Pages, declared for the private extension
-- in the second package. Verify the correctness of the components.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- F730A000.A
-- F730A001.A
-- => C730A02.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with F730A001; -- Book definitions.
package C730A02_0 is -- Extended book abstraction.
 
 
type Detailed_Book_Type is new F730A001.Book_Type -- Private ext.
with private; -- of root tagged
-- type.
 
-- Inherits Create_Book from Book_Type.
 
procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op.
Pages : in Natural); -- of extension.
 
 
-- The following function is needed to verify the value of the
-- extension's private component. It will be inherited by extensions
-- of Detailed_Book_Type.
 
function Get_Pages (Book : in Detailed_Book_Type) return Natural;
private
 
type Detailed_Book_Type is new F730A001.Book_Type with record
Pages : Natural;
end record;
 
end C730A02_0;
 
 
--==================================================================--
 
 
package body C730A02_0 is
 
 
procedure Update_Pages (Book : in out Detailed_Book_Type;
Pages : in Natural) is
begin
Book.Pages := Pages;
end Update_Pages;
 
 
function Get_Pages (Book : in Detailed_Book_Type) return Natural is
begin
return (Book.Pages);
end Get_Pages;
 
 
end C730A02_0;
 
 
--==================================================================--
 
 
with F730A001; -- Book definitions.
package C730A02_1 is -- Raw data to be used in creating book elements.
 
 
Book_Count : constant := 3;
 
subtype Number_Of_Books is Integer range 1 .. Book_Count;
 
type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr;
type Page_Counts is array (Number_Of_Books) of Natural;
 
Title_List : Data_List := (new String'("Wuthering Heights"),
new String'("Heart of Darkness"),
new String'("Ulysses"));
 
Author_List : Data_List := (new String'("Bronte, Emily"),
new String'("Conrad, Joseph"),
new String'("Joyce, James"));
 
Page_List : Page_Counts := (237, 215, 456);
 
end C730A02_1;
 
 
-- No body for C730A02_1.
 
 
--==================================================================--
 
 
-- Library-level instantiation. Actual parameter is private extension.
 
with C730A02_0; -- Extended book abstraction.
with F730A000; -- Singly-linked list abstraction.
package C730A02_2 is new F730A000
(Parent_Type => C730A02_0.Detailed_Book_Type);
 
 
--==================================================================--
 
 
with Report;
 
with C730A02_0; -- Extended book abstraction.
with C730A02_1; -- Raw book data.
with C730A02_2; -- Instance.
 
use C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
use C730A02_2; -- Operations inherited by Priv_Node_Type directly visible.
 
procedure C730A02 is
 
 
List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books.
 
 
--========================================================--
 
 
procedure Create_List (Title, Author : in C730A02_1.Data_List;
Pages : in C730A02_1.Page_Counts;
Head : in out Priv_Node_Ptr) is
 
Book : Priv_Node_Type; -- Object of extended type.
Book_Ptr : Priv_Node_Ptr;
 
begin
for I in C730A02_1.Number_Of_Books loop
Create_Book (Title (I), Author (I), Book); -- Call twice-inherited
-- operation.
Update_Pages (Book, Pages (I)); -- Call inherited op.
Book_Ptr := new Priv_Node_Type'(Book);
Add (Book_Ptr, Head);
end loop;
end Create_List;
 
 
--========================================================--
 
 
function Bad_List_Contents return Boolean is
Book1_Ptr : Priv_Node_Ptr;
Book2_Ptr : Priv_Node_Ptr;
Book3_Ptr : Priv_Node_Ptr;
begin
 
Remove (List_Of_Books, Book1_Ptr);
Remove (List_Of_Books, Book2_Ptr);
Remove (List_Of_Books, Book3_Ptr);
 
return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited
Book1_Ptr.Author.all /= "Joyce, James" or -- components
Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still
Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible
Book3_Ptr.Title.all /= "Wuthering Heights" or -- in private
Book3_Ptr.Author.all /= "Bronte, Emily" or -- "generic"
-- extension.
-- Call inherited operations using dereferenced pointers.
Get_Pages (Book1_Ptr.all) /= 456 or
Get_Pages (Book2_Ptr.all) /= 215 or
Get_Pages (Book3_Ptr.all) /= 237);
 
end Bad_List_Contents;
 
 
--========================================================--
 
 
begin -- Main program.
 
Report.Test ("C730A02", "Inheritance of primitive operations: private " &
"extension of formal tagged private type; actual is " &
"a private extension");
 
-- Create linked list using inherited operation:
Create_List (C730A02_1.Title_List, C730A02_1.Author_List,
C730A02_1.Page_List, List_Of_Books);
 
-- Verify results:
if Bad_List_Contents then
Report.Failed ("Wrong values after call to inherited operations");
end if;
 
Report.Result;
 
end C730A02;
/c72002a.ada
0,0 → 1,229
-- C72002A.ADA
 
-- 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 THE DECLARATIVE ITEMS IN A PACKAGE SPECIFICATION ARE
-- ELABORATED IN THE ORDER DECLARED.
 
-- HISTORY:
-- DHH 03/09/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE C72002A IS
 
A : INTEGER := 0;
TYPE ORDER_ARRAY IS ARRAY(1 .. 14) OF INTEGER;
OBJECT_ARRAY : ORDER_ARRAY;
TYPE REAL IS DIGITS 4;
TYPE ENUM IS (RED,YELLOW,BLUE);
 
TYPE ARR IS ARRAY(1 ..2) OF BOOLEAN;
D : ARR := (TRUE, TRUE);
E : ARR := (FALSE, FALSE);
 
TYPE REC IS
RECORD
I : INTEGER;
END RECORD;
B : REC := (I => IDENT_INT(1));
C : REC := (I => IDENT_INT(2));
 
FUNCTION GIVEN_ORDER(X : INTEGER) RETURN INTEGER IS
Y : INTEGER;
BEGIN
Y := X + 1;
RETURN Y;
END GIVEN_ORDER;
 
FUNCTION BOOL(X : INTEGER) RETURN BOOLEAN IS
BEGIN
IF X = IDENT_INT(1) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN TRUE;
ELSIF X = IDENT_INT(8) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN FALSE;
END IF;
END BOOL;
 
FUNCTION INT(X : INTEGER) RETURN INTEGER IS
BEGIN
IF X = IDENT_INT(2) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN IDENT_INT(1);
ELSIF X = IDENT_INT(9) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN IDENT_INT(2);
END IF;
END INT;
 
FUNCTION FLOAT(X : INTEGER) RETURN REAL IS
BEGIN
IF X = IDENT_INT(3) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN 1.0;
ELSIF X = IDENT_INT(10) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN 2.0;
END IF;
END FLOAT;
 
FUNCTION CHAR(X : INTEGER) RETURN CHARACTER IS
BEGIN
IF X = IDENT_INT(4) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN 'A';
ELSIF X = IDENT_INT(11) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN 'Z';
END IF;
END CHAR;
 
FUNCTION ENUMR(X : INTEGER) RETURN ENUM IS
BEGIN
IF X = IDENT_INT(5) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN RED;
ELSIF X = IDENT_INT(12) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN YELLOW;
END IF;
END ENUMR;
 
FUNCTION ARRY(X : INTEGER) RETURN ARR IS
BEGIN
IF X = IDENT_INT(6) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN D;
ELSIF X = IDENT_INT(13) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN E;
END IF;
END ARRY;
 
FUNCTION RECOR(X : INTEGER) RETURN REC IS
BEGIN
IF X = IDENT_INT(7) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN B;
ELSIF X = IDENT_INT(14) THEN
A := GIVEN_ORDER(A);
OBJECT_ARRAY(X) := A;
RETURN C;
END IF;
END RECOR;
 
PACKAGE PACK IS
A : BOOLEAN := BOOL(1);
B : INTEGER := INT(2);
C : REAL := FLOAT(3);
D : CHARACTER := CHAR(4);
E : ENUM := ENUMR(5);
F : ARR := ARRY(6);
G : REC := RECOR(7);
H : BOOLEAN := BOOL(8);
I : INTEGER := INT(9);
J : REAL := FLOAT(10);
K : CHARACTER := CHAR(11);
L : ENUM := ENUMR(12);
M : ARR := ARRY(13);
N : REC := RECOR(14);
END PACK;
 
BEGIN
TEST("C72002A", "CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE " &
"SPECIFICATION ARE ELABORATED IN THE ORDER " &
"DECLARED");
 
IF OBJECT_ARRAY(1) /= IDENT_INT(1) THEN
FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(2) /= IDENT_INT(2) THEN
FAILED("INTEGER 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(3) /= IDENT_INT(3) THEN
FAILED("REAL 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(4) /= IDENT_INT(4) THEN
FAILED("CHARACTER 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(5) /= IDENT_INT(5) THEN
FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(6) /= IDENT_INT(6) THEN
FAILED("ARRAY 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(7) /= IDENT_INT(7) THEN
FAILED("RECORD 1 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(8) /= IDENT_INT(8) THEN
FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(9) /= IDENT_INT(9) THEN
FAILED("INTEGER 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(10) /= IDENT_INT(10) THEN
FAILED("REAL 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(11) /= IDENT_INT(11) THEN
FAILED("CHARACTER 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(12) /= IDENT_INT(12) THEN
FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(13) /= IDENT_INT(13) THEN
FAILED("ARRAY 2 ELABORATED OUT OF ORDER");
END IF;
 
IF OBJECT_ARRAY(14) /= IDENT_INT(14) THEN
FAILED("RECORD 2 ELABORATED OUT OF ORDER");
END IF;
 
RESULT;
END C72002A;
/c73002a.ada
0,0 → 1,110
-- C73002A.ADA
 
-- 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.
--*
-- CHECK THAT THE STATEMENTS IN A PACKAGE BODY ARE EXECUTED AFTER THE
-- ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY).
 
 
-- RM 05/15/81
-- JBG 9/21/83
 
WITH REPORT;
PROCEDURE C73002A IS
 
USE REPORT;
 
BEGIN
 
TEST( "C73002A" , "CHECK: EXECUTION OF STATEMENTS IN A PACKAGE " &
"BODY FOLLOWS ELABORATION OF THE DECLARATIONS");
 
DECLARE
 
PACKAGE P1 IS
 
A : INTEGER := IDENT_INT(7);
 
PACKAGE P2 IS
B : INTEGER := IDENT_INT(11);
END P2;
 
END P1;
 
 
PACKAGE BODY P1 IS -- A AA B BB
 
AA : INTEGER := IDENT_INT(7); -- 7 7 11 (11)
 
PACKAGE BODY P2 IS
BB : INTEGER := IDENT_INT(11);-- 7 11 11
BEGIN
 
B := 2*B ; -- 7 7 22 11
BB := 2*BB; -- 7 7 22 22
A := 5*A ; -- 35 7 22 22
AA := 2*AA; -- 35 14 22 22
 
IF BB /= 22 OR
AA /= 14 OR
A /= 35 OR
B /= 22
THEN
FAILED( "ASSIGNED VALUES INCORRECT - 1" );
END IF;
 
END P2;
 
BEGIN
 
A := A + 20; -- 55 14 22 22
AA := AA + 20; -- 55 34 22 22
 
IF AA /= 34 OR
A /= 55 OR
P2.B /= 22
THEN
FAILED( "ASSIGNED VALUES INCORRECT - 2" );
END IF;
 
END P1;
 
 
USE P1;
USE P2;
 
BEGIN
 
IF A /= 55 OR
B /= 22
THEN
FAILED( "ASSIGNED VALUES INCORRECT - 3" );
END IF;
 
END;
 
 
RESULT;
 
 
END C73002A;
/c74210a.ada
0,0 → 1,117
-- C74210A.ADA
 
-- 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.
--*
-- CHECK THAT OPERATOR SYMBOLS OVERLOADED IN A PACKAGE ARE
-- USED AND DERIVED IN PREFERENCE TO THOSE OF THE PARENT OF A DERIVED
-- PRIVATE TYPE.
 
-- CHECK THAT OPERATOR DEFINITIONS FOR A PRIVATE TYPE MAY BE
-- OVERLOADED OUTSIDE THE PACKAGE.
 
-- CHECK THAT EQUALITY CAN BE DEFINED FOR LIMITED TYPES AND COMPOSITE
-- TYPES WITH LIMITED COMPONENTS.
 
-- DAT 5/11/81
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74210A IS
BEGIN
TEST ("C74210A", "OVERLOADED OPERATORS FOR PRIVATE TYPES");
 
DECLARE
PACKAGE P IS
TYPE T IS PRIVATE;
FUNCTION "+" (X, Y : T) RETURN T;
ONE, TWO : CONSTANT T;
 
TYPE L IS LIMITED PRIVATE;
TYPE A IS ARRAY (0 .. 0) OF L;
TYPE R IS RECORD
C : L;
END RECORD;
FUNCTION "=" (X, Y : L) RETURN BOOLEAN;
PRIVATE
TYPE T IS NEW INTEGER;
ONE : CONSTANT T := T(IDENT_INT(1));
TWO : CONSTANT T := T(IDENT_INT(2));
TYPE L IS (ENUM);
END P;
USE P;
 
VR : R;
VA : A;
 
PACKAGE BODY P IS
FUNCTION "+" (X, Y : T) RETURN T IS
BEGIN
RETURN 1;
END "+";
 
FUNCTION "=" (X, Y : L) RETURN BOOLEAN IS
BEGIN
RETURN IDENT_BOOL(FALSE);
END "=";
BEGIN
VR := (C => ENUM);
VA := (0 => VR.C);
END P;
BEGIN
IF ONE + TWO /= ONE THEN
FAILED ("WRONG ""+"" OPERATOR");
END IF;
 
DECLARE
TYPE NEW_T IS NEW T;
 
FUNCTION "=" (X, Y : A) RETURN BOOLEAN;
FUNCTION "=" (X, Y : R) RETURN BOOLEAN;
 
FUNCTION "+" (X, Y : T) RETURN T IS
BEGIN
RETURN TWO;
END "+";
 
FUNCTION "=" (X, Y : A) RETURN BOOLEAN IS
BEGIN
RETURN X(0) = Y(0);
END "=";
 
FUNCTION "=" (X, Y : R) RETURN BOOLEAN IS
BEGIN
RETURN X.C = Y.C;
END "=";
BEGIN
IF ONE + TWO /= TWO THEN
FAILED ("WRONG DERIVED ""+"" OPERATOR");
END IF;
 
IF VR = VR OR VA = VA THEN
FAILED ("CANNOT OVERLOAD ""="" CORRECTLY");
END IF;
END;
END;
 
RESULT;
END C74210A;
/c74004a.ada
0,0 → 1,375
-- C74004A.ADA
 
-- 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 OPERATIONS DEPENDING ON THE FULL DECLARATION OF A
-- PRIVATE TYPE ARE AVAILABLE WITHIN THE PACKAGE BODY.
 
-- HISTORY:
-- BCB 04/05/88 CREATED ORIGINAL TEST.
-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74004A IS
 
PACKAGE P IS
TYPE PR IS PRIVATE;
TYPE ARR1 IS LIMITED PRIVATE;
TYPE ARR2 IS PRIVATE;
TYPE REC (D : INTEGER) IS PRIVATE;
TYPE ACC IS PRIVATE;
TYPE TSK IS LIMITED PRIVATE;
TYPE FLT IS LIMITED PRIVATE;
TYPE FIX IS LIMITED PRIVATE;
 
TASK TYPE T IS
ENTRY ONE(V : IN OUT INTEGER);
END T;
 
PROCEDURE CHECK (V : ARR2);
PRIVATE
TYPE PR IS NEW INTEGER;
 
TYPE ARR1 IS ARRAY(1..5) OF INTEGER;
 
TYPE ARR2 IS ARRAY(1..5) OF BOOLEAN;
 
TYPE REC (D : INTEGER) IS RECORD
COMP1 : INTEGER;
COMP2 : BOOLEAN;
END RECORD;
 
TYPE ACC IS ACCESS INTEGER;
 
TYPE TSK IS NEW T;
 
TYPE FLT IS DIGITS 5;
 
TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0;
END P;
 
PACKAGE BODY P IS
X1, X2, X3 : PR;
BOOL : BOOLEAN := IDENT_BOOL(FALSE);
VAL : INTEGER := IDENT_INT(0);
FVAL : FLOAT := 0.0;
ST : STRING(1..2);
O1 : ARR1 := (1,2,3,4,5);
Y1 : ARR2 := (FALSE,TRUE,FALSE,TRUE,FALSE);
Y2 : ARR2 := (OTHERS => TRUE);
Y3 : ARR2 := (OTHERS => FALSE);
Z1 : REC(0) := (0,1,FALSE);
W1, W2 : ACC := NEW INTEGER'(0);
V1 : TSK;
 
TASK BODY T IS
BEGIN
ACCEPT ONE(V : IN OUT INTEGER) DO
V := IDENT_INT(10);
END ONE;
END T;
 
PROCEDURE CHECK (V : ARR2) IS
BEGIN
IF V /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
FAILED ("IMPROPER VALUE PASSED AS AGGREGATE");
END IF;
END CHECK;
BEGIN
TEST ("C74004A", "CHECK THAT OPERATIONS DEPENDING ON THE " &
"FULL DECLARATION OF A PRIVATE TYPE ARE " &
"AVAILABLE WITHIN THE PACKAGE BODY");
 
X1 := 10;
X2 := 5;
 
X3 := X1 + X2;
 
IF X3 /= 15 THEN
FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR");
END IF;
 
X3 := X1 - X2;
 
IF X3 /= 5 THEN
FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR");
END IF;
 
X3 := X1 * X2;
 
IF X3 /= 50 THEN
FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR");
END IF;
 
X3 := X1 / X2;
 
IF X3 /= 2 THEN
FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR");
END IF;
 
X3 := X1 ** 2;
 
IF X3 /= 100 THEN
FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR");
END IF;
 
BOOL := X1 < X2;
 
IF BOOL THEN
FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR");
END IF;
 
BOOL := X1 > X2;
 
IF NOT BOOL THEN
FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR");
END IF;
 
BOOL := X1 <= X2;
 
IF BOOL THEN
FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " &
"OPERATOR");
END IF;
 
BOOL := X1 >= X2;
 
IF NOT BOOL THEN
FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " &
"TO OPERATOR");
END IF;
 
X3 := X1 MOD X2;
 
IF X3 /= 0 THEN
FAILED ("IMPROPER RESULT FROM MOD OPERATOR");
END IF;
 
X3 := X1 REM X2;
 
IF X3 /= 0 THEN
FAILED ("IMPROPER RESULT FROM REM OPERATOR");
END IF;
 
X3 := ABS(X1);
 
IF X3 /= 10 THEN
FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 1");
END IF;
 
X1 := -10;
 
X3 := ABS(X1);
 
IF X3 /= 10 THEN
FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 2");
END IF;
 
X3 := PR'BASE'FIRST;
 
IF X3 /= PR(INTEGER'FIRST) THEN
FAILED ("IMPROPER RESULT FROM 'BASE'FIRST");
END IF;
 
X3 := PR'FIRST;
 
IF X3 /= PR(INTEGER'FIRST) THEN
FAILED ("IMPROPER RESULT FROM 'FIRST");
END IF;
 
VAL := PR'WIDTH;
 
IF NOT EQUAL(VAL,INTEGER'WIDTH) THEN
FAILED ("IMPROPER RESULT FROM 'WIDTH");
END IF;
 
VAL := PR'POS(X3);
 
IF NOT EQUAL(VAL,INTEGER'FIRST) THEN
FAILED ("IMPROPER RESULT FROM 'POS");
END IF;
 
X3 := PR'VAL(VAL);
 
IF X3 /= PR(INTEGER'FIRST) THEN
FAILED ("IMPROPER RESULT FROM 'VAL");
END IF;
 
X3 := PR'SUCC(X2);
 
IF X3 /= 6 THEN
FAILED ("IMPROPER RESULT FROM 'SUCC");
END IF;
 
X3 := PR'PRED(X2);
 
IF X3 /= 4 THEN
FAILED ("IMPROPER RESULT FROM 'PRED");
END IF;
 
ST := PR'IMAGE(X3);
 
IF ST /= INTEGER'IMAGE(INTEGER(X3)) THEN
FAILED ("IMPROPER RESULT FROM 'IMAGE");
END IF;
 
X3 := PR'VALUE(ST);
 
IF X3 /= PR(INTEGER'VALUE(ST)) THEN
FAILED ("IMPROPER RESULT FROM 'VALUE");
END IF;
 
CHECK ((TRUE,FALSE,TRUE,FALSE,TRUE));
 
IF O1(2) /= IDENT_INT(2) THEN
FAILED ("IMPROPER VALUE FROM INDEXING");
END IF;
 
IF O1(2..4) /= (2,3,4) THEN
FAILED ("IMPROPER VALUES FROM SLICING");
END IF;
 
IF VAL IN O1'RANGE THEN
FAILED ("IMPROPER RESULT FROM 'RANGE");
END IF;
 
VAL := O1'LENGTH;
 
IF NOT EQUAL(VAL,5) THEN
FAILED ("IMPROPER RESULT FROM 'LENGTH");
END IF;
 
Y3 := Y1(1..2) & Y2(3..5);
 
IF Y3 /= (FALSE,TRUE,TRUE,TRUE,TRUE) THEN
FAILED ("IMPROPER RESULT FROM CATENATION");
END IF;
 
Y3 := NOT Y1;
 
IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
FAILED ("IMPROPER RESULT FROM NOT OPERATOR");
END IF;
 
Y3 := Y1 AND Y2;
 
IF Y3 /= (FALSE,TRUE,FALSE,TRUE,FALSE) THEN
FAILED ("IMPROPER RESULT FROM AND OPERATOR");
END IF;
 
Y3 := Y1 OR Y2;
 
IF Y3 /= (TRUE,TRUE,TRUE,TRUE,TRUE) THEN
FAILED ("IMPROPER RESULT FROM OR OPERATOR");
END IF;
 
Y3 := Y1 XOR Y2;
 
IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN
FAILED ("IMPROPER RESULT FROM XOR OPERATOR");
END IF;
 
VAL := Z1.COMP1;
 
IF NOT EQUAL(VAL,1) THEN
FAILED ("IMPROPER RESULT FROM SELECTION OF RECORD " &
"COMPONENTS");
END IF;
 
W1 := NEW INTEGER'(0);
 
IF NOT EQUAL(W1.ALL,0) THEN
FAILED ("IMPROPER RESULT FROM ALLOCATION");
END IF;
 
W1 := NULL;
 
IF W1 /= NULL THEN
FAILED ("IMPROPER RESULT FROM NULL LITERAL");
END IF;
 
VAL := W2.ALL;
 
IF NOT EQUAL(VAL,0) THEN
FAILED ("IMPROPER RESULT FROM SELECTED COMPONENT");
END IF;
 
BOOL := V1'CALLABLE;
 
IF NOT BOOL THEN
FAILED ("IMPROPER RESULT FROM 'CALLABLE");
END IF;
 
BOOL := V1'TERMINATED;
 
IF BOOL THEN
FAILED ("IMPROPER RESULT FROM 'TERMINATED");
END IF;
 
V1.ONE(VAL);
 
IF NOT EQUAL(VAL,10) THEN
FAILED ("IMPROPER RESULT RETURNED FROM ENTRY SELECTION");
END IF;
 
IF NOT (FLT(1.0) IN FLT) THEN
FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION");
END IF;
 
VAL := FLT'DIGITS;
 
IF NOT EQUAL(VAL,5) THEN
FAILED ("IMPROPER RESULT FROM 'DIGITS");
END IF;
 
BOOL := FLT'MACHINE_ROUNDS;
 
BOOL := FLT'MACHINE_OVERFLOWS;
 
VAL := FLT'MACHINE_RADIX;
 
VAL := FLT'MACHINE_MANTISSA;
 
VAL := FLT'MACHINE_EMAX;
 
VAL := FLT'MACHINE_EMIN;
 
FVAL := FIX'DELTA;
 
IF FVAL /= 2.0**(-1) THEN
FAILED ("IMPROPER RESULT FROM 'DELTA");
END IF;
 
VAL := FIX'FORE;
 
VAL := FIX'AFT;
 
END P;
 
USE P;
 
BEGIN
RESULT;
END C74004A;
/c74402a.ada
0,0 → 1,154
-- C74402A.ADA
 
-- 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.
--*
-- CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED TYPE MAY HAVE A
-- DEFAULT EXPRESSION, EVEN IF THE SUBPROGRAM IS DECLARED OUTSIDE
-- THE PACKAGE THAT DECLARES THE LIMITED TYPE.
-- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.)
 
-- DSJ 5/6/83
-- SPS 10/24/83
 
WITH REPORT;
PROCEDURE C74402A IS
 
USE REPORT;
 
BEGIN
 
TEST("C74402A", "CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED " &
"TYPE MAY HAVE A DEFAULT EXPRESSION, EVEN IF " &
"THE SUBPROGRAM IS DECLARED OUTSIDE THE PACKAGE " &
"THAT DECLARES THE LIMITED TYPE");
 
DECLARE
 
PACKAGE PACK1 IS
 
TYPE LP1 IS LIMITED PRIVATE;
TYPE LP2 IS ARRAY (1 .. 2) OF LP1;
TYPE LP3 IS
RECORD
C1, C2 : LP2;
END RECORD;
 
FUNCTION F1 RETURN LP1;
FUNCTION F2 RETURN LP2;
FUNCTION F3 RETURN LP3;
 
PROCEDURE G1 (X : LP1 := F1); -- LEGAL
PROCEDURE G2 (X : LP2 := F2); -- LEGAL
PROCEDURE G3 (X : LP3 := F3); -- LEGAL
 
PRIVATE
 
TYPE LP1 IS NEW INTEGER;
 
END PACK1;
 
PACKAGE BODY PACK1 IS
 
FUNCTION F1 RETURN LP1 IS
BEGIN
RETURN LP1'(1);
END F1;
 
FUNCTION F2 RETURN LP2 IS
BEGIN
RETURN LP2'(2,3);
END F2;
 
FUNCTION F3 RETURN LP3 IS
BEGIN
RETURN LP3'((4,5),(6,7));
END F3;
 
PROCEDURE G1 (X : LP1 := F1) IS
BEGIN
IF X /= LP1'(1) THEN
FAILED("WRONG DEFAULT VALUE - LP1");
END IF;
END G1;
 
PROCEDURE G2 (X : LP2 := F2) IS
BEGIN
IF X /= LP2'(2,3) THEN
FAILED("WRONG DEFAULT VALUE - LP2");
END IF;
END G2;
 
PROCEDURE G3 (X : LP3 := F3) IS
BEGIN
IF X /= LP3'((4,5),(6,7)) THEN
FAILED("WRONG DEFAULT VALUE - LP3");
END IF;
END G3;
 
BEGIN
 
G1; -- LEGAL, DEFAULT USED
G2; -- LEGAL, DEFAULT USED
G3; -- LEGAL, DEFAULT USED
 
G1(F1); -- LEGAL
G2(F2); -- LEGAL
G3(F3); -- LEGAL
 
END PACK1;
 
USE PACK1;
 
PROCEDURE G4 (X : LP1 := F1) IS
BEGIN
G1; -- LEGAL, DEFAULT USED
G1(X);
END G4;
 
PROCEDURE G5 (X : LP2 := F2) IS
BEGIN
G2; -- LEGAL, DEFAULT USED
G2(X);
END G5;
 
PROCEDURE G6 (X : LP3 := F3) IS
BEGIN
G3; -- DEFAULT USED
G3(X);
END G6;
 
BEGIN
 
G4; -- LEGAL, DEFAULT USED
G5; -- LEGAL, DEFAULT USED
G6; -- LEGAL, DEFAULT USED
 
G4(F1); -- LEGAL
G5(F2); -- LEGAL
G6(F3); -- LEGAL
 
END;
 
RESULT;
 
END C74402A;
/c74402b.ada
0,0 → 1,103
-- C74402B.ADA
 
-- 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.
--*
-- CHECK THAT INITIALIZATION OF IN PARAMETERS THAT ARE OF
-- LIMITED PRIVATE TYPE IS PERMITTED.
-- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.)
 
-- DAS 1/21/81
-- ABW 6/30/82
-- BHS 7/10/84
 
WITH REPORT;
PROCEDURE C74402B IS
 
USE REPORT;
 
BEGIN
 
TEST( "C74402B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " &
"OF LIMITED PRIVATE TYPE IS PERMITTED" );
 
DECLARE
 
PACKAGE PKG IS
 
TYPE LPTYPE IS LIMITED PRIVATE;
CLP : CONSTANT LPTYPE;
XLP : CONSTANT LPTYPE;
FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN;
FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN;
 
PRIVATE
 
TYPE LPTYPE IS NEW INTEGER RANGE 0..127;
CLP : CONSTANT LPTYPE := 127;
XLP : CONSTANT LPTYPE := 0;
 
END;
 
PACKAGE BODY PKG IS
 
FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN IS
BEGIN
RETURN (L = CLP);
END EQCLP;
 
FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN IS
BEGIN
RETURN (L = XLP);
END EQXLP;
 
END PKG;
 
USE PKG;
 
PROCEDURE PROC1 (Y : IN LPTYPE := CLP) IS
BEGIN
IF (EQCLP (Y)) THEN
FAILED( "LIMITED PRIVATE NOT PASSED, " &
"DEFAULT CLP EMPLOYED" );
ELSIF (NOT EQXLP (Y)) THEN
FAILED( "NO LIMITED PRIVATE FOUND" );
END IF;
END PROC1;
 
PROCEDURE PROC2 (Y : IN LPTYPE := CLP) IS
BEGIN
IF (NOT EQCLP(Y)) THEN
FAILED( "DEFAULT NOT EMPLOYED" );
END IF;
END PROC2;
 
BEGIN
 
PROC1(XLP);
PROC2;
 
END;
 
RESULT;
 
END C74402B;
/c74305a.ada
0,0 → 1,160
-- C74305A.ADA
 
-- 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.
--*
-- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT
-- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA-
-- LIZATION FOR A COMPONENT (NON GENERIC CASE).
 
-- DAT 4/06/81
-- RM 5/21/81
-- SPS 8/23/82
-- SPS 2/10/83
-- SPS 10/20/83
-- EG 12/20/83
-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY.
 
WITH REPORT;
 
PROCEDURE C74305A IS
 
USE REPORT;
 
PACKAGE PK IS
TYPE T1 IS PRIVATE;
TYPE T2 IS PRIVATE;
C1 : CONSTANT T1; -- OK.
 
PROCEDURE P1 (P : T1 := C1); -- OK.
 
TYPE R1 IS RECORD
C : T1 := C1; -- OK.
END RECORD;
PRIVATE
PROCEDURE PROC2 (P : T1 := C1); -- OK.
 
TYPE R2 IS RECORD
C : T1 := C1; -- OK.
D : INTEGER := C1'SIZE; -- OK.
END RECORD;
 
FUNCTION F1 (P : T1) RETURN T1;
 
TYPE T1 IS NEW INTEGER;
TYPE T2 IS ARRAY (1..2) OF INTEGER; -- OK.
 
FUNCTION F2 (P : T1) RETURN T1;
 
PROCEDURE P3 (P : T1 := C1+1); -- OK.
 
PROCEDURE P4 (P : T1 := F1(C1));
TYPE R5 IS RECORD
C : T1 := F2(C1);
END RECORD;
 
PROCEDURE P5 (P : T1 := C1+2) RENAMES P3;
 
TYPE R3 IS RECORD
C : T1 := C1; -- OK.
END RECORD;
 
C1 : CONSTANT T1 := 1; -- OK.
C2 : CONSTANT T2 := (1,1); -- OK.
END PK;
 
USE PK;
 
PACKAGE BODY PK IS
 
R11 : R1;
 
PROCEDURE P1 (P : T1 := C1) IS
BEGIN
IF ( P /= 1 ) THEN
FAILED ("PARAMETER DEFAULT OF P1 NOT PROPERLY " &
"INITIALIZED");
END IF;
END P1;
 
PROCEDURE PROC2 (P : T1 := C1) IS
BEGIN NULL; END PROC2;
 
PROCEDURE P3 (P : T1 := C1+1) IS
BEGIN
IF ( P /= 3 ) THEN
FAILED ("PARAMETER DEFAULT OF P5 NOT PROPERLY " &
"INITIALIZED");
END IF;
END P3;
 
FUNCTION F1 (P : T1) RETURN T1 IS
BEGIN
RETURN P+10;
END F1;
 
PROCEDURE P4 (P : T1 := F1(C1)) IS
BEGIN
IF ( P /= 11 ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED");
END IF;
END P4;
 
FUNCTION F2 (P : T1) RETURN T1 IS
BEGIN
RETURN P+20;
END F2;
 
BEGIN -- PK BODY.
 
DECLARE
 
R55 : R5;
 
BEGIN
TEST ("C74305A","CHECK THAT A DEFERRED CONSTANT CAN " &
"BE USED AS A DEFAULT INITIALIZATION " &
"FOR A PARAMETER OR AS A DEFAULT " &
"INITIALIZATION FOR A COMPONENT (NON " &
"GENERIC CASE)");
 
IF ( R11.C /= 1 ) THEN
FAILED ("RECORD R11 NOT PROPERLY INITIALIZED");
END IF;
 
P4;
 
IF ( R55.C /= 21 ) THEN
FAILED ("RECORD R55 NOT PROPERLY INITIALIZED");
END IF;
 
P5;
END;
END PK;
 
BEGIN
 
P1;
 
RESULT;
END C74305A;
/c74206a.ada
0,0 → 1,144
-- C74206A.ADA
 
-- 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.
--*
-- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE PACKAGE AS A
-- PRIVATE TYPE AND CONTAINS A COMPONENT OF THE PRIVATE TYPE, OPERATIONS
-- OF THE COMPOSITE TYPE WHICH DO NOT DEPEND ON CHARACTERISTICS OF THE
-- PRIVATE TYPE ARE AVAILABLE AFTER THE FULL DECLARATION OF THE PRIVATE
-- TYPE, BUT BEFORE THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE
-- DECLARATION OF THE COMPOSITE TYPE THAT IS AFTER THE FULL DECLARATION
-- OF THE PRIVATE TYPE. IN PARTICULAR, CHECK FOR THE FOLLOWING :
 
-- 'FIRST, 'LAST, 'RANGE, AND 'LENGTH FOR ARRAY TYPES
-- SELECTED COMPONENTS FOR DISCRIMINANTS AND COMPONENTS OF RECORDS
-- INDEXED COMPONENTS AND SLICES FOR ARRAYS
 
-- DSJ 5/5/83
-- JBG 3/8/84
 
WITH REPORT;
PROCEDURE C74206A IS
 
USE REPORT;
 
BEGIN
 
TEST("C74206A", "CHECK THAT ADDITIONAL OPERATIONS FOR "
& "COMPOSITE TYPES OF PRIVATE TYPES ARE "
& "AVAILABLE AT THE EARLIEST PLACE AFTER THE "
& "FULL DECLARATION OF THE PRIVATE TYPE EVEN "
& "IF BEFORE THE EARLIEST PLACE WITHIN THE "
& "IMMEDIATE SCOPE OF THE COMPOSITE TYPE");
 
DECLARE
 
PACKAGE PACK1 IS
TYPE P1 IS PRIVATE;
TYPE LP1 IS LIMITED PRIVATE;
 
PACKAGE PACK_LP IS
TYPE LP_ARR IS ARRAY (1 .. 2) OF LP1;
TYPE LP_REC (D : INTEGER) IS
RECORD
C1, C2 : LP1;
END RECORD;
END PACK_LP;
 
PACKAGE PACK2 IS
TYPE ARR IS ARRAY ( 1 .. 2 ) OF P1;
TYPE REC (D : INTEGER) IS
RECORD
C1, C2 : P1;
END RECORD;
END PACK2;
PRIVATE
TYPE P1 IS NEW BOOLEAN;
TYPE LP1 IS NEW BOOLEAN;
END PACK1;
 
PACKAGE BODY PACK1 IS
 
USE PACK_LP;
USE PACK2;
 
A1 : ARR;
L1 : LP_ARR;
 
N1 : INTEGER := ARR'FIRST; -- LEGAL
N2 : INTEGER := ARR'LAST; -- LEGAL
N3 : INTEGER := A1'LENGTH; -- LEGAL
N4 : INTEGER := LP_ARR'FIRST; -- LEGAL
N5 : INTEGER := LP_ARR'LAST; -- LEGAL
N6 : INTEGER := L1'LENGTH; -- LEGAL
B1 : BOOLEAN := 1 IN ARR'RANGE; -- LEGAL
B2 : BOOLEAN := 5 IN LP_ARR'RANGE; -- LEGAL
 
N7 : INTEGER := A1(1)'SIZE; -- LEGAL: A1(1)
N8 : INTEGER := L1(2)'SIZE; -- LEGAL: L1(2)
 
R1 : REC(1);
Q1 : LP_REC(1);
 
K1 : INTEGER := R1.D'SIZE; -- LEGAL: R1.D
K2 : INTEGER := R1.C1'SIZE; -- LEGAL: R1.C1
K3 : INTEGER := Q1.D'SIZE; -- LEGAL: Q1.D
K4 : INTEGER := Q1.C2'SIZE; -- LEGAL: Q1.C2
 
BEGIN
 
IF N1 /= 1 OR N4 /= 1 THEN
FAILED ("WRONG VALUE FOR 'FIRST");
END IF;
 
IF N2 /= 2 OR N5 /= 2 THEN
FAILED ("WRONG VALUE FOR 'LAST");
END IF;
 
IF N3 /= 2 OR N6 /= 2 THEN
FAILED ("WRONG VALUE FOR 'LENGTH");
END IF;
 
IF B1 /= TRUE OR B2 /= FALSE THEN
FAILED ("INCORRECT RANGE TEST");
END IF;
 
IF N7 /= N8 THEN
FAILED ("INCORRECT INDEXED COMPONENTS");
END IF;
 
IF K1 /= K3 OR K2 /= K4 THEN
FAILED ("INCORRECT COMPONENT SELECTION");
END IF;
 
END PACK1;
 
BEGIN
 
NULL;
 
END;
 
RESULT;
 
END C74206A;
/c74305b.ada
0,0 → 1,101
-- C74305B.ADA
 
-- 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.
--*
-- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT
-- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA-
-- LIZATION FOR A COMPONENT (GENERIC CASE).
 
-- EG 12/20/83
 
WITH REPORT;
 
PROCEDURE C74305B IS
 
USE REPORT;
 
PACKAGE PK IS
TYPE TD IS PRIVATE;
CD : CONSTANT TD;
DD : CONSTANT TD;
 
GENERIC
TYPE T1 IS PRIVATE;
C1 : T1;
WITH PROCEDURE P2 (A1 : T1 := C1; A2 : TD := CD);
PROCEDURE P1 (A1 : TD := CD);
 
PRIVATE
TYPE TD IS NEW INTEGER;
CD : CONSTANT TD := 2;
DD : CONSTANT TD := 3;
END PK;
 
USE PK;
 
PACKAGE BODY PK IS
 
PROCEDURE P1 (A1 : TD := CD) IS
BEGIN
IF ( A1 /= 2 ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED (1)");
END IF;
P2;
END P1;
 
PROCEDURE P3 (X : TD := DD; Y : TD := DD) IS
BEGIN
IF ( X /= 2 ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED (2)");
END IF;
IF ( Y /= 2 ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED (3)");
END IF;
END P3;
 
PROCEDURE P4 IS NEW P1 (TD,CD,P3);
 
BEGIN
TEST ("C74305B","CHECK THAT A DEFERRED CONSTANT CAN BE " &
"USED AS A DEFAULT INITIALIZATION FOR A " &
"PARAMETER OR AS A DEFAULT INITIALIZATION " &
"FOR A COMPONENT (GENERIC CASE)");
P4;
END PK;
 
PROCEDURE P5 (X : TD := DD; Y : TD := DD) IS
BEGIN
IF ( X /= CD ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED (4)");
END IF;
IF ( Y /= CD ) THEN
FAILED ("WRONG ACTUAL PARAMETER RECEIVED (5)");
END IF;
END P5;
 
PROCEDURE P6 IS NEW P1 (TD,CD,P5);
 
BEGIN
P6;
RESULT;
END C74305B;
/c74307a.ada
0,0 → 1,58
-- C74307A.ADA
 
-- 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 AN EXPLICIT CONSTRAINT MAY BE GIVEN IN THE SUBTYPE
-- INDICATION OF THE FULL DECLARATION OF A DEFERRED CONSTANT.
 
-- HISTORY:
-- BCB 03/14/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74307A IS
 
PACKAGE P IS
TYPE T (D : INTEGER) IS PRIVATE;
C : CONSTANT T;
PRIVATE
TYPE T (D : INTEGER) IS RECORD
NULL;
END RECORD;
C : CONSTANT T(2) := (D => 2);
END P;
 
USE P;
 
BEGIN
TEST ("C74307A", "CHECK THAT AN EXPLICIT CONSTRAINT MAY BE " &
"GIVEN IN THE SUBTYPE INDICATION OF THE FULL " &
"DECLARATION OF A DEFERRED CONSTANT");
 
IF C.D /= 2 THEN
FAILED ("IMPROPER RESULTS FOR C.D");
END IF;
 
RESULT;
END C74307A;
/c730001.a
0,0 → 1,437
-- C730001.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 the full view of a private extension may be derived
-- indirectly from the ancestor type (i.e., the parent type of the full
-- type may be any descendant of the ancestor type). Check that, for
-- a primitive subprogram of the private extension that is inherited from
-- the ancestor type and not overridden, the formal parameter names and
-- default expressions come from the corresponding primitive subprogram
-- of the ancestor type, while the body comes from that of the parent
-- type. Check both dispatching and non-dispatching cases.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package P is
-- type Ancestor is tagged ...
-- procedure Op (P1: Ancestor; P2: Boolean := True);
-- end P;
--
-- with P;
-- package Q is
-- type Derived is new P.Ancestor with ...
-- procedure Op (X: Ancestor; Y: Boolean := False);
-- end Q;
--
-- with P, Q;
-- package R is
-- type Priv_Ext is new P.Ancestor with private; -- (A)
-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
-- -- But body executed is that of Q.Op.
-- private
-- type Priv_Ext is new Q.Derived with record ... -- (B)
-- end R;
--
-- The ancestor type in (A) differs from the parent type in (B); the
-- parent of the full type is descended from the ancestor type of the
-- private extension. For a call to Op (from outside the scope of the
-- full view) with an operand of type Priv_Ext, the formal parameter
-- names and default expression come from that of P.Op (the ancestor
-- type's version), but the body executed will be that of
-- Q.Op (the parent type's version)
--
-- One half of the test mirrors the above template, where an inherited
-- subprogram (Set_Display) is called using the formal parameter
-- name (C) and default parameter expression of the ancestor type's
-- version (type Clock), but the version of the body executed is from
-- the parent type.
--
-- The test also includes an examination of the dynamic evaluation
-- case, where correct body associations are required through dispatching
-- calls. As described for the non-dispatching case above, the formal
-- parameter name and default values of the ancestor type's (Phone)
-- version of the inherited subprogram (Answer) are used in the
-- dispatching call, but the body executed is from the parent type.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package C730001_0 is
 
type Display_Kind is (None, Analog, Digital);
type Illumination_Type is (None, Light, Phosphorescence);
type Capability_Type is (Available, In_Use, Call_Waiting, Conference);
type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem);
 
type Clock is abstract tagged record -- ancestor type associated
Display : Display_Kind := None; -- with non-dispatching case.
Illumination : Illumination_Type := None;
end record;
 
type Phone is tagged record -- ancestor type associated
Status : Capability_Type := Available; -- with dispatching case.
Indicator : Indicator_Type := None;
end record;
 
-- The Set_Display procedure for type Clock implements a basic, no-frills
-- clock display.
procedure Set_Display (C : in out Clock;
Disp: in Display_Kind := Digital);
 
-- The Answer procedure for type Phone implements a phone status change
-- operation.
procedure Answer (The_Phone : in out Phone;
Ind : in Indicator_Type := Light);
-- ...Other general clock and/or phone operations (not specified in this
-- test scenario).
 
end C730001_0;
 
 
--==================================================================--
 
 
package body C730001_0 is
 
procedure Set_Display (C : in out Clock;
Disp: in Display_Kind := Digital) is
begin
C.Display := Disp;
C.Illumination := Light;
end Set_Display;
 
procedure Answer (The_Phone : in out Phone;
Ind : in Indicator_Type := Light) is
begin
The_Phone.Status := In_Use;
The_Phone.Indicator := Ind;
end Answer;
 
end C730001_0;
 
 
--==================================================================--
 
 
with C730001_0; use C730001_0;
package C730001_1 is
 
type Power_Supply_Type is (Spring, Battery, AC_Current);
type Speaker_Type is (None, Present, Adjustable, Stereo);
 
type Wall_Clock is new Clock with record
Power_Source : Power_Supply_Type := Spring;
end record;
 
type Office_Phone is new Phone with record
Speaker : Speaker_Type := Present;
end record;
 
-- Note: Both procedures below, parameter names and defaults differ from
-- parent's version.
 
-- The Set_Display procedure for type Wall_Clock improves upon the
-- basic Set_Display procedure of type Clock.
 
procedure Set_Display (WC: in out Wall_Clock;
D : in Display_Kind := Analog);
 
procedure Answer (OP : in out Office_Phone;
OI : in Indicator_Type := Buzzer);
 
-- ...Other wall clock and/or Office_Phone operations (not specified in
-- this test scenario).
 
end C730001_1;
 
 
--==================================================================--
 
 
package body C730001_1 is
 
-- Note: This body is the one that should be executed in the test block
-- below, not the version of the body corresponding to type Clock.
 
procedure Set_Display (WC: in out Wall_Clock;
D : in Display_Kind := Analog) is
begin
WC.Display := D;
WC.Illumination := Phosphorescence;
end Set_Display;
 
 
procedure Answer (OP : in out Office_Phone;
OI : in Indicator_Type := Buzzer) is
begin
OP.Status := Call_Waiting;
OP.Indicator := OI;
end Answer;
 
end C730001_1;
 
 
--==================================================================--
 
 
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
package C730001_2 is
 
type Alarm_Type is (Buzzer, Radio, Both);
type Video_Type is (None, TV_Monitor, Wall_Projection);
 
type Alarm_Clock is new Clock with private;
-- Inherits proc Set_Display (C : in out Clock;
-- Disp: in Display_Kind := Digital); -- (A)
--
-- Would also inherit other general clock operations (if present).
 
 
type Conference_Room_Phone is new Office_Phone with record
Display : Video_Type := TV_Monitor;
end record;
 
procedure Answer (CP : in out Conference_Room_Phone;
CI : in Indicator_Type := Modem);
 
 
function TC_Get_Display (C: Alarm_Clock) return Display_Kind;
function TC_Get_Display_Illumination (C: Alarm_Clock)
return Illumination_Type;
 
private
 
-- ...however, certain of the wall clock's operations (Set_Display, in
-- this example) improve on the implementations provided for the general
-- clock. We want to call the improved implementations, so we
-- derive from Wall_Clock in the private part.
 
type Alarm_Clock is new Wall_Clock with record
Alarm : Alarm_Type := Buzzer;
end record;
 
-- Inherits proc Set_Display (WC: in out Wall_Clock;
-- D : in Display_Kind := Analog); -- (B)
 
-- The implicit Set_Display at (B) overrides the implicit Set_Display at
-- (A), but only within the scope of the full view.
--
-- Outside the scope of the full view, only (A) is visible, so calls
-- from outside the scope will get the formal parameter names and default
-- from (A). Both inside and outside the scope, however, the body executed
-- will be that corresponding to Set_Display of the parent type.
 
end C730001_2;
 
 
--==================================================================--
 
 
package body C730001_2 is
 
procedure Answer (CP : in out Conference_Room_Phone;
CI : in Indicator_Type := Modem)is
begin
CP.Status := Conference;
CP.Indicator := CI;
end Answer;
 
 
function TC_Get_Display (C: Alarm_Clock) return Display_Kind is
begin
return C.Display;
end TC_Get_Display;
 
 
function TC_Get_Display_Illumination (C: Alarm_Clock)
return Illumination_Type is
begin
return C.Illumination;
end TC_Get_Display_Illumination;
 
end C730001_2;
 
 
--==================================================================--
 
 
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
with C730001_2; use C730001_2;
 
package C730001_3 is
 
-- Types extended from the ancestor (Phone) type in the specification.
 
type Secure_Phone_Type is new Phone with private;
type Auditorium_Phone_Type is new Phone with private;
-- Inherit versions of Answer from ancestor (Phone).
 
function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type;
function TC_Get_Indicator (P : Phone'Class) return Indicator_Type;
 
private
 
-- Types extended from descendents of Phone_Type in the private part.
 
type Secure_Phone_Type is new Office_Phone with record
Scrambled_Communication : Boolean := True;
end record;
 
type Auditorium_Phone_Type is new Conference_Room_Phone with record
Volume_Control : Boolean := True;
end record;
 
end C730001_3;
 
--==================================================================--
 
package body C730001_3 is
 
function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is
begin
return P.Status;
end TC_Get_Phone_Status;
 
function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is
begin
return P.Indicator;
end TC_Get_Indicator;
 
end C730001_3;
 
--==================================================================--
 
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
with C730001_2; use C730001_2;
with C730001_3; use C730001_3;
 
with Report;
 
procedure C730001 is
begin
 
Report.Test ("C730001","Check that the full view of a private extension " &
"may be derived indirectly from the ancestor " &
"type. Check that, for a primitive subprogram " &
"of the private extension that is inherited from " &
"the ancestor type and not overridden, the " &
"formal parameter names and default expressions " &
"come from the corresponding primitive " &
"subprogram of the ancestor type, while the body " &
"comes from that of the parent type");
 
Test_Block:
declare
 
Alarm : Alarm_Clock;
Hot_Line : Secure_Phone_Type;
TeleConference_Phone : Auditorium_Phone_Type;
 
begin
 
-- Evaluate non-dispatching case:
 
-- Call Set_Display using formal parameter name from
-- C730001_0.Set_Display.
-- Give no 2nd parameter so that default expression must be used.
 
Set_Display (C => Alarm);
-- The value of the Display component should equal Digital, which is
-- the default value from the ancestor's version of Set_Display,
-- and not the default value from the parent's version of Set_Display.
 
if TC_Get_Display (Alarm) /= Digital then
Report.Failed ("Default expression for ancestor op not used " &
"in non-dispatching case");
end if;
 
-- However, the value of the Illumination component should equal
-- Phosphorescence, which is assigned in the parent type's version of
-- the body of Set_Display.
 
if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then
Report.Failed ("Wrong body was executed in non-dispatching case");
end if;
 
 
-- Evaluate dispatching case:
declare
 
Hot_Line : Secure_Phone_Type;
TeleConference_Phone : Auditorium_Phone_Type;
 
procedure Answer_The_Phone (P : in out Phone'Class) is
begin
-- Give no 2nd parameter so that default expression must be used.
Answer (P);
end Answer_The_Phone;
 
begin
 
Answer_The_Phone (Hot_Line);
Answer_The_Phone (TeleConference_Phone);
 
-- The value of the Indicator field shold equal "Light", the default
-- value from the ancestor's version of Answer, and not the default
-- from either of the parent versions of Answer.
 
if TC_Get_Indicator(Hot_Line) /= Light or
TC_Get_Indicator(TeleConference_Phone) /= Light
then
Report.Failed("Default expression from ancestor operation " &
"not used in dispatching case");
end if;
 
-- However, the value of the Status component should equal
-- Call_Waiting or Conference respectively, based on the assignment
-- in the parent type's version of the body of Answer.
 
if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then
Report.Failed("Wrong body executed in dispatching case - 1");
end if;
 
if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then
Report.Failed("Wrong body executed in dispatching case - 2");
end if;
 
end;
 
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
 
 
Report.Result;
 
end C730001;
/c74208a.ada
0,0 → 1,116
-- C74208A.ADA
 
-- 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 'SIZE AND 'ADDRESS FOR OBJECTS OF LIMITED AND
-- NON-LIMITED TYPES ARE AVAILABLE BOTH INSIDE AND OUTSIDE THE
-- PACKAGE DECLARING THE TYPES.
 
-- HISTORY:
-- BCB 03/14/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
WITH SYSTEM; USE SYSTEM;
 
PROCEDURE C74208A IS
 
PACKAGE P IS
TYPE T IS PRIVATE;
TYPE U IS LIMITED PRIVATE;
PRIVATE
TYPE T IS RANGE 1 .. 100;
TYPE U IS RANGE 1 .. 100;
END P;
 
A : P.T;
B : P.U;
ASIZE, BSIZE : INTEGER;
AADDRESS, BADDRESS : ADDRESS;
 
FUNCTION IDENT_ADR(X : ADDRESS) RETURN ADDRESS IS
Y : P.T;
BEGIN
IF EQUAL(3,3) THEN
RETURN X;
END IF;
RETURN Y'ADDRESS;
END IDENT_ADR;
 
PACKAGE BODY P IS
X : T;
Y : U;
XSIZE, YSIZE : INTEGER;
XADDRESS, YADDRESS : ADDRESS;
BEGIN
TEST ("C74208A", "CHECK THAT 'SIZE AND 'ADDRESS FOR " &
"OBJECTS OF LIMITED AND NON-LIMITED TYPES " &
"ARE AVAILABLE BOTH INSIDE AND OUTSIDE " &
"THE PACKAGE DECLARING THE TYPES");
 
XSIZE := X'SIZE;
YSIZE := Y'SIZE;
XADDRESS := X'ADDRESS;
YADDRESS := Y'ADDRESS;
 
IF NOT EQUAL(XSIZE,X'SIZE) THEN
FAILED ("IMPROPER VALUE FOR X'SIZE");
END IF;
 
IF XADDRESS /= IDENT_ADR(X'ADDRESS) THEN
FAILED ("IMPROPER VALUE FOR X'ADDRESS");
END IF;
 
IF NOT EQUAL(YSIZE,Y'SIZE) THEN
FAILED ("IMPROPER VALUE FOR Y'SIZE");
END IF;
 
IF YADDRESS /= IDENT_ADR(Y'ADDRESS) THEN
FAILED ("IMPROPER VALUE FOR Y'ADDRESS");
END IF;
END P;
 
BEGIN
ASIZE := A'SIZE;
BSIZE := B'SIZE;
AADDRESS := A'ADDRESS;
BADDRESS := B'ADDRESS;
 
IF NOT EQUAL(ASIZE,A'SIZE) THEN
FAILED ("IMPROPER VALUE FOR A'SIZE");
END IF;
 
IF AADDRESS /= IDENT_ADR(A'ADDRESS) THEN
FAILED ("IMPROPER VALUE FOR A'ADDRESS");
END IF;
 
IF NOT EQUAL(BSIZE,B'SIZE) THEN
FAILED ("IMPROPER VALUE FOR B'SIZE");
END IF;
 
IF BADDRESS /= IDENT_ADR(B'ADDRESS) THEN
FAILED ("IMPROPER VALUE FOR B'ADDRESS");
END IF;
 
RESULT;
END C74208A;
/c74406a.ada
0,0 → 1,130
-- C74406A.ADA
 
-- 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 THE FULL DECLARATION OF A LIMITED PRIVATE TYPE CAN
-- DECLARE A TASK TYPE, A TYPE DERIVED FROM A LIMITED PRIVATE TYPE,
-- AND A COMPOSITE TYPE WITH A COMPONENT OF A LIMITED TYPE.
 
-- HISTORY:
-- BCB 03/10/88 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74406A IS
 
PACKAGE TP IS
TYPE T IS LIMITED PRIVATE;
PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER);
FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN;
PRIVATE
TYPE T IS RANGE 1 .. 100;
END TP;
 
PACKAGE BODY TP IS
PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER) IS
BEGIN
Z1 := T (Z2);
END INIT;
 
FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN IS
BEGIN
IF EQUAL(3,3) THEN
RETURN ONE = TWO;
ELSE
RETURN ONE /= TWO;
END IF;
END EQUAL_T;
BEGIN
NULL;
END TP;
 
USE TP;
 
PACKAGE P IS
TYPE T1 IS LIMITED PRIVATE;
TYPE T2 IS LIMITED PRIVATE;
TYPE T3 IS LIMITED PRIVATE;
TYPE T4 IS LIMITED PRIVATE;
PRIVATE
TASK TYPE T1 IS
ENTRY HERE(VAL1 : IN OUT INTEGER);
END T1;
 
TYPE T2 IS NEW T;
 
TYPE T3 IS RECORD
INT : T;
END RECORD;
 
TYPE T4 IS ARRAY(1..5) OF T;
END P;
 
PACKAGE BODY P IS
X1 : T1;
X3 : T3;
X4 : T4;
VAR : INTEGER := 25;
 
TASK BODY T1 IS
BEGIN
ACCEPT HERE(VAL1 : IN OUT INTEGER) DO
VAL1 := VAL1 * 2;
END HERE;
END T1;
 
BEGIN
TEST ("C74406A", "CHECK THAT THE FULL DECLARATION OF A " &
"LIMITED PRIVATE TYPE CAN DECLARE A TASK " &
"TYPE, A TYPE DERIVED FROM A LIMITED " &
"PRIVATE TYPE, AND A COMPOSITE TYPE WITH " &
"A COMPONENT OF A LIMITED TYPE");
 
X1.HERE(VAR);
 
IF NOT EQUAL(VAR,IDENT_INT(50)) THEN
FAILED ("IMPROPER VALUE FOR VAL");
END IF;
 
INIT (X3.INT, 50);
 
IF X3.INT NOT IN T THEN
FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST");
END IF;
 
INIT (X4(3), 17);
 
IF NOT EQUAL_T(T'(X4(3)),T(X4(3))) THEN
FAILED ("IMPROPER RESULT FROM QUALIFICATION AND " &
"EXPLICIT CONVERSION");
END IF;
 
RESULT;
END P;
 
USE P;
 
BEGIN
NULL;
END C74406A;
/c730002.a
0,0 → 1,383
-- C730002.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 the full view of a private extension may be derived
-- indirectly from the ancestor type (i.e., the parent type of the full
-- type may be any descendant of the ancestor type). Check that, for
-- a primitive subprogram of the private extension that is inherited from
-- the ancestor type and not overridden, the formal parameter names and
-- default expressions come from the corresponding primitive subprogram
-- of the ancestor type, while the body comes from that of the parent
-- type.
-- Check for a case where the parent type is derived from the ancestor
-- type through a series of types produced by generic instantiations.
-- Examine both the static and dynamic binding cases.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package P is
-- type Ancestor is tagged ...
-- procedure Op (P1: Ancestor; P2: Boolean := True);
-- end P;
--
-- with P;
-- generic
-- type T is new P.Ancestor with private;
-- package Gen1 is
-- type Enhanced is new T with private;
-- procedure Op (A: Enhanced; B: Boolean := True);
-- -- other specific procedures...
-- private
-- type Enhanced is new T with ...
-- end Gen1;
--
-- with P, Gen1;
-- package N is new Gen1 (P.Ancestor);
--
-- with N;
-- generic
-- type T is new N.Enhanced with private;
-- package Gen2 is
-- type Enhanced_Again is new T with private;
-- procedure Op (X: Enhanced_Again; Y: Boolean := False);
-- -- other specific procedures...
-- private
-- type Enhanced_Again is new T with ...
-- end Gen2;
--
-- with N, Gen2;
-- package Q is new Gen2 (N.Enhanced);
--
-- with P, Q;
-- package R is
-- type Priv_Ext is new P.Ancestor with private; -- (A)
-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
-- -- But body executed is that of Q.Op.
-- private
-- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
-- end R;
--
-- The ancestor type in (A) differs from the parent type in (B); the
-- parent of the full type is descended from the ancestor type of the
-- private extension, in this case through a series of types produced
-- by generic instantiations. Gen1 redefines the implementation of Op
-- for any type that has one. N is an instance of Gen1 for the ancestor
-- type. Gen2 again redefines the implementation of Op for any type that
-- has one. Q is an instance of Gen2 for the extension of the P.Ancestor
-- declared in N. Both N and Q could define other operations which we
-- don't want to be available in R. For a call to Op (from outside the
-- scope of the full view) with an operand of type R.Priv_Ext, the body
-- executed will be that of Q.Op (the parent type's version), but the
-- formal parameter names and default expression come from that of P.Op
-- (the ancestor type's version).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 27 Feb 97 CTA.PWB Added elaboration pragmas.
--!
 
package C730002_0 is
 
type Hours_Type is range 0..1000;
type Personnel_Type is range 0..10;
type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);
 
type Engine_Type is tagged record
Ave_Repair_Time : Hours_Type := 0; -- Default init. for
Personnel_Required : Personnel_Type := 0; -- component fields.
Specialist : Specialist_ID := Manny;
end record;
 
procedure Routine_Maintenance (Engine : in out Engine_Type ;
Specialist : in Specialist_ID := Moe);
 
-- The Routine_Maintenance procedure implements the processing required
-- for an engine.
 
end C730002_0;
 
--==================================================================--
 
package body C730002_0 is
 
procedure Routine_Maintenance (Engine : in out Engine_Type ;
Specialist : in Specialist_ID := Moe) is
begin
Engine.Ave_Repair_Time := 3;
Engine.Personnel_Required := 1;
Engine.Specialist := Specialist;
end Routine_Maintenance;
 
end C730002_0;
 
--==================================================================--
 
with C730002_0; use C730002_0;
generic
type T is new C730002_0.Engine_Type with private;
package C730002_1 is
 
-- This generic package contains types/procedures specific to engines
-- of the diesel variety.
 
type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);
 
type Diesel_Series is new T with private;
 
procedure Routine_Maintenance (Eng : in out Diesel_Series;
Spec_Req : in Specialist_ID := Jack);
-- Other diesel specific operations... (not required in this test).
 
private
 
type Diesel_Series is new T with record
Repair_Facility_Required : Repair_Facility_Type := On_Site;
end record;
 
end C730002_1;
 
--==================================================================--
 
package body C730002_1 is
 
procedure Routine_Maintenance (Eng : in out Diesel_Series;
Spec_Req : in Specialist_ID := Jack) is
begin
Eng.Ave_Repair_Time := 6;
Eng.Personnel_Required := 2;
Eng.Specialist := Spec_Req;
Eng.Repair_Facility_Required := On_Site;
end Routine_Maintenance;
 
end C730002_1;
 
--==================================================================--
 
with C730002_0;
with C730002_1;
pragma Elaborate (C730002_1);
package C730002_2 is new C730002_1 (C730002_0.Engine_Type);
 
--==================================================================--
 
with C730002_0; use C730002_0;
with C730002_2; use C730002_2;
generic
type T is new C730002_2.Diesel_Series with private;
package C730002_3 is
 
type Time_Of_Operation_Type is range 0..100_000;
 
type Electric_Series is new T with private;
 
procedure Routine_Maintenance (E : in out Electric_Series;
SR : in Specialist_ID := Curly);
 
-- Other electric specific operations... (not required in this test).
 
private
 
type Electric_Series is new T with record
Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
end record;
 
end C730002_3;
 
--==================================================================--
 
package body C730002_3 is
 
procedure Routine_Maintenance (E : in out Electric_Series;
SR : in Specialist_ID := Curly) is
begin
E.Ave_Repair_Time := 9;
E.Personnel_Required := 3;
E.Specialist := SR;
E.Mean_Time_Between_Repair := 1000;
end Routine_Maintenance;
 
end C730002_3;
 
--==================================================================--
 
with C730002_2;
with C730002_3;
pragma Elaborate (C730002_3);
package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);
 
--==================================================================--
 
with C730002_0; use C730002_0;
with C730002_4; use C730002_4;
 
package C730002_5 is
 
type Inspection_Type is (AAA, MIL_STD, NRC);
 
type Nuclear_Series is new Engine_Type with private; -- (A)
 
-- Inherits procedure Routine_Maintenance from ancestor; does not override.
-- (Engine : in out Nuclear_Series;
-- Specialist : in Specialist_ID := Moe);
-- But body executed will be that of C730002_4.Routine_Maintenance,
-- the parent type.
 
function TC_Specialist (E : Nuclear_Series) return Specialist_ID;
function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
function TC_Time_Required (E : Nuclear_Series) return Hours_Type;
 
-- Dispatching subprogram.
procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);
 
private
 
type Nuclear_Series is new Electric_Series with record -- (B)
Inspector_Rep : Inspection_Type := NRC;
end record;
 
-- The ancestor type is used in the type extension (A), while the parent
-- of the full type (B) is a descendent of the ancestor type, through a
-- series of types produced by generic instantiation.
 
end C730002_5;
 
--==================================================================--
 
package body C730002_5 is
 
function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
begin
return E.Specialist;
end TC_Specialist;
 
function TC_Personnel_Required (E : Nuclear_Series)
return Personnel_Type is
begin
return E.Personnel_Required;
end TC_Personnel_Required;
 
function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
begin
return E.Ave_Repair_Time;
end TC_Time_Required;
 
-- Dispatching subprogram.
procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
begin
Routine_Maintenance (The_Engine);
end Maintain_The_Engine;
 
 
end C730002_5;
 
--==================================================================--
 
with Report;
with C730002_0; use C730002_0;
with C730002_2; use C730002_2;
with C730002_4; use C730002_4;
with C730002_5; use C730002_5;
 
procedure C730002 is
begin
 
Report.Test ("C730002", "Check that the full view of a private " &
"extension may be derived indirectly from " &
"the ancestor type. Check for a case where " &
"the parent type is derived from the ancestor " &
"type through a series of types produced by " &
"generic instantiations");
 
Test_Block:
declare
Nuclear_Drive : Nuclear_Series;
Warp_Drive : Nuclear_Series;
begin
 
-- Non-Dispatching Case:
-- Call Routine_Maintenance using formal parameter name from
-- C730002_0.Routine_Maintenance (ancestor version).
-- Give no second parameter so that the default expression must be
-- used.
 
Routine_Maintenance (Engine => Nuclear_Drive);
 
-- The value of the Specialist component should equal "Moe",
-- which is the default value from the ancestor's version of
-- Routine_Maintenance, and not the default value from the parent's
-- version of Routine_Maintenance.
 
if TC_Specialist (Nuclear_Drive) /= Moe then
Report.Failed
("Default expression for ancestor op not used " &
" - non-dispatching case");
end if;
 
-- However the value of the Ave_Repair_Time and Personnel_Required
-- components should be those assigned in the parent type's version
-- of the body of Routine_Maintenance.
-- Note: Only components associated with the ancestor type are
-- evaluated for the purposes of this test.
 
if TC_Personnel_Required (Nuclear_Drive) /= 3 or
TC_Time_Required (Nuclear_Drive) /= 9
then
Report.Failed("Wrong body was executed - non-dispatching case");
end if;
 
-- Dispatching Case:
-- Use a dispatching subprogram to ensure that the correct body is
-- used at runtime.
 
Maintain_The_Engine (Warp_Drive);
 
-- The resulting assignments to the fields of the Warp_Drive variable
-- should be the same as those of the Nuclear_Drive above, indicating
-- that the body of the parent version of the inherited subprogram
-- was used.
 
if TC_Specialist (Warp_Drive) /= Moe then
Report.Failed
("Default expression for ancestor op not used - dispatching case");
end if;
 
if TC_Personnel_Required (Nuclear_Drive) /= 3 or
TC_Time_Required (Nuclear_Drive) /= 9
then
Report.Failed("Wrong body was executed - dispatching case");
end if;
 
 
exception
when others => Report.Failed("Exception raised in Test_Block");
end Test_Block;
 
Report.Result;
 
end C730002;
/c74208b.ada
0,0 → 1,106
-- C74208B.ADA
 
-- 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 'CONSTRAINED FOR OBJECTS OF A PRIVATE TYPE WITH
-- VISIBLE DISCRIMINANTS IS AVAILABLE OUTSIDE THE PACKAGE DECLARING
-- THE TYPE AND IS AVAILABLE BEFORE AND AFTER THE FULL DECLARATION.
 
-- HISTORY:
-- BCB 07/14/88 CREATED ORIGINAL TEST.
-- GJD 11/15/95 MOVED REC2_VAR OUT OF P DUE TO ADA 95 FREEZING RULES.
 
WITH REPORT; USE REPORT;
 
PROCEDURE C74208B IS
 
PACKAGE P IS
TYPE REC (D : INTEGER := 0) IS PRIVATE;
R1 : CONSTANT REC;
TYPE REC2 IS RECORD
COMP : BOOLEAN := R1'CONSTRAINED;
END RECORD;
PRIVATE
TYPE REC (D : INTEGER := 0) IS RECORD
NULL;
END RECORD;
R1 : CONSTANT REC := (D => 5);
R2 : REC := (D => 0);
R2A : REC(3);
R2CON : CONSTANT REC := (D => 3);
C : BOOLEAN := R2'CONSTRAINED;
D : BOOLEAN := R2A'CONSTRAINED;
E : BOOLEAN := R2CON'CONSTRAINED;
END P;
 
REC2_VAR : P.REC2;
R3 : P.REC(0);
R3A : P.REC;
 
A : BOOLEAN := R3'CONSTRAINED;
B : BOOLEAN := R3A'CONSTRAINED;
 
PACKAGE BODY P IS
BEGIN
TEST ("C74208B", "CHECK THAT 'CONSTRAINED FOR OBJECTS OF A " &
"PRIVATE TYPE WITH VISIBLE DISCRIMINANTS " &
"IS AVAILABLE OUTSIDE THE PACKAGE " &
"DECLARING THE TYPE AND IS AVAILABLE " &
"BEFORE AND AFTER THE FULL DECLARATION");
 
IF NOT REC2_VAR.COMP THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED BEFORE THE " &
"FULL DECLARATION OF THE PRIVATE TYPE");
END IF;
 
IF C THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
"FULL DECLARATION OF THE PRIVATE TYPE - 1");
END IF;
 
IF NOT D THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
"FULL DECLARATION OF THE PRIVATE TYPE - 2");
END IF;
 
IF NOT E THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " &
"FULL DECLARATION OF THE PRIVATE TYPE - 3");
END IF;
END P;
 
BEGIN
IF NOT A THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " &
"PACKAGE DECLARING THE PRIVATE TYPE - 1");
END IF;
 
IF B THEN
FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " &
"PACKAGE DECLARING THE PRIVATE TYPE - 2");
END IF;
 
RESULT;
END C74208B;
/c730003.a
0,0 → 1,283
-- C730003.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
-- F08630-91-C-0015, 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 WHATSOVER, 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 the characteristics of a type derived from a private
-- extension (outside the scope of the full view) are those defined by
-- the partial view of the private extension.
-- In particular, check that a component of the derived type may be
-- explicitly declared with the same name as a component declared for
-- the full view of the private extension.
-- Check that a component defined in the private extension of a type
-- may be updated through a view conversion of a type derived from
-- the type.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package Parent is
-- type T is tagged record
-- ...
-- end record;
--
-- type DT is new T with private;
-- procedure Op1 (P: in out DT);
--
-- private
-- type DT is new T with record
-- Y: ...; -- (A)
-- end record;
-- end Parent;
--
-- package body Parent is
-- function Op1 (P: in DT) return ... is
-- begin
-- return P.Y;
-- end Op1;
-- end Parent;
--
-- package Unrelated is
-- type Intermediate is new DT with record
-- Y: ...; -- Note: same name as component of -- (B)
-- -- parent's full view.
-- end record;
-- end Unrelated;
--
-- package Parent.Child is
-- type DDT is new Intermediate with null record;
-- -- Implicit declared Op1 (P.DDT); -- (C)
--
-- procedure Op2 (P: in out DDT);
-- end Parent.Child;
--
-- package body Parent.Child is
-- procedure Op2 (P: in out DDT) is
-- Obj : DT renames DT(P);
-- begin
-- ...
-- P.Y := ...; -- Updates DDT's Y. -- (D)
-- DT(P).Y := ...; -- Updates DT's Y. -- (E)
-- Obj.Y := ...; -- Updates DT's Y. -- (F)
-- end Op2;
-- end Parent.Child;
--
-- Types DT and DDT both declare a component Y at (A) and (B),
-- respectively. The component Y of the full view of DT is not visible
-- at the place where DDT is declared. Therefore, it is invisible for
-- all views of DDT (although it still exists for objects of DDT), and
-- it is legal to declare another component for DDT with the same name.
--
-- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
-- the component Y; for calls with an operand of type DDT, Op1 returns
-- the Y inherited from DT, not the new Y explicitly declared for DDT,
-- even though the inherited Y is not visible for any view of DDT.
--
-- Within the body of Op2, the assignment statement at (D) updates the
-- Y explicitly declared for DDT. At (E) and (F), however, a view
-- conversion denotes a new view of P as an object of type DT, which
-- enables access to the Y from the full view of DT. Thus, the
-- assignment statements at (E) and (F) update the (invisible) Y from DT.
--
-- Note that the above analysis would be wrong if the new component Y
-- were declared directly in Child. In that case, the two same-named
-- components would be illegal -- see AI-150.
--
--
-- CHANGE HISTORY:
-- 06 Dec 1994 SAIC ACVC 2.0
-- 29 JUN 1999 RAD Declare same-named component in an
-- unrelated package -- see AI-150.
--
--!
 
package C730003_0 is
 
type Suit_Kind is (Clubs, Diamonds, Hearts, Spades);
type Face_Kind is (Up, Down);
 
type Playing_Card is tagged record
Face: Face_Kind;
Suit: Suit_Kind;
end record;
 
procedure Turn_Over_Card (Card : in out Playing_Card);
 
type Disp_Card is new Playing_Card with private;
 
subtype ASCII_Representation is Natural range 1..14;
 
function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation;
 
private
 
type Disp_Card is new Playing_Card with record
View: ASCII_Representation; -- (A)
end record;
 
end C730003_0;
 
--==================================================================--
 
package body C730003_0 is
 
procedure Turn_Over_Card (Card: in out Playing_Card) is
begin
Card.Face := Up;
end Turn_Over_Card;
 
function Get_Private_View (A_Card : Disp_Card)
return ASCII_Representation is
begin
return A_Card.View;
end Get_Private_View;
 
end C730003_0;
 
--==================================================================--
 
with C730003_0; use C730003_0;
package C730003_1 is
 
subtype Graphic_Representation is String (1 .. 2);
 
type Graphic_Card is new Disp_Card with record
View : Graphic_Representation; -- (B)
-- "Duplicate" component field name.
end record;
 
end C730003_1;
 
--==================================================================--
 
with C730003_1; use C730003_1;
package C730003_0.C730003_2 is
 
Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12;
Ace_Of_Hearts : constant String := "AH";
Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14;
Read_Em_And_Weep : constant String := "AA";
 
type Graphic_Card is new C730003_1.Graphic_Card with null record;
 
-- Implicit function Get_Private_View -- (C)
-- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
 
function Get_View (Card : Graphic_Card) return String;
procedure Update_View (Card : in out Graphic_Card);
procedure Hide_From_View (Card : in out Graphic_Card);
 
end C730003_0.C730003_2;
 
--==================================================================--
 
package body C730003_0.C730003_2 is
 
function Get_View (Card : Graphic_Card) return String is
begin
return Card.View;
end Get_View;
 
procedure Update_View (Card : in out Graphic_Card) is
ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion.
begin
ASCII_View.View := Queen_Of_Spades; -- (F)
-- Assignment to "hidden" field.
Card.View := Ace_Of_Hearts; -- (D)
-- Assignment to Graphic_Card declared field.
end Update_View;
 
procedure Hide_From_View (Card : in out Graphic_Card) is
begin
-- Update both of Card's View components.
Disp_Card(Card).View := Close_To_The_Vest; -- (E)
-- Assignment to "hidden" field.
Card.View := Read_Em_And_Weep; -- (D)
-- Assignment to Graphic_Card declared field.
end Hide_From_View;
 
end C730003_0.C730003_2;
 
--==================================================================--
 
with C730003_0;
with C730003_0.C730003_2;
with Report;
 
procedure C730003 is
begin
 
Report.Test ("C730003", "Check that the characteristics of a type " &
"derived from a private extension (outside " &
"the scope of the full view) are those " &
"defined by the partial view of the private " &
"extension");
 
Check_Your_Cards:
declare
use C730003_0;
use C730003_0.C730003_2;
 
Top_Card_On_The_Deck : Graphic_Card;
 
begin
 
-- Update value in the components of the card. There are two
-- component fields named View, although one is not visible for
-- any view of a Graphic_Card.
 
Update_View(Top_Card_On_The_Deck);
 
-- Verify that both "View" components of the card have been updated.
 
if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then
Report.Failed ("Incorrect value in visible component - 1");
end if;
 
if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades
then
Report.Failed ("Incorrect value in non-visible component - 1");
end if;
 
-- Again, update the components of the card (to blank values).
 
Hide_From_View(Top_Card_On_The_Deck);
 
-- Verify that both components have been updated.
 
if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then
Report.Failed ("Incorrect value in visible component - 2");
end if;
 
if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest
then
Report.Failed ("Incorrect value in non-visible component - 2");
end if;
 
exception
when others => Report.Failed("Exception raised in test block");
end Check_Your_Cards;
 
Report.Result;
 
end C730003;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.