OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/tags/gnu-src/gcc-4.5.1/gcc-4.5.1-or32-1.0rc1/gcc/testsuite/ada/acats/tests/ca
    from Rev 294 to Rev 338
    ↔ Reverse comparison
  •

Rev 294 → Rev 338

/ca140282.a
0,0 → 1,64
-- CA140282.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:
-- See CA140283.AM.
--
-- TEST DESCRIPTION
-- See CA140283.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140280.A
-- CA140281.A
-- -> CA140282.A
-- CA140283.AM
--
-- CHANGE HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
-- NOT THE SAME.
-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
 
WITH GENPROC_CA14028;
PRAGMA ELABORATE (GENPROC_CA14028);
PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5);
 
WITH GENFUNC_CA14028;
PRAGMA ELABORATE (GENFUNC_CA14028);
FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS
BEGIN
X := IDENT_INT(4);
END CA14028_PROC3;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
FUNCTION CA14028_FUNC3 RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(7);
END CA14028_FUNC3;
/ca1108b.ada
0,0 → 1,168
-- CA1108B.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 WITH_CLAUSES ARE GIVEN FOR BOTH A SPEC AND A BODY, AND
-- THE CLAUSES NAME DIFFERENT LIBRARY UNITS, THE UNITS NAMED IN ALL THE
-- CLAUSES ARE VISIBLE IN THE BODY AND IN SUBUNITS OF THE BODY.
 
-- BHS 7/31/84
-- JBG 5/1/85
 
PACKAGE FIRST_PKG IS
 
FUNCTION F (X : INTEGER := 1) RETURN INTEGER;
 
END FIRST_PKG;
 
PACKAGE BODY FIRST_PKG IS
 
FUNCTION F (X : INTEGER := 1) RETURN INTEGER IS
BEGIN
RETURN X;
END F;
 
END FIRST_PKG;
 
PACKAGE LATER_PKG IS
 
FUNCTION F (Y : INTEGER := 2) RETURN INTEGER;
 
END LATER_PKG;
 
PACKAGE BODY LATER_PKG IS
 
FUNCTION F (Y : INTEGER := 2) RETURN INTEGER IS
BEGIN
RETURN Y + 1;
END F;
 
END LATER_PKG;
 
WITH REPORT, FIRST_PKG;
USE REPORT;
PRAGMA ELABORATE (FIRST_PKG);
PACKAGE CA1108B_PKG IS
 
I, J : INTEGER;
PROCEDURE PROC;
PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER);
 
END CA1108B_PKG;
 
WITH LATER_PKG;
PRAGMA ELABORATE (LATER_PKG);
PACKAGE BODY CA1108B_PKG IS
 
PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE;
 
PROCEDURE PROC IS
I, J : INTEGER;
BEGIN
I := FIRST_PKG.F;
IF I /= 1 THEN
FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN " &
"PACKAGE BODY PROCEDURE");
END IF;
J := LATER_PKG.F;
IF J /= 3 THEN
FAILED ("LATER_PKG FUNCITON NOT VISIBLE IN " &
"PACKAGE BODY PROCEDURE");
END IF;
END PROC;
 
PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS
BEGIN
SUB (X, Y);
END CALL_SUBS;
 
BEGIN
 
I := FIRST_PKG.F;
IF I /= 1 THEN
FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY");
END IF;
J := LATER_PKG.F;
IF J /= 3 THEN
FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY");
END IF;
 
END CA1108B_PKG;
 
WITH REPORT, CA1108B_PKG;
USE REPORT, CA1108B_PKG;
PROCEDURE CA1108B IS
 
VAR1, VAR2 : INTEGER;
 
BEGIN
 
TEST ("CA1108B", "IF DIFFERENT WITH_CLAUSES GIVEN FOR PACKAGE " &
"SPEC AND BODY, ALL NAMED UNITS ARE VISIBLE " &
"IN THE BODY AND ITS SUBUNITS");
 
PROC;
 
VAR1 := 0;
VAR2 := 1;
CALL_SUBS (VAR1, VAR2);
IF VAR1 /= 1 THEN
FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT");
END IF;
 
IF VAR2 /= 3 THEN
FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT");
END IF;
 
RESULT;
 
END CA1108B;
 
 
SEPARATE (CA1108B_PKG)
PROCEDURE SUB (X, Y : IN OUT INTEGER) IS
PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS SEPARATE;
BEGIN
 
SUB2 (Y, X);
IF Y /= 1 THEN
FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
"OF SUBUNIT");
END IF;
IF X /= 3 THEN
FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
"OF SUBUNIT");
END IF;
X := FIRST_PKG.F;
Y := LATER_PKG.F;
 
END SUB;
 
SEPARATE (CA1108B_PKG.SUB)
PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS
BEGIN
 
A := FIRST_PKG.F;
B := LATER_PKG.F;
 
END SUB2;
/ca11020.a
0,0 → 1,238
-- CA11020.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 body of the generic parent package can depend on one of
-- its own public generic children.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of adding a
-- public generic child during code maintenance without distubing a large
-- subsystem. After child is added to the subsystem, a maintainer
-- decides to take advantage of the new functionality and rewrites
-- the parent's body.
--
-- Declare a bag abstraction in a generic package. Declare a public
-- generic child of this package which adds a generic procedure to the
-- original subsystem. In the parent body, instantiate the public
-- child. Then instantiate the procedure as a child instance of the
-- public child instance.
--
-- In the main program, declare an instance of parent. Check that the
-- operations in both parent and child packages perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Simulates bag application.
 
generic
type Element is private;
with function Image (E : Element) return String;
 
package CA11020_0 is
 
type Bag is limited private;
 
procedure Add (E : in Element; To_The_Bag : in out Bag);
 
function Bag_Image (B : Bag) return string;
 
private
type Node_Type;
type Bag is access Node_Type;
 
type Node_Type is
record
The_Element : Element;
 
-- Other components in real application, i.e.,
-- The_Count : positive;
 
Next : Bag;
end record;
 
end CA11020_0;
 
--==================================================================--
 
-- More operations on Bag.
 
generic
 
-- Parameters go here.
 
package CA11020_0.CA11020_1 is
 
-- ... Other declarations.
 
generic -- Generic iterator procedure.
with procedure Use_Element (E : in Element);
 
procedure Iterate (B : in Bag); -- Called once per element in the bag.
 
-- ... Various other operations.
 
end CA11020_0.CA11020_1;
 
--==================================================================--
 
package body CA11020_0.CA11020_1 is
 
procedure Iterate (B : in Bag) is
 
-- Traverse each element in the bag.
 
Elem : Bag := B;
 
begin
while Elem /= null loop
Use_Element (Elem.The_Element);
Elem := Elem.Next;
end loop;
 
end Iterate;
 
end CA11020_0.CA11020_1;
 
--==================================================================--
 
with CA11020_0.CA11020_1; -- Public generic child package.
 
package body CA11020_0 is
 
----------------------------------------------------
-- Parent's body depends on public generic child. --
----------------------------------------------------
 
-- Instantiate the public child.
 
package MS is new CA11020_1;
 
function Bag_Image (B : Bag) return string is
 
Buffer : String (1 .. 10_000);
Last : Integer := 0;
 
-----------------------------------------------------
 
-- Will be called by the iterator.
 
procedure Append_Image (E : in Element) is
Im : constant String := Image (E);
 
begin -- Append_Image
if Last /= 0 then -- Insert a comma.
Last := Last + 1;
Buffer (Last) := ',';
end if;
 
Buffer (Last + 1 .. Last + Im'Length) := Im;
Last := Last + Im'Length;
 
end Append_Image;
 
-----------------------------------------------------
 
-- Instantiate procedure Iterate as a child of instance MS.
 
procedure Append_All is new MS.Iterate (Use_Element => Append_Image);
 
begin -- Bag_Image
 
Append_All (B);
 
return Buffer (1 .. Last);
 
end Bag_Image;
 
-----------------------------------------------------
 
procedure Add (E : in Element; To_The_Bag : in out Bag) is
 
-- Not a real bag addition.
 
Index : Bag := To_The_Bag;
 
begin
-- ... Error-checking code omitted for brevity.
if Index = null then
To_The_Bag := new Node_Type' (The_Element => E,
Next => null);
else
-- Goto the end of the list.
 
while Index.Next /= null loop
Index := Index.Next;
end loop;
 
-- Add element to the end of the list.
 
Index.Next := new Node_Type' (The_Element => E,
Next => null);
end if;
 
end Add;
 
end CA11020_0;
 
--==================================================================--
 
with CA11020_0; -- Bag application.
 
with Report;
 
procedure CA11020 is
 
-- Instantiate the bag application for integer type and attribute
-- Image.
 
package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);
 
My_Bag : Bag_Of_Integers.Bag;
 
begin
 
Report.Test ("CA11020", "Check that body of the generic parent package " &
"can depend on one of its own public generic children");
 
-- Add 10 consecutive integers to the bag.
 
for I in 1 .. 10 loop
Bag_Of_Integers.Add (I, My_Bag);
end loop;
 
if Bag_Of_Integers.Bag_Image (My_Bag)
/= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then
Report.Failed ("Incorrect results");
end if;
 
Report.Result;
 
end CA11020;
/ca11003.a
0,0 → 1,290
-- CA11003.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 public grandchild can utilize its ancestor unit's visible
-- definitions.
--
-- TEST DESCRIPTION:
-- Declare a public package, public child package, and public
-- grandchild package and library unit function. Within the
-- grandchild package and function, make use of components that are
-- declared in the ancestor packages, both parent and grandparent.
--
-- Use the following ancestral components in the grandchildren library
-- units:
-- Grandparent Parent
-- Type X X
-- Constant X X
-- Object X X
-- Subprogram X X
-- Exception X X
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Dec 94 SAIC Modified procedure Create_File
-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
--
--!
package CA11003_0 is -- Package OS
 
type File_Descriptor is new Integer;
type File_Mode is (Read_Only, Write_Only, Read_Write);
 
Null_File : constant File_Descriptor := 0;
Default_Mode : constant File_Mode := Read_Only;
File_Data_Error : exception;
 
type File_Type is tagged
record
Descriptor : File_Descriptor := Null_File;
Mode : File_Mode := Read_Write;
end record;
 
System_File : File_Type;
 
function Next_Available_File return File_Descriptor;
 
procedure Reclaim_File_Descriptor;
 
end CA11003_0; -- Package OS
 
--=================================================================--
 
package body CA11003_0 is -- Package body OS
File_Count : Integer := 0;
 
function Next_Available_File return File_Descriptor is
begin
File_Count := File_Count + 1;
return (File_Descriptor(File_Count));
end Next_Available_File;
--------------------------------------------------
procedure Reclaim_File_Descriptor is
begin
null; -- Dummy processing unit.
end Reclaim_File_Descriptor;
 
end CA11003_0; -- Package body OS
 
--=================================================================--
 
package CA11003_0.CA11003_1 is -- Child package OS.Operations
 
subtype File_Length_Type is Integer range 0 .. 1000;
Min_File_Size : File_Length_Type := File_Length_Type'First;
Max_File_Size : File_Length_Type := File_Length_Type'Last;
 
File_Duplication_Error : exception;
 
type Extended_File_Type is new File_Type with private;
 
procedure Create_File (Mode : in File_Mode;
File : out Extended_File_Type);
 
procedure Duplicate_File (Original : in Extended_File_Type;
Duplicate : out Extended_File_Type);
 
private
type Extended_File_Type is new File_Type with
record
Blocks : File_Length_Type := Min_File_Size;
end record;
 
System_Extended_File : Extended_File_Type;
 
end CA11003_0.CA11003_1; -- Child Package OS.Operations
 
--=================================================================--
 
package body CA11003_0.CA11003_1 is -- Child package body OS.Operations
 
procedure Create_File
(Mode : in File_Mode;
File : out Extended_File_Type) is
begin
File.Descriptor := Next_Available_File; -- Parent subprogram.
File.Mode := Default_Mode; -- Parent constant.
File.Blocks := Min_File_Size;
end Create_File;
--------------------------------------------------
procedure Duplicate_File (Original : in Extended_File_Type;
Duplicate : out Extended_File_Type) is
begin
Duplicate.Descriptor := Next_Available_File; -- Parent subprogram.
Duplicate.Mode := Original.Mode;
Duplicate.Blocks := Original.Blocks;
end Duplicate_File;
 
end CA11003_0.CA11003_1; -- Child package body OS.Operations
 
--=================================================================--
 
-- This package contains menu selectable operations for manipulating files.
-- This abstraction builds on the capabilities available from ancestor
-- packages.
 
package CA11003_0.CA11003_1.CA11003_2 is
 
procedure News (Mode : in File_Mode;
File : out Extended_File_Type);
 
procedure Copy (Original : in Extended_File_Type;
Duplicate : out Extended_File_Type);
 
procedure Delete (File : in Extended_File_Type);
 
end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu
--=================================================================--
 
-- Grandchild subprogram Validate
function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type)
return Boolean;
 
--=================================================================--
 
-- Grandchild subprogram Validate
function CA11003_0.CA11003_1.CA11003_3
(File : in Extended_File_Type) -- Parent type.
return Boolean is
 
function New_File_Validated (File : Extended_File_Type)
return Boolean is
begin
if (File.Descriptor > System_File.Descriptor) and -- Grandparent
(File.Mode in File_Mode ) and -- object and type
not ((File.Blocks < System_Extended_File.Blocks) or
(File.Blocks > Max_File_Size)) -- Parent object
then -- and constant.
return True;
else
return False;
end if;
end New_File_Validated;
begin
return (New_File_Validated (File)) and
(File.Descriptor /= Null_File); -- Grandparent constant.
end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate
 
--=================================================================--
 
with CA11003_0.CA11003_1.CA11003_3;
-- Grandchild package body OS.Operations.Menu
package body CA11003_0.CA11003_1.CA11003_2 is
 
procedure News (Mode : in File_Mode;
File : out Extended_File_Type) is -- Parent type.
begin
Create_File (Mode, File); -- Parent subprogram.
if not CA11003_0.CA11003_1.CA11003_3 (File) then
raise File_Data_Error; -- Grandparent exception.
end if;
end News;
--------------------------------------------------
procedure Copy (Original : in Extended_File_Type;
Duplicate : out Extended_File_Type) is
begin
Duplicate_File (Original, Duplicate); -- Parent subprogram.
 
if Original.Descriptor = Duplicate.Descriptor then
raise File_Duplication_Error; -- Parent exception.
end if;
 
end Copy;
--------------------------------------------------
procedure Delete (File : in Extended_File_Type) is
begin
Reclaim_File_Descriptor; -- Grandparent
end Delete; -- subprogram.
 
end CA11003_0.CA11003_1.CA11003_2;
 
--=================================================================--
 
with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu
with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate
with Report;
 
procedure CA11003 is
 
package Menu renames CA11003_0.CA11003_1.CA11003_2;
 
begin
 
Report.Test ("CA11003", "Check that a public grandchild can utilize " &
"its ancestor unit's visible definitions");
 
File_Processing: -- Validate all of the capabilities contained in
-- the Menu package by exercising them on specific
-- files. This will demonstrate the use of child
-- and grandchild functionality based on components
-- that have been declared in the
-- parent/grandparent package.
declare
 
function Validate (File : CA11003_0.CA11003_1.Extended_File_Type)
return Boolean renames CA11003_0.CA11003_1.CA11003_3;
 
MacWrite_File,
Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type;
MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write;
begin
Menu.News (MacWrite_File_Mode, MacWrite_File);
 
if not Validate (MacWrite_File) then
Report.Failed ("Incorrect initialization of files");
end if;
 
Menu.Copy (MacWrite_File, Backup_Copy);
 
if not (Validate (MacWrite_File) and
Validate (Backup_Copy))
then
Report.Failed ("Incorrect duplication of files");
end if;
 
Menu.Delete (Backup_Copy);
 
exception
when CA11003_0.File_Data_Error =>
Report.Failed ("Exception raised during file validation");
when CA11003_0.CA11003_1.File_Duplication_Error =>
Report.Failed ("Exception raised during file duplication");
when others =>
Report.Failed ("Unexpected exception in test procedure");
 
end File_Processing;
 
Report.Result;
 
end CA11003;
/ca110042.am
0,0 → 1,130
-- CA110042.AM
--
-- 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 private part of a child library unit package can
-- utilize its parent unit's visible definitions.
--
-- TEST DESCRIPTION:
-- Declare a public library unit package and child package, with the
-- child package having a private part in the specification. Within
-- this child private part, make use of components that are declared in
-- the visible part of the parent.
--
-- Demonstrate visibility to the following parent components in the
-- child private part:
-- Parent
-- Type X
-- Constant X
-- Object X
-- Subprogram X
-- Exception X
--
--
-- TEST FILES:
-- The following files comprise this test:
--
-- CA110040.A
-- CA110041.A
-- => CA110042.AM
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
with Report;
with CA110040.CA110041;
 
procedure CA110042 is
 
package System_Manager renames CA110040.CA110041;
use CA110040;
User1, User2, User3 : System_Manager.User_Account;
 
begin
 
Report.Test ("CA110042", "Check that the private part of a child " &
"library unit package can utilize its " &
"parent unit's visible definitions");
 
Assign_New_Accounts: -- This code simulates the entering of new
-- user accounts into a computer system.
-- It also simulates the processing that
-- could occur when the limit on system
-- accounts has been exceeded.
 
-- This processing block demonstrates the
-- use of child package functionality that
-- takes advantage of components declared in
-- the parent package.
begin
 
if Total_Accounts /= 2 then
Report.Failed ("Incorrect number of accounts currently allocated");
end if; -- At this point, both
-- System_Account and
-- Auditor_Account have
-- been declared and
-- initialized in package
-- CA110040.CA110041.
 
System_Manager.Initialize_User_Account (User1); -- User_ID has been
-- set to 3.
 
System_Manager.Initialize_User_Account (User2); -- User_ID has been
-- set to 4, which
-- is the last value
-- defined for the
-- CA110040.ID_Type
-- range.
 
System_Manager.Initialize_User_Account (User3); -- This final call will
-- result in an
-- Account_Limit_Exceeded
-- exception being raised.
 
Report.Failed ("Control should have transferred with exception");
 
exception
 
when Account_Limit_Exceeded =>
if (not (Administrator_Account.User_ID = ID_Type'First)) or
(User2.User_ID /= CA110040.ID_Type'Last)
then
Report.Failed ("Account initialization failure");
end if;
when others =>
Report.Failed ("Unexpected exception raised");
 
end Assign_New_Accounts;
 
if (User1.User_ID /= 3) or (User2.User_ID /= 4) then
Report.Failed ("Improper initialization of user accounts");
end if;
 
Report.Result;
 
end CA110042;
/ca13002.a
0,0 → 1,259
-- CA13002.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 two library child units and/or subunits may have the same
-- simple names if they have distinct expanded names.
--
-- TEST DESCRIPTION:
-- Declare a package that provides some primitive functionality (minimal
-- terminal driver operations in this case). Add child packages to
-- expand the functionality for different but related contexts (different
-- terminal kinds). Add child packages, or subunits, to the children to
-- provide the same high level operation for each of the different
-- contexts (terminals). Since the operations are the same, at the leaf
-- level they are likely to have the same names.
--
-- The main program "with"s the child packages. Check that the
-- child units and subunits perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
-- Public parent.
package CA13002_0 is -- Terminal_Driver.
 
type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child);
type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit,
Second_Subunit);
type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean;
TC_Calls : TC_Calls_Arr := (others => (others => false));
 
-- In real application, Send_Control_Sequence sends keystrokes from
-- the terminal, i.e., space, escape, etc.
procedure Send_Control_Sequence (Row : in TC_Name;
Col : in TC_Call_From);
 
end CA13002_0;
 
--==================================================================--
 
-- First child.
package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100
 
-- Move cursor up, down, left, or right.
procedure Move_Cursor (Col : in TC_Call_From);
 
end CA13002_0.CA13002_1;
 
--==================================================================--
 
-- First grandchild.
procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up
 
--==================================================================--
 
-- Second child.
package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270
 
procedure Move_Cursor (Col : in TC_Call_From);
 
end CA13002_0.CA13002_2;
 
--==================================================================--
 
-- Second grandchild.
procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up
 
--==================================================================--
 
-- Third child.
package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI
 
procedure Move_Cursor (Col : in TC_Call_From);
 
procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up
-- implementation will be as a
-- separate subunit.
end CA13002_0.CA13002_3;
 
--==================================================================--
 
-- Fourth child.
package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE
 
procedure Move_Cursor (Col : in TC_Call_From);
 
procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up
-- implementation will be as a
-- separate subunit.
 
end CA13002_0.CA13002_4;
 
--==================================================================--
 
-- Terminal_Driver.
package body CA13002_0 is
 
procedure Send_Control_Sequence (Row : in TC_Name;
Col : in TC_Call_From) is
begin
-- Reads a key and takes action.
TC_Calls (Row, Col) := true;
end Send_Control_Sequence;
 
end CA13002_0;
 
--==================================================================--
 
-- Terminal_Driver.VT100.
package body CA13002_0.CA13002_1 is
 
procedure Move_Cursor (Col : in TC_Call_From) is
begin
Send_Control_Sequence (First_Child, Col);
end Move_Cursor;
 
end CA13002_0.CA13002_1;
 
--==================================================================--
 
-- Terminal_Driver.VT100.Cursor_Up.
procedure CA13002_0.CA13002_1.CA13002_5 is
begin
Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100.
end CA13002_0.CA13002_1.CA13002_5;
 
--==================================================================--
 
-- Terminal_Driver.IBM3270.
package body CA13002_0.CA13002_2 is
 
procedure Move_Cursor (Col : in TC_Call_From) is
begin
Send_Control_Sequence (Second_Child, Col);
end Move_Cursor;
 
end CA13002_0.CA13002_2;
 
--==================================================================--
 
-- Terminal_Driver.IBM3270.Cursor_Up.
procedure CA13002_0.CA13002_2.CA13002_5 is
begin
Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270.
end CA13002_0.CA13002_2.CA13002_5;
 
--==================================================================--
 
-- Terminal_Driver.DOS_ANSI.
package body CA13002_0.CA13002_3 is
 
procedure Move_Cursor (Col : in TC_Call_From) is
begin
Send_Control_Sequence (Third_Child, Col);
end Move_Cursor;
 
procedure CA13002_5 is separate;
 
end CA13002_0.CA13002_3;
 
--==================================================================--
 
-- Terminal_Driver.DOS_ANSI.Cursor_Up.
separate (CA13002_0.CA13002_3)
procedure CA13002_5 is
begin
Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI.
end CA13002_5;
 
--==================================================================--
 
-- Terminal_Driver.WYSE.
package body CA13002_0.CA13002_4 is
 
procedure Move_Cursor (Col : in TC_Call_From) is
begin
Send_Control_Sequence (Fourth_Child, Col);
end Move_Cursor;
 
procedure CA13002_5 is separate;
 
end CA13002_0.CA13002_4;
 
--==================================================================--
 
-- Terminal_Driver.WYSE.Cursor_Up.
separate (CA13002_0.CA13002_4)
procedure CA13002_5 is
begin
Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE.
end CA13002_5;
 
--==================================================================--
 
with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up,
-- implicitly with parent, CA13002_0.
with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up.
with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI.
with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE.
with Report;
use CA13002_0; -- All primitive subprograms directly
-- visible.
 
procedure CA13002 is
Expected_Calls : constant CA13002_0.TC_Calls_Arr
:= ((true, false, false, false),
(false, true , false, false),
(false, false, true , false),
(false, false, false, true ));
begin
Report.Test ("CA13002", "Check that two library units and/or subunits " &
"may have the same simple names if they have distinct " &
"expanded names");
 
-- Note that the leaves all have the same name.
-- Call the first grandchild.
CA13002_0.CA13002_1.CA13002_5;
 
-- Call the second grandchild.
CA13002_0.CA13002_2.CA13002_5;
 
-- Call the first subunit.
CA13002_0.CA13002_3.CA13002_5;
 
-- Call the second subunit.
CA13002_0.CA13002_4.CA13002_5;
 
if TC_Calls /= Expected_Calls then
Report.Failed ("Wrong result");
end if;
 
Report.Result;
 
end CA13002;
/ca11007.a
0,0 → 1,228
-- CA11007.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 private part of a grandchild library unit can
-- utilize its grandparent unit's private definition.
--
-- TEST DESCRIPTION:
-- Declare a package, child package, and grandchild package, all
-- with private parts in their specifications.
--
-- The private part of the grandchild package will make use of components
-- that have been declared in the private part of the grandparent
-- specification.
--
-- The child package demonstrates the extension of a parent file type
-- into an abstraction of an analog file structure. The grandchild package
-- extends the grandparent file type into an abstraction of a digital
-- file structure, and provides conversion capability to/from the parent
-- analog file structure.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package CA11007_0 is -- Package File_Package
 
type File_Descriptor is private;
type File_Type is tagged private;
 
function Next_Available_File return File_Descriptor;
 
private
 
type File_Measure_Type is range 0 .. 1000;
type File_Descriptor is new Integer;
 
Null_Measure : constant File_Measure_Type := File_Measure_Type'First;
Null_File : constant File_Descriptor := 0;
 
type File_Type is tagged
record
Descriptor : File_Descriptor := Null_File;
end record;
 
end CA11007_0; -- Package File_Package
 
--=================================================================--
 
package body CA11007_0 is -- Package body File_Package
 
File_Count : Integer := 0;
 
function Next_Available_File return File_Descriptor is
begin
File_Count := File_Count + 1;
return File_Descriptor (File_Count);
end Next_Available_File;
 
end CA11007_0; -- Package body File_Package
 
--=================================================================--
 
package CA11007_0.CA11007_1 is -- Child package Analog
 
type Analog_File_Type is new File_Type with private;
 
private
 
type Wavelength_Type is new File_Measure_Type;
 
Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First;
 
type Analog_File_Type is new File_Type with -- Parent type.
record
Wavelength : Wavelength_Type := Min_Wavelength;
end record;
 
end CA11007_0.CA11007_1; -- Child package Analog
 
--=================================================================--
 
package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital
 
type Digital_File_Type is new File_Type with private;
 
procedure Recording (File : out Digital_File_Type);
 
procedure Convert (From : in Analog_File_Type;
To : out Digital_File_Type);
 
function Validate (File : in Digital_File_Type) return Boolean;
function Valid_Conversion (To : Digital_File_Type) return Boolean;
function Valid_Initial (From : Analog_File_Type) return Boolean;
 
private
 
type Track_Type is new File_Measure_Type; -- Grandparent type.
 
Min_Tracks : constant Track_Type :=
Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private
Max_Tracks : constant Track_Type := -- constant.
Track_Type (Null_Measure) + Track_Type'Last;
 
type Digital_File_Type is new File_Type with -- Grandparent type.
record
Tracks : Track_Type := Min_Tracks;
end record;
 
end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital
 
--=================================================================--
 
-- Grandchild package body Digital
package body CA11007_0.CA11007_1.CA11007_2 is
 
procedure Recording (File : out Digital_File_Type) is
begin
File.Descriptor := Next_Available_File; -- Assign new file descriptor.
File.Tracks := Max_Tracks; -- Change initial value.
end Recording;
--------------------------------------------------------------------------
procedure Convert (From : in Analog_File_Type;
To : out Digital_File_Type) is
begin
To.Descriptor := From.Descriptor + 100; -- Dummy conversion.
To.Tracks := Track_Type (From.Wavelength) / 2;
end Convert;
--------------------------------------------------------------------------
function Validate (File : in Digital_File_Type) return Boolean is
Result : Boolean := False;
begin
if not (File.Tracks /= Max_Tracks) then
Result := True;
end if;
return Result;
end Validate;
--------------------------------------------------------------------------
function Valid_Conversion (To : Digital_File_Type) return Boolean is
begin
return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2));
end Valid_Conversion;
--------------------------------------------------------------------------
function Valid_Initial (From : Analog_File_Type) return Boolean is
begin
return (From.Wavelength = Min_Wavelength); -- Validate initial
end Valid_Initial; -- conditions.
 
end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital
 
--=================================================================--
 
with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital
with Report;
 
procedure CA11007 is
 
package Analog renames CA11007_0.CA11007_1;
package Digital renames CA11007_0.CA11007_1.CA11007_2;
 
Original_Digital_File,
Converted_Digital_File : Digital.Digital_File_Type;
 
Original_Analog_File : Analog.Analog_File_Type;
 
begin
-- This code demonstrates how private extensions could be utilized
-- in child packages to allow for recording on different media.
-- The processing contained in the procedures and functions is
-- "dummy" processing, not intended to perform actual recording,
-- conversion, or validation operations, but simply to demonstrate
-- this type of structural decomposition as a possible solution to
-- a user's design problem.
 
Report.Test ("CA11007", "Check that the private part of a grandchild " &
"library unit can utilize its grandparent " &
"unit's private definition");
 
if not Digital.Valid_Initial (Original_Analog_File)
then
Report.Failed ("Incorrect initialization of Analog File");
end if;
 
---
 
Digital.Convert (From => Original_Analog_File, -- Convert file to
To => Converted_Digital_File); -- digital format.
 
if not Digital.Valid_Conversion (To => Converted_Digital_File) then
Report.Failed ("Incorrect conversion of analog file");
end if;
---
 
Digital.Recording (Original_Digital_File); -- Create file in
-- digital format.
if not Digital.Validate (Original_Digital_File) then
Report.Failed ("Incorrect recording of digital file");
end if;
 
Report.Result;
 
end CA11007;
/ca1102a0.ada
0,0 → 1,31
-- CA1102A0.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.
--*
-- WKB 6/12/81
 
PACKAGE CA1102A0 IS -- BODY IS IN CA1102A1.
 
PROCEDURE P (INVOKED : IN OUT BOOLEAN);
 
END CA1102A0;
/ca1102a2.ada
0,0 → 1,58
-- CA1102A2M.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 MORE THAN ONE WITH_CLAUSE CAN APPEAR IN
-- A CONTEXT_SPECIFICATION.
-- CHECK THAT USE_CLAUSES CAN MENTION NAMES MADE
-- VISIBLE BY PRECEDING WITH_CLAUSES IN THE SAME
-- CONTEXT_SPECIFICATION.
-- CHECK THAT CONSECUTIVE USE_CLAUSES ARE ALLOWED.
 
-- SEPARATE FILES ARE:
-- CA1102A0 A LIBRARY PACKAGE DECLARATION.
-- CA1102A1 A LIBRARY PACKAGE BODY (CA1102A0).
-- CA1102A2M THE MAIN PROCEDURE.
 
-- WKB 6/12/81
-- BHS 7/19/84
 
WITH CA1102A0;
WITH REPORT; USE CA1102A0; USE REPORT;
PROCEDURE CA1102A2M IS
 
 
INVOKED : BOOLEAN := FALSE;
 
BEGIN
TEST ("CA1102A", "MORE THAN ONE WITH_CLAUSE; ALSO, A " &
"USE_CLAUSE REFERING TO A PRECEDING WITH_CLAUSE " &
"IN THE SAME CONTEXT_SPECIFICATION");
 
P (INVOKED);
IF NOT INVOKED THEN
FAILED ("COMPILATION UNIT NOT MADE VISIBLE");
END IF;
 
RESULT;
END CA1102A2M;
/ca200020.a
0,0 → 1,70
-- CA200020.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 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 partition can be created even if the environment contains
-- two units with the same name. (This is rule 10.2(19)).
--
-- TEST DESCRIPTION:
-- Declare the a parent package (CA20002_0). Declare a child package
-- (CA20002_0.CA20002_1). Declare a subunit in the parent package body
-- (CA20002_1). Declare a main subprogram that does NOT include the
-- child package. Insure that this partition can be created.
--
-- This test is intended to test the effects of program maintenance.
-- After the programmer receives an error from creating a partition
-- like that tested in test LA20001, the programmer may then repair
-- the partition by eliminating the reference of the child unit. The
-- partition should be able to be created.
--
-- To build this test:
-- 1) Compile the file CA200020 (and include the results in the
-- program library).
-- 2) Compile the file CA200021 (and include the results in the
-- program library).
-- 3) Compile the file CA200022 (and include the results in the
-- program library).
-- 4) Build an executable image, and run it.
--
-- TEST FILES:
-- This test consists of the following files:
-- -> CA200020.A
-- CA200021.A
-- CA200022.AM
--
-- CHANGE HISTORY:
-- 27 Jan 99 RLB Initial test.
-- 20 Mar 00 RLB Removed special requirements, because there
-- aren't any.
--!
 
package CA20002_0 is
procedure Do_a_Little (A : out Integer);
 
end CA20002_0;
 
package CA20002_0.CA20002_1 is
My_Global : Integer;
end CA20002_0.CA20002_1;
 
/ca11d013.am
0,0 → 1,256
-- CA11D013.AM
--
-- 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 child unit can raise an exception that is declared in
-- parent.
--
-- TEST DESCRIPTION:
-- Declare a package which defines complex number abstraction with
-- user-defined exceptions (foundation code).
--
-- Add a public child package to the above package. Declare two
-- subprograms for the parent type. Each of the subprograms raises a
-- different exception, based on the value of an input parameter.
--
-- Add a public child procedure to the foundation package. This
-- procedure raises an exception based on the value of an input
-- parameter.
--
-- Add a public child function to the foundation package. This
-- function raises an exception based on the value of an input
-- parameter.
--
-- In the main program, "with" the child packages, then check that
-- the exceptions are raised and handled as expected. Ensure that
-- exceptions are:
-- 1) raised in the public child package and handled/reraised to
-- be handled by the main program.
-- 2) raised and handled locally in the public child package.
-- 3) raised and handled locally by "others" in the public child
-- procedure.
-- 4) raised in the public child function and propagated to the
-- main program.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA11D00.A
-- CA11D010.A
-- CA11D011.A
-- CA11D012.A
-- => CA11D013.AM
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with FA11D00.CA11D010; -- Add_Subtract_Complex
with FA11D00.CA11D011; -- Multiply_Complex
with FA11D00.CA11D012; -- Divide_Complex
 
with Report;
 
 
procedure CA11D013 is
 
package Complex_Pkg renames FA11D00;
package Add_Subtract_Complex_Pkg renames FA11D00.CA11D010;
use Complex_Pkg;
 
begin
 
Report.Test ("CA11D013", "Check that a child unit can raise an " &
"exception that is declared in parent");
 
 
Add_Complex_Subtest:
declare
First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (7)));
Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)),
Int_Type (Report.Ident_Int (3)));
Add_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (8)),
Int_Type (Report.Ident_Int (10)));
Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-100)),
Int_Type (Report.Ident_Int (100)));
Complex_Num : Complex_Type := Zero;
 
begin
Add_Subtract_Complex_Pkg.Add (First, Second, Complex_Num);
 
if (Complex_Num /= Add_Result) then
Report.Failed ("Incorrect results from addition");
end if;
-- Error is raised in child package and exception
-- will be handled/reraised to caller.
 
Add_Subtract_Complex_Pkg.Add (First, Third, Complex_Num);
 
-- Error was not raised in child package.
Report.Failed ("Exception was not reraised in addition");
 
exception
when Add_Error =>
if not TC_Handled_In_Child_Pkg_Proc then
Report.Failed ("Exception was not raised in addition");
else
TC_Handled_In_Caller := true; -- Exception is reraised from
-- child package.
end if;
 
when others =>
Report.Failed ("Unexpected exception in addition subtest");
TC_Handled_In_Caller := false; -- Improper exception handling
-- in caller.
 
end Add_Complex_Subtest;
 
 
Subtract_Complex_Subtest:
declare
First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (6)));
Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)),
Int_Type (Report.Ident_Int (7)));
Sub_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
Int_Type (Report.Ident_Int (1)));
Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-200)),
Int_Type (Report.Ident_Int (1)));
Complex_Num : Complex_Type;
 
begin
Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, First);
 
if (Complex_Num /= Sub_Result) then
Report.Failed ("Incorrect results from subtraction");
end if;
-- Error is raised and exception will be handled in child package.
Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, Third);
 
exception
when Subtract_Error =>
Report.Failed ("Exception raised in subtraction and " &
"propagated to caller");
TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling
-- in caller.
 
when others =>
Report.Failed ("Unexpected exception in subtraction subtest");
TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling
-- in caller.
 
end Subtract_Complex_Subtest;
 
 
Multiply_Complex_Subtest:
declare
First : Complex_Type := Complex (Int_Type(Report.Ident_Int(3)),
Int_Type (Report.Ident_Int (4)));
Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)),
Int_Type (Report.Ident_Int (3)));
Mult_Result : Complex_Type := Complex(Int_Type(Report.Ident_Int(15)),
Int_Type(Report.Ident_Int (12)));
Third : Complex_Type := Complex(Int_Type(Report.Ident_Int(10)),
Int_Type(Report.Ident_Int (-10)));
Complex_Num : Complex_Type;
 
begin
CA11D011 (First, Second, Complex_Num);
 
if (Complex_Num /= Mult_Result) then
Report.Failed ("Incorrect results from multiplication");
end if;
-- Error is raised and exception will be handled in child package.
CA11D011 (First, Third, Complex_Num);
 
exception
when Multiply_Error =>
Report.Failed ("Exception raised in multiplication and " &
"propagated to caller");
TC_Handled_In_Child_Sub := false; -- Improper exception handling
-- in caller.
 
when others =>
Report.Failed ("Unexpected exception in multiplication subtest");
TC_Handled_In_Child_Sub := false; -- Improper exception handling
-- in caller.
end Multiply_Complex_Subtest;
 
 
Divide_Complex_Subtest:
declare
First : Complex_Type := Complex (Int_Type (Report.Ident_Int(10)),
Int_Type (Report.Ident_Int (15)));
Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)),
Int_Type (Report.Ident_Int (3)));
Div_Result : Complex_Type := Complex (Int_Type(Report.Ident_Int(2)),
Int_Type (Report.Ident_Int (5)));
Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-10)),
Int_Type (Report.Ident_Int (0)));
Complex_Num : Complex_Type := Zero;
 
begin
Complex_Num := CA11D012 (First, Second);
 
if (Complex_Num /= Div_Result) then
Report.Failed ("Incorrect results from division");
end if;
-- Error is raised in child package; exception will be
-- propagated to caller.
Complex_Num := CA11D012 (Second, Third);
 
-- Error was not raised in child package.
Report.Failed ("Exception was not raised in division subtest ");
 
exception
when Divide_Error =>
TC_Propagated_To_Caller := true; -- Exception is propagated.
 
when others =>
Report.Failed ("Unexpected exception in division subtest");
TC_Propagated_To_Caller := false; -- Improper exception handling
-- in caller.
end Divide_Complex_Subtest;
 
 
if not (TC_Handled_In_Caller and -- Check to see that all
TC_Handled_In_Child_Pkg_Proc and -- exceptions were handled in
TC_Handled_In_Child_Pkg_Func and -- the proper locations.
TC_Handled_In_Child_Sub and
TC_Propagated_To_Caller)
then
Report.Failed ("Exceptions handled in incorrect locations");
end if;
 
Report.Result;
 
end CA11D013;
/ca110050.a
0,0 → 1,99
-- CA110050.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:
-- See CA110051.AM
--
-- TEST DESCRIPTION:
-- See CA110051.AM
--
-- TEST FILES:
-- The test consists of the following files:
--
-- => CA110050.A
-- CA110051.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Dec 94 SAIC Modified discriminant type
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
-- Elaborate_Body.
--
--!
package CA110050_0 is -- Package Messages.
pragma Elaborate_Body (CA110050_0);
 
type Descriptor is new Integer;
 
Null_Descriptor_Value : constant Descriptor := 0;
Null_Message_Descriptor : constant Descriptor := 0;
 
type Message_Type is tagged
record
Number : Descriptor := Null_Message_Descriptor;
end record;
 
function Next_Available_Message return Descriptor;
 
end CA110050_0; -- Package Messages.
 
--=================================================================--
 
package body CA110050_0 is -- Package body Messages.
 
Message_Count : Integer := 0;
 
function Next_Available_Message return Descriptor is
begin
Message_Count := Message_Count + 5;
return (Descriptor(Message_Count));
end Next_Available_Message;
 
end CA110050_0; -- Package body Messages.
 
--=================================================================--
 
package CA110050_0.CA110050_1 is -- Child package Messages.Text
 
subtype Default_Length is Natural range 0 .. 80;
 
type Text_Type (Max_Length : Default_Length := 0) is
record
Length : Default_Length := Max_Length;
Text_Field : String (1 .. Max_Length);
end record;
 
type Text_Message_Type is new Message_Type with
record
Text : Text_Type;
end record;
 
Null_Text : Text_Type (0); -- Null range for
-- Text_Field component.
 
end CA110050_0.CA110050_1; -- Child package Messages.Text
--
-- No package body needed for this specification.
/ca2009f1.ada
0,0 → 1,43
-- CA2009F1.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.
--*
-- SEPARATE GENERIC PROCEDURE BODY.
-- SPECIFICATION, BODY STUB, AND INSTANTIATION ARE IN A2009F0M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- BHS 08/01/84 CREATED ORIGINAL TEST.
-- PWB 02/19/86 MODIFIED COMMENTS TO SHOW RELATION TO OTHER FILES
-- AND TO CLARIFY NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA2009F0M)
PROCEDURE PROC1 IS
BEGIN
PVAR1 := PCON1;
END PROC1;
/ca1004a.ada
0,0 → 1,77
-- CA1004A.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 DECLARATION AND BODY CAN BE
-- SUBMITTED TOGETHER FOR COMPILATION.
 
-- JRK 5/12/81
 
 
PACKAGE CA1004A_PKG IS
 
I : INTEGER := 0;
 
PROCEDURE P (I : IN OUT INTEGER);
 
END CA1004A_PKG;
 
 
PACKAGE BODY CA1004A_PKG IS
 
PROCEDURE P (I : IN OUT INTEGER) IS
BEGIN
I := I + 1;
END P;
 
BEGIN
 
I := 10;
 
END CA1004A_PKG;
 
 
WITH REPORT, CA1004A_PKG;
USE REPORT;
 
PROCEDURE CA1004A IS
 
I : INTEGER := IDENT_INT (0);
 
BEGIN
TEST ("CA1004A", "A PACKAGE DECLARATION AND BODY SUBMITTED " &
"TOGETHER");
 
CA1004A_PKG.I := CA1004A_PKG.I + IDENT_INT(5);
IF CA1004A_PKG.I /= 15 THEN
FAILED ("PACKAGED VARIABLE NOT ACCESSIBLE OR " &
"PACKAGE BODY NOT EXECUTED");
END IF;
 
CA1004A_PKG.P (I);
IF I /= 1 THEN
FAILED ("PACKAGED PROCEDURE NOT EXECUTED");
END IF;
 
RESULT;
END CA1004A;
/ca5004a.ada
0,0 → 1,105
-- CA5004A.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 PRAGMA ELABORATE IS APPLIED TO A PACKAGE THAT DECLARES
-- A TASK OBJECT, THE IMPLICIT PACKAGE BODY IS ELABORATED AND THE TASK
-- IS ACTIVATED.
 
-- BHS 8/03/84
-- JRK 9/20/84
-- PWN 01/31/95 ADDED A PROCEDURE TO REQUIRE A BODY FOR ADA 9X.
 
 
PACKAGE CA5004A0 IS
 
TASK TYPE TSK IS
ENTRY E (VAR : OUT INTEGER);
END TSK;
 
END CA5004A0;
 
 
PACKAGE BODY CA5004A0 IS
 
TASK BODY TSK IS
BEGIN
ACCEPT E (VAR : OUT INTEGER) DO
VAR := 4;
END E;
END TSK;
 
END CA5004A0;
 
 
WITH CA5004A0; USE CA5004A0; PRAGMA ELABORATE (CA5004A0);
PACKAGE CA5004A1 IS
 
T : TSK;
 
END CA5004A1;
 
 
PACKAGE CA5004A2 IS
PROCEDURE REQUIRE_BODY;
END CA5004A2;
 
 
WITH REPORT; USE REPORT;
WITH CA5004A1; USE CA5004A1;
PRAGMA ELABORATE (CA5004A1, REPORT);
PACKAGE BODY CA5004A2 IS
 
I : INTEGER := 1;
 
PROCEDURE REQUIRE_BODY IS
BEGIN
NULL;
END;
BEGIN
 
TEST ("CA5004A", "APPLYING PRAGMA ELABORATE TO A PACKAGE " &
"DECLARING A TASK OBJECT CAUSES IMPLICIT " &
"BODY ELABORATION AND TASK ACTIVATION");
 
SELECT
T.E(I);
IF I /= 4 THEN
FAILED ("TASK NOT EXECUTED PROPERLY");
END IF;
OR
DELAY 10.0;
FAILED ("TASK NOT ACTIVATED AFTER 10 SECONDS");
END SELECT;
 
END CA5004A2;
 
 
WITH CA5004A2;
WITH REPORT; USE REPORT;
PROCEDURE CA5004A IS
BEGIN
 
RESULT;
 
END CA5004A;
/ca200022.am
0,0 → 1,64
-- CA200022.AM
--
-- 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 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:
-- See CA200020.A.
--
-- TEST DESCRIPTION:
-- See CA200020.A.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA200020.A
-- CA200021.A
-- -> CA200022.AM
--
-- PASS/FAIL CRITERIA:
-- See CA200020.A.
--
-- CHANGE HISTORY:
-- 25 JAN 99 RLB Initial version.
-- 08 JUL 99 RLB Repaired comments.
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--!
 
with Report;
use Report;
with CA20002_0; -- Child unit not included in the partition.
procedure CA200022 is
Value : Integer := 0;
begin
Test ("CA20002","Check that compiling multiple units with the same " &
"name does not prevent the creation of a partition " &
"using only one of the units.");
CA20002_0.Do_a_Little (Value);
if Report.Equal (Value, 5) then
null; -- OK.
else
Failed ("Wrong result from subunit");
end if;
 
Result;
end CA200022;
/ca11012.a
0,0 → 1,259
-- CA11012.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 child package of a library level instantiation
-- of a generic can be the instantiation of a child package of
-- the generic. Check that the child instance can use its parent's
-- declarations and operations, including a formal type of the parent.
--
-- TEST DESCRIPTION:
-- Declare a generic package which simulates an integer complex
-- abstraction. Declare a generic child package of this package
-- which defines additional complex operations.
--
-- Instantiate the first generic package, then instantiate the child
-- generic package as a child unit of the first instance. In the main
-- program, check that the operations in both instances perform as
-- expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Dec 94 SAIC Corrected visibility errors for literals
-- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3
--!
 
generic -- Complex number abstraction.
type Int_Type is range <>;
 
package CA11012_0 is
-- Simulate a generic complex number support package. Complex numbers
-- are treated as coordinates in the Cartesian plane.
 
type Complex_Type is private;
 
Zero : constant Complex_Type; -- Real number (0,0).
 
function Complex (Real, Imag : Int_Type) -- Create a complex
return Complex_Type; -- number.
 
function "-" (Right : Complex_Type) -- Invert a complex
return Complex_Type; -- number.
 
function "+" (Left, Right : Complex_Type) -- Add two complex
return Complex_Type; -- numbers.
 
private
type Complex_Type is record
Real : Int_Type;
Imag : Int_Type;
end record;
 
Zero : constant Complex_Type := (Real => 0, Imag => 0);
 
end CA11012_0;
 
--==================================================================--
 
package body CA11012_0 is
 
function Complex (Real, Imag : Int_Type) return Complex_Type is
begin
return (Real, Imag);
end Complex;
---------------------------------------------------------------
function "-" (Right : Complex_Type) return Complex_Type is
begin
return (-Right.Real, -Right.Imag);
end "-";
---------------------------------------------------------------
function "+" (Left, Right : Complex_Type) return Complex_Type is
begin
return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
end "+";
 
end CA11012_0;
 
--==================================================================--
 
-- Generic child of complex number package. Child must be generic since
-- parent is generic.
 
generic -- Complex additional operations
 
package CA11012_0.CA11012_1 is
-- More operations on complex number. This child adds a layer of
-- functionality to the parent generic.
 
function Real_Part (Complex_No : Complex_Type)
return Int_Type;
 
function Imag_Part (Complex_No : Complex_Type)
return Int_Type;
 
function "*" (Factor : Int_Type;
C : Complex_Type) return Complex_Type;
 
function Vector_Magnitude (Complex_No : Complex_Type)
return Int_Type;
 
end CA11012_0.CA11012_1;
 
--==================================================================--
 
package body CA11012_0.CA11012_1 is
 
function Real_Part (Complex_No : Complex_Type) return Int_Type is
begin
return (Complex_No.Real);
end Real_Part;
---------------------------------------------------------------
function Imag_Part (Complex_No : Complex_Type) return Int_Type is
begin
return (Complex_No.Imag);
end Imag_Part;
---------------------------------------------------------------
function "*" (Factor : Int_Type;
C : Complex_Type) return Complex_Type is
Result : Complex_Type := Zero; -- Zero is declared in parent,
-- Complex_Number
begin
for I in 1 .. abs (Factor) loop
Result := Result + C; -- Complex_Number "+"
end loop;
 
if Factor < 0 then
Result := - Result; -- Complex_Number "-"
end if;
 
return Result;
end "*";
---------------------------------------------------------------
function Vector_Magnitude (Complex_No : Complex_Type)
return Int_Type is -- Not a real vector magnitude.
begin
return (Complex_No.Real + Complex_No.Imag);
end Vector_Magnitude;
 
end CA11012_0.CA11012_1;
 
--==================================================================--
 
package CA11012_2 is
 
subtype My_Integer is integer range -100 .. 100;
 
-- ... Various other types used by the application.
 
end CA11012_2;
 
-- No body for CA11012_2;
 
--==================================================================--
 
-- Declare instances of the generic complex packages for integer type.
-- The instance of the child must itself be declared as a child of the
-- instance of the parent.
 
with CA11012_0; -- Complex number abstraction
with CA11012_2; -- Package containing integer type
pragma Elaborate (CA11012_0);
package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer);
 
with CA11012_0.CA11012_1; -- Complex additional operations
with CA11012_3;
package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1;
 
--==================================================================--
 
with CA11012_2; -- Package containing integer type
with CA11012_3.CA11012_4; -- Complex abstraction + additional operations
with Report;
 
procedure CA11012 is
 
package My_Complex_Pkg renames CA11012_3;
 
package My_Complex_Operation renames CA11012_3.CA11012_4;
 
use My_Complex_Pkg, -- All user-defined
My_Complex_Operation; -- operators directly
-- visible.
Complex_One, Complex_Two : Complex_Type;
 
begin
 
Report.Test ("CA11012", "Check that child instance can use its parent's " &
"declarations and operations, including a formal " &
"type of the parent");
 
Correct_Range_Test:
declare
My_Literal : CA11012_2.My_Integer := -3;
 
begin
Complex_One := Complex (-4, 7); -- Operation from the generic
-- parent package.
 
Complex_Two := My_Literal * Complex_One; -- Operation from the generic
-- child package.
 
if Real_Part (Complex_Two) /= 12 -- Operation from the generic
or Imag_Part (Complex_Two) /= -21 -- child package.
then
Report.Failed ("Incorrect results from complex operation");
end if;
 
end Correct_Range_Test;
 
---------------------------------------------------------------
 
Out_Of_Range_Test:
declare
My_Vector : CA11012_2.My_Integer;
 
begin
Complex_One := Complex (70, 70); -- Operation from the generic
-- parent package.
My_Vector := Vector_Magnitude (Complex_One);
-- Operation from the generic child package.
 
Report.Failed ("Exception not raised in child package");
 
exception
when Constraint_Error =>
Report.Comment ("Exception is raised as expected");
 
when others =>
Report.Failed ("Others exception is raised");
 
end Out_Of_Range_Test;
 
Report.Result;
 
end CA11012;
/ca110051.am
0,0 → 1,224
-- CA110051.AM
--
-- 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 entities and operations declared in a package can be used
-- in the private part of a child of a child of the package.
--
-- TEST DESCRIPTION:
-- Declare a series of library unit packages -- parent, child, and
-- grandchild. The grandchild package will have a private part.
-- From within the private part of the grandchild, make use of
-- components declared in the parent and grandparent packages.
--
-- TEST FILES:
-- The test consists of the following files:
--
-- CA110050.A
-- => CA110051.AM
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Grandchild Package Message.Text.Encoded
package CA110050_0.CA110050_1.CA110050_2 is
 
type Coded_Message is new Text_Message_Type with private;
 
procedure Send (Message : in Coded_Message;
Confirm : out Coded_Message;
Status : out Boolean);
 
function Encode (Message : Text_Message_Type) return Coded_Message;
function Decode (Message : Coded_Message) return Boolean;
function Test_Connection return Boolean;
 
private
 
Uncoded : Descriptor renames Null_Descriptor_Value; -- Grandparent object.
 
type Coded_Message is new Text_Message_Type with -- Parent type.
record
Key : Descriptor := Uncoded;
Coded_Key : Descriptor := Next_Available_Message;
-- Grandparent type, grandparent function.
Scrambled : Text_Type := Null_Text; -- Parent object.
end record;
 
Coded_Msg : Coded_Message;
 
type Blank_Message is new Message_Type with -- Grandparent type.
record
ID : Descriptor := Next_Available_Message;
-- Grandparent type, grandparent function.
end record;
 
Test_Message : Blank_Message;
 
Confirm_String : constant String := "OK";
Scrambled_String : constant String := "KO";
 
Confirm_Text : Text_Type (Confirm_String'Length) :=
(Max_Length => Confirm_String'Length,
Length => Confirm_String'Length,
Text_Field => Confirm_String);
 
Scrambled_Text : Text_Type (Scrambled_String'Length) :=
(Max_Length => Scrambled_String'Length,
Length => Scrambled_String'Length,
Text_Field => Scrambled_String);
end CA110050_0.CA110050_1.CA110050_2; -- Grandchild Pkg Message.Text.Encoded
 
--=================================================================--
 
-- Grandchild Package body Message.Text.Encoded
package body CA110050_0.CA110050_1.CA110050_2 is
 
procedure Send (Message : in Coded_Message;
Confirm : out Coded_Message;
Status : out Boolean) is
 
Confirmation_Message : Coded_Message :=
(Number => Message.Number,
Text => Confirm_Text,
Key => Message.Number,
Coded_Key => Message.Number,
Scrambled => Scrambled_Text);
 
begin -- Dummy processing unit.
Confirm := Confirmation_Message;
if Confirm.Number /= Null_Message_Descriptor then
Status := True;
else
Status := False;
end if;
end Send;
-------------------------------------------------------------------------
function Encode (Message : Text_Message_Type) return Coded_Message is
begin
Coded_Msg.Number := Message.Number;
if Message.Text.Length > 0 then
Coded_Msg.Text := Message.Text; -- Record assignment.
Coded_Msg.Key := Message.Number; -- Same as msg number.
Coded_Msg.Coded_Key := Message.Number; -- Same as msg number.
Coded_Msg.Scrambled := Message.Text; -- Dummy processing.
end if;
return (Coded_Msg);
end Encode;
-------------------------------------------------------------------------
function Decode (Message : Coded_Message) return Boolean is
Decoded : Boolean := False;
begin
if (Message.Text.Length = Confirm_String'Length) and then
(Message.Text.Text_Field = Confirm_String) and then
(Message.Scrambled.Length = Scrambled_String'Length) and then
(Message.Scrambled.Text_Field = Scrambled_String) and then
(Message.Coded_Key = 15)
then
Decoded := True;
end if;
return (Decoded);
end Decode;
-------------------------------------------------------------------------
function Test_Connection return Boolean is
begin
return Test_Message.Id = 10;
end Test_Connection;
 
end CA110050_0.CA110050_1.CA110050_2;
-- Grandchild Package body Message.Text.Encoded
--=================================================================--
 
with CA110050_0.CA110050_1.CA110050_2;
with Report;
 
procedure CA110051 is
 
package Message_Package renames CA110050_0.CA110050_1;
package Code_Package renames CA110050_0.CA110050_1.CA110050_2;
 
Message_String : constant String := "One if by land, two if by sea";
 
Message_Text : Message_Package.Text_Type (Message_String'Length) :=
(Max_Length => Message_String'Length,
Length => Message_String'Length,
Text_Field => Message_String);
 
Message : Message_Package.Text_Message_Type :=
(Number => CA110050_0.Next_Available_Message,
Text => Message_Text);
 
Confirmation_Message : Code_Package.Coded_Message;
Verification_OK : Boolean := False;
Transmission_OK : Boolean := False;
 
begin
 
-- This test simulates the use of child library unit packages to implement
-- a message encoding and transmission scheme. The full capability of the
-- encoding and transmission mechanisms are not developed here, but the
-- intent is to demonstrate that a grandchild library unit package with a
-- private part will provide the framework for this type of processing.
 
Report.Test ("CA110051", "Check that entities and operations declared " &
"in a package can be used in the private part " &
"of a child of a child of the package");
 
-- The following code demonstrates the use
-- of functionality contained in a grandchild
-- library unit. The grandchild unit made use
-- of components declared in the ancestor
-- packages.
Code_Package.Send -- Message object declared
(Message => Code_Package.Encode (Message), -- above in "encoded" by a
Confirm => Confirmation_Message, -- call to grandchild pkg
Status => Transmission_OK); -- function call, reseting
-- fields and returning a
-- coded message to the
-- parameter. The confirm
-- parameter receives an
-- encoded message value
-- from proc Send, which is
-- "decoded"/verified below.
 
if not Code_Package.Test_Connection then
Report.Failed ("Bad initialization");
end if;
 
Verification_OK := Code_Package.Decode (Confirmation_Message);
 
if not (Transmission_OK and Verification_OK) then
Report.Failed ("Message transmission failure");
end if;
 
Report.Result;
 
end CA110051;
/ca11016.a
0,0 → 1,321
-- CA11016.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 child of a non-generic package can be a private generic
-- package. Check that the private child instance can use its parent's
-- declarations and operations. Check that the body of a public child
-- package can instantiate its sibling private generic package.
--
-- TEST DESCRIPTION:
-- Declare a map abstraction in a package which manages basic physical
-- map[s]. Declare a private generic child of this package which can be
-- instantiated for any display device which has display locations of
-- the physical map that can be characterized by any integer type, i.e.,
-- the intensity of the display point.
--
-- Declare a public child of the physical map which specifies the
-- display device. In the body of this child, declare an instance of
-- its generic sibling to display the geographic locations.
--
-- In the main program, check that the operations in the parent, public
-- child and instance of the private child package perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate.
--
--!
 
-- Simulates map of physical features, i.e., desert, forest, or water.
 
package CA11016_0 is
type Map_Type is private;
subtype Latitude is integer range 1 .. 9;
subtype Longitude is integer range 1 .. 7;
 
type Physical_Features is (Desert, Forest, Water);
-- Use geographic database to initialize the basic map.
 
procedure Initialize_Basic_Map (Map : in out Map_Type);
 
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type) return Physical_Features;
 
private
type Map_Type is array (Latitude, Longitude) of Physical_Features;
Basic_Map : Map_Type;
 
end CA11016_0;
 
--==================================================================--
 
package body CA11016_0 is
 
procedure Initialize_Basic_Map (Map : in out Map_Type) is
-- Not a real initialization. Real application can use geographic
-- database to create the basic map.
 
begin
for I in Latitude'first .. Latitude'last loop
for J in 1 .. 2 loop
Map (I, J) := Desert;
end loop;
for J in 3 .. 4 loop
Map (I, J) := Forest;
end loop;
for J in 5 .. 7 loop
Map (I, J) := Water;
end loop;
end loop;
 
end Initialize_Basic_Map;
--------------------------------------------------------
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type)
return Physical_Features is
begin
return (Map (Lat, Long));
end Get_Physical_Feature;
--------------------------------------------------------
 
begin
-- Initialize a basic map.
Initialize_Basic_Map (Basic_Map);
 
end CA11016_0;
 
--==================================================================--
 
-- Private generic child package of physical map. This generic package may
-- be instantiated for any display device which has display locations
-- (latitude, longitude) that can be characterized by an integer value.
-- For example, the intensity of the display point might be so characterized.
-- It can be instantiated for any desired range of values (which would
-- correspond to the range accepted by the display device).
 
 
private
 
generic
 
type Display_Value is range <>; -- Any display feature that is
-- represented by an integer.
 
package CA11016_0.CA11016_1 is
 
function Get_Display_Value (Lat : Latitude;
Long : Longitude;
Map : Map_Type) return Display_Value;
 
end CA11016_0.CA11016_1;
 
 
--==================================================================--
 
 
package body CA11016_0.CA11016_1 is
 
function Get_Display_Value (Lat : Latitude;
Long : Longitude;
Map : Map_Type)
return Display_Value is
begin
case Get_Physical_Feature (Lat, Long, Map) is
-- Parent's operation,
when Forest => return (Display_Value'first);
-- Parent's type.
when Desert => return (Display_Value'last);
-- Parent's type.
when others => return
( (Display_Value'last - Display_Value'first) / 2 );
-- NOTE: Results are truncated.
end case;
 
end Get_Display_Value;
 
end CA11016_0.CA11016_1;
 
 
--==================================================================--
 
-- Map display operation, public child of physical map.
 
package CA11016_0.CA11016_2 is
 
-- Super-duper Ultra Geographic Display Device (SDUGD) can display
-- geographic locations with light intensity values ranging from 1 to 7.
 
type Display_Val is range 1 .. 7;
 
type Device_Color is (Brown, Blue, Green);
 
type IO_Packet is
record
Lat : Latitude; -- Parent's type.
Long : Longitude; -- Parent's type.
Color : Device_Color;
Intensity : Display_Val;
end record;
 
procedure Data_For_SDUGD (Lat : in Latitude;
Long : in Longitude;
Output_Packet : in out IO_Packet);
 
end CA11016_0.CA11016_2;
 
--==================================================================--
 
 
with CA11016_0.CA11016_1; -- Private generic sibling.
pragma Elaborate (CA11016_0.CA11016_1);
 
package body CA11016_0.CA11016_2 is
 
-- Declare instance of the private generic sibling for
-- an integer type that represents color intensity.
 
package SDUGD is new CA11016_0.CA11016_1 (Display_Val);
 
procedure Data_For_SDUGD (Lat : in Latitude;
Long : in Longitude;
Output_Packet : in out IO_Packet) is
 
-- Simulates sending control information to a display device.
-- Control information consists of latitude, longitude, a
-- color, and an intensity.
 
begin
case Get_Physical_Feature (Lat, Long, Basic_Map) is
-- Parent's operation.
when Water => Output_Packet.Color := Blue;
Output_Packet.Intensity := SDUGD.Get_Display_Value
(Lat, Long, Basic_Map);
-- Sibling's operation.
when Forest => Output_Packet.Color := Green;
Output_Packet.Intensity := SDUGD.Get_Display_Value
(Lat, Long, Basic_Map);
-- Sibling's operation.
when others => Output_Packet.Color := Brown;
Output_Packet.Intensity := SDUGD.Get_Display_Value
(Lat, Long, Basic_Map);
-- Sibling's operation.
end case;
 
end Data_For_SDUGD;
 
end CA11016_0.CA11016_2;
 
--==================================================================--
 
with CA11016_0.CA11016_2; -- Map display device operation,
-- implicitly withs parent, physical map
-- application.
 
use CA11016_0.CA11016_2; -- Allows direct visibility to the simple
-- name of CA11016_0.CA11016_2.
 
with Report;
 
procedure CA11016 is
 
TC_Packet : IO_Packet;
 
begin
 
Report.Test ("CA11016", "Check that body of a public child package can " &
"use its sibling private generic package " &
"declarations and operations");
 
-- Simulate control information at coordinates 3 and 7 of the
-- basic map for the SDUGD.
Water_Display_Subtest:
begin
TC_Packet.Lat := 3;
TC_Packet.Long := 7;
 
-- Build color and light intensity of the basic map at
-- latitude 3 and longitude 7.
 
Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
 
if ( (TC_Packet.Color /= Blue) or
(TC_Packet.Intensity /= 3) ) then
Report.Failed ("Map display device contains " &
"incorrect values for water subtest");
end if;
 
end Water_Display_Subtest;
 
-- Simulate control information at coordinates 2 and 1 of the
-- basic map for the SDUGD.
Desert_Display_Subtest:
begin
TC_Packet.Lat := 9;
TC_Packet.Long := 2;
 
-- Build color and light intensity of the basic map at
-- latitude 9 and longitude 2.
 
Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
 
if ( (TC_Packet.Color /= Brown) or
(TC_Packet.Intensity /= 7) ) then
Report.Failed ("Map display device contains " &
"incorrect values for desert subtest");
end if;
 
end Desert_Display_Subtest;
 
-- Simulate control information at coordinates 8 and 4 of the
-- basic map for the SDUGD.
Forest_Display_Subtest:
begin
TC_Packet.Lat := 8;
TC_Packet.Long := 4;
 
-- Build color and light intensity of the basic map at
-- latitude 8 and longitude 4.
 
Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet);
 
if ( (TC_Packet.Color /= Green) or
(TC_Packet.Intensity /= 1) ) then
Report.Failed ("Map display device contains " &
"incorrect values for forest subtest");
end if;
 
end Forest_Display_Subtest;
 
Report.Result;
 
end CA11016;
/ca1011a0.ada
0,0 → 1,35
-- CA1011A0.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
WITH REPORT; USE REPORT;
PROCEDURE CA1011A0 (X : IN OUT INTEGER; Y : IN INTEGER := 2) IS
BEGIN
 
X := Y;
FAILED ("DID NOT REPLACE CA1011A0");
 
END CA1011A0;
/ca2002a0.ada
0,0 → 1,139
-- CA2002A0M.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 SUBUNITS HAVING DIFFERENT ANCESTOR LIBRARY UNITS CAN HAVE
-- THE SAME NAME.
 
-- SEPARATE FILES ARE:
-- CA2002A0M THE MAIN PROCEDURE, WITH SEPARATE LIBRARY
-- PACKAGES (CA2002A1) AND (CA2002A2).
-- CA2002A1 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A1.
-- CA2002A2 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A2.
 
-- BHS 8/02/84
 
PACKAGE CA2002A1 IS
 
PROCEDURE PROC (X : OUT INTEGER);
FUNCTION FUN RETURN BOOLEAN;
 
PACKAGE PKG IS
I : INTEGER;
PROCEDURE PKG_PROC (XX : IN OUT INTEGER);
END PKG;
 
END CA2002A1;
 
PACKAGE BODY CA2002A1 IS
 
PROCEDURE PROC (X : OUT INTEGER) IS SEPARATE;
FUNCTION FUN RETURN BOOLEAN IS SEPARATE;
PACKAGE BODY PKG IS SEPARATE;
 
END CA2002A1;
 
 
PACKAGE CA2002A2 IS
 
PROCEDURE PROC (Y : OUT INTEGER);
FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN;
 
PACKAGE PKG IS
I : INTEGER;
PROCEDURE PKG_PROC (YY : IN OUT INTEGER);
END PKG;
 
END CA2002A2;
 
PACKAGE BODY CA2002A2 IS
 
PROCEDURE PROC (Y : OUT INTEGER) IS SEPARATE;
FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS SEPARATE;
PACKAGE BODY PKG IS SEPARATE;
 
END CA2002A2;
 
WITH CA2002A1, CA2002A2;
WITH REPORT; USE REPORT;
PROCEDURE CA2002A0M IS
BEGIN
 
TEST ("CA2002A", "SUBUNITS WITH DIFFERENT ANCESTORS " &
"CAN HAVE THE SAME NAME");
 
DECLARE
VAR1 : INTEGER;
USE CA2002A1;
BEGIN
 
PROC (VAR1);
IF VAR1 /= 1 THEN
FAILED ("CA2002A1 PROCEDURE NOT INVOKED CORRECTLY");
END IF;
 
IF NOT FUN THEN
FAILED ("CA2002A1 FUNCTION NOT INVOKED CORRECTLY");
END IF;
 
IF PKG.I /= 1 THEN
FAILED ("CA2202A1 PKG VARIABLE NOT ACCESSED CORRECTLY");
END IF;
 
VAR1 := 5;
PKG.PKG_PROC (VAR1);
IF VAR1 /= 4 THEN
FAILED ("CA2002A1 PKG SUBUNIT NOT INVOKED CORRECTLY");
END IF;
 
END;
 
DECLARE
VAR2 : INTEGER;
USE CA2002A2;
BEGIN
 
PROC (VAR2);
IF VAR2 /= 2 THEN
FAILED ("CA2002A2 PROCEDURE NOT INVOKED CORRECTLY");
END IF;
 
IF FUN THEN
FAILED ("CA2002A2 FUNCTION NOT INVOKED CORRECTLY");
END IF;
 
IF PKG.I /= 2 THEN
FAILED ("CA2002A2 PKG VARIABLE NOT ACCESSED CORRECTLY");
END IF;
 
VAR2 := 3;
PKG.PKG_PROC (VAR2);
IF VAR2 /= 4 THEN
FAILED ("CA2002A2 PKG SUBUNIT NOT INVOKED CORRECTLY");
END IF;
 
END;
 
RESULT;
 
END CA2002A0M;
/ca1011a2.ada
0,0 → 1,35
-- CA1011A2.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
WITH REPORT; USE REPORT;
PROCEDURE CA1011A2 (X : INTEGER := 1; Y : IN OUT FLOAT) IS
BEGIN
 
Y := 2.0;
FAILED ("DID NOT REPLACE CA1011A2");
 
END CA1011A2;
/ca1013a1.ada
0,0 → 1,39
-- CA1013A1.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.
--*
-- WKB 7/20/81
 
 
GENERIC
TYPE INDEX IS RANGE <>;
PROCEDURE CA1013A1 (I : IN OUT INDEX);
 
 
PROCEDURE CA1013A1 (I : IN OUT INDEX) IS
 
BEGIN
I := I + 1;
 
END CA1013A1;
/ca2002a2.ada
0,0 → 1,53
-- CA2002A2.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.
--*
-- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A2 IN FILE
-- CA2002A0M.
 
-- BHS 8/02/84
 
SEPARATE (CA2002A2)
PROCEDURE PROC (Y : OUT INTEGER) IS
BEGIN
Y := 2;
END PROC;
 
SEPARATE (CA2002A2)
FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS
BEGIN
RETURN Z /= 3;
END FUN;
 
SEPARATE (CA2002A2)
PACKAGE BODY PKG IS
PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS SEPARATE;
BEGIN
I := 2;
END PKG;
 
SEPARATE (CA2002A2.PKG)
PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS
BEGIN
YY := YY + 1;
END PKG_PROC;
/ca1011a4.ada
0,0 → 1,35
-- CA1011A4.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
WITH REPORT; USE REPORT;
FUNCTION CA1011A4 RETURN INTEGER IS
BEGIN
 
FAILED ("DID NOT REPLACE CA1011A4");
RETURN 2;
 
END CA1011A4;
/ca2004a1.ada
0,0 → 1,34
-- CA2004A1.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.
--*
-- WKB 6/26/81
 
SEPARATE (CA2004A0M)
PACKAGE BODY CA2004A1 IS
 
K : INTEGER := 3;
 
PROCEDURE CA2004A2 IS SEPARATE;
 
END CA2004A1;
/ca1013a3.ada
0,0 → 1,31
-- CA1013A3.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.
--*
-- WKB 7/20/81
-- SPS 10/27/82
-- JBG 9/15/83
 
WITH CA1013A0;
PRAGMA ELABORATE (CA1013A0);
PACKAGE CA1013A3 IS NEW CA1013A0 (INTEGER);
/ca1011a6.ada
0,0 → 1,71
-- CA1011A6M.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 SUBPROGRAM BODY IS INITIALLY COMPILED, SUBSEQUENT
-- ATTEMPTS TO COMPILE A SUBPROGRAM BODY WITH A DIFFERENT PARAMETER AND
-- RESULT TYPE PROFILE ARE ACCEPTED (SEE AI-00199).
 
-- SEPARATE FILES ARE:
-- CA1011A0 A LIBRARY PROCEDURE (CA1011A0).
-- CA1011A1 A LIBRARY PROCEDURE (CA1011A0).
-- CA1011A2 A LIBRARY PROCEDURE (CA1011A2).
-- CA1011A3 A LIBRARY PROCEDURE (CA1011A2).
-- CA1011A4 A LIBRARY FUNCTION (CA1011A4).
-- CA1011A5 A LIBRARY FUNCTION (CA1011A4).
-- CA1011A6M THE MAIN PROCEDURE.
 
-- BHS 7/20/84
-- JBG 5/23/85
 
WITH CA1011A0, CA1011A2, CA1011A4;
WITH REPORT; USE REPORT;
PROCEDURE CA1011A6M IS
 
I : INTEGER := 5;
J : FLOAT := 4.0;
 
BEGIN
 
TEST("CA1011A", "ATTEMPTS TO RECOMPILE A SUBPROGRAM WITH " &
"NONCONFORMING PARAMETER OR RESULT TYPE " &
"PROFILES ARE ACCEPTED");
 
CA1011A0(X => I); -- EXPECT DEFAULT Y
IF I = 3 THEN
COMMENT ("SECOND DECLARATION OF CA1011A0 INVOKED CORRECTLY");
END IF;
 
CA1011A2(Y => J); -- USE DEFAULT X.
IF J = 3.0 THEN
COMMENT ("SECOND DECLARATION OF CA1011A2 INVOKED CORRECTLY");
END IF;
 
I := INTEGER(CA1011A4);
IF I = 3 THEN
COMMENT ("SECOND DECLARATION OF CA1011A4 INVOKED CORRECTLY");
END IF;
 
RESULT;
 
END CA1011A6M;
/ca2004a3.ada
0,0 → 1,39
-- CA2004A3.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.
--*
-- BHS 7/31/84
 
SEPARATE (CA2004A0M)
PROCEDURE CA2004A3 IS
 
PROCEDURE CA2004A4 IS SEPARATE;
 
BEGIN
 
IF I /= IDENT_INT(1) OR
J /= IDENT_INT(2) THEN
FAILED ("IDENTIFIER NOT VISIBLE - 4");
END IF;
 
END CA2004A3;
/ca1013a5.ada
0,0 → 1,30
-- CA1013A5.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.
--*
-- WKB 7/20/81
-- JBG 9/15/83
 
WITH CA1013A2;
PRAGMA ELABORATE (CA1013A2);
FUNCTION CA1013A5 IS NEW CA1013A2 (INTEGER);
/ca5004b1.ada
0,0 → 1,56
-- CA5004B1.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: See CA5004B2M.ADA
--
-- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA
--
-- TEST FILES:
-- CA5004B0.ADA
-- => CA5004B1.ADA
-- CA5004B2M.ADA
 
-- PWN 05/31/96 Split test into files without duplicate unit names.
-- RLB 03/11/99 Split test into files so that units that will be replaced
-- and units that won't are not in the same source file.
 
------------------------------------------------------------------
 
PACKAGE CA5004B0 IS
 
I : INTEGER := 1;
 
FUNCTION F RETURN BOOLEAN;
 
END CA5004B0;
 
 
PACKAGE BODY CA5004B0 IS
 
FUNCTION F RETURN BOOLEAN IS
BEGIN
RETURN TRUE;
END F;
 
END CA5004B0;
/ca2008a1.ada
0,0 → 1,35
-- CA2008A1.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.
--*
-- WKB 6/26/81
 
SEPARATE (CA2008A0M)
 
PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS
 
BEGIN
 
B := FALSE;
 
END CA2008A1;
/ca2009c1.ada
0,0 → 1,43
-- CA2009C1.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.
--*
-- A GENERIC PACKAGE BODY.
-- THE DECLARATION AND AN INSTANTIATION ARE IN CA2009C0M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- BHS 08/09/84 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS TO RELATE TO OTHER TEST FILES
-- AND TO DESCRIBE EXPECTED COMPILER ACTION.
-- BCB 01/05/88 MODIFIED HEADER.
-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA2009C0M)
PACKAGE BODY PKG1 IS
BEGIN
VAR1 := CON1;
END PKG1;
/ca11a01.a
0,0 → 1,228
-- CA11A01.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 type extended in a public child inherits primitive
-- operations from its ancestor.
--
-- TEST DESCRIPTION:
-- Declare a root tagged type in a package specification. Declare two
-- primitive subprograms for the type (foundation code).
--
-- Add a public child to the above package. Extend the root type with
-- a record extension in the specification. Declare a new primitive
-- subprogram to write to the child extension.
--
-- Add a public grandchild to the above package. Extend the extension of
-- the parent type with a record extension in the private part of the
-- specification. Declare a new primitive subprogram for this grandchild
-- extension.
--
-- In the main program, "with" the grandchild. Access the primitive
-- operations from grandparent and parent package.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11A00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package FA11A00.CA11A01_0 is -- Color_Widget_Pkg
-- This public child declares an extension from its parent. It
-- represents processing of widgets in a window system.
 
type Widget_Color_Enum is (Black, Green, White);
 
type Color_Widget is new Widget with -- Record extension of
record -- parent tagged type.
Color : Widget_Color_Enum;
end record;
 
-- Inherits procedure Set_Width from Widget.
-- Inherits procedure Set_Height from Widget.
 
-- To be inherited by its derivatives.
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum);
 
procedure Set_Color_Widget (The_Widget : in out Color_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum);
 
end FA11A00.CA11A01_0; -- Color_Widget_Pkg
 
--=======================================================================--
 
package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg
 
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum) is
begin
The_Widget.Color := C;
end Set_Color;
---------------------------------------------------------------
procedure Set_Color_Widget (The_Widget : in out Color_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum) is
begin
Set_Width (The_Widget, The_Width); -- Inherited from parent.
Set_Height (The_Widget, The_Height); -- Inherited from parent.
Set_Color (The_Widget, The_Color);
end Set_Color_Widget;
 
end FA11A00.CA11A01_0; -- Color_Widget_Pkg
 
--=======================================================================--
 
package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
-- This public grandchild extends the extension from its parent. It
-- represents processing of widgets in a window system.
 
-- Declaration used by private extension component.
subtype Widget_Label_Str is string (1 .. 10);
 
type Label_Widget is new Color_Widget with private;
-- Record extension of parent tagged type.
 
-- Inherits (inherited) procedure Set_Width from Color_Widget.
-- Inherits (inherited) procedure Set_Height from Color_Widget.
-- Inherits procedure Set_Color from Color_Widget.
-- Inherits procedure Set_Color_Widget from Color_Widget.
 
procedure Set_Label_Widget (The_Widget : in out Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum;
The_Label : in Widget_Label_Str);
 
-- The following function is needed to verify the value of the
-- extension's private component.
 
function Verify_Label (The_Widget : in Label_Widget;
The_Label : in Widget_Label_Str) return Boolean;
 
private
type Label_Widget is new Color_Widget with
record
Label : Widget_Label_Str;
end record;
 
end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
 
--=======================================================================--
 
package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg
 
procedure Set_Label (The_Widget : in out Label_Widget;
L : in Widget_Label_Str) is
begin
The_Widget.Label := L;
end Set_Label;
--------------------------------------------------------------
procedure Set_Label_Widget (The_Widget : in out Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in Widget_Color_Enum;
The_Label : in Widget_Label_Str) is
begin
Set_Width (The_Widget, The_Width); -- Twice inherited.
Set_Height (The_Widget, The_Height); -- Twice inherited.
Set_Color (The_Widget, The_Color); -- Inherited from parent.
Set_Label (The_Widget, The_Label);
end Set_Label_Widget;
--------------------------------------------------------------
function Verify_Label (The_Widget : in Label_Widget;
The_Label : in Widget_Label_Str) return Boolean is
begin
return (The_Widget.Label = The_Label);
end Verify_Label;
 
end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg
 
--=======================================================================--
 
with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg,
-- implicitly with Widget_Pkg,
-- implicitly with Color_Widget_Pkg
with Report;
 
procedure CA11A01 is
 
package Widget_Pkg renames FA11A00;
package Color_Widget_Pkg renames FA11A00.CA11A01_0;
package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
 
use Widget_Pkg; -- All user-defined operators directly visible.
 
Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
 
Default_Widget : Widget;
Black_Widget : Color_Widget_Pkg.Color_Widget;
Mail_Widget : Label_Widget_Pkg.Label_Widget;
 
begin
 
Report.Test ("CA11A01", "Check that type extended in a public " &
"child inherits primitive operations from its " &
"ancestor");
 
Set_Width (Default_Widget, 9); -- Call from parent.
Set_Height (Default_Widget, 10); -- Call from parent.
 
If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
Report.Failed ("Incorrect result for Default_Widget");
end if;
 
Color_Widget_Pkg.Set_Color_Widget
(Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared.
 
If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
Report.Failed ("Incorrect result for Black_Widget");
end if;
 
Label_Widget_Pkg.Set_Label_Widget
(Mail_Widget, 15, 21, Color_Widget_Pkg.White,
"Quick_Mail"); -- Explicitly declared.
 
If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
Report.Failed ("Incorrect result for Mail_Widget");
end if;
 
Report.Result;
 
end CA11A01;
/ca11c01.a
0,0 → 1,170
-- CA11C01.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 when primitive operations declared in a child package
-- override operations declared in ancestor packages, a client of the
-- child package inherits the operations correctly.
--
-- TEST DESCRIPTION:
--
-- This test builds on the foundation code file (FA11C00) that contains
-- a parent package, child package, and grandchild package. The parent
-- package declares a tagged type and primitive operation. The child
-- package extends the type, and overrides the primitive operation. The
-- grandchild package does the same.
--
-- The test procedure "withs" the grandchild package, and receives
-- visibility to all of its ancestor packages, types and operations.
-- Three procedures, each with a formal parameter of a specific type are
-- defined. Each of these invokes a particular version of the overridden
-- primitive operation Image. Calls to these local procedures are made,
-- with objects of each of the tagged types as parameters, and the global
-- variable is finally examined to ensure that the correct version of
-- primitive operation was inherited by the client and invoked by the
-- call.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11C00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
with Report;
 
procedure CA11C01 is
 
package Animal_Package renames FA11C00_0;
package Mammal_Package renames FA11C00_0.FA11C00_1;
package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
 
Max_Animals : constant := 3;
 
subtype Data_String is String (1 .. 37);
type Data_Base_Type is array (1 .. Max_Animals) of Data_String;
 
Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
-- Global variable.
 
Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ",
Weight => 10);
 
Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ",
Weight => 13,
Hair_Color => Mammal_Package.Brown);
 
Orangutan : Primate_Package.Primate :=
(Common_Name => "Sumatran Orangutan ",
Weight => 220,
Hair_Color => Mammal_Package.Red,
Habitat => Primate_Package.Arboreal);
begin
 
Report.Test ("CA11C01", "Check that when primitive operations declared " &
"in a child package override operations declared " &
"in ancestor packages, a client of the child " &
"package inherits the operations correctly");
 
declare
 
use Animal_Package, Mammal_Package, Primate_Package;
 
-- The function Image has been overridden in the child and grandchild
-- packages, but the client has inherited all versions of the function,
-- and can successfully use them to enter data into the database.
-- Each of the following procedures updates the global variable
-- Zoo_Data_Base.
 
procedure Enter_Animal_Data (A : Animal; I : Integer) is
begin
Zoo_Data_Base (I) := Image (A);
end Enter_Animal_Data;
 
procedure Enter_Mammal_Data (M : Mammal; I : Integer) is
begin
Zoo_Data_Base (I) := Image (M);
end Enter_Mammal_Data;
 
procedure Enter_Primate_Data (P : Primate; I : Integer) is
begin
Zoo_Data_Base (I) := Image (P);
end Enter_Primate_Data;
 
begin
 
-- Verify initial test conditions.
 
if not (Zoo_Data_Base(1)(1..6) = " ")
or else
(Zoo_Data_Base(2)(1..6) /= " ")
or else
(Zoo_Data_Base(3)(1..6) /= " ")
then
Report.Failed ("Initial condition failure");
end if;
 
 
-- Enter data from all three animals into the zoo database.
 
Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database.
Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry.
Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry.
 
-- Verify the correct version of the overridden function Image was used
-- for entering the specific data.
 
if Zoo_Data_Base(1)(1 .. 6) /= "Animal"
or else
Zoo_Data_Base(1)(26 .. 31) /= "Salmon"
then
Report.Failed ("Incorrect version of Image for parent type");
end if;
 
if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal")
or
(Zoo_Data_Base(2)(28 .. 35) /= "Platypus")
then
Report.Failed ("Incorrect version of Image for child type");
end if;
 
if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate")
or
(Zoo_Data_Base(3)(27 .. 35) /= "Orangutan"))
then
Report.Failed ("Incorrect version of Image for grandchild type");
end if;
 
end;
 
 
Report.Result;
 
end CA11C01;
/ca11d03.a
0,0 → 1,174
-- CA11D03.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 exception declared in a package can be raised by a
-- client of a child of the package. Check that it can be renamed in
-- the client of the child of the package and raised with the correct
-- effect.
--
-- TEST DESCRIPTION:
-- Declare a package which defines complex number abstraction with
-- user-defined exceptions (foundation code).
--
-- Add a public child package to the above package. Declare two
-- subprograms for the parent type.
--
-- In the main program, "with" the child package, then check that
-- an exception can be raised and handled as expected.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11D00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Child package of FA11D00.
package FA11D00.CA11D03_0 is -- Basic_Complex
 
function "+" (Left, Right : Complex_Type)
return Complex_Type; -- Add two complex numbers.
 
function "*" (Left, Right : Complex_Type)
return Complex_Type; -- Multiply two complex numbers.
 
end FA11D00.CA11D03_0; -- Basic_Complex
 
--=======================================================================--
 
package body FA11D00.CA11D03_0 is -- Basic_Complex
 
function "+" (Left, Right : Complex_Type) return Complex_Type is
begin
return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
end "+";
--------------------------------------------------------------
function "*" (Left, Right : Complex_Type) return Complex_Type is
begin
return ( Real => (Left.Real * Right.Real),
Imag => (Left.Imag * Right.Imag) );
end "*";
 
end FA11D00.CA11D03_0; -- Basic_Complex
 
--=======================================================================--
 
with FA11D00.CA11D03_0; -- Basic_Complex,
-- implicitly with Complex_Definition.
with Report;
 
procedure CA11D03 is
 
package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg
package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex
 
use Complex_Pkg;
use Basic_Complex_Pkg;
TC_Handled_In_Subtest_1,
TC_Handled_In_Subtest_2 : boolean := false;
 
begin
 
Report.Test ("CA11D03", "Check that an exception declared in a package " &
"can be raised by a client of a child of the package");
 
Multiply_Complex_Subtest:
declare
Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (2)));
-- Referenced to function in parent package.
Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)),
Int_Type (Report.Ident_Int (8)));
Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)),
Int_Type (Report.Ident_Int (16)));
Complex_No : Complex_Type := Zero; -- Zero is declared in parent package.
begin
Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*".
if Complex_No /= Mul_Res then
Report.Failed ("Incorrect results from multiplication");
end if;
 
-- Error is raised and exception will be handled.
if Complex_No = Mul_Res then
raise Multiply_Error; -- Reference to exception in
end if; -- parent package.
 
exception
when Multiply_Error =>
TC_Handled_In_Subtest_1 := true;
when others =>
TC_Handled_In_Subtest_1 := false; -- Improper exception handling.
 
end Multiply_Complex_Subtest;
 
Add_Complex_Subtest:
declare
Error_In_Client : exception renames Add_Error;
-- Reference to exception in parent package.
Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)),
Int_Type (Report.Ident_Int (7)));
Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)),
Int_Type (Report.Ident_Int (1)));
Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)),
Int_Type (Report.Ident_Int (8)));
Complex_No : Complex_Type := One; -- One is declared in parent
-- package.
begin
Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+".
 
if Complex_No /= Add_Res then
Report.Failed ("Incorrect results from multiplication");
end if;
 
-- Error is raised and exception will be handled.
if Complex_No = Add_Res then
raise Error_In_Client;
end if;
 
exception
when Error_In_Client =>
TC_Handled_In_Subtest_2 := true;
 
when others =>
TC_Handled_In_Subtest_2 := false; -- Improper exception handling.
 
end Add_Complex_Subtest;
 
if not (TC_Handled_In_Subtest_1 and -- Check to see that all
TC_Handled_In_Subtest_2) -- exceptions were handled
-- in the proper location.
then
Report.Failed ("Exceptions handled in incorrect locations");
end if;
 
Report.Result;
 
end CA11D03;
/ca1106a.ada
0,0 → 1,112
-- CA1106A.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 A WITH CLAUSE FOR A PACKAGE BODY (GENERIC OR
-- NONGENERIC) OR FOR A GENERIC SUBPROGRAM BODY CAN NAME THE
-- CORRESPONDING SPECIFICATION, AND A USE CLAUSE CAN ALSO BE
-- GIVEN.
 
-- HISTORY:
-- JET 07/14/88 CREATED ORIGINAL TEST.
-- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
 
PACKAGE CA1106A_1 IS
I : INTEGER := 0;
PROCEDURE REQUIRE_BODY;
END CA1106A_1;
 
GENERIC
TYPE TG IS RANGE <>;
PACKAGE CA1106A_2 IS
J : TG := 0;
PROCEDURE REQUIRE_BODY;
END CA1106A_2;
 
GENERIC
TYPE TG IS RANGE <>;
FUNCTION CA1106A_3 RETURN TG;
 
WITH REPORT; USE REPORT;
WITH CA1106A_1; USE CA1106A_1;
PRAGMA ELABORATE (REPORT);
PACKAGE BODY CA1106A_1 IS
PROCEDURE REQUIRE_BODY IS
BEGIN
NULL;
END;
BEGIN
I := IDENT_INT(1);
END CA1106A_1;
 
WITH REPORT; USE REPORT;
WITH CA1106A_2;
PRAGMA ELABORATE (REPORT);
PACKAGE BODY CA1106A_2 IS
PROCEDURE REQUIRE_BODY IS
BEGIN
NULL;
END;
BEGIN
J := TG(IDENT_INT(2));
END CA1106A_2;
 
WITH REPORT; USE REPORT;
WITH CA1106A_3;
FUNCTION CA1106A_3 RETURN TG IS
BEGIN
RETURN TG(IDENT_INT(3));
END CA1106A_3;
 
WITH REPORT; USE REPORT;
WITH CA1106A_1, CA1106A_2, CA1106A_3;
USE CA1106A_1;
PROCEDURE CA1106A IS
 
PACKAGE CA1106A_2X IS NEW CA1106A_2 (INTEGER);
FUNCTION CA1106A_3X IS NEW CA1106A_3 (INTEGER);
 
USE CA1106A_2X;
 
BEGIN
TEST ("CA1106A", "CHECK THAT A WITH CLAUSE FOR A PACKAGE BODY " &
"(GENERIC OR NONGENERIC) OR FOR A GENERIC " &
"SUBPROGRAM BODY CAN NAME THE CORRESPONDING " &
"SPECIFICATION, AND A USE CLAUSE CAN ALSO BE " &
"GIVEN");
 
IF I /= 1 THEN
FAILED ("INCORRECT VALUE FROM NONGENERIC PACKAGE");
END IF;
 
IF J /= 2 THEN
FAILED ("INCORRECT VALUE FROM GENERIC PACKAGE");
END IF;
 
IF CA1106A_3X /= 3 THEN
FAILED ("INCORRECT VALUE FROM GENERIC SUBPROGRAM");
END IF;
 
RESULT;
END CA1106A;
/ca2009a.ada
0,0 → 1,77
-- CA2009A.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 GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND
-- INSTANTIATED.
 
-- BHS 8/01/84
-- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323.
 
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2009A IS
 
INT1 : INTEGER := 1;
 
SUBTYPE STR15 IS STRING (1..15);
SVAR : STR15 := "ABCDEFGHIJKLMNO";
 
GENERIC
TYPE ITEM IS PRIVATE;
CON1 : IN ITEM;
VAR1 : IN OUT ITEM;
PACKAGE PKG1 IS
END PKG1;
 
PACKAGE BODY PKG1 IS SEPARATE;
PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1);
PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"),
SVAR);
 
BEGIN
 
TEST ("CA2009A", "SPECIFICATION AND INSTANTIATION " &
"OF GENERIC PACKAGE SUBUNITS");
 
IF INT1 /= 2 THEN
FAILED ("INCORRECT INSTANTIATION - INTEGER");
END IF;
 
IF SVAR /= "REINSTANTIATION" THEN
FAILED ("INCORRECT INSTANTIATION - STRING");
END IF;
 
 
RESULT;
 
END CA2009A;
 
 
SEPARATE (CA2009A)
PACKAGE BODY PKG1 IS
BEGIN
VAR1 := CON1;
END PKG1;
/ca21001.a
0,0 → 1,152
-- CA21001.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 the requirements of the revised 10.2.1(11) from Technical
-- Corrigendum 1 (originally discussed as AI95-00002).
-- A package subunit whose parent is a preelaborated subprogram need
-- not be preelaborable.
--
-- TEST DESCRIPTION
-- We create several preelaborated library procedures with
-- non-preelaborable package body subunits. We try various levels
-- of nesting of package and procedure subunits.
--
-- CHANGE HISTORY:
-- 29 JUN 1999 RAD Initial Version
-- 23 SEP 1999 RLB Improved comments, renamed, issued.
--
--!
 
procedure CA21001_1(X: out Integer);
pragma Preelaborate(CA21001_1);
 
procedure CA21001_1(X: out Integer) is
function F return Integer is separate;
 
package Sub is
function G(X: Integer) return Integer;
-- Returns X + 1.
Not_Preelaborable: Integer := F; -- OK, by AI-2.
end Sub;
 
package body Sub is separate;
 
begin
X := -1;
X := F;
X := Sub.G(X);
end CA21001_1;
 
separate(CA21001_1)
package body Sub is
package Sub_Sub is
-- Empty.
end Sub_Sub;
package body Sub_Sub is separate;
 
function G(X: Integer) return Integer is separate;
begin
Not_Preelaborable := G(F); -- OK, by AI-2.
if Not_Preelaborable /= 101 then
raise Program_Error; -- Can't call Report.Failed, here,
-- because Report is not preelaborated.
end if;
end Sub;
 
separate(CA21001_1.Sub)
package body Sub_Sub is
begin
X := X; -- OK by AI-2.
end Sub_Sub;
 
separate(CA21001_1.Sub)
function G(X: Integer) return Integer is
 
package G_Sub is
function H(X: Integer) return Integer;
-- Returns X + 1.
Not_Preelaborable: Integer := F; -- OK, by AI-2.
end G_Sub;
package body G_Sub is separate;
 
begin
return G_Sub.H(X);
end G;
 
separate(CA21001_1.Sub.G)
package body G_Sub is
function H(X: Integer) return Integer is separate;
begin
Not_Preelaborable := H(F); -- OK, by AI-2.
if Not_Preelaborable /= 101 then
raise Program_Error; -- Can't call Report.Failed, here,
-- because Report is not preelaborated.
end if;
end G_Sub;
 
separate(CA21001_1.Sub.G.G_Sub)
function H(X: Integer) return Integer is
begin
return X + 1;
end H;
 
separate(CA21001_1)
function F return Integer is
 
package F_Sub is
-- Empty.
end F_Sub;
 
package body F_Sub is separate;
begin
return 100;
end F;
 
separate(CA21001_1.F)
package body F_Sub is
True_Var: Boolean;
begin
True_Var := True;
if True_Var then -- OK by AI-2.
X := X;
else
X := X + 2;
end if;
end F_Sub;
 
with Report; use Report;
with CA21001_1;
procedure CA21001 is
X: Integer := 0;
begin
Test("CA21001",
"Test that a package subunit whose parent is a preelaborated"
& " subprogram need not be preelaborable");
CA21001_1(X);
if X /= 101 then
Failed("Bad value for X");
end if;
Result;
end CA21001;
/ca11021.a
0,0 → 1,245
-- CA11021.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 body of the generic parent package can depend on one of
-- its own private generic children.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of adding a
-- public generic child during code maintenance without distubing a large
-- subsystem. After child is added to the subsystem, a maintainer
-- decides to take advantage of the new functionality and rewrites
-- the parent's body.
--
-- Declare a generic package which declares high level operations for a
-- complex number abstraction. Declare a private generic child package
-- of this package which defines low level complex operations. In the
-- parent body, instantiate the private child. Use the low level
-- operation to complete the high level operation.
--
-- In the main program, instantiate the parent generic package.
-- Check that the operations in both packages perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
generic -- Complex number abstraction.
type Int_Type is range <>;
 
package CA11021_0 is
-- Simulate a generic complex number support package. Complex numbers
-- are treated as coordinates in the Cartesian plane.
 
type Complex_Type is private;
 
Zero : constant Complex_Type; -- Real number (0,0).
 
function Real_Part (Complex_No : Complex_Type)
return Int_Type;
 
function Imag_Part (Complex_No : Complex_Type)
return Int_Type;
 
function Complex (Real, Imag : Int_Type)
return Complex_Type;
 
-- High level operation for complex number.
function "*" (Factor : Int_Type;
C : Complex_Type) return Complex_Type;
 
-- ... and other complicated ones.
 
private
type Complex_Type is record
Real : Int_Type;
Imag : Int_Type;
end record;
 
Zero : constant Complex_Type := (Real => 0, Imag => 0);
 
end CA11021_0;
 
--==================================================================--
 
-- Private generic child of Complex_Number.
 
private
 
generic
 
-- No parameter.
 
package CA11021_0.CA11021_1 is
-- ... Other declarations.
 
-- Low level operation on complex number.
function "+" (Left, Right : Complex_Type)
return Complex_Type;
 
function "-" (Right : Complex_Type)
return Complex_Type;
 
-- ... Various other operations in real application.
 
end CA11021_0.CA11021_1;
 
--==================================================================--
 
package body CA11021_0.CA11021_1 is
 
function "+" (Left, Right : Complex_Type)
return Complex_Type is
 
begin
return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
end "+";
 
--------------------------------------------------
 
function "-" (Right : Complex_Type) return Complex_Type is
begin
return (-Right.Real, -Right.Imag);
end "-";
 
end CA11021_0.CA11021_1;
 
--==================================================================--
 
with CA11021_0.CA11021_1; -- Private generic child package.
 
package body CA11021_0 is
 
-----------------------------------------------------
-- Parent's body depends on private generic child. --
-----------------------------------------------------
 
-- Instantiate the private child.
 
package Complex_Ops is new CA11021_1;
use Complex_Ops; -- All user-defined operators
-- directly visible.
 
--------------------------------------------------
 
function "*" (Factor : Int_Type;
C : Complex_Type) return Complex_Type is
Result : Complex_Type := Zero;
 
begin
for I in 1 .. abs (Factor) loop
Result := Result + C; -- Private generic child "+".
end loop;
 
if Factor < 0 then
Result := - Result; -- Private generic child "-".
end if;
 
return Result;
end "*";
 
--------------------------------------------------
 
function Real_Part (Complex_No : Complex_Type) return Int_Type is
begin
return (Complex_No.Real);
end Real_Part;
 
--------------------------------------------------
 
function Imag_Part (Complex_No : Complex_Type) return Int_Type is
begin
return (Complex_No.Imag);
end Imag_Part;
 
--------------------------------------------------
 
function Complex (Real, Imag : Int_Type) return Complex_Type is
begin
return (Real, Imag);
end Complex;
 
end CA11021_0;
 
--==================================================================--
 
with CA11021_0; -- Complex number abstraction.
 
with Report;
 
procedure CA11021 is
 
type My_Integer is range -100 .. 100;
 
--------------------------------------------------
 
-- Declare instance of the generic complex package for one particular
-- integer type.
 
package My_Complex_Pkg is new
CA11021_0 (Int_Type => My_Integer);
 
use My_Complex_Pkg; -- All user-defined operators
-- directly visible.
 
--------------------------------------------------
 
Complex_One, Complex_Two : Complex_Type;
 
My_Literal : My_Integer := -3;
 
begin
 
Report.Test ("CA11021", "Check that body of the generic parent package " &
"can depend on its private generic child");
 
Complex_One := Complex (11, 6);
 
Complex_Two := 5 * Complex_One;
 
if Real_Part (Complex_Two) /= 55
and Imag_Part (Complex_Two) /= 30
then
Report.Failed ("Incorrect results from complex operation");
end if;
 
Complex_One := Complex (-4, 7);
 
Complex_Two := My_Literal * Complex_One;
 
if Real_Part (Complex_Two) /= 12
and Imag_Part (Complex_Two) /= -21
then
Report.Failed ("Incorrect results from complex operation");
end if;
 
Report.Result;
 
end CA11021;
/ca13003.a
0,0 → 1,256
-- CA13003.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 separate subunits which share an ancestor may have the
-- same name if they have different fully qualified names. Check
-- the case of separate subunits of separate subunits.
-- This test is a change in semantics from Ada 83 to Ada 9X.
--
-- TEST DESCRIPTION:
-- Declare a package that provides file processing operations. Declare
-- one separate package to do the file processing, and another to do the
-- auditing. These packages contain similar functions declared in
-- separate subunits. Verify that the main program can call the
-- separate subunits with the same name.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Simulates a file processing application. The processing package opens
-- files, reads files, does file processing, and generates reports.
-- The auditing package opens files, read files, and generates reports.
 
package CA13003_0 is
 
type File_ID is range 1 .. 100;
subtype File_Name is string (1 .. 10);
 
TC_Open_For_Process : boolean := false;
TC_Open_For_Audit : boolean := false;
TC_Report_From_Process : boolean := false;
TC_Report_From_Audit : boolean := false;
 
type File_Rec is
record
Name : File_Name;
ID : File_ID;
end record;
 
procedure Initialize_File_Rec (Name_In : in File_Name;
ID_In : in File_ID;
File_In : out File_Rec);
----------------------------------------------------------------------
 
package CA13003_1 is -- File processing
 
procedure CA13003_3; -- Open files
function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
return File_Name; -- Process files
package CA13003_5 is -- Generate report
procedure Generate_Report;
end CA13003_5;
 
end CA13003_1;
 
----------------------------------------------------------------------
 
package CA13003_2 is -- File auditing
 
procedure CA13003_3; -- Open files
function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
return File_Name; -- Process files
package CA13003_5 is -- Generate report
procedure Generate_Report;
end CA13003_5;
 
end CA13003_2;
 
end CA13003_0;
 
--==================================================================--
 
package body CA13003_0 is
 
procedure Initialize_File_Rec (Name_In : in File_Name;
ID_In : in File_ID;
File_In : out File_Rec) is
-- Not a real initialization. Real application can use file
-- database to create the file record.
begin
File_In.Name := Name_In;
File_In.ID := ID_In;
end Initialize_File_Rec;
 
package body CA13003_1 is separate;
package body CA13003_2 is separate;
 
end CA13003_0;
 
--==================================================================--
 
separate (CA13003_0)
package body CA13003_1 is
 
procedure CA13003_3 is separate; -- Open files
function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
return File_Name is separate; -- Process files
package body CA13003_5 is separate; -- Generate report
 
end CA13003_1;
 
--==================================================================--
 
separate (CA13003_0.CA13003_1)
procedure CA13003_3 is -- Open files
begin
-- In real file processing application, open file from database, setup
-- data structure, etc.
TC_Open_For_Process := true;
end CA13003_3;
 
--==================================================================--
 
separate (CA13003_0.CA13003_1)
function CA13003_4 (ID_In : File_ID; -- Process files
File_In : File_Rec) return File_Name is
begin
-- In real file processing application, process files for more information.
return File_In.Name;
end CA13003_4;
 
--==================================================================--
 
separate (CA13003_0.CA13003_1)
package body CA13003_5 is -- Generate report
procedure Generate_Report is
begin
-- In real file processing application, generate various report from the
-- file database.
TC_Report_From_Process := true;
end Generate_Report;
 
end CA13003_5;
 
--==================================================================--
 
separate (CA13003_0)
package body CA13003_2 is
 
procedure CA13003_3 is separate; -- Open files
function CA13003_4 (ID_In : File_ID; File_In : File_Rec)
return File_Name is separate; -- Process files
package body CA13003_5 is separate; -- Generate report
 
end CA13003_2;
 
--==================================================================--
 
separate (CA13003_0.CA13003_2)
procedure CA13003_3 is -- Open files
begin
TC_Open_For_Audit := true;
end CA13003_3;
 
--==================================================================--
 
separate (CA13003_0.CA13003_2)
function CA13003_4 (ID_In : File_ID;
File_In : File_Rec) return File_Name is
begin
return File_In.Name;
end CA13003_4;
 
--==================================================================--
 
separate (CA13003_0.CA13003_2)
package body CA13003_5 is -- Generate report
procedure Generate_Report is
begin
TC_Report_From_Audit := true;
end Generate_Report;
 
end CA13003_5;
 
--==================================================================--
 
with CA13003_0;
with Report;
 
procedure CA13003 is
First_File_Name : CA13003_0.File_Name := "Joe Smith ";
First_File_Id : CA13003_0.File_ID := 11;
Second_File_Name : CA13003_0.File_Name := "John Schep";
Second_File_Id : CA13003_0.File_ID := 47;
Expected_Name : CA13003_0.File_Name := " ";
Student_File : CA13003_0.File_Rec;
function Process_Input_Files (ID_In : CA13003_0.File_ID;
File_In : CA13003_0.File_Rec) return
CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4;
 
function Process_Audit_Files (ID_In : CA13003_0.File_ID;
File_In : CA13003_0.File_Rec) return
CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4;
begin
Report.Test ("CA13003", "Check that separate subunits which share " &
"an ancestor may have the same name if they have " &
"different fully qualified names");
 
Student_File := (ID => First_File_Id, Name => First_File_Name);
 
-- Note that all subunits have the same simple name.
-- Generate report from file processing.
CA13003_0.CA13003_1.CA13003_3;
Expected_Name := Process_Input_Files (First_File_Id, Student_File);
CA13003_0.CA13003_1.CA13003_5.Generate_Report;
 
if not CA13003_0.TC_Open_For_Process or
not CA13003_0.TC_Report_From_Process or
Expected_Name /= First_File_Name then
Report.Failed ("Unexpected results in processing file");
end if;
 
CA13003_0.Initialize_File_Rec
(Second_File_Name, Second_File_Id, Student_File);
 
-- Generate report from file auditing.
CA13003_0.CA13003_2.CA13003_3;
Expected_Name := Process_Audit_Files (Second_File_Id, Student_File);
CA13003_0.CA13003_2.CA13003_5.Generate_Report;
 
if not CA13003_0.TC_Open_For_Audit or
not CA13003_0.TC_Report_From_Audit or
Expected_Name /= Second_File_Name then
Report.Failed ("Unexpected results in auditing file");
end if;
 
Report.Result;
 
end CA13003;
/ca11d010.a
0,0 → 1,119
-- CA11D010.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:
-- See CA11D013.AM
--
-- TEST DESCRIPTION:
-- See CA11D013.AM
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA11D00.A
-- => CA11D010.A
-- CA11D011.A
-- CA11D012.A
-- CA11D013.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
--
--!
 
-- Child package of FA11D00.
 
package FA11D00.CA11D010 is -- Add_Subtract_Complex
 
procedure Add (Left, Right : in Complex_Type; -- Add two complex
C : out Complex_Type); -- numbers.
 
function Subtract (Left, Right : Complex_Type) -- Subtract two
return Complex_Type; -- complex numbers.
end FA11D00.CA11D010; -- Add_Subtract_Complex
 
--=======================================================================--
 
with Report;
 
package body FA11D00.CA11D010 is -- Add_Subtract_Complex
 
procedure Add (Left, Right : in Complex_Type;
C : out Complex_Type) is
begin
-- Zero is declared in parent package.
 
if Left.Real < Zero.Real or else Right.Real < Zero.Real
or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then
raise Add_Error; -- Reference to exception in parent package.
Report.Failed ("Program control not transferred by raise in " &
"procedure Add");
else
C.Real := (Left.Real + Right.Real);
C.Imag := (Left.Imag + Right.Imag);
end if;
 
exception
when Add_Error =>
TC_Handled_In_Child_Pkg_Proc := true;
C := Check_Value; -- Reference to object in parent package.
raise; -- Reraise the Add_Error exception in the subtest.
Report.Failed ("Exception not reraised in handler");
 
when others =>
Report.Failed ("Unexpected exception raised in Add");
 
end Add;
-----------------------------------------------------------
function Subtract (Left, Right : Complex_Type)
return Complex_Type is
begin
-- Zero is declared in parent package.
if Left.Real < Zero.Real or Right.Real < Zero.Real
or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then
raise Subtract_Error; -- Reference to exception in parent package.
Report.Failed ("Program control not transferred by raise in " &
"function Subtract");
else
return ( Real => (Left.Real - Right.Real),
Imag => (Left.Imag - Right.Imag) );
end if;
 
exception
when Subtract_Error =>
Report.Comment ("Exception is properly handled in Subtract");
TC_Handled_In_Child_Pkg_Func := true;
return Check_Value;
 
when others =>
Report.Failed ("Unexpected exception raised in Subtract");
 
end Subtract;
 
end FA11D00.CA11D010; -- Add_Subtract_Complex
/ca11008.a
0,0 → 1,216
-- CA11008.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 child package can use entities declared in the
-- visible part of its parent unit.
--
-- TEST DESCRIPTION:
-- Declare a parent package containing types and objects used
-- by the system. Declare a private child package that uses the parent
-- components to provide functionality to the system.
--
-- The tagged file type defined in the parent has defaults for all
-- component fields. Prior to initialization, these values are checked
-- to ensure a correct start condition. The initial subprogram is
-- called, which utilizes the functionality provided in the private
-- child package. This subprogram changes the fields of the file object
-- to something other than the default values, and this process is then
-- verified at the conclusion of the test.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package CA11008_0 is -- Package OS.
 
type File_Descriptor_Type is new Integer;
type File_Name_Type is new String (1 .. 11);
type Permission_Type is (None, User, System, Bypass);
type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
type File_Status_Type is (Open, Closed);
 
Default_Descriptor : constant File_Descriptor_Type := 0;
Default_Permission : constant Permission_Type := None;
Default_Mode : constant File_Mode_Type := Read_Only;
Default_Status : constant File_Status_Type := Closed;
Default_Filename : constant File_Name_Type := " ";
 
Max_Files : constant File_Descriptor_Type := 100;
Constant_Name : constant File_Name_Type := "AdaFileName";
File_Counter : Integer := 0;
 
type File_Type is tagged
record
Descriptor : File_Descriptor_Type := Default_Descriptor;
Name : File_Name_Type := Default_Filename;
Acct_Access : Permission_Type := Default_Permission;
Mode : File_Mode_Type := Default_Mode;
Current_Status : File_Status_Type := Default_Status;
end record;
 
type File_Array_Type is array (1 .. Max_Files) of File_Type;
 
File_Table : File_Array_Type;
 
--
 
function Get_File_Name return File_Name_Type;
 
function Initialize_File return File_Descriptor_Type;
 
end CA11008_0; -- Package OS.
 
--=================================================================--
 
-- Subprograms that perform the actual file operations are contained in a
-- private package so that they are not accessible to any client.
 
private package CA11008_0.CA11008_1 is -- Package OS.Internals
 
Private_File_Counter : Integer renames File_Counter; -- Parent
-- object.
function Initialize
(File_Name : File_Name_Type := Get_File_Name; -- Parent function.
File_Mode : File_Mode_Type := Read_Write) -- Parent literal.
return File_Descriptor_Type; -- Parent type.
 
end CA11008_0.CA11008_1; -- Package OS.Internals
 
--=================================================================--
 
package body CA11008_0.CA11008_1 is -- Package body OS.Internals
 
function Next_Available_File return File_Descriptor_Type is
begin
Private_File_Counter := Private_File_Counter + 1;
return (File_Descriptor_Type(File_Counter));
end Next_Available_File;
-----------------------------------------------------------------
function Initialize
(File_Name : File_Name_Type := Get_File_Name; -- Parent function
File_Mode : File_Mode_Type := Read_Write) -- Parent literal
return File_Descriptor_Type is -- Parent type
Number : File_Descriptor_Type;
begin
Number := Next_Available_File;
File_Table(Number).Descriptor := Number; -- Parent object
File_Table(Number).Name := File_Name; -- Default parameter value
File_Table(Number).Mode := File_Mode; -- Default parameter value
File_Table(Number).Acct_Access := User;
File_Table(Number).Current_Status := Open;
return (Number);
end Initialize;
 
end CA11008_0.CA11008_1; -- Package body OS.Internals
 
--=================================================================--
 
with CA11008_0.CA11008_1; -- Private child package "withed" by
-- parent body.
 
package body CA11008_0 is -- Package body OS
 
function Get_File_Name return File_Name_Type is
begin
return (Constant_Name); -- Of course if this was a real function, the
end Get_File_Name; -- user would be asked to input a name, or
-- there would be some type of similar process.
 
-- This subprogram utilizes a call to a subprogram contained in a private
-- child to perform the actual processing.
 
function Initialize_File return File_Descriptor_Type is
begin
return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed,
-- since defaults have been
-- provided.
end Initialize_File;
 
end CA11008_0; -- Package body OS
 
--=================================================================--
 
with CA11008_0; -- with Package OS.
with Report;
 
procedure CA11008 is
 
package OS renames CA11008_0;
use OS;
Ada_File_Key : File_Descriptor_Type := Default_Descriptor;
 
begin
 
-- This test indicates one approach to file management operations.
-- It is not intended to demonstrate full functionality, but rather
-- that the use of a private child package can provide a solution
-- to a user situation, that being the implementation of certain functions
-- being provided in a child package, with the parent package body
-- utilizing these implementations.
 
Report.Test ("CA11008", "Check that a private child package can use " &
"entities declared in the visible part of its " &
"parent unit");
 
-- Check initial conditions of the first entry in the file table.
-- These are all default values provided in the declaration of the
-- type File_Type.
 
if (Ada_File_Key /= Default_Descriptor) or else
(File_Table(1).Descriptor /= (Default_Descriptor) or
(File_Table(1).Name /= Default_Filename)) or else
(File_Table(1).Acct_Access /= (Default_Permission) or
(File_Table(1).Mode /= Default_Mode)) or else
(File_Table(1).Current_Status /= Default_Status)
then
Report.Failed ("Initial condition failure");
end if;
-- Call the initialization function. This will result in the resetting
-- of the fields associated with the first entry in the File_Table (this
-- is the first call of Initialize_File).
-- No parameters are necessary for this call, due to the default values
-- provided in the private child package routine Initialize.
Ada_File_Key := Initialize_File;
 
-- Verify that the initial conditions of the file table component have
-- been properly modified by the initialization function.
 
if not ((File_Table(1).Descriptor = Ada_File_Key) and then
(File_Table(1).Name = Constant_Name) and then
(File_Table(1).Acct_Access = User) and then
not ((File_Table(1).Mode = Default_Mode) or else
(File_Table(1).Current_Status = Default_Status)))
then
Report.Failed ("Initialization processing failure");
end if;
 
Report.Result;
 
end CA11008;
/ca1022a1.ada
0,0 → 1,33
-- CA1022A1.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.
--*
-- BHS 7/23/84
 
WITH CA1022A0;
PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS
BEGIN
 
CA1022A0.P0 (Y);
 
END CA1022A1;
/ca1020e1.ada
0,0 → 1,59
-- CA1020E1.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 A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
-- SUBPROGRAMS TO BE REPLACED BY LATER GENERIC INSTANTIATIONS.
 
-- HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
-- DECLARED WITHOUT A BODY.
 
PROCEDURE CA1020E_PROC1 (X : OUT INTEGER) IS
BEGIN
X := 3;
END CA1020E_PROC1;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
FUNCTION CA1020E_FUNC1 RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(4);
END CA1020E_FUNC1;
 
PROCEDURE CA1020E_PROC2 (X : OUT INTEGER);
PROCEDURE CA1020E_PROC2 (X : OUT INTEGER) IS
BEGIN
X := 3;
END CA1020E_PROC2;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
FUNCTION CA1020E_FUNC2 RETURN FLOAT IS
BEGIN
RETURN FLOAT(IDENT_INT(4));
END CA1020E_FUNC2;
/ca1022a3.ada
0,0 → 1,53
-- CA1022A3.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.
--*
-- RECOMPILATION OF PACKAGE CA1022A0.
 
-- BHS 7/23/84
 
PACKAGE CA1022A0 IS
 
I, J : INTEGER;
PROCEDURE P0 (X : IN OUT INTEGER);
FUNCTION F RETURN INTEGER;
 
END CA1022A0;
 
PACKAGE BODY CA1022A0 IS
 
PROCEDURE P0 (X : IN OUT INTEGER) IS
BEGIN
 
X := X + 2;
 
END P0;
 
FUNCTION F RETURN INTEGER IS
BEGIN
 
RETURN 3;
 
END F;
 
END CA1022A0;
/ca5003a0.ada
0,0 → 1,50
-- CA5003A0.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
PACKAGE CA5003A0 IS
 
ORDER : STRING (1..5) := " ";
 
INDEX : NATURAL := 1;
 
FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER;
 
END CA5003A0;
 
 
WITH REPORT;
USE REPORT;
PACKAGE BODY CA5003A0 IS
 
FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS
BEGIN
ORDER (INDEX) := UNIT;
INDEX := INDEX + 1;
RETURN INDEX - 1;
END SHOW_ELAB;
 
END CA5003A0;
/ca140283.am
0,0 → 1,91
-- CA140283.AM
--
-- 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 a subprogram body is compiled as a library unit
-- it is not interpreted as a completion for any previous library
-- subprogram created by generic instantiation, and it therefore
-- declares a new library subprogram.
--
-- TEST DESCRIPTION
-- A generic function and procedure plus their instantiations are
-- created. Then, subprogram bodies which ought to replace the
-- instantiations are compiled. Following that, additional instantiations
-- are compiled. Finally the main subprogram is compiled.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140280.A
-- CA140281.A
-- CA140282.A
-- -> CA140283.AM
--
-- CHANGE HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
-- NOT THE SAME.
-- THS 09/24/90 REWORDED HEADER COMMENTS, ERROR MESSAGES, AND
-- CALL TO TEST. CALLED IDENT_INT CONSISTENTLY.
-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
 
WITH REPORT; USE REPORT;
WITH CA14028_PROC1, CA14028_FUNC2, CA14028_PROC5, CA14028_FUNC22,
CA14028_PROC3, CA14028_FUNC3;
PROCEDURE CA140283 IS
TEMP : INTEGER := 0;
BEGIN
TEST ("CA14028", "Check that library subprograms created by " &
"generic instantiation are replaced " &
"when new non-generic subprogram bodies are " &
"compiled");
 
CA14028_PROC1(TEMP);
IF TEMP /= IDENT_INT(3) THEN
FAILED ("CA14028_Proc1 instantiation not replaced");
END IF;
 
IF CA14028_FUNC2 /= IDENT_INT(4) THEN
FAILED ("CA14028_Func2 instantiation not replaced");
END IF;
 
CA14028_PROC5(TEMP);
IF TEMP /= IDENT_INT(5) THEN
FAILED ("New CA14028_Proc5 instantiation not correct");
END IF;
 
IF CA14028_FUNC22 /= IDENT_INT(2) THEN
FAILED ("New CA14028_Func22 instantiation not correct");
END IF;
 
CA14028_PROC3(TEMP);
IF TEMP /= IDENT_INT(4) THEN
FAILED ("CA14028_Proc3 not replaced by correct version");
END IF;
 
IF CA14028_FUNC3 /= IDENT_INT(7) THEN
FAILED ("CA14028_Func3 not replaced by correct version");
END IF;
 
RESULT;
END CA140283;
/ca1020e3.ada
0,0 → 1,71
-- CA1020E3M.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 A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
-- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS.
 
-- SEPARATE FILES ARE:
-- CA1020E0 -- GENERIC UNITS GENPROC_CA1020E AND GENFUNC_CA1020E.
-- CA1020E1 -- SUBPROGRAM LIBRARY UNIT BODIES (CA1020E_PROC1,
-- CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2).
-- CA1020E2 -- INSTANTIATIONS REPLACING UNITS COMPILED IN CA1020E1.
-- CA1020E3M -- MAIN PROGRAM.
 
-- HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
-- DECLARED WITHOUT A BODY.
 
WITH REPORT; USE REPORT;
WITH CA1020E_PROC1, CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2;
PROCEDURE CA1020E3M IS
TEMP : INTEGER := 0;
BEGIN
TEST ("CA1020E", "CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE " &
"REPLACED BY A GENERIC INSTANTIATION HAVING " &
"THE SAME IDENTIFIER");
 
CA1020E_PROC1 (TEMP);
IF TEMP /= IDENT_INT(1) THEN
FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE");
END IF;
 
IF CA1020E_FUNC1 /= IDENT_INT(2) THEN
FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION");
END IF;
 
CA1020E_PROC2 (TEMP);
IF TEMP /= IDENT_INT(5) THEN
FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE");
END IF;
 
IF CA1020E_FUNC2 /= IDENT_INT(2) THEN
FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION");
END IF;
 
RESULT;
END CA1020E3M;
/ca1022a5.ada
0,0 → 1,34
-- CA1022A5.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.
--*
-- RECOMPILATION OF FUNCTION CA1022A2 (DECL AND BODY).
 
-- BHS 7/23/84
 
FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS
BEGIN
 
RETURN Z /= 1;
 
END CA1022A2;
/ca5003a2.ada
0,0 → 1,34
-- CA5003A2.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH CA5003A0;
USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
PACKAGE CA5003A2 IS
 
A2 : INTEGER := SHOW_ELAB ('2');
 
END CA5003A2;
/ca2001h1.ada
0,0 → 1,39
-- CA2001H1.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.
--*
-- WKB 6/25/81
-- JBG 8/25/83
-- BHS 7/31/84
 
SEPARATE (CA2001H0)
 
PACKAGE BODY CA2001H1 IS
PROCEDURE NOT_USED IS SEPARATE;
 
BEGIN
 
I := 1;
NOT_USED;
 
END CA2001H1;
/ca5003a4.ada
0,0 → 1,34
-- CA5003A4.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH CA5003A0, CA5003A2;
USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
PACKAGE CA5003A4 IS
 
A4 : INTEGER := SHOW_ELAB ('4');
 
END CA5003A4;
/ca2001h3.ada
0,0 → 1,66
-- CA2001H3M.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 BODY_STUB IS DELETED FROM A COMPILATION UNIT,
-- THE PREVIOUSLY EXISTING SUBUNIT CAN NO LONGER BE ACCESSED.
 
-- SEPARATE FILES ARE;
-- CA2001H0 A LIBRARY FUNCTION (CA2001H0).
-- CA2001H1 A SUBUNIT PACKAGE BODY.
-- CA2001H2 A LIBRARY FUNCTION (CA2001H0).
-- CA2001H3M THE MAIN PROCEDURE.
 
-- WKB 6/25/81
-- JRK 6/26/81
-- SPS 11/2/82
-- JBG 8/25/83
 
 
WITH REPORT, CA2001H0;
USE REPORT;
PROCEDURE CA2001H3M IS
 
I : INTEGER := -1;
 
BEGIN
TEST ("CA2001H", "IF A BODY_STUB IS DELETED FROM A COMPILATION " &
"UNIT, THE PREVIOUSLY EXISTING SUBUNIT CAN NO " &
"LONGER BE ACCESSED");
 
I := CA2001H0;
 
IF I = 1 THEN
FAILED ("SUBUNIT ACCESSED");
END IF;
 
IF I = 0 THEN
FAILED ("OLD LIBRARY UNIT ACCESSED");
END IF;
 
IF I /= 2 THEN
FAILED ("NEW LIBRARY UNIT NOT ACCESSED");
END IF;
 
RESULT;
END CA2001H3M;
/ca5003a6.ada
0,0 → 1,71
-- CA5003A6M.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 ELABORATION OF LIBRARY UNITS REQUIRED BY
-- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL
-- ORDERING DEFINED BY THE COMPILATION ORDER RULES.
 
-- SEPARATE FILES ARE:
-- CA5003A0 A LIBRARY PACKAGE.
-- CA5003A1 A LIBRARY PACKAGE SPECIFICATION.
-- CA5003A2 A LIBRARY PACKAGE SPECIFICATION.
-- CA5003A3 A LIBRARY PACKAGE SPECIFICATION.
-- CA5003A4 A LIBRARY PACKAGE SPECIFICATION.
-- CA5003A5 A LIBRARY PACKAGE SPECIFICATION.
-- CA5003A6M THE MAIN PROCEDURE.
 
-- PACKAGE A5 MUST BE ELABORATED AFTER A2, A3, AND A4.
-- PACKAGE A3 MUST BE ELABORATED AFTER A2.
-- PACKAGE A4 MUST BE ELABORATED AFTER A2.
 
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH REPORT, CA5003A0;
USE REPORT, CA5003A0;
WITH CA5003A1, CA5003A5;
PROCEDURE CA5003A6M IS
 
BEGIN
 
TEST ("CA5003A", "CHECK THAT ELABORATION ORDER IS CONSISTENT " &
"WITH PARTIAL ORDERING REQUIREMENTS");
 
COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER);
 
IF ORDER /= "12345" AND
ORDER /= "12435" AND
ORDER /= "21345" AND
ORDER /= "21435" AND
ORDER /= "23145" AND
ORDER /= "24135" AND
ORDER /= "23415" AND
ORDER /= "24315" AND
ORDER /= "23451" AND
ORDER /= "24351" THEN
FAILED ("ILLEGAL ELABORATION ORDER");
END IF;
 
RESULT;
END CA5003A6M;
/ca200021.a
0,0 → 1,66
-- CA200021.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 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:
-- See CA200020.A.
--
-- TEST DESCRIPTION:
-- See CA200020.A.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA200020.A
-- -> CA200021.A
-- CA200022.AM
--
-- PASS/FAIL CRITERIA:
-- See CA200020.A.
--
-- CHANGE HISTORY:
-- 27 JAN 99 RLB Initial version.
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--
--!
 
package body CA20002_0 is
 
function CA20002_1 return Integer is separate; -- Has the same expanded name
-- as the child.
-- Note: An implementation may produce a warning about the child
-- unit at this point, but it must accept the subunit declaration.
 
procedure Do_a_Little (A : out Integer) is
begin
A := CA20002_1;
end Do_a_Little;
 
end CA20002_0;
 
with Report;
separate (CA20002_0)
function CA20002_1 return Integer is
begin
return Report.Ident_Int(5);
end CA20002_1;
/ca140233.a
0,0 → 1,68
-- CA140233.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:
-- See CA140232.AM.
--
-- TEST DESCRIPTION:
-- See CA140232.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140230.A
-- CA140231.A
-- CA140232.AM
-- -> CA140233.A
--
-- PASS/FAIL CRITERIA:
-- See CA140232.AM.
--
-- CHANGE HISTORY:
-- 01 MAY 95 ACVC 1.12 LA5008T baseline version
-- 29 JUN 95 SAIC Initial version
-- 05 MAR 96 SAIC First revision after review
-- 18 NOV 96 SAIC Modified unit names and prologue to conform
-- to coding conventions.
-- 07 DEC 96 SAIC Modified prologue to reflect new test
-- file organization.
-- 13 SEP 99 RLB Changed to C-test (by AI-00077).
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--!
 
-- here is the replacement body, correcting "errors" in
-- the original
 
function CA14023_1 (P1, P2 : Data_type) return Data_type is
begin
-- return min rather than max
if Floor < P1 and Floor < P2 then
return Floor;
elsif P2 < P1 then
return P2;
else
return P1;
end if;
end CA14023_1;
/ca1006a.ada
0,0 → 1,106
-- CA1006A.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 LIBRARY UNIT AND ITS SUBUNITS CAN BE
-- SUBMITTED TOGETHER FOR COMPILATION.
 
-- JRK 5/14/81
 
WITH REPORT;
USE REPORT;
 
PROCEDURE CA1006A IS
 
I : INTEGER := IDENT_INT (0);
 
PACKAGE CALL_TEST IS
END CALL_TEST;
 
PACKAGE BODY CALL_TEST IS
BEGIN
TEST ("CA1006A", "A LIBRARY UNIT AND ITS SUBUNITS " &
"SUBMITTED TOGETHER");
END CALL_TEST;
 
FUNCTION F (I : INTEGER) RETURN INTEGER IS SEPARATE;
 
PACKAGE PKG IS
I : INTEGER := IDENT_INT (0);
PROCEDURE P (I : IN OUT INTEGER);
END PKG;
 
PACKAGE BODY PKG IS SEPARATE;
 
PROCEDURE P (I : IN OUT INTEGER) IS SEPARATE;
 
BEGIN
 
IF PKG.I /= 10 THEN
FAILED ("PACKAGE BODY STATEMENTS NOT EXECUTED");
END IF;
 
IF F(IDENT_INT(5)) /= -5 THEN
FAILED ("FUNCTION NOT ELABORATED/EXECUTED");
END IF;
 
PKG.P (I);
IF I /= 3 THEN
FAILED ("PACKAGED PROCEDURE NOT ELABORATED/EXECUTED");
END IF;
 
I := IDENT_INT (-20);
P (I);
IF I /= -24 THEN
FAILED ("PROCEDURE NOT ELABORATED/EXECUTED");
END IF;
 
RESULT;
END CA1006A;
 
 
SEPARATE (CA1006A)
FUNCTION F (I : INTEGER) RETURN INTEGER IS
BEGIN
RETURN -I;
END F;
 
 
SEPARATE (CA1006A)
PACKAGE BODY PKG IS
 
PROCEDURE P (I : IN OUT INTEGER) IS
BEGIN
I := I + 3;
END P;
 
BEGIN
I := I + 10;
END PKG;
 
 
SEPARATE (CA1006A)
PROCEDURE P (I : IN OUT INTEGER) IS
BEGIN
I := I - 4;
END P;
/ca5006a.ada
0,0 → 1,145
-- CA5006A.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 PROGRAM IS NOT REJECTED JUST BECAUSE THERE IS NO WAY TO
-- ELABORATE SECONDARY UNITS SO PROGRAM_ERROR WILL BE AVOIDED.
 
-- R.WILLIAMS 9/22/86
 
-----------------------------------------------------------------------
 
PACKAGE CA5006A0 IS
FUNCTION P_E_RAISED RETURN BOOLEAN;
PROCEDURE SHOW_PE_RAISED;
END CA5006A0;
 
-----------------------------------------------------------------------
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PACKAGE BODY CA5006A0 IS
RAISED : BOOLEAN := FALSE;
 
FUNCTION P_E_RAISED RETURN BOOLEAN IS
BEGIN
RETURN RAISED;
END P_E_RAISED;
 
PROCEDURE SHOW_PE_RAISED IS
BEGIN
RAISED := TRUE;
END SHOW_PE_RAISED;
 
BEGIN
TEST ( "CA5006A", "CHECK THAT A PROGRAM IS NOT REJECTED JUST " &
"BECAUSE THERE IS NO WAY TO ELABORATE " &
"SECONDARY UNITS SO PROGRAM_ERROR WILL BE " &
"AVOIDED" );
 
END CA5006A0;
 
-----------------------------------------------------------------------
 
PACKAGE CA5006A1 IS
FUNCTION F RETURN INTEGER;
END CA5006A1;
 
-----------------------------------------------------------------------
 
PACKAGE CA5006A2 IS
FUNCTION G RETURN INTEGER;
END CA5006A2;
 
-----------------------------------------------------------------------
 
WITH REPORT; USE REPORT;
WITH CA5006A0; USE CA5006A0;
WITH CA5006A2; USE CA5006A2;
PRAGMA ELABORATE(CA5006A0);
 
PACKAGE BODY CA5006A1 IS
X : INTEGER;
 
FUNCTION F RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(0);
END F;
 
BEGIN
X := G;
IF NOT P_E_RAISED THEN
FAILED ( "G CALLED" );
END IF;
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A1" );
SHOW_PE_RAISED;
WHEN OTHERS =>
FAILED ( "OTHER ERROR RAISED IN CA5006A1" );
END CA5006A1;
 
-----------------------------------------------------------------------
 
WITH REPORT; USE REPORT;
WITH CA5006A0; USE CA5006A0;
WITH CA5006A1; USE CA5006A1;
PRAGMA ELABORATE(CA5006A0);
 
PACKAGE BODY CA5006A2 IS
X : INTEGER;
 
FUNCTION G RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(1);
END G;
 
BEGIN
X := F;
IF NOT P_E_RAISED THEN
FAILED ( "F CALLED" );
END IF;
EXCEPTION
WHEN PROGRAM_ERROR =>
COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A2" );
SHOW_PE_RAISED;
WHEN OTHERS =>
FAILED ( "OTHER ERROR RAISED IN CA5006A2" );
END CA5006A2;
 
-----------------------------------------------------------------------
 
WITH REPORT; USE REPORT;
WITH CA5006A0; USE CA5006A0;
WITH CA5006A1;
WITH CA5006A2;
 
PROCEDURE CA5006A IS
BEGIN
IF NOT P_E_RAISED THEN
FAILED ( "PROGRAM_ERROR NEVER RAISED" );
END IF;
 
RESULT;
END CA5006A;
/ca11013.a
0,0 → 1,201
-- CA11013.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 child function of a library level instantiation
-- of a generic can be the instantiation of a child function of
-- the generic. Check that the child instance can use its parent's
-- declarations and operations, including a formal subprogram of the
-- parent.
--
-- TEST DESCRIPTION:
-- Declare a generic package which simulates a real complex
-- abstraction. Declare a generic child function of this package
-- which builds a random complex number. Declare a second
-- package which defines a random complex number generator. This
-- package provides actual parameters for the generic parent package.
--
-- Instantiate the first generic package, then instantiate the child
-- generic function as a child unit of the first instance. In the main
-- program, check that the operations in both instances perform as
-- expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
-- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
-- clause of CA11013_3.
-- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3
--!
generic -- Complex number abstraction.
type Real_Type is digits <>;
with function Random_Generator (Seed : Real_Type) return Real_Type;
 
package CA11013_0 is
-- Simulate a generic complex number support package. Complex numbers
-- are treated as coordinates in the Cartesian plane.
 
type Complex_Type is
record
Real : Real_Type;
Imag : Real_Type;
end record;
 
function Make (Real, Imag : Real_Type) -- Create a complex
return Complex_Type; -- number.
 
procedure Components (Complex_No : in Complex_Type;
Real_Part, Imag_Part : out Real_Type);
 
end CA11013_0;
 
--==================================================================--
 
package body CA11013_0 is
 
function Make (Real, Imag : Real_Type) return Complex_Type is
begin
return (Real, Imag);
end Make;
-------------------------------------------------------------
procedure Components (Complex_No : in Complex_Type;
Real_Part, Imag_Part : out Real_Type) is
begin
Real_Part := Complex_No.Real;
Imag_Part := Complex_No.Imag;
end Components;
 
end CA11013_0;
 
--==================================================================--
 
-- Generic child of complex number package. This child adds a layer of
-- functionality to the parent generic.
 
generic -- Random complex number operation.
 
function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type;
 
--==============================================--
 
function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is
 
Random_Real_Part : Real_Type := Random_Generator (Seed);
-- parent's formal subprogram
Random_Imag_Part : Real_Type
:= Random_Generator (Random_Generator (Seed));
-- parent's formal subprogram
Random_Complex_No : Complex_Type;
 
begin -- CA11013_0.CA11013_1
 
Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part);
-- operation from parent
return (Random_Complex_No);
 
end CA11013_0.CA11013_1;
 
--==================================================================--
 
package CA11013_2 is
-- To be used as actual parameters for random number generator
-- in the parent package.
 
type My_Float is digits 6 range -10.0 .. 100.0;
 
function Random_Complex (Seed : My_float) return My_Float;
 
end CA11013_2;
 
--==================================================================--
 
package body CA11013_2 is
 
-- Not a real random number generator.
function Random_Complex (Seed : My_float) return My_Float is
begin
return (Seed + 3.0);
end Random_Complex;
 
end CA11013_2;
 
--==================================================================--
 
-- Declare instances of the generic complex packages for real type.
-- The instance of the child must itself be declared as a child of the
-- instance of the parent.
 
with CA11013_0; -- Complex number.
with CA11013_2; -- Random number generator.
pragma Elaborate (CA11013_0);
package CA11013_3 is new
CA11013_0 (Random_Generator => CA11013_2.Random_Complex,
Real_Type => CA11013_2.My_Float);
 
with CA11013_0.CA11013_1; -- Random complex number operation.
with CA11013_3;
pragma Elaborate (CA11013_3);
function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1;
--==================================================================--
 
with Report;
with CA11013_2; -- Random number generator.
with CA11013_3.CA11013_4; -- Complex abstraction + Random complex
-- number operation.
procedure CA11013 is
 
package My_Complex_Pkg renames CA11013_3;
use type CA11013_2.My_Float;
 
My_Complex : My_Complex_Pkg.Complex_Type;
My_Literal : CA11013_2.My_Float := 3.0;
My_Real_Part, My_Imag_Part : CA11013_2.My_Float;
 
begin
 
Report.Test ("CA11013", "Check that child instance can use its parent's " &
"declarations and operations, including a formal " &
"subprogram of the parent");
 
My_Complex := CA11013_3.CA11013_4 (My_Literal);
-- Operation from the generic child function.
 
My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part);
-- Operation from the generic parent package.
 
if My_Real_Part /= 6.0 -- Operation from the generic
or My_Imag_Part /= 9.0 -- parent package.
then
Report.Failed ("Incorrect results from complex operation");
end if;
 
Report.Result;
 
end CA11013;
/ca140232.am
0,0 → 1,139
-- CA140232.AM
--
-- 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 compilation unit may not depend semantically
-- on two different versions of the same compilation unit.
-- Check the case where a generic instantiation depends on
-- a generic function that is changed.
--
-- TEST DESCRIPTION:
-- This test compiles a generic function, a generic
-- instantiation of the generic function, and a main
-- procedure that withs the instantiated generic
-- function. Then, a new version of the first generic
-- function is compiled (in a separate file, simulating
-- editing and modification to the unit). The test should
-- link the correct version of the withed function and
-- report "PASSED" at execution time.
--
-- Note that compilers are required by the standard to support
-- replacement of a generic body without recompilation of the
-- instantation. The ARG confirmed 10.1.4(10) with AI-00077.
--
-- To build this test:
-- 1) Compile the file CA140230 (and include the results in the
-- program library).
-- 2) Compile the file CA140231 (and include the results in the
-- program library).
-- 3) Compile the file CA140232 (and include the results in the
-- program library).
-- 4) Compile the file CA140233 (and include the results in the
-- program library).
-- 5) Build and run an executable image.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140230.A
-- CA140231.A
-- -> CA140232.AM
-- CA140233.A
--
-- CHANGE HISTORY:
-- 01 MAY 95 ACVC 1.12 LA5008T baseline version
-- 29 JUN 95 SAIC Initial version
-- 05 MAR 96 SAIC First revision after review
-- 18 NOV 96 SAIC Modified unit names and prologue to conform
-- to coding conventions.
-- 07 DEC 96 SAIC Moved CA14023_1 to a separate file.
-- 13 SEP 99 RLB Changed to C-test (by AI-00077).
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--
--!
 
with CA14023_0;
use CA14023_0;
 
generic
Min : Little_float := 0.0;
type Any_rec is new Data_rec with private;
function CA14023_2 (R1, R2 : Any_rec) return Little_float;
 
--------------------------------------------------------
 
with CA14023_1;
 
function CA14023_2 (R1, R2 : Any_rec) return Little_float is
function Max_val is new CA14023_1 (Little_float, Min);
begin
return max_val (R1.Data, R2.Data);
end CA14023_2;
 
--------------------------------------------------------
 
package CA14023_0.CA14023_3 is
type New_data_rec is new Data_rec with record
Other_val : integer := 100;
end record;
end CA14023_0.CA14023_3;
 
--------------------------------------------------------
 
with Report; use Report;
with CA14023_2;
with CA14023_0;
with CA14023_0.CA14023_3;
 
procedure CA140232 is
 
NDR1, NDR2 : CA14023_0.CA14023_3.New_data_rec;
Min_value : constant CA14023_0.Little_float := 0.0;
TC_result : CA14023_0.Little_float;
function Max_Data_Val is new CA14023_2 (Min_value,
CA14023_0.CA14023_3.New_data_rec);
begin
Test ("CA14023", "Check that a compilation unit may not " &
"depend semantically on two different " &
"versions of the same compilation unit. " &
"Check the case where a generic " &
"instantiation depends on a generic " &
"function that is changed");
 
NDR1.Data := 2.0;
NDR2.Data := 5.0;
 
TC_result := Max_Data_Val (NDR1, NDR2);
 
if TC_result = 5.0 then
Failed ("Revised generic not used");
elsif TC_result /= 0.0 then -- the minimum, floor
Failed ("Incorrect value returned"); -- value of 0.0 should
end if; -- be returned rather
-- than the min of the
-- two actual parameters
 
Result;
end CA140232;
/ca11017.a
0,0 → 1,246
-- CA11017.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 body of the parent package may depend on one of its own
-- public children.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of adding a
-- public child during code maintenance without distubing a large
-- subsystem. After child is added to the subsystem, a maintainer
-- decides to take advantage of the new functionality and rewrites
-- the parent's body.
--
-- Declare a string abstraction in a package which manipulates string
-- replacement. Define a parent package which provides operations for
-- a record type with discriminant. Declare a public child of this
-- package which adds functionality to the original subsystem. In the
-- parent body, call operations from the public child.
--
-- In the main program, check that operations in the parent and public
-- child perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Simulates application which manipulates strings.
 
package CA11017_0 is
 
type String_Rec (The_Size : positive) is private;
 
type Substring is new string;
 
-- ... Various other types used by the application.
 
procedure Replace (In_The_String : in out String_Rec;
At_The_Position : in positive;
With_The_String : in String_Rec);
 
-- ... Various other operations used by the application.
 
private
-- Different size for each individual record.
 
type String_Rec (The_Size : positive) is
record
The_Length : natural := 0;
The_Content : Substring (1 .. The_Size);
end record;
 
end CA11017_0;
 
--=================================================================--
 
-- Public child added during code maintenance without disturbing a
-- large system. This public child would add functionality to the
-- original system.
 
package CA11017_0.CA11017_1 is
 
Position_Error : exception;
 
function Equal_Length (Left : in String_Rec;
Right : in String_Rec) return boolean;
 
function Same_Content (Left : in String_Rec;
Right : in String_Rec) return boolean;
 
procedure Copy (From_The_Substring : in Substring;
To_The_String : in out String_Rec);
 
-- ... Various other operations used by the application.
 
end CA11017_0.CA11017_1;
 
--=================================================================--
 
package body CA11017_0.CA11017_1 is
 
function Equal_Length (Left : in String_Rec;
Right : in String_Rec) return boolean is
-- Quick comparison between the lengths of the input strings.
 
begin
return (Left.The_Length = Right.The_Length); -- Parent's private
-- type.
end Equal_Length;
--------------------------------------------------------------------
function Same_Content (Left : in String_Rec;
Right : in String_Rec) return boolean is
 
begin
for I in 1 .. Left.The_Length loop
if Left.The_Content (I) = Right.The_Content (I) then
return true;
else
return false;
end if;
end loop;
 
end Same_Content;
--------------------------------------------------------------------
procedure Copy (From_The_Substring : in Substring;
To_The_String : in out String_Rec) is
begin
To_The_String.The_Content -- Parent's private type.
(1 .. From_The_Substring'length) := From_The_Substring;
 
To_The_String.The_Length -- Parent's private type.
:= From_The_Substring'length;
end Copy;
 
end CA11017_0.CA11017_1;
 
--=================================================================--
 
-- After child is added to the subsystem, a maintainer decides
-- to take advantage of the new functionality and rewrites the
-- parent's body.
 
with CA11017_0.CA11017_1;
 
package body CA11017_0 is
 
-- Calls functions from public child for a quick comparison of the
-- input strings. If their lengths are the same, do the replacement.
 
procedure Replace (In_The_String : in out String_Rec;
At_The_Position : in positive;
With_The_String : in String_Rec) is
End_Position : natural := At_The_Position +
With_The_String.The_Length - 1;
 
begin
if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation.
(With_The_String, In_The_String) then
raise CA11017_0.CA11017_1.Position_Error;
-- Public child's exception.
else
In_The_String.The_Content (At_The_Position .. End_Position) :=
With_The_String.The_Content (1 .. With_The_String.The_Length);
end if;
 
end Replace;
 
end CA11017_0;
 
--=================================================================--
 
with Report;
 
with CA11017_0.CA11017_1; -- Explicit with public child package,
-- implicit with parent package (CA11017_0).
 
procedure CA11017 is
 
package String_Pkg renames CA11017_0;
use String_Pkg;
 
begin
 
Report.Test ("CA11017", "Check that body of the parent package can " &
"depend on one of its own public children");
 
-- Both input strings have the same size. Replace the first string by the
-- second string.
 
Replace_Subtest:
declare
The_First_String, The_Second_String : String_Rec (16);
-- Parent's private type.
The_Position : positive := 1;
begin
CA11017_1.Copy ("This is the time",
To_The_String => The_First_String);
 
CA11017_1.Copy ("For all good men", The_Second_String);
 
Replace (The_First_String, The_Position, The_Second_String);
-- Compare results using function from public child since
-- the type is private.
 
if not CA11017_1.Same_Content
(The_First_String, The_Second_String) then
Report.Failed ("Incorrect results");
end if;
 
end Replace_Subtest;
 
-- During processing, the application may erroneously attempt to replace
-- strings of different size. This would result in the raising of an
-- exception.
 
Exception_Subtest:
declare
The_First_String : String_Rec (17);
-- Parent's private type.
The_Second_String : String_Rec (13);
-- Parent's private type.
The_Position : positive := 2;
begin
CA11017_1.Copy (" ACVC Version 2.0", The_First_String);
 
CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic",
To_The_String => The_Second_String);
 
Replace (The_First_String, The_Position, The_Second_String);
 
Report.Failed ("Exception was not raised");
 
exception
when CA11017_1.Position_Error =>
Report.Comment ("Exception is raised as expected");
 
end Exception_Subtest;
 
Report.Result;
 
end CA11017;
/ca1012a1.ada
0,0 → 1,45
-- CA1012A1.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.
--*
-- GENERIC PROCEDURE BODY.
-- DECLARATION IS IN CA1012A0.DEP.
-- INSTANTIATION IN CA1012A4M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- WKB 07/20/81 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
-- IN TEST AND POSSIBLE NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
PROCEDURE CA1012A0 (I : IN OUT INDEX) IS
 
BEGIN
 
I := I + 1;
 
END CA1012A0;
/ca3011a0.ada
0,0 → 1,74
-- CA3011A0.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.
--*
-- A GENERIC UNIT.
-- SUBUNITS ARE IN CA3011A1, CA3011A2, AND CA3011A3.
-- INSTANTIATION IS IN CA3011A4M.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- RJW 09/22/86 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
WITH REPORT; USE REPORT;
 
GENERIC
TYPE T IS (<>);
X : T;
PROCEDURE CA3011A0 (Z : OUT T);
 
PROCEDURE CA3011A0 (Z : OUT T) IS
T1 : T;
 
FUNCTION CA3011A1 RETURN T IS SEPARATE;
 
PROCEDURE CA3011A2 (Y : OUT T) IS SEPARATE;
 
PACKAGE CA3011A3 IS
FUNCTION CA3011A3F RETURN T;
END CA3011A3;
 
PACKAGE BODY CA3011A3 IS SEPARATE;
 
BEGIN
IF CA3011A1 /= X THEN
FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A1" );
END IF;
 
CA3011A2 (T1);
 
IF T1 /= X THEN
FAILED ( "INCORRECT VALUE RETURNED BY PROCEDURE CA3011A2 " );
END IF;
 
IF CA3011A3.CA3011A3F /= X THEN
FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A3F " );
END IF;
 
Z := X;
 
END CA3011A0;
/ca1014a0.ada
0,0 → 1,85
-- CA1014A0M.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 SUBUNIT CAN BE SUBMITTED FOR COMPILATION
-- SEPARATELY FROM ITS PARENT UNIT.
 
-- SEPARATE FILES ARE:
-- CA1014A0M THE MAIN PROCEDURE.
-- CA1014A1 A SUBUNIT PROCEDURE BODY.
-- CA1014A2 A SUBUNIT PACKAGE BODY.
-- CA1014A3 A SUBUNIT FUNCTION BODY.
 
-- JRK 5/20/81
 
WITH REPORT;
USE REPORT;
 
PROCEDURE CA1014A0M IS
 
I : INTEGER := 0;
 
PACKAGE CALL_TEST IS
END CALL_TEST;
 
PACKAGE BODY CALL_TEST IS
BEGIN
TEST ("CA1014A", "SUBUNITS SUBMITTED FOR COMPILATION " &
"SEPARATELY FROM PARENT UNIT");
END CALL_TEST;
 
PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS SEPARATE;
 
PACKAGE CA1014A2 IS
I : INTEGER := 10;
PROCEDURE P (I : IN OUT INTEGER);
END CA1014A2;
 
PACKAGE BODY CA1014A2 IS SEPARATE;
 
FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS SEPARATE;
 
BEGIN
 
CA1014A1 (I);
IF I /= 1 THEN
FAILED ("SUBUNIT PROCEDURE NOT ELABORATED/EXECUTED");
END IF;
 
IF CA1014A2.I /= 15 THEN
FAILED ("SUBUNIT PACKAGE BODY NOT ELABORATED/EXECUTED");
END IF;
 
I := 0;
CA1014A2.P (I);
IF I /= -20 THEN
FAILED ("SUBUNIT PACKAGED PROCEDURE NOT ELABORATED/EXECUTED");
END IF;
 
IF CA1014A3(50) /= -50 THEN
FAILED ("SUBUNIT FUNCTION NOT ELABORATED/EXECUTED");
END IF;
 
RESULT;
END CA1014A0M;
/ca2003a1.ada
0,0 → 1,35
-- CA2003A1.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.
--*
-- WKB 6/26/81
 
SEPARATE (CA2003A0M)
PROCEDURE CA2003A1 IS
BEGIN
 
IF I /= 1 THEN
FAILED ("IDENTIFIER IN PARENT NOT VISIBLE");
END IF;
 
END CA2003A1;
/ca3011a2.ada
0,0 → 1,42
-- CA3011A2.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.
--*
-- A SUBUNIT OF A GENERIC UNIT.
-- THE GENERIC UNIT IS IN CA3011A0.
-- INSTANTIATION IS IN CA3011A4M.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- RJW 09/22/86 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA3011A0)
PROCEDURE CA3011A2 (Y : OUT T) IS
 
BEGIN
Y := X;
END CA3011A2;
/ca1012a3.ada
0,0 → 1,45
-- CA1012A3.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.
--*
-- GENERIC FUNCTION BODY.
-- DECLARATION IS IN CA1012AB.DEP.
-- INSTANTIATION IS IN CA1012A4B.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- WKB 07/20/81 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
-- AND POSSIBLE NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT IS
 
BEGIN
 
RETURN J + 1;
 
END CA1012A2;
/ca1014a2.ada
0,0 → 1,39
-- CA1014A2.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.
--*
-- JRK 5/20/81
 
SEPARATE (CA1014A0M)
PACKAGE BODY CA1014A2 IS
 
PROCEDURE P (I : IN OUT INTEGER) IS
BEGIN
I := I - 20;
END P;
 
BEGIN
 
I := I + 5;
 
END CA1014A2;
/ca3011a4.ada
0,0 → 1,61
-- CA3011A4M.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 IMPLEMENTATION DOES NOT REQUIRE GENERIC UNIT BODIES AND
-- SUBUNITS TO BE COMPILED TOGETHER IN THE SAME FILE.
 
-- SEPARATE FILES ARE:
-- CA3011A0 - A GENERIC UNIT.
-- CA3011A1, CA3011A2, CA3011A3 - SUBUNITS OF GENERIC UNIT.
-- CA3011A4M - THE MAIN PROCEDURE.
 
-- APPLICABILITY CRITERIA:
-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
-- THIS WAS NOT REQUIRED FOR ADA 83.
 
-- HISTORY:
-- RJW 09/22/86 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-- RLB 09/15/99 REPAIRED OBJECTIVE FOR ADA 95.
 
WITH REPORT; USE REPORT;
WITH CA3011A0;
PROCEDURE CA3011A4M IS
I : INTEGER;
PROCEDURE P IS NEW CA3011A0 (INTEGER, 22);
 
BEGIN
TEST ( "CA3011A", "CHECK THAT AN IMPLEMENTATION DOES NOT REQUIRE " &
"GENERIC UNIT BODIES AND SUBUNITS TO BE " &
"COMPILED TOGETHER IN THE SAME FILE" );
 
P (I);
IF I /= 22 THEN
FAILED ( "INCORRECT INSTANTIATION" );
END IF;
 
RESULT;
END CA3011A4M;
/ca5003b1.ada
0,0 → 1,46
-- CA5003B1.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
-- BHS 8/02/84
-- JRK 9/20/84
 
 
WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
PACKAGE CA5003B1 IS
 
PACKAGE CA5003B2 IS
PROCEDURE P1;
END CA5003B2;
 
END CA5003B1;
 
 
PACKAGE BODY CA5003B1 IS
 
A1 : INTEGER := SHOW_ELAB ('1');
PACKAGE BODY CA5003B2 IS SEPARATE;
 
END CA5003B1;
/ca2007a1.ada
0,0 → 1,36
-- CA2007A1.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.
--*
-- WKB 7/1/81
 
SEPARATE (CA2007A0M)
 
PACKAGE BODY CA2007A1 IS
 
BEGIN
 
ELAB_ORDER (NEXT) := '1';
NEXT := NEXT + 1;
 
END CA2007A1;
/ca5003b3.ada
0,0 → 1,35
-- CA5003B3.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
-- BHS 8/02/84
-- JRK 9/20/84
 
WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
PACKAGE CA5003B3 IS
 
A3 : INTEGER := SHOW_ELAB ('3');
 
END CA5003B3;
/ca2007a3.ada
0,0 → 1,36
-- CA2007A3.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.
--*
-- WKB 7/1/81
 
SEPARATE (CA2007A0M)
 
PACKAGE BODY CA2007A3 IS
 
BEGIN
 
ELAB_ORDER (NEXT) := '3';
NEXT := NEXT + 1;
 
END CA2007A3;
/ca5003b5.ada
0,0 → 1,65
-- CA5003B5M.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 ELABORATION OF LIBRARY UNITS REQUIRED BY
-- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL
-- ORDERING DEFINED BY THE COMPILATION ORDER RULES.
-- IN PARTICULAR, CHECK THAT A LIBRARY UNIT MENTIONED IN THE
-- WITH_CLAUSE OF A SUBUNIT IS ELABORATED PRIOR TO THE BODY OF
-- THE ANCESTOR UNIT.
 
-- SEPARATE FILES ARE:
-- CA5003B0 A LIBRARY PACKAGE.
-- CA5003B1 A LIBRARY PACKAGE.
-- CA5003B2 A SUBUNIT PACKAGE BODY (_B1._B2).
-- CA5003B3 A LIBRARY PACKAGE DECLARATION.
-- CA5003B4 A SUBUNIT PACKAGE BODY (_B1._B2._B4).
-- CA5003B5M THE MAIN PROCEDURE.
 
-- LIBRARY PACKAGES MUST BE ELABORATED IN ORDER: _B0, _B3, _B1.
-- PARENT UNITS MUST BE ELABORATED BEFORE THEIR SUBUNITS.
 
-- WKB 7/22/81
-- JBG 10/6/83
-- BHS 8/02/84
-- JRK 9/20/84
 
WITH REPORT, CA5003B0;
USE REPORT, CA5003B0;
WITH CA5003B1;
PROCEDURE CA5003B5M IS
 
BEGIN
TEST ("CA5003B", "CHECK THAT UNITS IN WITH_CLAUSES OF " &
"SUBUNITS ARE ELABORATED PRIOR TO THE " &
"BODY OF THE ANCESTOR UNIT");
 
COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER);
 
IF ORDER /= "3124" THEN
FAILED ("ILLEGAL ELABORATION ORDER");
END IF;
 
RESULT;
END CA5003B5M;
/ca11a02.a
0,0 → 1,156
-- CA11A02.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 type extended in a client of a public child inherits
-- primitive operations from parent.
--
-- TEST DESCRIPTION:
-- Declare a root tagged type in a package specification. Declare two
-- primitive subprograms for the type (foundation code).
--
-- Add a public child to the above package. Extend the root type with
-- a record extension in the specification. Declare a new primitive
-- subprogram to write to the child extension.
--
-- In the main program, "with" the child. Declare an extension of
-- the child extension. Access the primitive operations from both
-- parent and child packages.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11A00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level
--
--!
 
package FA11A00.CA11A02_0 is -- Color_Widget_Pkg
-- This public child declares an extension from its parent. It
-- represents processing of widgets in a window system.
 
type Widget_Color_Enum is (Black, Green, White);
 
type Color_Widget is new Widget with -- Record extension of
record -- parent tagged type.
Color : Widget_Color_Enum;
end record;
 
-- Inherits procedure Set_Width from parent.
-- Inherits procedure Set_Height from parent.
 
-- To be inherited by its derivatives.
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum);
 
end FA11A00.CA11A02_0; -- Color_Widget_Pkg
 
--=======================================================================--
 
package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg
 
procedure Set_Color (The_Widget : in out Color_Widget;
C : in Widget_Color_Enum) is
begin
The_Widget.Color := C;
end Set_Color;
 
end FA11A00.CA11A02_0; -- Color_Widget_Pkg
 
--=======================================================================--
 
with FA11A00.CA11A02_0; -- Color_Widget_Pkg.
 
package CA11A02_1 is
 
type Label_Widget (Str_Disc : Integer) is new
FA11A00.CA11A02_0.Color_Widget with
record
Label : String (1 .. Str_Disc);
end record;
 
-- Inherits (inherited) procedure Set_Width from Color_Widget.
-- Inherits (inherited) procedure Set_Height from Color_Widget.
-- Inherits procedure Set_Color from Color_Widget.
 
end CA11A02_1;
 
--=======================================================================--
 
with FA11A00.CA11A02_0; -- Color_Widget_Pkg,
-- implicitly with Widget_Pkg
with CA11A02_1;
 
with Report;
 
procedure CA11A02 is
 
package Widget_Pkg renames FA11A00;
package Color_Widget_Pkg renames FA11A00.CA11A02_0;
 
use Widget_Pkg; -- All user-defined operators directly visible.
 
procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget;
L : in String) is
begin
The_Widget.Label := L;
end Set_Label;
---------------------------------------------------------
procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget;
The_Width : in Widget_Length;
The_Height : in Widget_Length;
The_Color : in
Color_Widget_Pkg.Widget_Color_Enum;
The_Label : in String) is
begin
CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited.
CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited.
CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited.
Set_Label (The_Widget, The_Label); -- Explicitly declared.
end Set_Widget;
 
White_Widget : CA11A02_1.Label_Widget (11);
 
begin
 
Report.Test ("CA11A02", "Check that a type extended in a client of " &
"a public child inherits primitive operations from parent");
 
Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock");
 
If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or
White_Widget.Label /= "Alarm_Clock" then
Report.Failed ("Incorrect result for White_Widget");
end if;
 
Report.Result;
 
end CA11A02;
/ca13a01.a
0,0 → 1,320
-- CA13A01.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 subunits declared in non-generic child units of a public
-- parent have the same visibility into its parent, its siblings
-- (public and private), and packages on which its parent depends
-- as is available at the point of their declaration.
--
-- TEST DESCRIPTION:
-- Declare an check system procedure as a subunit in a private child
-- package of the basic operation package (FA13A00.A). This procedure
-- has visibility into its parent ancestor and its private sibling.
--
-- Declare an emergency procedure as a subunit in a public child package
-- of the basic operation package (FA13A00.A). This procedure has
-- visibility into its parent ancestor and its private sibling.
--
-- Declare an express procedure as a subunit in a public child subprogram
-- of the basic operation package (FA13A00.A). This procedure has
-- visibility into its parent ancestor and its public sibling.
--
-- In the main program, "with"s the child package and subprogram. Check
-- that subunits perform as expected.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA13A00.A
-- CA13A01.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Private child package of an elevator application. This package
-- provides maintenance operations.
 
private package FA13A00_1.CA13A01_4 is -- Maintenance operation
 
One_Floor : Floor_No := 1; -- Type declared in parent.
 
procedure Check_System;
 
-- other type definitions and procedure declarations in real application.
 
end FA13A00_1.CA13A01_4;
 
--==================================================================--
 
-- Context clauses required for visibility needed by separate subunit.
 
with FA13A00_0; -- Building Manager
 
with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
with FA13A00_1.FA13A00_3; -- Move Elevator
 
use FA13A00_0;
 
package body FA13A00_1.CA13A01_4 is
 
procedure Check_System is separate;
 
end FA13A00_1.CA13A01_4;
 
--==================================================================--
 
separate (FA13A00_1.CA13A01_4)
 
-- Subunit Check_System declared in Maintenance Operation.
 
procedure Check_System is
begin
-- See if regular power is on.
 
if Power /= V120 then -- Reference package with'ed by
TC_Operation := false; -- the subunit parent's body.
end if;
 
-- Test elevator function.
 
FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
(Penthouse, Call_Waiting); -- the subunit parent's body.
 
if not Call_Waiting (Penthouse) then -- Reference private part of the
TC_Operation := false; -- parent of the subunit package's
-- body.
end if;
 
FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of
-- the subunit parent's body.
 
if Current_Floor /= Floor'pred (Penthouse) then
TC_Operation := false; -- Reference type declared in the
end if; -- parent of the subunit parent's
-- body.
 
end Check_System;
 
--==================================================================--
 
-- Public child package of an elevator application. This package provides
-- an emergency operation.
 
package FA13A00_1.CA13A01_5 is -- Emergency Operation
 
-- Other type definitions in real application.
 
procedure Emergency;
 
private
type Bell_Type is (Inactive, Active);
 
end FA13A00_1.CA13A01_5;
 
--==================================================================--
 
-- Context clauses required for visibility needed by separate subunit.
 
with FA13A00_0; -- Building Manager
 
with FA13A00_1.FA13A00_3; -- Move Elevator
 
with FA13A00_1.CA13A01_4; -- Maintenance Operation (private)
 
use FA13A00_0;
 
package body FA13A00_1.CA13A01_5 is
 
procedure Emergency is separate;
 
end FA13A00_1.CA13A01_5;
 
--==================================================================--
 
separate (FA13A00_1.CA13A01_5)
 
-- Subunit Emergency declared in Maintenance Operation.
 
procedure Emergency is
Bell : Bell_Type; -- Reference type declared in the
-- subunit parent's body.
 
begin
-- Calls maintenance operation.
 
FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the
-- subunit parent 's body.
 
-- Clear all calls to the elevator.
 
Clear_Calls (Call_Waiting); -- Reference subprogram declared
-- in the parent of the subunit
-- parent's body.
for I in Floor loop
if Call_Waiting (I) then -- Reference private part of the
TC_Operation := false; -- parent of the subunit parent's
end if; -- body.
end loop;
 
-- Move elevator to the basement.
 
FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
(Basement, Call_Waiting); -- subunit parent's body.
 
if Current_Floor /= Basement then -- Reference type declared in the
TC_Operation := false; -- parent of the subunit parent's
end if; -- body.
 
-- Shut off power.
 
Power := Off; -- Reference package with'ed by
-- the subunit parent's body.
 
-- Activate bell.
 
Bell := Active; -- Reference type declared in the
-- subunit parent's body.
 
end Emergency;
 
--==================================================================--
 
-- Public child subprogram of an elevator application. This subprogram
-- provides an express operation.
 
procedure FA13A00_1.CA13A01_6;
 
--==================================================================--
 
-- Context clauses required for visibility needed by separate subunit.
 
with FA13A00_0; -- Building Manager
 
with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
 
with FA13A00_1.FA13A00_3; -- Move Elevator
 
use FA13A00_0;
 
procedure FA13A00_1.CA13A01_6 is -- Express Operation
 
-- Other type definitions in real application.
 
procedure GoTo_Penthouse is separate;
 
begin
GoTo_Penthouse;
 
end FA13A00_1.CA13A01_6;
 
--==================================================================--
 
separate (FA13A00_1.CA13A01_6)
 
-- Subunit GoTo_Penthouse declared in Express Operation.
 
procedure GoTo_Penthouse is
begin
-- Go faster.
 
Power := V240; -- Reference package with'ed by
-- the subunit parent's body.
 
-- Call elevator.
 
Call (Penthouse, Call_Waiting); -- Reference subprogram declared in
-- the parent of the subunit
-- parent's body.
 
if not Call_Waiting (Penthouse) then -- Reference private part of the
TC_Operation := false; -- parent of the subunit parent's
end if; -- body.
 
-- Move elevator to Penthouse.
 
FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the
(Penthouse, Call_Waiting); -- subunit parent's body.
 
if Current_Floor /= Penthouse then -- Reference type declared in the
TC_Operation := false; -- parent of the subunit parent's
end if; -- body.
 
-- Return slowly
 
while Current_Floor /= Floor1 loop -- Reference type, subprogram
FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the
-- subunit parent's body.
end loop;
 
if Current_Floor /= Floor1 then -- Reference type declared in
TC_Operation := false; -- the parent of the subunit
end if; -- parent's body.
 
-- Back to normal.
Power := V120; -- Reference package with'ed by
-- the subunit parent's body.
 
end GoTo_Penthouse;
 
--==================================================================--
 
with FA13A00_1.CA13A01_5; -- Emergency Operation
-- implicitly with Basic Elevator
-- Operations
 
with FA13A00_1.CA13A01_6; -- Express Operation
 
with Report;
 
procedure CA13A01 is
 
begin
 
Report.Test ("CA13A01", "Check that subunits declared in non-generic " &
"child units of a public parent have the same visibility " &
"into its parent, its parent's siblings, and packages on " &
"which its parent depends");
 
-- Go to Penthouse.
 
FA13A00_1.CA13A01_6;
 
-- Call emergency operation.
 
FA13A00_1.CA13A01_5.Emergency;
 
if not FA13A00_1.TC_Operation then
Report.Failed ("Incorrect elevator operation");
end if;
 
Report.Result;
 
end CA13A01;
/ca11c02.a
0,0 → 1,158
-- CA11C02.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 primitive operations declared in a child package
-- override operations declared in ancestor packages, and that
-- operations on class-wide types defined in the ancestor packages
-- dispatch as appropriate to these overriding implementations.
--
-- TEST DESCRIPTION:
--
-- This test builds on the foundation code file (FA11C00) that contains
-- a parent package, child package, and grandchild package. The parent
-- package declares a tagged type and primitive operation. The child
-- package extends the type, and overrides the primitive operation. The
-- grandchild package does the same.
--
-- The test procedure "withs" the grandchild package, and receives
-- visibility to all of its ancestor packages, types and operations.
-- A procedure with a formal class-wide parameter is defined that will
-- allow for dispatching calls to the overridden primitive operations,
-- based on the specific type of the actual parameter. The primitive
-- operations provide a string value to update a global string array
-- variable. Calls to the local procedure are made, with objects of each
-- of the tagged types as parameters, and the global variable is finally
-- examined to ensure that the correct version of primitive operation was
-- dispatched correctly.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11C00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate
with Report;
 
procedure CA11C02 is
 
package Animal_Package renames FA11C00_0;
package Mammal_Package renames FA11C00_0.FA11C00_1;
package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2;
 
Max_Animals : constant := 3;
 
type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37);
 
Zoo_Data_Base : Data_Base_Type := (others => (others => ' '));
-- Global variable.
 
Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ",
Weight => 2);
 
Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ",
Weight => 230,
Hair_Color => Mammal_Package.Brown);
 
Lemur : Primate_Package.Primate :=
(Common_Name => "Ring-Tailed Lemur ",
Weight => 5,
Hair_Color => Mammal_Package.Black,
Habitat => Primate_Package.Arboreal);
begin
 
Report.Test ("CA11C02", "Check that primitive operations declared " &
"in a child package override operations declared " &
"in ancestor packages, and that operations " &
"on class-wide types defined in the ancestor " &
"packages dispatch as appropriate to these " &
"overriding implementations");
 
declare
 
use Animal_Package, Mammal_Package, Primate_Package;
 
-- The following procedure updates the global variable Zoo_Data_Base.
 
procedure Enter_Data (A : Animal'Class; I : Integer) is
begin
Zoo_Data_Base (I) := Image (A);
end Enter_Data;
 
begin
 
-- Verify initial test conditions.
 
if not (Zoo_Data_Base(1)(1..6) = " ")
or not
(Zoo_Data_Base(2)(1..6) = " ")
or not
(Zoo_Data_Base(3)(1..6) = " ")
then
Report.Failed ("Initial condition failure");
end if;
 
 
-- Enter data from all three animals into the zoo database.
 
Enter_Data (Macaw, 1); -- First entry in database.
Enter_Data (A => Manatee, I => 2); -- Second entry.
Enter_Data (Lemur, I => 3); -- Third entry.
 
-- Verify the correct version of the overridden function Image was used
-- for entering the specific data.
 
if not (Zoo_Data_Base(1)(1 .. 6) = "Animal")
or not
(Zoo_Data_Base(1)(26 .. 30) = "Macaw")
then
Report.Failed ("Incorrect version of Image for parent type");
end if;
 
if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal"
and
Zoo_Data_Base(2)(27 .. 33) = "Manatee")
then
Report.Failed ("Incorrect version of Image for child type");
end if;
 
if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate")
and
(Zoo_Data_Base(3)(30 .. 34) = "Lemur"))
then
Report.Failed ("Incorrect version of Image for grandchild type");
end if;
 
end;
 
Report.Result;
 
end CA11C02;
/ca1003a.ada
0,0 → 1,73
-- CA1003A.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 MORE THAN ONE COMPLETELY INDEPENDENT COMPILATION
-- UNIT CAN BE SUBMITTED IN A SINGLE FILE.
 
-- JRK 5/13/81
-- JBG 8/25/83
 
PROCEDURE CA1003A_P (I : IN OUT INTEGER) IS
BEGIN
I := I + 1;
END CA1003A_P;
 
 
PACKAGE CA1003A_PKG IS
I : INTEGER := 0;
END CA1003A_PKG;
 
 
FUNCTION CA1003A_F (I : INTEGER) RETURN INTEGER IS
BEGIN
RETURN -I;
END CA1003A_F;
 
 
WITH REPORT, CA1003A_P, CA1003A_PKG, CA1003A_F;
USE REPORT;
 
PROCEDURE CA1003A IS
 
I : INTEGER := IDENT_INT (0);
 
BEGIN
TEST ("CA1003A", "INDEPENDENT UNITS IN A SINGLE FILE");
 
CA1003A_P (I);
IF I /= 1 THEN
FAILED ("INDEPENDENT PROCEDURE NOT INVOKED");
END IF;
 
CA1003A_PKG.I := CA1003A_PKG.I + IDENT_INT(10);
IF CA1003A_PKG.I /= 10 THEN
FAILED ("INDEPENDENT PACKAGE VARIABLE ACCESSED INCORRECTLY");
END IF;
 
IF CA1003A_F(IDENT_INT(5)) /= -5 THEN
FAILED ("INDEPENDENT FUNCTION NOT INVOKED");
END IF;
 
RESULT;
END CA1003A;
/ca2011b.ada
0,0 → 1,118
-- CA2011B.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 FOR A SUBPROGRAM DECLARATION-STUB-BODY TRIPLE, THE
-- DECLARATION-STUB AND STUB-BODY SPECIFICATIONS CAN CONFORM, BUT
-- THE DECLARATION-BODY SPECIFICATIONS NEED NOT.
 
-- HISTORY:
-- JET 08/01/88 CREATED ORIGINAL TEST.
 
PACKAGE CA2011B0 IS
SUBTYPE T IS INTEGER RANGE -100 .. 100;
I : T := 0;
END CA2011B0;
 
WITH CA2011B0; USE CA2011B0;
PACKAGE CA2011B1 IS
PROCEDURE P1 (X : CA2011B0.T);
PROCEDURE P2 (X : T);
END CA2011B1;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PACKAGE BODY CA2011B1 IS
PACKAGE CA2011BX RENAMES CA2011B0;
PROCEDURE P1 (X : T) IS SEPARATE;
PROCEDURE P2 (X : CA2011BX.T) IS SEPARATE;
END CA2011B1;
 
SEPARATE (CA2011B1)
PROCEDURE P1 (X : CA2011BX.T) IS
BEGIN
I := IDENT_INT(X);
END P1;
 
SEPARATE (CA2011B1)
PROCEDURE P2 (X : CA2011BX.T) IS
BEGIN
I := IDENT_INT(X);
END P2;
 
WITH REPORT; USE REPORT;
WITH CA2011B0, CA2011B1;
PROCEDURE CA2011B IS
 
PACKAGE P1 IS
SUBTYPE T IS INTEGER RANGE -100 .. 100;
END P1;
USE P1;
 
FUNCTION F1 RETURN P1.T;
FUNCTION F2 RETURN T;
 
PACKAGE P2 RENAMES P1;
 
FUNCTION F1 RETURN T IS SEPARATE;
FUNCTION F2 RETURN P2.T IS SEPARATE;
 
BEGIN
TEST ("CA2011B", "CHECK THAT FOR A SUBPROGRAM DECLARATION-STUB-" &
"BODY TRIPLE, THE DECLARATION-STUB AND STUB-" &
"BODY SPECIFICATIONS CAN CONFORM, BUT THE " &
"DECLARATON-BODY SPECIFICATIONS NEED NOT");
 
IF F1 /= IDENT_INT(100) THEN
FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 1");
END IF;
 
IF F2 /= IDENT_INT(-100) THEN
FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 2");
END IF;
 
CA2011B1.P1(3);
IF CA2011B0.I /= IDENT_INT(3) THEN
FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 1");
END IF;
 
CA2011B1.P2(4);
IF CA2011B0.I /= IDENT_INT(4) THEN
FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 2");
END IF;
 
RESULT;
END CA2011B;
 
SEPARATE (CA2011B)
FUNCTION F1 RETURN P2.T IS
BEGIN
RETURN 100;
END F1;
 
SEPARATE (CA2011B)
FUNCTION F2 RETURN P2.T IS
BEGIN
RETURN -100;
END F2;
/ca140280.a
0,0 → 1,77
-- CA140280.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:
-- See CA140283.AM.
--
-- TEST DESCRIPTION
-- See CA140283.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- -> CA140280.A
-- CA140281.A
-- CA140282.A
-- CA140283.AM
--
-- CHANGE HISTORY:
-- JBG 05/28/85 CREATED ORGINAL TEST.
-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
-- NOT THE SAME.
-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
 
GENERIC
C : INTEGER;
PROCEDURE GENPROC_CA14028 (X : OUT INTEGER);
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS
BEGIN
X := IDENT_INT(C);
END GENPROC_CA14028;
 
GENERIC
FUNCTION GENFUNC_CA14028 RETURN INTEGER;
 
FUNCTION GENFUNC_CA14028 RETURN INTEGER IS
BEGIN
RETURN 2;
END GENFUNC_CA14028;
 
WITH GENPROC_CA14028;
PRAGMA ELABORATE (GENPROC_CA14028);
PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1);
 
WITH GENFUNC_CA14028;
PRAGMA ELABORATE (GENFUNC_CA14028);
FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028;
 
WITH GENPROC_CA14028;
PRAGMA ELABORATE (GENPROC_CA14028);
PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3);
 
WITH GENFUNC_CA14028;
PRAGMA ELABORATE (GENFUNC_CA14028);
FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028;
/ca1108a.ada
0,0 → 1,136
-- CA1108A.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 WITH_CLAUSE AND USE_CLAUSE GIVEN FOR A PACKAGE
-- SPECIFICATION APPLIES TO THE BODY AND SUBUNITS OF THE BODY.
 
-- BHS 7/27/84
-- JBG 5/1/85
 
PACKAGE OTHER_PKG IS
 
I : INTEGER := 4;
FUNCTION F (X : INTEGER) RETURN INTEGER;
 
END OTHER_PKG;
 
PACKAGE BODY OTHER_PKG IS
 
FUNCTION F (X : INTEGER) RETURN INTEGER IS
BEGIN
RETURN X + 1;
END F;
 
END OTHER_PKG;
 
WITH REPORT, OTHER_PKG;
USE REPORT, OTHER_PKG;
PRAGMA ELABORATE (OTHER_PKG);
PACKAGE CA1108A_PKG IS
 
J : INTEGER := 2;
PROCEDURE PROC;
PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER);
 
END CA1108A_PKG;
 
PACKAGE BODY CA1108A_PKG IS
PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE;
 
PROCEDURE PROC IS
Y : INTEGER := 2;
BEGIN
Y := OTHER_PKG.I;
IF Y /= 4 THEN
FAILED ("OTHER_PKG VARIABLE NOT VISIBLE " &
"IN PACKAGE BODY PROCEDURE");
END IF;
END PROC;
 
PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS
BEGIN
SUB (X, Y);
END CALL_SUBS;
 
BEGIN
 
J := F(J); -- J => J + 1.
IF J /= 3 THEN
FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN " &
"PACKAGE BODY");
END IF;
 
END CA1108A_PKG;
 
 
WITH REPORT, CA1108A_PKG;
USE REPORT, CA1108A_PKG;
PROCEDURE CA1108A IS
 
VAR1, VAR2 : INTEGER;
 
BEGIN
 
TEST ("CA1108A", "WITH_ AND USE_CLAUSES GIVEN FOR A PACKAGE " &
"SPEC APPLY TO THE BODY AND ITS SUBUNITS");
 
PROC;
 
VAR1 := 1;
VAR2 := 1;
CALL_SUBS (VAR1, VAR2);
IF VAR1 /= 4 THEN
FAILED ("OTHER_PKG VARIABLE NOT VISIBLE IN SUBUNIT");
END IF;
 
IF VAR2 /= 6 THEN
FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " &
"OF SUBUNIT");
END IF;
 
RESULT;
 
END CA1108A;
 
 
SEPARATE (CA1108A_PKG)
PROCEDURE SUB (X, Y : IN OUT INTEGER) IS
PROCEDURE SUB2 (Z : IN OUT INTEGER) IS SEPARATE;
BEGIN
 
X := I;
SUB2 (Y);
 
END SUB;
 
 
SEPARATE (CA1108A_PKG.SUB)
PROCEDURE SUB2 (Z : IN OUT INTEGER) IS
I : INTEGER := 5;
BEGIN
 
Z := OTHER_PKG.F(I); -- Z => I + 1.
 
END SUB2;
/ca11001.a
0,0 → 1,276
-- CA11001.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 child unit can be used to provide an alternate view and
-- operations on a private type in its parent package. Check that a
-- child unit can be a package. Check that a WITH of a child unit
-- includes an implicit WITH of its ancestor unit.
--
-- TEST DESCRIPTION:
-- Declare a private type in a package specification. Declare
-- subprograms for the type.
--
-- Add a public child to the above package. Within the body of this
-- package, access the private type. Declare operations to read and
-- write to its parent private type.
--
-- In the main program, "with" the child. Declare objects of the
-- parent private type. Access the subprograms from both parent and
-- child packages.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package CA11001_0 is -- Cartesian_Complex
-- This package represents a Cartesian view of a complex number. It contains
-- a private type plus subprograms to construct and decompose a complex
-- number.
 
type Complex_Int is range 0 .. 100;
 
type Complex_Type is private;
 
Constant_Complex : constant Complex_Type;
 
Complex_Error : exception;
 
procedure Cartesian_Assign (R, I : in Complex_Int;
C : out Complex_Type);
 
function Cartesian_Real_Part (C : Complex_Type)
return Complex_Int;
 
function Cartesian_Imag_Part (C : Complex_Type)
return Complex_Int;
 
function Complex (Real, Imaginary : Complex_Int)
return Complex_Type;
 
private
type Complex_Type is -- Parent private type
record
Real, Imaginary : Complex_Int;
end record;
 
Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0);
 
end CA11001_0; -- Cartesian_Complex
 
--=======================================================================--
 
package body CA11001_0 is -- Cartesian_Complex
 
procedure Cartesian_Assign (R, I : in Complex_Int;
C : out Complex_Type) is
begin
C.Real := R;
C.Imaginary := I;
end Cartesian_Assign;
-------------------------------------------------------------
function Cartesian_Real_Part (C : Complex_Type)
return Complex_Int is
begin
return C.Real;
end Cartesian_Real_Part;
-------------------------------------------------------------
function Cartesian_Imag_Part (C : Complex_Type)
return Complex_Int is
begin
return C.Imaginary;
end Cartesian_Imag_Part;
-------------------------------------------------------------
function Complex (Real, Imaginary : Complex_Int)
return Complex_Type is
begin
return (Real, Imaginary);
end Complex;
 
end CA11001_0; -- Cartesian_Complex
 
--=======================================================================--
 
package CA11001_0.CA11001_1 is -- Polar_Complex
-- This public child provides a different view of the private type from its
-- parent. It provides a polar view by the provision of subprograms which
-- construct and decompose a complex number.
 
procedure Polar_Assign (R, Theta : in Complex_Int;
C : out Complex_Type);
-- Complex_Type is a
-- record of CA11001_0
 
function Polar_Real_Part (C: Complex_Type) return Complex_Int;
 
function Polar_Imag_Part (C: Complex_Type) return Complex_Int;
 
function Equals_Const (Num : Complex_Type) return Boolean;
 
end CA11001_0.CA11001_1; -- Polar_Complex
 
--=======================================================================--
 
package body CA11001_0.CA11001_1 is -- Polar_Complex
 
function Cos (Angle : Complex_Int) return Complex_Int is
Num : constant Complex_Int := 2;
begin
return (Angle * Num); -- not true Cosine function
end Cos;
-------------------------------------------------------------
function Sine (Angle : Complex_Int) return Complex_Int is
begin
return 1; -- not true Sine function
end Sine;
-------------------------------------------------------------
function Sqrt (Num : Complex_Int)
return Complex_Int is
begin
return (Num); -- not true Square root function
end Sqrt;
-------------------------------------------------------------
function Tan (Angle : Complex_Int) return Complex_Int is
begin
return Angle; -- not true Tangent function
end Tan;
-------------------------------------------------------------
procedure Polar_Assign (R, Theta : in Complex_Int;
C : out Complex_Type) is
begin
if R = 0 and Theta = 0 then
raise Complex_Error;
end if;
C.Real := R * Cos (Theta);
C.Imaginary := R * Sine (Theta);
end Polar_Assign;
-------------------------------------------------------------
function Polar_Real_Part (C: Complex_Type) return Complex_Int is
begin
return Sqrt ((Cartesian_Imag_Part (C)) ** 2 +
(Cartesian_Real_Part (C)) ** 2);
end Polar_Real_Part;
-------------------------------------------------------------
function Polar_Imag_Part (C: Complex_Type) return Complex_Int is
begin
return (Tan (Cartesian_Imag_Part (C) /
Cartesian_Real_Part (C)));
end Polar_Imag_Part;
-------------------------------------------------------------
function Equals_Const (Num : Complex_Type) return Boolean is
begin
return Num.Real = Constant_Complex.Real and
Num.Imaginary = Constant_Complex.Imaginary;
end Equals_Const;
 
end CA11001_0.CA11001_1; -- Polar_Complex
 
--=======================================================================--
 
with CA11001_0.CA11001_1; -- Polar_Complex
with Report;
 
procedure CA11001 is
 
Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a
-- record of CA11001_0
 
Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2);
 
Int_2 : CA11001_0.Complex_Int
:= CA11001_0.Complex_Int (Report.Ident_Int (2));
 
begin
 
Report.Test ("CA11001", "Check that a child unit can be used " &
"to provide an alternate view and operations " &
"on a private type in its parent package");
 
Basic_View_Subtest:
 
begin
-- Assign using Cartesian coordinates.
CA11001_0.Cartesian_Assign
(CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No);
 
-- Read back in Polar coordinates.
-- Polar values are surrogates used in checking for correct
-- subprogram calls.
if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No),
CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/="
(CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No),
CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then
Report.Failed ("Incorrect Cartesian result");
end if;
 
end Basic_View_Subtest;
-------------------------------------------------------------
Alternate_View_Subtest:
begin
-- Assign using Polar coordinates.
CA11001_0.CA11001_1.Polar_Assign
(Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No);
 
-- Read back in Cartesian coordinates.
if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part
(Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or
CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2)
then
Report.Failed ("Incorrect Polar result");
end if;
end Alternate_View_Subtest;
-------------------------------------------------------------
Other_Subtest:
begin
-- Assign using Polar coordinates.
CA11001_0.CA11001_1.Polar_Assign
(CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No);
 
-- Compare with Complex_Num in CA11001_0.
if not CA11001_0.CA11001_1.Equals_Const (Complex_No)
then
Report.Failed ("Incorrect result");
end if;
end Other_Subtest;
-------------------------------------------------------------
Exception_Subtest:
begin
-- Raised parent's exception.
CA11001_0.CA11001_1.Polar_Assign
(CA11001_0.Complex_Int (Report.Ident_Int (0)),
CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No);
Report.Failed ("Exception was not raised");
exception
when CA11001_0.Complex_Error =>
null;
when others =>
Report.Failed ("Unexpected exception raised in test");
end Exception_Subtest;
 
Report.Result;
 
end CA11001;
/ca11022.a
0,0 → 1,242
-- CA11022.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 body of a child unit can instantiate its generic sibling.
--
-- TEST DESCRIPTION:
-- Declare a package that provides some types for the graphic
-- application. Add a generic child package with a subprogram parameter
-- to provide algorithms that can be used by different terminal types
-- but that have to be customized to the specific terminal. Add child
-- packages to take advantage of the parent types and to provide a
-- customized operation for each of the different terminals. The
-- customized operation will be passed as a generic subprogram parameter
-- to the child package's sibling.
--
-- The main program "with"s the child packages. Check that the
-- operations in child units perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package CA11022_0 is -- Graphic Manager
type Row is range 1 .. 66;
type Column is range 1 .. 80;
type Radius is range 1 .. 3;
type Length is range 5 .. 10;
 
-- Testing artifice.
TC_Screen : array (Row, Column) of boolean := (others => (others => false));
TC_Draw_Circle : boolean := false;
TC_Draw_Square : boolean := false;
 
-- ... and other complicated ones.
 
end CA11022_0;
 
-- No bodies required for CA11022_0.
 
--==================================================================--
 
-- Child package to provide general graphic functionalities.
 
generic
 
with procedure Put_Dot (X : in Column;
Y : in Row);
 
package CA11022_0.CA11022_1 is
 
procedure Draw_Square (At_Col : in Column;
At_Row : in Row;
Len : in Length);
 
procedure Draw_Circle (At_Col : in Column;
At_Row : in Row;
Rad : in Radius);
 
-- procedure Draw_Ellipse ...
-- and other drawings ...
 
end CA11022_0.CA11022_1;
 
--==================================================================--
 
package body CA11022_0.CA11022_1 is
 
procedure Draw_Square (At_Col : in Column;
At_Row : in Row;
Len : in Length) is
begin
-- use square drawing algorithm
-- call
Put_Dot (At_Col + Column (Len), At_Row + Row(Len));
-- as needed in the algorithm.
TC_Draw_Square := true;
end Draw_Square;
 
-------------------------------------------------------
procedure Draw_Circle (At_Col : in Column;
At_Row : in Row;
Rad : in Radius) is
begin
-- use circle drawing algorithm
-- call
for I in 1 .. Rad loop
Put_Dot (At_Col + Column(I), At_Row + Row(I));
end loop;
-- as needed in the algorithm.
TC_Draw_Circle := true;
end Draw_Circle;
 
end CA11022_0.CA11022_1;
 
--==================================================================--
 
with CA11022_0.CA11022_1; -- Generic sibling.
 
-- Child package to provide customized graphic functions for the
-- VT100.
package CA11022_0.CA11022_2 is -- VT100 Graphic.
 
X : Column := 8;
Y : Row := 3;
R : Radius := 2;
L : Length := 6;
 
procedure VT100_Graphic;
 
end CA11022_0.CA11022_2;
 
--==================================================================--
 
package body CA11022_0.CA11022_2 is
 
procedure VT100_Graphic is
procedure VT100_Putdot (X : in Column;
Y : in Row) is
begin
-- Light a pixel at location (X, Y);
TC_Screen (Y, X) := true;
end VT100_Putdot;
 
------------------------------------
 
-- Declare instance of the generic sibling package to draw a circle,
-- a square, or an ellipse customized for the VT100.
package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot);
begin
VT100_Graphic.Draw_Circle (X, Y, R);
VT100_Graphic.Draw_Square (X, Y, L);
end VT100_Graphic;
 
end CA11022_0.CA11022_2;
 
--==================================================================--
 
with CA11022_0.CA11022_1; -- Generic sibling.
 
-- Child package to provide customized graphic functions for the
-- IBM3270.
package CA11022_0.CA11022_3 is -- IBM3270 Graphic.
 
X : Column := 39;
Y : Row := 11;
R : Radius := 3;
L : Length := 7;
 
procedure IBM3270_Graphic;
 
end CA11022_0.CA11022_3;
 
--==================================================================--
 
package body CA11022_0.CA11022_3 is
 
procedure IBM3270_Graphic is
procedure IBM3270_Putdot (X : in Column;
Y : in Row) is
begin
-- Light a pixel at location (X + 2, Y);
TC_Screen (Y, X + Column(2)) := true;
end IBM3270_Putdot;
 
------------------------------------
 
-- Declare instance of the generic sibling package to draw a circle,
-- a square, or an ellipse customized for the IBM3270.
package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot);
begin
IBM3270_Graphic.Draw_Circle (X, Y, R);
IBM3270_Graphic.Draw_Square (X, Y, L);
end IBM3270_Graphic;
 
end CA11022_0.CA11022_3;
 
--==================================================================--
 
with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with
-- CA11022_0, Graphic Manager.
with CA11022_0.CA11022_3; -- IBM3270 Graphic.
with Report;
 
procedure CA11022 is
 
begin
 
Report.Test ("CA11022", "Check that body of a child unit can depend on " &
"its generic sibling");
 
-- Customized graphic functions for the VT100 terminal.
CA11022_0.CA11022_2.VT100_Graphic;
 
if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10)
and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle
and not CA11022_0.TC_Draw_Square then
Report.Failed ("Wrong results for the VT100");
end if;
 
CA11022_0.TC_Draw_Circle := false;
CA11022_0.TC_Draw_Square := false;
 
-- Customized graphic functions for the IBM3270 terminal.
CA11022_0.CA11022_3.IBM3270_Graphic;
 
if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43)
and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18)
and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then
Report.Failed ("Wrong results for the IBM3270");
end if;
 
Report.Result;
 
end CA11022;
/ca11d011.a
0,0 → 1,79
-- CA11D011.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:
-- See CA11D013.AM
--
-- TEST DESCRIPTION:
-- See CA11D013.AM
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA11D00.A
-- CA11D010.A
-- => CA11D011.A
-- CA11D012.A
-- CA11D013.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Dec 94 SAIC Declared child procedure specification
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
--
--!
 
with Report;
 
 
-- Child procedure of FA11D00.
 
procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
C : out Complex_Type);
 
--=======================================================================--
 
procedure FA11D00.CA11D011 (Left, Right : in Complex_Type;
C : out Complex_Type) is
-- Multiply_Complex.
 
begin
-- Zero is declared in parent package.
 
if Left.Real < Zero.Real or Right.Imag < Zero.Imag then
raise Multiply_Error; -- Reference to exception in parent package.
Report.Failed ("Program control not transferred by raise in " &
"child procedure FA11D00.CA11D011");
else
C.Real := (Left.Real * Right.Real);
C.Imag := (Left.Imag * Right.Imag);
end if;
 
exception
when others =>
TC_Handled_In_Child_Sub := true;
C := Check_Value; -- Reference to object in parent package.
 
end FA11D00.CA11D011; -- Multiply_Complex
/ca15003.a
0,0 → 1,161
-- CA15003.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 the requirements of 10.1.5(4) and the modified 10.1.5(5)
-- from Technical Corrigendum 1. (Originally discussed as AI95-00136.)
-- Specifically:
-- Check that program unit pragma for a generic package are accepted
-- when given at the beginning of the package specification.
-- Check that a program unit pragma can be given for a generic
-- instantiation by placing the pragma immediately after the instantation.
--
-- TEST DESCRIPTION
-- This test checks the cases that are *not* forbidden by the RM,
-- and makes sure such legal cases actually work.
--
-- CHANGE HISTORY:
-- 29 JUN 1999 RAD Initial Version
-- 08 JUL 1999 RLB Cleaned up and added to test suite.
-- 27 AUG 1999 RLB Repaired errors introduced by me.
--
--!
 
with System;
package CA15003A is
pragma Pure;
 
type Big_Int is range -System.Max_Int .. System.Max_Int;
type Big_Positive is new Big_Int range 1..Big_Int'Last;
end CA15003A;
 
generic
type Int is new Big_Int;
package CA15003A.Pure is
pragma Pure;
function F(X: access Int) return Int;
end CA15003A.Pure;
 
with CA15003A.Pure;
package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive);
pragma Pure(CA15003A.Pure_Instance);
 
package body CA15003A.Pure is
function F(X: access Int) return Int is
begin
X.all := X.all + 1;
return X.all;
end F;
end CA15003A.Pure;
 
generic
package CA15003A.Pure.Preelaborate is
pragma Preelaborate;
One: Int := 1;
function F(X: access Int) return Int;
end CA15003A.Pure.Preelaborate;
 
package body CA15003A.Pure.Preelaborate is
function F(X: access Int) return Int is
begin
X.all := X.all + One;
return X.all;
end F;
end CA15003A.Pure.Preelaborate;
 
with CA15003A.Pure_Instance;
with CA15003A.Pure.Preelaborate;
package CA15003A.Pure_Preelaborate_Instance is
new CA15003A.Pure_Instance.Preelaborate;
pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance);
 
package CA15003A.Empty_Pure is
pragma Pure;
pragma Elaborate_Body;
end CA15003A.Empty_Pure;
 
package body CA15003A.Empty_Pure is
end CA15003A.Empty_Pure;
 
package CA15003A.Empty_Preelaborate is
pragma Preelaborate;
pragma Elaborate_Body;
One: Big_Int := 1;
end CA15003A.Empty_Preelaborate;
 
package body CA15003A.Empty_Preelaborate is
function F(X: access Big_Int) return Big_Int is
begin
X.all := X.all + One;
return X.all;
end F;
end CA15003A.Empty_Preelaborate;
 
package CA15003A.Empty_Elaborate_Body is
pragma Elaborate_Body;
Three: aliased Big_Positive := 1;
Two, Tres: Big_Positive'Base := 0;
end CA15003A.Empty_Elaborate_Body;
 
with Report; use Report; pragma Elaborate_All(Report);
with CA15003A.Pure_Instance;
with CA15003A.Pure_Preelaborate_Instance;
use CA15003A;
package body CA15003A.Empty_Elaborate_Body is
begin
if Two /= Big_Positive'Base(Ident_Int(0)) then
Failed ("Two should be zero now");
end if;
if Tres /= Big_Positive'Base(Ident_Int(0)) then
Failed ("Tres should be zero now");
end if;
if Two /= Tres then
Failed ("Tres should be zero now");
end if;
Two := Pure_Instance.F(Three'Access);
Tres := Pure_Preelaborate_Instance.F(Three'Access);
if Two /= Big_Positive(Ident_Int(2)) then
Failed ("Two should be 2 now");
end if;
if Tres /= Big_Positive(Ident_Int(3)) then
Failed ("Tres should be 3 now");
end if;
end CA15003A.Empty_Elaborate_Body;
 
with Report; use Report;
with CA15003A.Empty_Pure;
with CA15003A.Empty_Preelaborate;
with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body;
use type CA15003A.Big_Positive'Base;
procedure CA15003 is
begin
Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages");
if Two /= 2 then
Failed ("Two should be 2 now");
end if;
if Tres /= 3 then
Failed ("Tres should be 3 now");
end if;
Result;
end CA15003;
/ca11009.a
0,0 → 1,246
-- CA11009.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 child package can use entities declared in the
-- visible part of the parent unit of its parent unit.
--
-- TEST DESCRIPTION:
-- Declare a parent package containing types and objects used by the
-- system. Declare a public child package that provides a visible
-- interface to the system functionality.
-- Declare a private grandchild package that uses the visible grandparent
-- components to provide the actual functionality to the system.
--
-- The public child (parent of the private grandchild) uses the
-- functionality of its private child (grandchild package) to provide
-- the visible interface to operations of the system.
--
-- The test itself will utilize the visible interface provided in the
-- public child package to demonstrate a possible structure for
-- file management.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body.
--
--!
 
package CA11009_0 is -- Package OS.
pragma Elaborate_Body (CA11009_0);
 
type File_Descriptor_Type is new Integer;
type File_Name_Type is new String (1 .. 11);
type Permission_Type is (None, User, System, Bypass);
type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
type File_Status_Type is (Open, Closed);
 
Default_Descriptor : constant File_Descriptor_Type := 0;
Default_Permission : constant Permission_Type := None;
Default_Mode : constant File_Mode_Type := Read_Only;
Default_Status : constant File_Status_Type := Closed;
Default_Filename : constant File_Name_Type := " ";
 
Max_Files : constant File_Descriptor_Type := 10;
An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
File_Counter : Integer := 0;
 
type File_Type is tagged
record
Descriptor : File_Descriptor_Type := Default_Descriptor;
Name : File_Name_Type := Default_Filename;
Acct_Access : Permission_Type := Default_Permission;
Mode : File_Mode_Type := Default_Mode;
Current_Status : File_Status_Type := Default_Status;
end record;
 
type File_Array_Type is array (1 .. Max_Files) of File_Type;
 
File_Table : File_Array_Type;
 
--
 
function Get_File_Name return File_Name_Type;
 
end CA11009_0; -- Package OS.
 
--=================================================================--
 
package body CA11009_0 is -- Package body OS.
 
function Get_File_Name return File_Name_Type is
begin
return (An_Ada_File_Name); -- Processing would be replace by a user
-- prompt in a functioning system.
end Get_File_Name;
end CA11009_0; -- Package body OS.
 
--=================================================================--
 
package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager
 
-- This package simulates a visible interface for the Operating System.
-- The actual processing performed by this routine is encapsulated
-- in the routines of private child package Internals, which is "withed"
-- by the body of this package.
 
procedure Create_File (Mode : in File_Mode_Type;
File_Key : out File_Descriptor_Type);
 
end CA11009_0.CA11009_1; -- Child Package OS.File_Manager
 
--=================================================================--
 
-- Subprogram that performs the actual file operation is contained in a
-- private package so that it is not accessible to any client, and can be
-- modified/extended without requiring recompilation of the clients of the
-- parent (since this package is "withed" by the parent body only.)
 
 
-- Grandchild Package OS.File_Manager.Internals
private package CA11009_0.CA11009_1.CA11009_2 is
 
Initial_Permission : constant Permission_Type := User; -- Grandparent
Initial_Status : constant File_Status_Type := Open; -- literals.
Initial_Filename : constant File_Name_Type := -- Grandparent type.
Get_File_Name; -- Grandparent function.
 
function Create (Mode : File_Mode_Type)
return File_Descriptor_Type; -- Grandparent type.
 
end CA11009_0.CA11009_1.CA11009_2;
-- Grandchild Package OS.File_Manager.Internals
 
--=================================================================--
 
-- Grandchild Package body OS.File_Manager.Internals
package body CA11009_0.CA11009_1.CA11009_2 is
 
function Next_Available_File return File_Descriptor_Type is
begin
File_Counter := File_Counter + 1; -- Grandparent object.
return (File_Descriptor_Type(File_Counter));
end Next_Available_File;
-------------------------------------------------------------------------
function Create (Mode : File_Mode_Type) -- Grandparent literal.
return File_Descriptor_Type is
Number : File_Descriptor_Type; -- Grandparent type.
begin
Number := Next_Available_File;
File_Table(Number).Descriptor := Number; -- Grandparent object.
File_Table(Number).Name := Initial_Filename;
File_Table(Number).Mode := Mode; -- Parameter.
File_Table(Number).Acct_Access := Initial_Permission;
File_Table(Number).Current_Status := Initial_Status;
return (Number);
end Create;
 
end CA11009_0.CA11009_1.CA11009_2;
-- Grandchild Package body OS.File_Manager.Internals
 
--=================================================================--
 
-- "With" of a child package
-- by the parent body.
with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals
 
package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager
 
package Internal renames CA11009_0.CA11009_1.CA11009_2;
 
-- These subprograms utilize calls to subprograms contained in a private
-- sibling to perform the actual processing.
 
procedure Create_File (Mode : in File_Mode_Type;
File_Key : out File_Descriptor_Type) is
begin
File_Key := Internal.Create (Mode);
end Create_File;
 
end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager
 
--=================================================================--
 
with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager
with Report;
 
procedure CA11009 is
 
package OS renames CA11009_0;
use OS;
package File_Manager renames CA11009_0.CA11009_1;
 
Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor;
New_Mode : File_Mode_Type := Read_Write;
 
begin
-- This test indicates one approach to file management.
-- It is not intended to demonstrate full functionality, but rather
-- that the use of a private child package could provide a solution
-- to this type of situation.
 
Report.Test ("CA11009", "Check that a private child package can use " &
"entities declared in the visible part of the " &
"parent unit of its parent unit");
 
-- Check initial conditions of the first entry in the file table.
-- These are all default values provided in the declaration of the
-- type File_Type.
 
if (not (Data_Base_File_Key = Default_Descriptor)) and then
(((not (File_Table(1).Name = Default_Filename)) or
(File_Table(1).Descriptor /= Default_Descriptor)) or else
((File_Table(1).Acct_Access /= Default_Permission) or
(not (File_Table(1).Mode = Default_Mode)) or
(File_Table(1).Current_Status /= Default_Status)))
then
Report.Failed ("Initial condition failure");
end if;
 
-- Create/initialize file using the capability provided by the visible
-- interface to the operating system, OS.File_Manager. The actual
-- processing routine is contained in the private grandchild package
-- Internals, which utilize the components from the grandparent package.
 
File_Manager.Create_File (New_Mode, Data_Base_File_Key);
 
-- Verify that the initial conditions of the file table component have
-- been properly modified by the initialization function.
 
if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then
(File_Table(1).Name = An_Ada_File_Name) and then
(File_Table(1).Acct_Access = User) and then
not ((File_Table(1).Mode = Default_Mode) or else
(File_Table(1).Current_Status = Default_Status)))
then
Report.Failed ("File creation failure");
end if;
 
Report.Result;
 
end CA11009;
/ca1012b0.ada
0,0 → 1,37
-- CA1012B0.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.
--*
-- WKB 7/20/81
 
GENERIC
TYPE INDEX IS RANGE <>;
PROCEDURE CA1012B0 (I : IN OUT INDEX);
 
PROCEDURE CA1012B0 (I : IN OUT INDEX) IS
 
BEGIN
 
I := I + 1;
 
END CA1012B0;
/ca1102a1.ada
0,0 → 1,36
-- CA1102A1.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.
--*
-- WKB 6/12/81
 
PACKAGE BODY CA1102A0 IS
 
PROCEDURE P (INVOKED : IN OUT BOOLEAN) IS
BEGIN
INVOKED := TRUE;
END P;
 
BEGIN
NULL;
END CA1102A0;
/ca1012b2.ada
0,0 → 1,37
-- CA1012B2.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.
--*
-- WKB 7/20/81
 
GENERIC
TYPE ELEMENT IS RANGE <>;
FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT;
 
FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT IS
 
BEGIN
 
RETURN J + 1;
 
END CA1012B2;
/ca1012b4.ada
0,0 → 1,63
-- CA1012B4M.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 GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE
-- COMPILED SEPARATELY.
 
-- SEPARATE FILES ARE:
-- CA1012B0 A LIBRARY GENERIC PROCEDURE DECLARATION AND BODY.
-- CA1012B2 A LIBRARY GENERIC FUNCTION DECLARATION AND BODY.
-- CA1012B4M THE MAIN PROCEDURE.
 
-- WKB 7/20/81
 
WITH REPORT, CA1012B0, CA1012B2;
USE REPORT;
PROCEDURE CA1012B4M IS
 
N : INTEGER := 1;
 
SUBTYPE S50 IS INTEGER RANGE 1..50;
 
PROCEDURE P IS NEW CA1012B0 (S50);
 
FUNCTION F IS NEW CA1012B2 (INTEGER);
 
BEGIN
TEST ("CA1012B", "SEPARATELY COMPILED GENERIC SUBPROGRAM " &
"DECLARATIONS AND BODIES");
 
P(N);
IF N /= 2 THEN
FAILED ("PROCEDURE NOT INVOKED");
END IF;
 
N := 1;
IF F(N) /= 2 THEN
FAILED ("FUNCTION NOT INVOKED");
END IF;
 
RESULT;
 
END CA1012B4M;
/ca2009f0.ada
0,0 → 1,134
-- CA2009F0M.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 A GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND
-- INSTANTIATED. IN THIS TEST, SOME SUBUNIT BODIES ARE
-- IN SEPARATE FILES.
 
-- APPLICABILITY CRITERIA:
-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
 
-- SEPARATE FILES ARE:
-- CA2009F0M THE MAIN PROCEDURE, WITH SUBUNIT BODIES FOR
-- PROC2 AND FUNC2.
-- CA2009F1 A SUBUNIT PROCEDURE BODY (PROC1).
-- CA2009F2 A SUBUNIT FUNCTION BODY (FUNC1).
 
-- HISTORY:
-- BHS 08/01/84 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED "SOME" TO FIRST COMMENT.
-- BCB 01/05/88 MODIFIED HEADER.
-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-- RLB 09/15/99 REMOVED JUNK COMMENT.
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2009F0M IS
 
INT1 : INTEGER := 1;
INT2 : INTEGER := 2;
INT3 : INTEGER := 3;
INT4 : INTEGER := 4;
 
 
GENERIC
TYPE ELEM IS PRIVATE;
PCON1 : IN ELEM;
PVAR1 : IN OUT ELEM;
PROCEDURE PROC1;
 
GENERIC
TYPE ELEM IS PRIVATE;
PCON2 : IN ELEM;
PVAR2 : IN OUT ELEM;
PROCEDURE PROC2;
 
GENERIC
TYPE OBJ IS PRIVATE;
FCON1 : IN OBJ;
FVAR1 : IN OUT OBJ;
FUNCTION FUNC1 RETURN OBJ;
 
GENERIC
TYPE OBJ IS PRIVATE;
FCON2 : IN OBJ;
FVAR2 : IN OUT OBJ;
FUNCTION FUNC2 RETURN OBJ;
 
 
PROCEDURE PROC1 IS SEPARATE;
PROCEDURE PROC2 IS SEPARATE;
FUNCTION FUNC1 RETURN OBJ IS SEPARATE;
FUNCTION FUNC2 RETURN OBJ IS SEPARATE;
 
 
PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1);
PROCEDURE NI_PROC2 IS NEW PROC2 (INTEGER, 3, INT2);
FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 4, INT3);
FUNCTION NI_FUNC2 IS NEW FUNC2 (INTEGER, 5, INT4);
 
 
BEGIN
 
TEST ("CA2009F", "SPECIFICATION AND INSTANTIATION " &
"OF GENERIC SUBPROGRAM SUBUNITS");
 
NI_PROC1;
IF INT1 /= 2 THEN
FAILED ("INCORRECT INSTANTIATION - NI_PROC1");
END IF;
 
NI_PROC2;
IF INT2 /= 3 THEN
FAILED ("INCORRECT INSTANTIATION - NI_PROC2");
END IF;
 
IF NI_FUNC1 /= 4 THEN
FAILED ("INCORRECT INSTANTIATION - NI_FUNC1");
END IF;
 
IF NI_FUNC2 /= 5 THEN
FAILED ("INCORRECT INSTANTIATION - NI_FUNC2");
END IF;
 
 
RESULT;
 
END CA2009F0M;
 
 
SEPARATE (CA2009F0M)
PROCEDURE PROC2 IS
BEGIN
PVAR2 := PCON2;
END PROC2;
 
SEPARATE (CA2009F0M)
FUNCTION FUNC2 RETURN OBJ IS
BEGIN
FVAR2 := FCON2;
RETURN FVAR2;
END FUNC2;
/ca2009f2.ada
0,0 → 1,45
-- CA2009F2.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.
--*
-- SEPARATE GENERIC FUNCTION BODY.
-- SPECIFICATION, BODY STUB, AND AN INSTANTIATION ARE
-- IN CA2009F0M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- BHS 08/01/84 CREATED ORIGINAL TEST.
-- PWB 02/19/86 MODIFIED COMMENTS TO DESCRIBE RELATION TO OTHER
-- FILES AND POSSIBLE NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA2009F0M)
FUNCTION FUNC1 RETURN OBJ IS
BEGIN
FVAR1 := FCON1;
RETURN FVAR1;
END FUNC1;
/ca140230.a
0,0 → 1,62
-- CA140230.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:
-- See CA140232.AM.
--
-- TEST DESCRIPTION:
-- See CA140232.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- -> CA140230.A
-- CA140231.A
-- CA140232.AM
-- CA140233.A
--
-- PASS/FAIL CRITERIA:
-- See CA140232.AM.
--
-- CHANGE HISTORY:
-- 07 DEC 96 SAIC ACVC 2.1: Initial version.
-- 13 SEP 99 RLB Changed to C-test (by AI-00077).
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--
--!
 
package CA14023_0 is
subtype Little_float is float digits 4 range 0.0..100.0;
type Data_rec is tagged record
Data : Little_float;
end record;
end CA14023_0;
 
--------------------------------------------------------
 
generic
type Data_type is digits <>;
Floor : Data_type;
function CA14023_1 (P1, P2 : Data_type) return Data_type;
/ca11010.a
0,0 → 1,254
-- CA11010.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 child package can use entities declared in the
-- private part of its parent unit.
--
-- TEST DESCRIPTION:
-- Declare a parent package containing private types, objects,
-- and functions used by the system. Declare a private child package that
-- uses the parent components to provide functionality to the system.
--
-- Declare an array of files with default values for all
-- component fields of the files (records). Check the initial state of
-- a specified file for proper default values. Perform the file "creation"
-- (initialization), which will modify the fields of the record object.
-- Again verify the file object to determine whether the fields have been
-- reset properly.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
package CA11010_0 is -- Package OS.
type File_Descriptor_Type is private;
 
Default_Descriptor : constant File_Descriptor_Type;
 
function Initialize_File return File_Descriptor_Type;
procedure Verify_Initial_Conditions (Status : out Boolean);
function Final_Conditions_Valid return Boolean;
 
private
 
type File_Descriptor_Type is new Integer;
type File_Name_Type is new String (1 .. 11);
type Permission_Type is (None, User, System);
type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
type File_Status_Type is (Open, Closed);
 
Default_Descriptor : constant File_Descriptor_Type := 0;
Default_Permission : constant Permission_Type := None;
Default_Mode : constant File_Mode_Type := Read_Only;
Default_Status : constant File_Status_Type := Closed;
Default_Filename : constant File_Name_Type := " ";
An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
Max_Files : constant File_Descriptor_Type := 100;
 
type File_Type is tagged
record
Descriptor : File_Descriptor_Type := Default_Descriptor;
Name : File_Name_Type := Default_Filename;
Acct_Access : Permission_Type := Default_Permission;
Mode : File_Mode_Type := Default_Mode;
Current_Status : File_Status_Type := Default_Status;
end record;
 
type File_Array_Type is array (1 .. Max_Files) of File_Type;
 
File_Table : File_Array_Type;
File_Counter : Integer := 0;
 
--
 
function Get_File_Name return File_Name_Type;
 
end CA11010_0; -- Package OS.
 
--=================================================================--
 
-- Subprograms that perform the actual file operations are contained in a
-- private package so that they are not accessible to any client.
 
private package CA11010_0.CA11010_1 is -- Package OS.Internals
 
Private_File_Counter : Integer renames File_Counter; -- Parent priv. object.
 
function Initialize
(File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function.
File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal.
return File_Descriptor_Type; -- Parent type.
 
end CA11010_0.CA11010_1; -- Package OS.Internals
 
--=================================================================--
 
package body CA11010_0.CA11010_1 is -- Package body OS.Internals
 
function Next_Available_File return File_Descriptor_Type is
begin
Private_File_Counter := Private_File_Counter + 1;
return (File_Descriptor_Type(File_Counter));
end Next_Available_File;
----------------------------------------------------------------
function Initialize
(File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function
File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal
return File_Descriptor_Type is -- Parent type
Number : File_Descriptor_Type;
begin
Number := Next_Available_File;
File_Table(Number).Descriptor := Number; -- Parent priv. object
File_Table(Number).Name := File_Name; -- Default parameter value
File_Table(Number).Mode := File_Mode; -- Default parameter value
File_Table(Number).Acct_Access := User;
File_Table(Number).Current_Status := Open;
return (Number);
end Initialize;
 
end CA11010_0.CA11010_1; -- Package body OS.Internals
 
--=================================================================--
 
with CA11010_0.CA11010_1; -- Private child package "withed" by
-- parent body.
 
package body CA11010_0 is -- Package body OS
 
function Get_File_Name return File_Name_Type is
begin
return (An_Ada_File_Name); -- If this was a real function, the user
end Get_File_Name; -- would be asked to input a name, or there
-- would be some type of similar processing.
 
-- This subprogram utilizes a call to a subprogram contained in a private
-- child to perform the actual processing.
 
function Initialize_File return File_Descriptor_Type is
begin
return (CA11010_0.CA11010_1.Initialize); -- No parameters are needed,
-- since defaults have been
-- provided.
end Initialize_File;
 
--
-- Separate subunits.
--
 
procedure Verify_Initial_Conditions (Status : out Boolean) is separate;
 
function Final_Conditions_Valid return Boolean is separate;
 
end CA11010_0; -- Package body OS
 
--=================================================================--
 
separate (CA11010_0)
procedure Verify_Initial_Conditions (Status : out Boolean) is
begin
Status := False;
if (File_Table(1).Descriptor = Default_Descriptor) and then
(File_Table(1).Name = Default_Filename) and then
(File_Table(1).Acct_Access = Default_Permission) and then
(File_Table(1).Mode = Default_Mode) and then
(File_Table(1).Current_Status = Default_Status)
then
Status := True;
end if;
end Verify_Initial_Conditions;
 
--=================================================================--
 
separate (CA11010_0)
function Final_Conditions_Valid return Boolean is
begin
if ((File_Table(1).Descriptor /= Default_Descriptor) and then
(File_Table(1).Name = An_Ada_File_Name) and then
(File_Table(1).Acct_Access = User) and then
not ((File_Table(1).Mode = Default_Mode) or else
(File_Table(1).Current_Status = Default_Status)))
then
return (True);
else
return (False);
end if;
end Final_Conditions_Valid;
 
--=================================================================--
 
with CA11010_0; -- with Package OS.
with Report;
 
procedure CA11010 is
 
package OS renames CA11010_0;
 
Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor;
Initialization_Status : Boolean := False;
 
begin
 
-- This test indicates one approach to a file management operation.
-- It is not intended to demonstrate full functionality, but rather
-- that the use of a private child package can provide a solution
-- to a user situation, that being the implementation of certain functions
-- being provided in a child package, with the parent package body
-- utilizing these implementations.
 
Report.Test ("CA11010", "Check that a private child package can use " &
"entities declared in the private part of its " &
"parent unit");
 
-- Check initial conditions of the first entry in the file table.
-- These are all default values provided in the declaration of the
-- type File_Type.
 
OS.Verify_Initial_Conditions (Initialization_Status);
 
if not Initialization_Status then
Report.Failed ("Initial condition failure");
end if;
-- Call the initialization function. This will result in the resetting
-- of the fields associated with the first entry in the File_Table (this
-- is the first/only call of Initialize_File).
-- No parameters are necessary for this call, due to the default values
-- provided in the private child package routine Initialize.
Ada_File_Key := OS.Initialize_File;
 
-- Verify that the initial conditions of the file table component have
-- been properly modified by the initialization function.
 
if not OS.Final_Conditions_Valid then
Report.Failed ("Initialization processing failure");
end if;
 
Report.Result;
 
end CA11010;
/ca11014.a
0,0 → 1,302
-- CA11014.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 instantiation of a child package of a generic package
-- can use its parent's declarations and operations, including a formal
-- package of the parent.
--
-- TEST DESCRIPTION:
-- Declare a list abstraction in a generic package which manages lists of
-- elements of any discrete type. Declare a generic package which
-- operates on lists of elements of integer types. Declare a generic
-- child of this package which defines additional list operations.
-- Use the formal discrete type as the generic formal actual part for the
-- parent formal package.
--
-- Declare an instance of parent, then declare an instance of the child
-- which is itself a child the parent's instance. In the main program,
-- check that the operations in both instances perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
-- 07 Sep 96 SAIC Change formal param E to be out only.
-- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context
-- clauses of CA11014_0, CA11014_1, and CA11014_5.
-- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4
--!
-- Actual package for the parent's formal.
generic
 
type Element_Type is (<>); -- List elems may be of any discrete types.
 
package CA11014_0 is
 
type Node_Type;
type Node_Pointer is access Node_Type;
 
type Node_Type is record
Item : Element_Type;
Next : Node_Pointer := null;
end record;
 
type List_Type is record
First : Node_Pointer := null;
Current : Node_Pointer := null;
Last : Node_Pointer := null;
end record;
 
-- Return true if current element is last in the list.
function End_Of_List (L : List_Type) return boolean;
 
-- Set "current" pointer to first list element.
procedure Reset (L : in out List_Type);
 
end CA11014_0;
 
--==================================================================--
 
package body CA11014_0 is
 
function End_Of_List (L : List_Type) return boolean is
begin
return (L.Current = null);
end End_Of_List;
-------------------------------------------------------
procedure Reset (L : in out List_Type) is
begin
L.Current := L.First; -- Set "current" pointer to first
end Reset; -- list element.
 
end CA11014_0;
 
--==================================================================--
 
with CA11014_0; -- Generic list abstraction.
pragma Elaborate (CA11014_0);
generic
 
-- Import the list abstraction defined in CA11014_0.
with package List_Mgr is new CA11014_0 (<>);
 
package CA11014_1 is
 
-- Write to current element and advance "current" pointer.
procedure Write_Element (L : in out List_Mgr.List_Type;
E : in List_Mgr.Element_Type);
 
-- Read from current element and advance "current" pointer.
procedure Read_Element (L : in out List_Mgr.List_Type;
E : out List_Mgr.Element_Type);
 
-- Add element to end of list.
procedure Add_Element (L : in out List_Mgr.List_Type;
E : in List_Mgr.Element_Type);
 
end CA11014_1;
 
--==================================================================--
 
package body CA11014_1 is
 
procedure Write_Element (L : in out List_Mgr.List_Type;
E : in List_Mgr.Element_Type) is
begin
L.Current.Item := E; -- Write to current element.
L.Current := L.Current.Next; -- Advance "current" pointer.
end Write_Element;
-------------------------------------------------------
procedure Read_Element (L : in out List_Mgr.List_Type;
E : out List_Mgr.Element_Type) is
begin
E := L.Current.Item; -- Retrieve current element.
L.Current := L.Current.Next; -- Advance "current" pointer.
end Read_Element;
-------------------------------------------------------
procedure Add_Element (L : in out List_Mgr.List_Type;
E : in List_Mgr.Element_Type) is
New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null);
use type List_Mgr.Node_Pointer;
begin
if L.First = null then -- No elements in list, so add new
L.First := New_Node; -- element at beginning of list.
else
L.Last.Next := New_Node; -- Add new element at end of list.
end if;
L.Last := New_Node; -- Set last-in-list pointer.
end Add_Element;
 
end CA11014_1;
 
--==================================================================--
 
-- Generic child of list operation. This child adds a layer of
-- functionality to the parent generic.
 
generic
 
package CA11014_1.CA11014_2 is
 
procedure Write_First_To_List (L : in out List_Mgr.List_Type);
 
-- ... Various other operations used by the application.
 
end CA11014_1.CA11014_2;
 
--==================================================================--
 
package body CA11014_1.CA11014_2 is
 
procedure Write_First_To_List (L : in out List_Mgr.List_Type) is
begin
List_Mgr.Reset (L); -- Parent's formal package.
 
while not List_Mgr.End_Of_List (L) loop -- Parent's formal package.
Write_Element (L, List_Mgr.Element_Type'First);
-- Parent's operation,
end loop; -- parent's formal.
end Write_First_To_List;
 
end CA11014_1.CA11014_2;
 
--==================================================================--
 
package CA11014_3 is
 
type Points is range 0 .. 100;
 
-- ... Various other types used by the application.
 
end CA11014_3;
 
 
-- No body for CA11014_3;
 
--==================================================================--
 
-- Declare instances of the generic list packages for the discrete type.
-- The instance of the child must itself be declared as a child of the
-- instance of the parent.
 
with CA11014_0; -- Generic list abstraction.
with CA11014_3; -- Package containing discrete type declaration.
pragma Elaborate (CA11014_0);
package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list.
 
with CA11014_4; -- Points list.
with CA11014_1; -- Generic list operation.
pragma Elaborate (CA11014_1);
package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list.
 
with CA11014_1.CA11014_2; -- Additional generic list operation,
with CA11014_5;
pragma Elaborate (CA11014_5);
package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2;
-- Points list operation.
 
--==================================================================--
 
with CA11014_1.CA11014_2; -- Additional generic list operation,
-- implicitly with list operation.
with CA11014_3; -- Package containing discrete type declaration.
with CA11014_4; -- Points list.
with CA11014_5.CA11014_6; -- Points list operation.
with Report;
 
procedure CA11014 is
 
package Lists_Of_Scores renames CA11014_4;
package Score_Ops renames CA11014_5;
package Point_Ops renames CA11014_5.CA11014_6;
 
Scores : Lists_Of_Scores.List_Type; -- List of points.
 
type TC_Score_Array is array (1 .. 3) of CA11014_3.Points;
 
TC_Initial_Values : constant TC_Score_Array := (10, 21, 49);
TC_Final_Values : constant TC_Score_Array := (0, 0, 0);
 
TC_Initial_Values_Are_Correct : boolean := false;
TC_Final_Values_Are_Correct : boolean := false;
 
--------------------------------------------------
 
-- Initial list contains 3 scores with the values 10, 21, and 49.
procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is
begin
for I in TC_Score_Array'range loop
Score_Ops.Add_Element (L, TC_Initial_Values(I));
-- Operation from generic parent.
end loop;
end TC_Initialize_List;
 
--------------------------------------------------
 
-- Verify that all scores have been set to zero.
procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type;
Expected : in TC_Score_Array;
OK : out boolean) is
Actual : TC_Score_Array;
begin
Lists_of_Scores.Reset (L); -- Operation from parent's formal.
for I in TC_Score_Array'range loop
Score_Ops.Read_Element (L, Actual(I));
-- Operation from generic parent.
end loop;
OK := (Actual = Expected);
end TC_Verify_List;
 
--------------------------------------------------
 
begin -- CA11014
 
Report.Test ("CA11014", "Check that an instantiation of a child package " &
"of a generic package can use its parent's " &
"declarations and operations, including a " &
"formal package of the parent");
 
TC_Initialize_List (Scores);
TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct);
 
if not TC_Initial_Values_Are_Correct then
Report.Failed ("List contains incorrect initial values");
end if;
 
Point_Ops.Write_First_To_List (Scores);
-- Operation from generic child package.
 
TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct);
 
if not TC_Final_Values_Are_Correct then
Report.Failed ("List contains incorrect final values");
end if;
 
Report.Result;
 
end CA11014;
/ca1011a1.ada
0,0 → 1,36
-- CA1011A1.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
PROCEDURE CA1011A0 (X : IN OUT INTEGER;
Y : IN INTEGER := -1;
Z : IN INTEGER := 2) IS
 
BEGIN
 
X := 3;
 
END CA1011A0;
/ca11018.a
0,0 → 1,366
-- CA11018.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 body of the parent package may depend on one of its own
-- public generic children.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of adding a
-- public generic child during code maintenance without distubing a large
-- subsystem. After child is added to the subsystem, a maintainer
-- decides to take advantage of the new functionality and rewrites
-- the parent's body.
--
-- Declare a message application in a package which highlights some
-- key words. Declare a public generic child of this package which adds
-- functionality to the original subsystem. In the parent body,
-- instantiate the child.
--
-- In the main program, check that the operations in the parent,
-- and instances of the public child package perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst.
-- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
--
--!
-- Simulates application which displays messages.
 
package CA11018_0 is
 
type Designated_Num is new Integer range 0 .. 100;
 
type Particularly_Designated_Num is new Integer range 0 .. 100;
 
type Message is new String;
 
type Message_Rec is tagged private;
 
type Designated_Msg is new Message_Rec with private;
 
type Particularly_Designated_Msg is new Message_Rec with private;
 
-- Analyzes message for presence of word in the secret message. If found,
-- word is highlighted.
 
procedure Highlight_Designated (The_Word : in Message;
In_The_Message : in out Designated_Msg);
 
-- Analyzes message for presence of word in the secret message. If found,
-- word is highlighted and do other actions.
 
procedure Highlight_Particularly_Designated
(The_Word : in Message;
In_The_Message : in out Particularly_Designated_Msg);
 
-- Begin test code declarations: -----------------------
 
TC_Designated_Not_Zero : Boolean := false;
 
TC_Particularly_Designated_Not_Zero : Boolean := false;
 
-- The following two functions are used to check for function
-- calls from the public generic child.
 
function TC_Designated_Success return Boolean;
 
function TC_Particularly_Designated_Success return Boolean;
 
-- End test code declarations. -------------------------
 
private
type Message_Rec is tagged
record
The_Length : natural := 0;
The_Content : Message (1 .. 60);
end record;
 
type Designated_Msg is new Message_Rec with null record;
-- ... More components in real application.
 
type Particularly_Designated_Msg is new Message_Rec with null record;
-- ... More components in real application.
 
end CA11018_0;
 
--=================================================================--
 
 
-- Public generic child package of message display application. Imagine that
-- messages of one security level are associated with a type derived from
-- integer. For overall system security, messages of a different security
-- level are associated with a different type derived from integer. By
-- instantiating this package for each security level, the results of Count
-- applied to one kind of message cannot inadvertently be compared with the
-- results applied to a different kind.
 
generic
type Msg_Type is new Message_Rec with private;
-- Derived from parent's type.
type Count is range <>;
 
package CA11018_0.CA11018_1 is
 
TC_Function_Called : Boolean := false;
 
function Find_Word (Wrd : in Message;
Msg : in Msg_Type) return Count;
 
end CA11018_0.CA11018_1;
 
--=================================================================--
 
package body CA11018_0.CA11018_1 is
 
function Find_Word (Wrd : in Message;
Msg : in Msg_Type) return Count is
 
Num : Count := Count'first;
 
-- Count how many time the word appears within the given message.
 
begin
-- ... Error-checking code omitted for brevity.
 
for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop
-- Parent's private type
if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd
-- Parent's private type
then
Num := Num + 1;
end if;
 
end loop;
 
TC_Function_Called := true;
 
return (Num);
 
end Find_Word;
 
end CA11018_0.CA11018_1;
 
--=================================================================--
 
with CA11018_0.CA11018_1; -- Public generic child.
 
pragma Elaborate (CA11018_0.CA11018_1);
package body CA11018_0 is
 
----------------------------------------------------
-- Parent's body depends on public generic child. --
----------------------------------------------------
 
-- Instantiate the public child for the secret message.
 
package Designated_Pkg is new CA11018_0.CA11018_1
(Msg_Type => Designated_Msg, Count => Designated_Num);
 
-- Instantiate the public child for the top secret message.
 
package Particularly_Designated_Pkg is new CA11018_0.CA11018_1
(Particularly_Designated_Msg, Particularly_Designated_Num);
 
-- End instantiations. -----------------------------
 
function TC_Designated_Success return Boolean is
-- Check to see if the function in the public generic child is called.
 
begin
return Designated_Pkg.TC_Function_Called;
end TC_Designated_Success;
--------------------------------------------------------------
function TC_Particularly_Designated_Success return Boolean is
-- Check to see if the function in the public generic child is called.
 
begin
return Particularly_Designated_Pkg.TC_Function_Called;
end TC_Particularly_Designated_Success;
--------------------------------------------------------------
-- Calls functions from public child to search for a key word.
-- If the word appears more than once in each message,
-- highlight all of them.
 
procedure Highlight_Designated (The_Word : in Message;
In_The_Message : in out Designated_Msg) is
 
-- Not a real highlight procedure. Real application can use graphic
-- device to highlight all occurrences of words.
 
begin
--------------------------------------------------------------
-- Parent's body uses function from instantiation of public --
-- generic child. --
--------------------------------------------------------------
 
if Designated_Pkg.Find_Word -- Child's operation.
(The_Word, In_The_Message) > 0 then
 
-- Highlight all occurrences in lavender.
 
TC_Designated_Not_Zero := true;
end if;
 
end Highlight_Designated;
--------------------------------------------------------------
procedure Highlight_Particularly_Designated
(The_Word : in Message;
In_The_Message : in out Particularly_Designated_Msg) is
 
-- Not a real highlight procedure. Real application can use graphic
-- device to highlight all occurrences of words.
 
begin
--------------------------------------------------------------
-- Parent's body uses function from instantiation of public --
-- generic child. --
--------------------------------------------------------------
 
if Particularly_Designated_Pkg.Find_Word -- Child's operation.
(The_Word, In_The_Message) > 0 then
 
-- Highlight all occurrences in chartreuse.
-- Do other more secret stuff.
 
TC_Particularly_Designated_Not_Zero := true;
end if;
 
end Highlight_Particularly_Designated;
 
end CA11018_0;
 
--=================================================================--
 
-- Public generic child to copy words to the messages.
 
generic
type Message_Type is new Message_Rec with private;
-- Derived from parent's type.
 
package CA11018_0.CA11018_2 is
 
procedure Copy (From_The_Word : in Message;
To_The_Message : in out Message_Type);
 
end CA11018_0.CA11018_2;
 
--=================================================================--
 
package body CA11018_0.CA11018_2 is
 
procedure Copy (From_The_Word : in Message;
To_The_Message : in out Message_Type) is
 
-- Copy words to the appropriate messages.
 
begin
To_The_Message.The_Content -- Parent's private type.
(1 .. From_The_Word'length) := From_The_Word;
 
To_The_Message.The_Length -- Parent's private type.
:= From_The_Word'length;
end Copy;
 
end CA11018_0.CA11018_2;
 
--=================================================================--
 
with Report;
 
with CA11018_0.CA11018_2; -- Public generic child package, copy words
-- to the message.
-- Implicit with parent package (CA11018_0).
 
procedure CA11018 is
 
package Message_Pkg renames CA11018_0;
 
begin
 
Report.Test ("CA11018", "Check that body of the parent package can " &
"depend on one of its own public generic children");
 
-- Highlight the word "Alert" from the secret message.
Designated_Subtest:
declare
The_Message : Message_Pkg.Designated_Msg; -- Parent's private type.
 
-- Instantiate the public child to copy words to the secret message.
 
package Copy_Designated_Pkg is new CA11018_0.CA11018_2
(Message_Pkg.Designated_Msg);
 
begin
Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard",
To_The_Message => The_Message);
 
Message_Pkg.Highlight_Designated ("Alert", The_Message);
 
if not Message_Pkg.TC_Designated_Not_Zero and
Message_Pkg.TC_Designated_Success then
Report.Failed ("Alert should have been highlighted");
end if;
 
end Designated_Subtest;
 
-- Highlight the word "Push The Alarm" from the top secret message.
 
Particularly_Designated_Subtest:
declare
The_Message : Message_Pkg.Particularly_Designated_Msg ;
-- Parent's private type.
 
-- Instantiate the public child to copy words to the top secret
-- message.
 
package Copy_Particularly_Designated_Pkg is new
CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg);
 
begin
Copy_Particularly_Designated_Pkg.Copy
("Alert Level 10 : Alert The Guard and Push The Alarm",
The_Message);
 
Message_Pkg.Highlight_Particularly_Designated
("Push The Alarm", The_Message);
 
if not Message_Pkg.TC_Particularly_Designated_Not_Zero and
Message_Pkg.TC_Particularly_Designated_Success then
Report.Failed ("Key words should have been highlighted");
end if;
 
end Particularly_Designated_Subtest;
 
Report.Result;
 
end CA11018;
/ca1013a0.ada
0,0 → 1,51
-- CA1013A0.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.
--*
-- WKB 7/20/81
-- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
 
 
GENERIC
TYPE ELEM IS RANGE <>;
PACKAGE CA1013A0 IS
 
I : ELEM;
 
PROCEDURE REQUIRE_BODY;
 
END CA1013A0;
 
 
PACKAGE BODY CA1013A0 IS
 
PROCEDURE REQUIRE_BODY IS
BEGIN
NULL;
END;
 
BEGIN
 
I := 1;
 
END CA1013A0;
/ca2002a1.ada
0,0 → 1,53
-- CA2002A1.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.
--*
-- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A1 IN FILE
-- CA2002A0M.
 
-- BHS 8/02/84
 
SEPARATE (CA2002A1)
PROCEDURE PROC (X : OUT INTEGER) IS
BEGIN
X := 1;
END PROC;
 
SEPARATE (CA2002A1)
FUNCTION FUN RETURN BOOLEAN IS
BEGIN
RETURN TRUE;
END FUN;
 
SEPARATE (CA2002A1)
PACKAGE BODY PKG IS
PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS SEPARATE;
BEGIN
I := 1;
END PKG;
 
SEPARATE (CA2002A1.PKG)
PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS
BEGIN
XX := XX - 1;
END PKG_PROC;
/ca1011a3.ada
0,0 → 1,34
-- CA1011A3.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
PROCEDURE CA1011A2 (X : BOOLEAN := TRUE;
Y : IN OUT FLOAT) IS
BEGIN
 
Y := 3.0;
 
END CA1011A2;
/ca2004a0.ada
0,0 → 1,65
-- CA2004A0M.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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED
-- IN ANCESTORS OTHER THAN THE PARENT.
 
-- SEPARATE FILES ARE:
-- CA2004A0M THE MAIN PROCEDURE.
-- CA2004A1 A SUBUNIT PACKAGE BODY.
-- CA2004A2 A SUBUNIT PROCEDURE BODY.
-- CA2004A3 A SUBUNIT PROCEDURE BODY.
-- CA2004A4 A SUBUNIT PROCEDURE BODY.
 
-- WKB 6/26/81
-- JRK 6/26/81
-- BHS 7/31/84
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2004A0M IS
 
I : INTEGER := 1;
 
PACKAGE CA2004A1 IS
J : INTEGER := 2;
PROCEDURE CA2004A2;
END CA2004A1;
 
USE CA2004A1;
PACKAGE BODY CA2004A1 IS SEPARATE;
PROCEDURE CA2004A3 IS SEPARATE;
 
BEGIN
TEST ("CA2004A", "CHECK THAT A SUBUNIT HAS VISIBILITY OF " &
"IDENTIFIERS DECLARED IN ANCESTORS");
 
 
CA2004A1.
CA2004A2;
 
CA2004A3;
 
RESULT;
END CA2004A0M;
/ca1013a2.ada
0,0 → 1,39
-- CA1013A2.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.
--*
-- WKB 7/20/81
 
 
GENERIC
TYPE ITEM IS RANGE <>;
FUNCTION CA1013A2 RETURN ITEM;
 
 
FUNCTION CA1013A2 RETURN ITEM IS
 
BEGIN
 
RETURN 2;
 
END CA1013A2;
/ca1011a5.ada
0,0 → 1,33
-- CA1011A5.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.
--*
-- BHS 7/20/84
-- JBG 5/23/85
 
FUNCTION CA1011A4 RETURN FLOAT IS
BEGIN
 
RETURN 3.0;
 
END CA1011A4;
/ca2004a2.ada
0,0 → 1,43
-- CA2004A2.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.
--*
-- WKB 6/26/81
 
SEPARATE (CA2004A0M.CA2004A1)
PROCEDURE CA2004A2 IS
BEGIN
 
IF I /= 1 THEN
FAILED ("IDENTIFIER NOT VISIBLE - 1");
END IF;
 
IF J /= 2 THEN
FAILED ("IDENTIFIER NOT VISIBLE - 2");
END IF;
 
IF K /= 3 THEN
FAILED ("IDENTIFIER NOT VISIBLE - 3");
END IF;
 
END CA2004A2;
/ca1013a4.ada
0,0 → 1,31
-- CA1013A4.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.
--*
-- WKB 7/20/81
-- SPS 10/27/82
-- JBG 9/15/83
 
WITH CA1013A1;
PRAGMA ELABORATE (CA1013A1);
PROCEDURE CA1013A4 IS NEW CA1013A1 (INTEGER);
/ca5004b0.ada
0,0 → 1,64
-- CA5004B0.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: See CA5004B2M.ADA
--
-- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA
--
-- TEST FILES:
-- => CA5004B0.ADA
-- CA5004B1.ADA
-- CA5004B2M.ADA
 
-- PWN 05/31/96 Split test into files without duplicate unit names.
-- RLB 03/11/99 Split test into files so that units that will be replaced
-- and units that won't are not in the same source file.
 
-------------------------------------------------------------
 
PACKAGE HEADER IS
 
PROCEDURE WRONG (WHY : STRING);
 
END HEADER;
 
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PACKAGE BODY HEADER IS
 
PROCEDURE WRONG (WHY : STRING) IS
BEGIN
FAILED ("PACKAGE WITH " & WHY & " NOT ELABORATED " &
"CORRECTLY");
END WRONG;
 
BEGIN
 
TEST ("CA5004B", "PRAGMA ELABORATE IS ACCEPTED AND OBEYED " &
"EVEN WHEN THE BODY OF THE UNIT NAMED IS " &
"MISSING OR OBSOLETE");
 
END HEADER;
 
/ca2004a4.ada
0,0 → 1,36
-- CA2004A4.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.
--*
-- BHS 7/31/84
 
SEPARATE (CA2004A0M.CA2004A3)
PROCEDURE CA2004A4 IS
BEGIN
 
IF I /= IDENT_INT(1) OR
J /= IDENT_INT(2) THEN
FAILED ("IDENTIFIER NOT VISIBLE - 5");
END IF;
 
END CA2004A4;
/ca2008a0.ada
0,0 → 1,81
-- CA2008A0M.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 FOR AN OVERLOADED SUBPROGRAM, ONE OF THE
-- SUBPROGRAM BODIES CAN BE SPECIFIED WITH A BODY_STUB AND
-- COMPILED SEPARATELY.
 
-- SEPARATE FILES ARE:
-- CA2008A0M THE MAIN PROCEDURE.
-- CA2008A1 A SUBUNIT PROCEDURE BODY.
-- CA2008A2 A SUBUNIT FUNCTION BODY.
 
-- WKB 6/26/81
-- SPS 11/2/82
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2008A0M IS
 
I : INTEGER := 0;
B : BOOLEAN := TRUE;
 
PROCEDURE CA2008A1 (I : IN OUT INTEGER) IS
BEGIN
I := IDENT_INT (1);
END CA2008A1;
 
PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS SEPARATE;
 
FUNCTION CA2008A2 RETURN INTEGER IS SEPARATE;
 
FUNCTION CA2008A2 RETURN BOOLEAN IS
BEGIN
RETURN IDENT_BOOL (FALSE);
END CA2008A2;
 
BEGIN
TEST ("CA2008A", "CHECK THAT AN OVERLOADED SUBPROGRAM " &
"CAN HAVE ONE OF ITS BODIES COMPILED SEPARATELY");
 
CA2008A1 (I);
IF I /= 1 THEN
FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 1");
END IF;
 
CA2008A1 (B);
IF B THEN
FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 2");
END IF;
 
IF CA2008A2 /= 2 THEN
FAILED ("OVERLOADED FUNCTION NOT INVOKED - 1");
END IF;
 
IF CA2008A2 THEN
FAILED ("OVERLOADED FUNCTION NOT INVOKED - 2");
END IF;
 
RESULT;
END CA2008A0M;
/ca1013a6.ada
0,0 → 1,65
-- CA1013A6M.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 GENERIC PACKAGE OR SUBPROGRAM INSTANTIATION
-- CAN BE SUBMITTED FOR SEPARATE COMPILATION.
 
-- SEPARATE FILES ARE:
-- CA1013A0 A LIBRARY GENERIC PACKAGE.
-- CA1013A1 A LIBRARY GENERIC PROCEDURE.
-- CA1013A2 A LIBRARY GENERIC FUNCTION.
-- CA1013A3 A LIBRARY GENERIC PACKAGE INSTANTIATION.
-- CA1013A4 A LIBRARY GENERIC PROCEDURE INSTANTIATION.
-- CA1013A5 A LIBRARY GENERIC FUNCTION INSTANTIATION.
-- CA1013A6M THE MAIN PROCEDURE.
 
-- WKB 7/20/81
-- SPS 11/5/82
 
WITH REPORT;
WITH CA1013A3, CA1013A4, CA1013A5;
USE REPORT;
PROCEDURE CA1013A6M IS
 
J : INTEGER := 1;
 
BEGIN
TEST ("CA1013A", "GENERIC INSTANTIATIONS SUBMITTED " &
"FOR SEPARATE COMPILATION");
 
IF CA1013A3.I /= 1 THEN
FAILED ("PACKAGE NOT ACCESSED");
END IF;
 
CA1013A4 (J);
IF J /= 2 THEN
FAILED ("PROCEDURE NOT INVOKED");
END IF;
 
IF CA1013A5 /= 2 THEN
FAILED ("FUNCTION NOT INVOKED");
END IF;
 
RESULT;
END CA1013A6M;
/ca5004b2.ada
0,0 → 1,153
-- CA5004B2M.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 PRAGMA ELABORATE IS ACCEPTED AND OBEYED EVEN IF THE UNIT
-- NAMED IN THE PRAGMA DOES NOT YET HAVE A BODY IN THE LIBRARY OR IF
-- ITS BODY IS OBSOLETE.
-- CHECK THAT MORE THAN ONE NAME IS ALLOWED IN A PRAGMA ELABORATE.
--
-- SPECIAL INSTRUCTIONS:
-- 1. Compile CA5004B0.ADA
-- 2. Compile CA5004B1.ADA
-- 3. Compile CA5004B2M.ADA
-- 4. Bind/Link main unit CA5004B2M
-- 5. Execute the resulting file
--
-- TEST FILES:
-- CA5004B0.ADA
-- CA5004B1.ADA
-- => CA5004B2M.ADA
 
-- BHS 8/03/84
-- JRK 9/20/84
-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL.
-- PWN 05/31/96 Split test into files without duplicate unit names.
-- TMB 11/20/96 ADDED PROCEDURE DECL TO CA5004B0 TO INSURE IT MAKES
-- THE OLD BODY OBSOLETE
-- TMB 12/2/96 MADE NAME OF MAIN PROCEDURE SAME AS FILE NAME
-- RLB 03/11/99 Split first test file in order to prevent good units
-- from being made obsolete.
 
-------------------------------------------------------------
 
PACKAGE CA5004B0 IS -- OLD BODY NOW OBSOLETE.
 
I : INTEGER := 2;
B : BOOLEAN := TRUE;
 
FUNCTION F RETURN BOOLEAN;
PROCEDURE P;
 
END CA5004B0;
 
---------------------------------------------------------
 
PACKAGE CA5004B1 IS
 
J : INTEGER := 3;
 
PROCEDURE P (X : INTEGER);
 
END CA5004B1; -- NO BODY GIVEN YET.
 
----------------------------------------------------------
 
WITH HEADER; USE HEADER;
WITH CA5004B0, CA5004B1;
USE CA5004B0, CA5004B1;
PRAGMA ELABORATE (HEADER, CA5004B0, CA5004B1);
PACKAGE CA5004B2 IS
 
K1 : INTEGER := CA5004B0.I;
K2 : INTEGER := CA5004B1.J;
 
PROCEDURE REQUIRE_BODY;
 
END CA5004B2;
 
 
PACKAGE BODY CA5004B2 IS
 
PROCEDURE REQUIRE_BODY IS
BEGIN
NULL;
END;
 
BEGIN
 
IF K1 /= 4 THEN
WRONG ("OBSOLETE BODY");
END IF;
 
IF K2 /= 5 THEN
WRONG ("NO BODY");
END IF;
 
END CA5004B2;
 
--------------------------------------------------
 
WITH REPORT, CA5004B2;
USE REPORT, CA5004B2;
PROCEDURE CA5004B2M IS
BEGIN
 
RESULT;
 
END CA5004B2M;
 
----------------------------------------------------
 
PACKAGE BODY CA5004B0 IS
 
FUNCTION F RETURN BOOLEAN IS
BEGIN
RETURN FALSE;
END F;
 
PROCEDURE P IS
BEGIN
RETURN;
END P;
 
BEGIN
 
I := 4;
 
END CA5004B0;
 
---------------------------------------------------
 
PACKAGE BODY CA5004B1 IS
 
PROCEDURE P (X : INTEGER) IS
BEGIN
NULL;
END P;
 
BEGIN
 
J := 5;
 
END CA5004B1;
/ca2008a2.ada
0,0 → 1,35
-- CA2008A2.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.
--*
-- WKB 6/26/81
 
SEPARATE (CA2008A0M)
 
FUNCTION CA2008A2 RETURN INTEGER IS
 
BEGIN
 
RETURN 2;
 
END CA2008A2;
/ca2009c0.ada
0,0 → 1,83
-- CA2009C0M.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 A GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND
-- INSTANTIATED. IN THIS TEST, THE SUBUNIT BODY IS IN A
-- SEPARATE FILE.
 
-- APPLICABILITY CRITERIA:
-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
 
-- SEPARATE FILES ARE:
-- CA2009C0M THE MAIN PROCEDURE.
-- CA2009C1 A SUBUNIT PACKAGE BODY (PKG1).
 
-- HISTORY:
-- BHS 08/01/84 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-- RLB 09/15/99 REMOVED JUNK COMMENT.
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2009C0M IS
 
INT1 : INTEGER := 1;
 
SUBTYPE STR15 IS STRING (1..15);
SVAR : STR15 := "ABCDEFGHIJKLMNO";
 
GENERIC
TYPE ITEM IS PRIVATE;
CON1 : IN ITEM;
VAR1 : IN OUT ITEM;
PACKAGE PKG1 IS
END PKG1;
 
PACKAGE BODY PKG1 IS SEPARATE;
 
PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1);
PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"),
SVAR);
 
BEGIN
 
TEST ("CA2009C", "SPECIFICATION AND INSTANTIATION " &
"OF GENERIC PACKAGE SUBUNITS " &
" - SEPARATE FILES USED");
 
IF INT1 /= 2 THEN
FAILED ("INCORRECT INSTANTIATION - INTEGER");
END IF;
 
IF SVAR /= "REINSTANTIATION" THEN
FAILED ("INCORRECT INSTANTIATION - STRING");
END IF;
 
 
RESULT;
 
END CA2009C0M;
/ca11b01.a
0,0 → 1,208
-- CA11B01.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 type derived in a public child inherits primitive
-- operations from parent.
--
-- TEST DESCRIPTION:
-- Declare a root record type with discriminant in a package
-- specification. Declare a primitive subprogram for the type
-- (foundation code).
--
-- Add a public child to the above package. Derive a new type
-- with constraint to the discriminant record type from the parent
-- package. Declare a new primitive subprogram to write to the child
-- derived type.
--
-- Add a new public child to the above package. This grandchild package
-- derives a new type using the record type from the above package.
-- Declare a new primitive subprogram to write to the grandchild derived
-- type.
--
-- In the main program, "with" the grandchild. Access the inherited
-- operations from grandparent, parent, and grandchild packages.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11B00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Child package of FA11B00.
package FA11B00.CA11B01_0 is -- Application_Two_Widget
-- This public child declares a derived type from its parent. It
-- represents processing of widgets in a window system.
type App2_Widget is new App1_Widget (Maximum_Size => 5000);
-- Inherits procedure Create_Widget from parent.
 
-- Primitive operation of type App2_Widget.
-- To be inherited by its children derivatives.
procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget;
Loc : in Widget_Location);
 
end FA11B00.CA11B01_0; -- Application_Two_Widget
 
--=======================================================================--
 
package body FA11B00.CA11B01_0 is -- Application_Two_Widget
 
procedure App2_Widget_Specific_Oper
(The_Widget : in out App2_Widget;
Loc : in Widget_Location) is
begin
The_Widget.Location := Loc;
end App2_Widget_Specific_Oper;
 
end FA11B00.CA11B01_0; -- Application_Two_Widget
 
--=======================================================================--
 
-- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0.
package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
-- This public grandchild declares a derived type from its parent. It
-- represents processing of widgets in a window system.
 
type App3_Widget is new App2_Widget; -- Derived record of App2_Widget.
 
-- Inherits (inherited) procedure Create_Widget from Application_One_Widget.
-- Inherits procedure App2_Widget_Specific_Oper from App2_Widget.
 
-- Primitive operation of type App3_Widget.
procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget;
S : in Widget_Size);
 
end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
 
--=======================================================================--
 
package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget
 
procedure App3_Widget_Specific_Oper
(The_Widget : in out App3_Widget;
S : in Widget_Size) is
begin
The_Widget.Size := S;
end App3_Widget_Specific_Oper;
 
end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget
 
--=======================================================================--
 
with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget,
-- implicitly with Application_Two_Widget,
-- implicitly with Application_Three_Widget.
with Report;
 
procedure CA11B01 is
 
package Application_One_Widget renames FA11B00;
package Application_Two_Widget renames FA11B00.CA11B01_0;
package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1;
 
use Application_One_Widget;
use Application_Two_Widget;
use Application_Three_Widget;
 
begin
 
Report.Test ("CA11B01", "Check that a type derived in a public " &
"child inherits primitive operations from parent");
 
Application_One_Subtest:
declare
White_Widget : App1_Widget;
 
begin
-- perform an App1_Widget specific operation.
App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
The_Widget => White_Widget, I => 10);
 
If White_Widget.Color /= White or
White_Widget.Id /= Widget_ID
(Report.Ident_Int (10)) or
White_Widget.Label /= "Line Editor " then
Report.Failed ("Incorrect result for White_Widget");
end if;
 
end Application_One_Subtest;
---------------------------------------------------------------
Application_Two_Subtest:
declare
Amber_Widget : App2_Widget;
 
begin
App1_Widget_Specific_Oper (Amber_Widget, I => 11,
C => Amber, L => "Alarm_Clock ");
-- Inherited from Application_One_Widget.
-- perform an App2_Widget specific operation.
App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512));
 
If Amber_Widget.Color /= Amber or
Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or
Amber_Widget.Label /= "Alarm_Clock " or
Amber_Widget.Location /= (380,512) then
Report.Failed ("Incorrect result for Amber_Widget");
end if;
 
end Application_Two_Subtest;
---------------------------------------------------------------
Application_Three_Subtest:
declare
Green_Widget : App3_Widget;
 
begin
App1_Widget_Specific_Oper (Green_Widget, 100, Green,
"Screen Editor ");
-- Inherited (inherited) from Basic_Widget.
 
-- perform an App2_Widget specific operation.
App2_Widget_Specific_Oper (Loc => (1024,760),
The_Widget => Green_Widget);
-- Inherited from App_1_Widget.
 
-- perform an App3_Widget specific operation.
App3_Widget_Specific_Oper (Green_Widget, S => (100,100));
 
If Green_Widget.Color /= Green or
Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or
Green_Widget.Label /= "Screen Editor " or
Green_Widget.Location /= (1024,760) or
Green_Widget.Size /= (100,100) then
Report.Failed ("Incorrect result for Green_Widget");
end if;
 
end Application_Three_Subtest;
 
Report.Result;
 
end CA11B01;
/ca110040.a
0,0 → 1,90
-- CA110040.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:
-- See CA110042.AM
--
-- TEST DESCRIPTION:
-- See CA110042.AM
--
-- TEST FILES:
-- The following files comprise this test:
--
-- => CA110040.A
-- CA110041.A
-- CA110042.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma
-- Elaborate_Body.
--
--!
 
package CA110040 is -- Package Computer_System.
pragma Elaborate_Body (CA110040);
 
-- Types.
type ID_Type is range 1 .. 4;
type System_Account_Capacity is new ID_Type;
 
type Account is tagged
record
User_ID : ID_Type;
end record;
 
-- Constants.
Maximum_System_Accounts : constant System_Account_Capacity :=
System_Account_Capacity'Last;
 
System_Administrator : constant ID_Type :=
ID_Type (System_Account_Capacity'First);
 
Administrator_Account : constant Account :=
(User_ID => System_Administrator);
 
-- Objects.
Total_Accounts : System_Account_Capacity := 1;
 
-- Exceptions.
Illegal_Account : exception;
Account_Limit_Exceeded : exception;
 
-- Subprograms.
function Next_Available_ID return ID_Type;
 
end CA110040; -- Package Computer_System.
 
--=================================================================--
 
package body CA110040 is -- Package body Computer_System.
 
function Next_Available_ID return ID_Type is
begin
Total_Accounts := Total_Accounts + 1;
return (ID_Type(Total_Accounts));
end Next_Available_ID;
 
end CA110040; -- Package body Computer_System.
/ca13a02.a
0,0 → 1,301
-- CA13A02.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 subunits declared in generic child units of a public
-- parent have the same visibility into its parent, its siblings
-- (public and private), and packages on which its parent depends
-- as is available at the point of their declaration.
--
-- TEST DESCRIPTION:
-- Declare an outside elevator button operation as a subunit in a
-- generic child package of the basic operation package (FA13A00.A).
-- This procedure has visibility into its parent ancestor and its
-- private sibling.
--
-- In the main program, instantiate the child package. Check that
-- subunits perform as expected.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA13A00.A
-- CA13A02.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Public generic child package of an elevator application. This package
-- provides outside elevator button operations.
 
generic -- Instantiate once for each floor.
Our_Floor : in Floor; -- Reference type declared in parent.
 
package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations
 
type Light is (Up, Down, Express, Off);
 
type Direction is (Up, Down, Express);
 
function Call_Elevator (D : Direction) return Light;
 
-- other type definitions and procedure declarations in real application.
 
end FA13A00_1.CA13A02_4;
 
--==================================================================--
 
-- Context clauses required for visibility needed by separate subunit.
 
with FA13A00_0; -- Building Manager
 
with FA13A00_1.FA13A00_2; -- Floor Calculation (private)
with FA13A00_1.FA13A00_3; -- Move Elevator
 
use FA13A00_0;
 
package body FA13A00_1.CA13A02_4 is
 
function Call_Elevator (D : Direction) return Light is separate;
 
end FA13A00_1.CA13A02_4;
 
--==================================================================--
 
separate (FA13A00_1.CA13A02_4)
 
-- Subunit Call_Elevator declared in Outside Elevator Button Operations.
 
function Call_Elevator (D : Direction) return Light is
Elevator_Button : Light;
 
begin
-- See if power is on.
 
if Power = Off then -- Reference package with'ed by
Elevator_Button := Off; -- the subunit parent's body.
 
else
case D is
when Express =>
FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of
(Penthouse, Call_Waiting); -- the subunit parent's body.
 
Elevator_Button := Express;
 
when Up =>
if Current_Floor < Our_Floor then
FA13A00_1.FA13A00_2.Up -- Reference private sibling of
(Floor'pos (Our_Floor) -- the subunit parent's body.
- Floor'pos (Current_Floor));
else
FA13A00_1.FA13A00_2.Down -- Reference private sibling of
(Floor'pos (Current_Floor) -- the subunit parent's body.
- Floor'pos (Our_Floor));
end if;
 
-- Call elevator.
 
Call
(Current_Floor, Call_Waiting); -- Reference subprogram declared
-- in the parent of the subunit
-- parent's body.
Elevator_Button := Up;
 
when Down =>
if Current_Floor > Our_Floor then
FA13A00_1.FA13A00_2.Down -- Reference private sibling of
(Floor'pos (Current_Floor) -- the subunit parent's body.
- Floor'pos (Our_Floor));
else
FA13A00_1.FA13A00_2.Up -- Reference private sibling of
(Floor'pos (Our_Floor) -- the subunit parent's body.
- Floor'pos (Current_Floor));
end if;
 
Elevator_Button := Down;
 
-- Call elevator.
 
Call
(Current_Floor, Call_Waiting); -- Reference subprogram declared
-- in the parent of the subunit
-- parent's body.
end case;
 
if not Call_Waiting (Current_Floor) -- Reference private part of the
then -- parent of the subunit parent's
-- body.
TC_Operation := false;
end if;
 
end if;
 
return Elevator_Button;
 
end Call_Elevator;
 
--==================================================================--
 
with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations
-- implicitly with Basic Elevator
-- Operations
with Report;
 
procedure CA13A02 is
 
begin
 
Report.Test ("CA13A02", "Check that subunits declared in generic child " &
"units of a public parent have the same visibility into " &
"its parent, its parent's siblings, and packages on " &
"which its parent depends");
 
-- Going from floor one to penthouse.
 
Going_To_Penthouse:
declare
-- Declare instance of the child generic elevator package for penthouse.
package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
(FA13A00_1.Penthouse);
 
use Call_Elevator_Pkg;
 
Call_Button_Light : Light;
 
begin
 
Call_Button_Light := Call_Elevator (Express);
 
if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then
Report.Failed ("Incorrect elevator operation going to penthouse");
end if;
 
end Going_To_Penthouse;
 
-- Going from penthouse to basement.
 
Going_To_Basement:
declare
-- Declare instance of the child generic elevator package for basement.
package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
(FA13A00_1.Basement);
 
use Call_Elevator_Pkg;
 
Call_Button_Light : Light;
 
begin
 
Call_Button_Light := Call_Elevator (Down);
 
if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
Report.Failed ("Incorrect elevator operation going to basement");
end if;
 
end Going_To_Basement;
-- Going from basement to floor three.
 
Going_To_Floor3:
declare
-- Declare instance of the child generic elevator package for floor
-- three.
package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
(FA13A00_1.Floor3);
 
use Call_Elevator_Pkg;
 
Call_Button_Light : Light;
 
begin
 
Call_Button_Light := Call_Elevator (Up);
 
if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
Report.Failed ("Incorrect elevator operation going to floor 3");
end if;
 
end Going_To_Floor3;
-- Going from floor three to floor two.
 
Going_To_Floor2:
declare
-- Declare instance of the child generic elevator package for floor two.
package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
(FA13A00_1.Floor2);
 
use Call_Elevator_Pkg;
 
Call_Button_Light : Light;
 
begin
 
Call_Button_Light := Call_Elevator (Up);
 
if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then
Report.Failed ("Incorrect elevator operation going to floor 2");
end if;
 
end Going_To_Floor2;
-- Going to floor one.
 
Going_To_Floor1:
declare
-- Declare instance of the child generic elevator package for floor one.
package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4
(FA13A00_1.Floor1);
 
use Call_Elevator_Pkg;
 
Call_Button_Light : Light;
 
begin
-- Calling elevator from floor one.
 
FA13A00_1.Current_Floor := FA13A00_1.Floor1;
 
Call_Button_Light := Call_Elevator (Down);
 
if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then
Report.Failed ("Incorrect elevator operation going to floor 1");
end if;
 
end Going_To_Floor1;
 
Report.Result;
 
end CA13A02;
/ca11c03.a
0,0 → 1,186
-- CA11C03.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 when a child unit is "withed", visibility is obtained to
-- all ancestor units named in the expanded name of the "withed" child
-- unit. Check that when the parent unit is "used", the simple name of
-- a "withed" child unit is made directly visible.
--
-- TEST DESCRIPTION:
-- To satisfy the first part of the objective, various references are
-- made to types and functions declared in the ancestor packages of the
-- foundation code package hierarchy. Since the grandchild library unit
-- package has been "withed" by this test, the visibility of these
-- components demonstrates that visibility of the ancestor package names
-- is provided when the expanded name of a child library unit is "withed".
--
-- The declare block in the test program includes a "use" clause of the
-- parent package (FA11C00_0.FA11C00_1) of the "withed" child package.
-- As a result, the simple name of the child package (FA11C00_2) is
-- directly visible. The type and function declared in the child
-- package are now visible when qualified with the simple name of the
-- "withed" package (FA11C00_2).
--
-- This test simulates the formatting of data strings, based on the
-- component fields of a "doubly-extended" tagged record type.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11C00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package
-- Animal.Mammal.Primate.
-- This will be used in conjunction with
-- a "use" of FA11C00_0.FA11C00_1 below
-- to verify a portion of the objective.
with Report;
 
procedure CA11C03 is
 
Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' ');
-- Visibility of grandparent package.
-- The package FA11C00_0 is visible since
-- it is an ancestor that is mentioned in
-- the expanded name of its "withed"
-- grandchild package.
 
Blank_Hair_Color :
String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' ');
-- Visibility of parent package.
-- The package FA11C00_0.FA11C00_1 is
-- visible due to the "with" of its
-- child package.
 
subtype Data_String_Type is String (1 .. 60);
 
TC_Result_String : Data_String_Type := (others => ' ');
 
--
 
function Format_Primate_Data (Name : String := Blank_Name_String;
Hair : String := Blank_Hair_Color)
return Data_String_Type is
 
Pos : Integer := 1;
Hair_Color_Field_Separator : constant String := " Hair Color: ";
 
Result_String : Data_String_Type := (others => ' ');
 
begin
Result_String (Pos .. Name'Length) := Name; -- Enter name at start
-- of string.
Pos := Pos + Name'Length; -- Increment counter to
-- next blank position.
Result_String
(Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) :=
Hair_Color_Field_Separator & Hair; -- Include hair color data
-- in result string.
return (Result_String);
end Format_Primate_Data;
 
 
begin
 
Report.Test ("CA11C03", "Check that when a child unit is WITHED, " &
"visibility is obtained to all ancestor units " &
"named in the expanded name of the WITHED child " &
"unit. Check that when the parent unit is USED, " &
"the simple name of a WITHED child unit is made " &
"directly visible" );
 
declare
use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct
-- visibility to the simple name of
-- package FA11C00_0.FA11C00_1.FA11C00_2,
-- since this child package was "withed" by
-- the main program.
 
Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ",
Weight => 7,
Hair_Color => Brown,
Habitat => FA11C00_2.Arboreal);
 
-- Demonstrates visibility of package
-- FA11C00_0.FA11C00_1.FA11C00_2.
--
-- Type Primate referenced with the simple
-- name of package FA11C00_2 only.
--
-- Simple name of package FA11C00_2 is
-- directly visible through "use" of parent.
 
begin
 
-- Verify that the Format_Primate_Data function will return a blank
-- filled string when no parameters are provided in the call.
 
TC_Result_String := Format_Primate_Data;
 
if (TC_Result_String (1 .. 20) /= Blank_Name_String) then
Report.Failed ("Incorrect initialization value from function");
end if;
 
 
-- Use function Format_Primate_Data to return a formatted data string.
 
TC_Result_String :=
Format_Primate_Data
(Name => FA11C00_2.Image (Tarsier),
-- Function returns a 37 character string
-- value.
Hair => Hair_Color_Type'Image(Tarsier.Hair_Color));
-- The Hair_Color_Type is referenced
-- directly, without package
-- FA11C00_0.FA11C00_1 qualifier.
-- No qualification of Hair_Color_Type is
-- needed due to "use" clause.
 
-- Note that the result of calling 'Image
-- with an enumeration type argument
-- results in an upper-case string.
-- (See conditional statement below.)
 
-- Verify the results of the function call.
 
if not (TC_Result_String (1 .. 37) =
"Primate Species: East-Indian Tarsier " and then
TC_Result_String (38 .. 55) =
" Hair Color: BROWN") then
Report.Failed ("Incorrect result returned from function call");
end if;
 
end;
 
Report.Result;
 
end CA11C03;
/ca1005a.ada
0,0 → 1,70
-- CA1005A.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 DECLARATION AND BODY CAN BE
-- SUBMITTED TOGETHER FOR COMPILATION.
 
-- JRK 5/14/81
 
 
FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER;
 
 
FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER IS
BEGIN
RETURN I + 1;
END CA1005A_F;
 
 
PROCEDURE CA1005A_P (I : IN OUT INTEGER);
 
 
PROCEDURE CA1005A_P (I : IN OUT INTEGER) IS
BEGIN
I := -I;
END CA1005A_P;
 
 
WITH REPORT, CA1005A_F, CA1005A_P;
USE REPORT;
 
PROCEDURE CA1005A IS
 
I : INTEGER := IDENT_INT (7);
 
BEGIN
TEST ("CA1005A", "SUBPROGRAM DECLARATIONS AND BODIES " &
"SUBMITTED TOGETHER");
 
IF CA1005A_F (IDENT_INT(2)) /= 3 THEN
FAILED ("FUNCTION NOT EXECUTED");
END IF;
 
CA1005A_P (I);
IF I /= -7 THEN
FAILED ("PROCEDURE NOT EXECUTED");
END IF;
 
RESULT;
END CA1005A;
/ca140281.a
0,0 → 1,67
-- CA140281.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:
-- See CA140283.AM.
--
-- TEST DESCRIPTION
-- See CA140283.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140280.A
-- -> CA140281.A
-- CA140282.A
-- CA140283.AM
--
-- CHANGE HISTORY:
-- JBG 05/28/85 CREATED ORGINAL TEST.
-- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE
-- NOT THE SAME.
-- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format.
 
PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS
BEGIN
X := 3;
END CA14028_PROC1;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
FUNCTION CA14028_FUNC2 RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(4);
END CA14028_FUNC2;
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS
BEGIN
X := FALSE;
Y := IDENT_INT(6);
END CA14028_PROC3;
 
FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS
BEGIN
RETURN FALSE;
END CA14028_FUNC3;
/ca11002.a
0,0 → 1,238
-- CA11002.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 public child can utilize its parent unit's visible
-- definitions.
--
-- TEST DESCRIPTION:
-- Declare a parent package that contains the following: type, object,
-- constant, exception, and subprograms. Declare a public child unit
-- that utilizes the components found in the visible part of its parent.
--
-- Demonstrate utilization of the following parent components in the
-- child package:
--
-- Parent
-- Type X
-- Constant X
-- Object X
-- Subprogram X
-- Exception X
--
-- This abstraction simulates a portion of a simple operating system.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package CA11002_0 is -- Package OS.
 
type File_Descriptor is new Integer;
type File_Mode is (Read_Only, Write_Only, Read_Write);
 
Null_File : constant File_Descriptor := 0;
Default_Mode : constant File_Mode := Read_Only;
Active_Mode : constant File_Mode := Read_Write;
 
type File_Type is
record
Descriptor : File_Descriptor := Null_File;
Mode : File_Mode := Default_Mode;
end record;
 
System_File : File_Type;
File_Mode_Error : exception;
 
function Next_Available_File return File_Descriptor;
 
function Mode_Of_File (File : File_Type) return File_Mode;
 
end CA11002_0; -- Package OS.
 
--=================================================================--
 
package body CA11002_0 is -- Package body OS.
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;
--------------------------------------------------------------
function Mode_Of_File (File : File_Type) return File_Mode is
Mode : File_Mode := File.Mode;
begin
return (Mode);
end Mode_Of_File;
 
end CA11002_0; -- Package body OS.
 
--=================================================================--
 
package CA11002_0.CA11002_1 is -- Child package OS.Operations.
 
-- Dot qualification of types, objects, etc. from parent is not required
-- in a child unit.
 
procedure Create_File (Mode : in File_Mode:= Active_Mode;
File : out File_Type);
 
end CA11002_0.CA11002_1; -- Child package OS.Operations.
 
--=================================================================--
 
with Report;
package body CA11002_0.CA11002_1 is -- Child package body OS.Operations.
 
function New_File_Validated (File : File_Type) -- Ensure that a newly
return Boolean is -- created file has
Result : Boolean := False; -- appropriate values.
begin
if (File.Descriptor > System_File.Descriptor) and -- Parent object.
(File.Mode in File_Mode ) -- Parent type.
then
Result := True;
end if;
 
return (Result);
 
end New_File_Validated;
--------------------------------------------------------------
procedure Create_File
(Mode : in File_Mode := Active_Mode; -- Parent constant.
File : out File_Type) is -- Parent type.
 
New_File : File_Type;
 
begin
New_File.Descriptor := Next_Available_File; -- Parent subprogram.
New_File.Mode := Mode;
 
if New_File_Validated (File => New_File) then
File := New_File;
end if;
 
end Create_File;
 
end CA11002_0.CA11002_1; -- Child Package body OS.Operations.
 
--=================================================================--
 
-- Child library subprogram Convert_File_Mode specification.
procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type.
New_Mode : in File_Mode); -- Parent type.
 
 
--=================================================================--
with Report;
 
-- Child library subprogram Convert_File_Mode body.
procedure CA11002_0.CA11002_2 (File : in out File_Type;
New_Mode : in File_Mode) is
begin
if File.Mode = New_Mode then
raise File_Mode_Error; -- Parent exception.
Report.Failed ("Exception not raised in child unit");
else
File.Mode := New_Mode;
end if;
end CA11002_0.CA11002_2;
 
--=================================================================--
 
with Report;
with CA11002_0.CA11002_1; -- Child package OS.Operations.
with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode,
-- Implicitly with parent, OS.
use CA11002_0; -- All user-defined operators directly
-- visible.
procedure CA11002 is
begin
 
Report.Test ("CA11002", "Check that a public child can utilize its " &
"parent unit's visible definitions");
 
File_Creation: -- This processing block will demonstrate
-- use of child package subroutine that
-- takes advantage of components declared
-- in the parent package.
declare
User_File : File_Type;
begin
CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode
-- parameter used in
-- this call.
if (User_File.Descriptor = System_File.Descriptor) or
(User_File.Mode = Default_Mode)
then
Report.Failed ("Incorrect file creation");
end if;
 
end File_Creation;
 
--------------------------------------------------------------
File_Mode_Conversion: -- This processing block will demonstrate
-- the occurrence of a (forced) exception
-- being raised in a child subprogram, and
-- propagated to the caller. The exception
-- is handled, and the child subprogram
-- is called again, this time to perform
-- without error.
declare
procedure Convert_File_Mode (File : in out File_Type;
New_Mode : in File_Mode) renames CA11002_0.CA11002_2;
New_File : File_Type;
begin -- Raise an exception with this
-- illegal conversion operation
-- (attempt to change to current mode).
 
Convert_File_Mode (File => New_File,
New_Mode => Default_Mode);
Report.Failed ("Exception should have been raised in child unit");
 
exception
when File_Mode_Error => -- Perform the conversion again, this
-- time with a different file mode.
 
Convert_File_Mode (File => New_File,
New_Mode => CA11002_0.Active_Mode);
 
if New_File.Mode /= Read_Write then
Report.Failed ("Incorrect result from mode conversion operation");
end if;
 
when others =>
Report.Failed ("Unexpected exception raised in File_Mode_Conversion");
 
end File_Mode_Conversion;
 
Report.Result;
 
end CA11002;
/ca2009d.ada
0,0 → 1,95
-- CA2009D.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 GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND
-- INSTANTIATED.
 
-- BHS 8/01/84
-- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323.
 
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2009D IS
 
INT1 : INTEGER := 1;
INT2 : INTEGER := 2;
 
 
GENERIC
TYPE ELEM IS PRIVATE;
PCON1 : IN ELEM;
PVAR1 : IN OUT ELEM;
PROCEDURE PROC1;
 
 
GENERIC
TYPE OBJ IS PRIVATE;
FCON1 : IN OBJ;
FVAR1 : IN OUT OBJ;
FUNCTION FUNC1 RETURN OBJ;
 
 
PROCEDURE PROC1 IS SEPARATE;
FUNCTION FUNC1 RETURN OBJ IS SEPARATE;
 
 
PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1);
FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 3, INT2);
 
 
BEGIN
 
TEST ("CA2009D", "SPECIFICATION AND INSTANTIATION " &
"OF GENERIC SUBPROGRAM SUBUNITS");
 
NI_PROC1;
IF INT1 /= 2 THEN
FAILED ("INCORRECT INSTANTIATION - NI_PROC1");
END IF;
 
 
IF NI_FUNC1 /= 3 THEN
FAILED ("INCORRECT INSTANTIATION - NI_FUNC1");
END IF;
 
 
RESULT;
 
END CA2009D;
 
 
SEPARATE (CA2009D)
PROCEDURE PROC1 IS
BEGIN
PVAR1 := PCON1;
END PROC1;
 
 
SEPARATE (CA2009D)
FUNCTION FUNC1 RETURN OBJ IS
BEGIN
FVAR1 := FCON1;
RETURN FVAR1;
END FUNC1;
/ca13001.a
0,0 → 1,370
-- CA13001.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 separate protected unit declared in a non-generic child
-- unit of a private parent have the same visibility into its parent,
-- its siblings, and packages on which its parent depends as is available
-- at the point of their declaration.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of having all
-- members of one family to take out a transportation. The restriction
-- is depend on each member to determine who can get a car, a clunker,
-- or a bicycle. If no transportation is available, that member has to
-- walk.
--
-- Declare a package with location for each family member. Declare
-- a public parent package. Declare a private child package. Declare a
-- public grandchild of this private package. Declare a protected unit
-- as a subunit in a public grandchild package. This subunit has
-- visibility into it's parent body ancestor and its sibling.
--
-- Declare another public parent package. The body of this package has
-- visibility into its private sibling's descendants.
--
-- In the main program, "with"s the parent package. Check that the
-- protected subunit performs as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1
--
--!
 
package CA13001_0 is
 
type Location is (School, Work, Beach, Home);
type Family is (Father, Mother, Teen);
Destination : array (Family) of Location;
 
-- Other type definitions and procedure declarations in real application.
 
end CA13001_0;
 
-- No bodies required for CA13001_0.
 
--==================================================================--
 
-- Public parent.
 
package CA13001_1 is
 
type Transportation is (Bicycle, Clunker, New_Car);
type Key_Type is private;
Walking : boolean := false;
 
-- Other type definitions and procedure declarations in real application.
 
private
type Key_Type
is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car);
 
end CA13001_1;
 
-- No bodies required for CA13001_1.
 
--==================================================================--
 
-- Private child.
 
private package CA13001_1.CA13001_2 is
 
type Transport is
record
In_Use : boolean := false;
end record;
Vehicles : array (Transportation) of Transport;
 
-- Other type definitions and procedure declarations in real application.
 
end CA13001_1.CA13001_2;
 
-- No bodies required for CA13001_1.CA13001_2.
 
--==================================================================--
 
-- Public grandchild of a private parent.
 
package CA13001_1.CA13001_2.CA13001_3 is
 
Flat_Tire : array (Transportation) of boolean := (others => false);
 
-- Other type definitions and procedure declarations in real application.
 
end CA13001_1.CA13001_2.CA13001_3;
 
-- No bodies required for CA13001_1.CA13001_2.CA13001_3.
 
--==================================================================--
 
-- Context clauses required for visibility needed by a separate subunit.
 
with CA13001_0;
use CA13001_0;
 
-- Public grandchild of a private parent.
 
package CA13001_1.CA13001_2.CA13001_4 is
 
type Transit is
record
Available : boolean := false;
end record;
type Keys_Array is array (Transportation) of Transit;
Fuel : array (Transportation) of boolean := (others => true);
 
protected Family_Transportation is
 
procedure Get_Vehicle (Who : in Family;
Key : out Key_Type);
procedure Return_Vehicle (Tr : in Transportation);
function TC_Verify (What : Transportation) return boolean;
 
private
Keys : Keys_Array;
 
end Family_Transportation;
 
end CA13001_1.CA13001_2.CA13001_4;
 
--==================================================================--
 
-- Context clause required for visibility needed by a separate subunit.
 
with CA13001_1.CA13001_2.CA13001_3; -- Public sibling.
 
package body CA13001_1.CA13001_2.CA13001_4 is
 
protected body Family_Transportation is separate;
 
end CA13001_1.CA13001_2.CA13001_4;
 
--==================================================================--
 
separate (CA13001_1.CA13001_2.CA13001_4)
protected body Family_Transportation is
 
procedure Get_Vehicle (Who : in Family;
Key : out Key_Type) is
begin
case Who is
when Father|Mother =>
-- Drive new car to work
 
-- Reference package with'ed by the subunit parent's body.
if Destination(Who) = Work then
 
-- Reference type declared in the private parent of the subunit
-- parent's body.
-- Reference type declared in the visible part of the
-- subunit parent's body.
if not Vehicles(New_Car).In_Use and Fuel(New_Car)
 
-- Reference type declared in the public sibling of the
-- subunit parent's body.
and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then
Vehicles(New_Car).In_Use := true;
 
-- Reference type declared in the private part of the
-- protected subunit.
Keys(New_Car).Available := false;
Key := Transportation'pos(New_Car);
else
-- Reference type declared in the grandparent of the subunit
-- parent's body.
Walking := true;
end if;
 
-- Drive clunker to other destinations.
else
if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
Vehicles(Clunker).In_Use := true;
Keys(Clunker).Available := false;
Key := Transportation'pos(Clunker);
else
Walking := true;
Key := Transportation'pos(Bicycle);
end if;
end if;
-- Similar for Teen.
when Teen =>
if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not
CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
Vehicles(Clunker).In_Use := true;
Keys(Clunker).Available := false;
Key := Transportation'pos(Clunker);
else
Walking := true;
Key := Transportation'pos(Bicycle);
end if;
end case;
 
end Get_Vehicle;
 
----------------------------------------------------------------
 
-- Any family member can bring back the transportation with the key.
 
procedure Return_Vehicle (Tr : in Transportation) is
begin
Vehicles(Tr).In_Use := false;
Keys(Tr).Available := true;
end Return_Vehicle;
 
----------------------------------------------------------------
 
function TC_Verify (What : Transportation) return boolean is
begin
return Keys(What).Available;
end TC_Verify;
end Family_Transportation;
 
--==================================================================--
 
with CA13001_0;
use CA13001_0;
 
-- Public child.
 
package CA13001_1.CA13001_5 is
 
-- In a real application, tasks could be used to demonstrate
-- a family transportation scenario, i.e., each member of
-- a family can take a vehicle out concurrently, then return
-- them at the same time. For the purposes of the test, family
-- transportation happens sequentially.
 
procedure Provide_Transportation (Who : in Family;
Get_Key : out Key_Type;
Get_Veh : out boolean);
procedure Return_Transportation (What : in Transportation;
Rt_Veh : out boolean);
 
end CA13001_1.CA13001_5;
 
--==================================================================--
 
with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent,
-- implicitly with CA13001_1.CA13001_2.
package body CA13001_1.CA13001_5 is
 
package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4;
use Transportation_Pkg;
 
-- These two validation subprograms provide the capability to check the
-- components defined in the private packages from within the client
-- program.
 
procedure Provide_Transportation (Who : in Family;
Get_Key : out Key_Type;
Get_Veh : out boolean) is
begin
-- Goto work, school, or to the beach.
Family_Transportation.Get_Vehicle (Who, Get_Key);
if not Family_Transportation.TC_Verify
(Transportation'Val(Get_Key)) then
Get_Veh := true;
else
Get_Veh := false;
end if;
 
end Provide_Transportation;
 
----------------------------------------------------------------
 
procedure Return_Transportation (What : in Transportation;
Rt_Veh : out boolean) is
begin
Family_Transportation.Return_Vehicle (What);
if Family_Transportation.TC_Verify(What) and
not CA13001_1.CA13001_2.Vehicles(What).In_Use then
Rt_Veh := true;
else
Rt_Veh := false;
end if;
 
end Return_Transportation;
 
end CA13001_1.CA13001_5;
 
--==================================================================--
 
with CA13001_0;
with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1.
with Report;
 
procedure CA13001 is
 
Mommy : CA13001_0.Family := CA13001_0.Mother;
Daddy : CA13001_0.Family := CA13001_0.Father;
BG : CA13001_0.Family := CA13001_0.Teen;
BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker;
Get_Key : CA13001_1.Key_Type;
Get_Transit : boolean := false;
Return_Transit : boolean := false;
 
begin
Report.Test ("CA13001", "Check that a protected subunit declared in " &
"a child unit of a private parent have the same visibility " &
"into its parent, its parent's siblings, and packages on " &
"which its parent depends");
 
-- Get transportation for mother to go to work.
CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work;
CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit);
if not Get_Transit then
Report.Failed ("Failed to get mother transportation");
end if;
 
-- Get transportation for teen to go to school.
CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School;
Get_Transit := false;
CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit);
if not Get_Transit then
Report.Failed ("Failed to get teen transportation");
end if;
 
-- Get transportation for father to go to the beach.
CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach;
Get_Transit := false;
CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit);
if Get_Transit and not CA13001_1.Walking then
Report.Failed ("Failed to make daddy to walk to the beach");
end if;
 
-- Return the clunker.
CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit);
if not Return_Transit then
Report.Failed ("Failed to get back the clunker");
end if;
 
Report.Result;
 
end CA13001;
/ca11006.a
0,0 → 1,211
-- CA11006.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 private part of a child library unit can utilize
-- its parent unit's private definition.
--
-- TEST DESCRIPTION:
-- Declare a package and public child package, both with private
-- parts. The child package will have a private extension of a type
-- declared in the parent's private part. In addition, the private
-- part of the child package specification will make use of some of
-- the components declared in the private part of the parent.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1
--
--!
 
package CA11006_0 is -- Package File_Package
 
type File_Descriptor is private;
type File_Mode is (Read_Only, Write_Only, Read_Write);
type File_Type is tagged private;
 
function Next_Available_File return File_Descriptor;
 
private
 
type File_Measure is range 0 .. 1000;
type File_Descriptor is new Integer;
 
Null_File : constant File_Descriptor := 0;
Default_Mode : constant File_Mode := Read_Write;
 
type File_Type is tagged
record
Descriptor : File_Descriptor := Null_File;
Mode : File_Mode := Default_Mode;
end record;
 
System_File : File_Type;
 
end CA11006_0; -- Package File_Package
 
--=================================================================--
 
package body CA11006_0 is -- Package File_Package
File_Count : Integer := 0;
 
function Next_Available_File return File_Descriptor is
begin
File_Count := File_Count + 1;
return File_Descriptor (File_Count);
end Next_Available_File;
 
end CA11006_0; -- Package File_Package
 
--=================================================================--
 
package CA11006_0.CA11006_1 is -- Child package File_Package.Operations
 
type File_Length_Type is private;
type Extended_File_Type is new File_Type with private;
 
System_Extended_File : constant Extended_File_Type;
 
procedure Create_File (Mode : in File_Mode;
File : out Extended_File_Type);
 
procedure Compress_File (Original : in Extended_File_Type;
Compressed_File : out Extended_File_Type);
 
function Validate (File : in Extended_File_Type) return Boolean;
 
function Validate_Compression (File : in Extended_File_Type)
return Boolean;
-- These two validation functions provide
-- the capability to check the private
-- components defined in the parent and
-- child packages from within the client
-- program.
private
 
type File_Length_Type is new File_Measure; -- Parent private type.
 
Min_File_Size : File_Length_Type := File_Length_Type'First;
Max_File_Size : File_Length_Type := File_Length_Type'Last;
 
type Extended_File_Type is new File_Type with -- Parent type.
record
Blocks : File_Length_Type := Min_File_Size;
end record;
 
System_Extended_File : constant Extended_File_Type :=
(Descriptor => System_File.Descriptor, -- Parent private object.
Mode => Read_Only, -- Parent enumeration literal.
Blocks => Min_File_Size);
 
 
end CA11006_0.CA11006_1; -- Child Package File_Package.Operations
 
--=================================================================--
 
-- Child package body File_Package.Operations
package body CA11006_0.CA11006_1 is
 
procedure Create_File
(Mode : in File_Mode;
File : out Extended_File_Type) is
begin
File.Descriptor := Next_Available_File; -- Parent subprogram.
File.Mode := Default_Mode; -- Parent private constant.
File.Blocks := Max_File_Size;
end Create_File;
------------------------------------------------------------------------
procedure Compress_File (Original : in Extended_File_Type;
Compressed_File : out Extended_File_Type) is
begin
Compressed_File.Descriptor := Next_Available_File;
Compressed_File.Mode := Read_Only;
Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file
end Compress_File; -- compression.
------------------------------------------------------------------------
function Validate (File : in Extended_File_Type) return Boolean is
begin
if ((File.Descriptor /= System_Extended_File.Descriptor) and
(File.Mode = Read_Write) and
(File.Blocks = Max_File_Size)) then
return True;
else
return False;
end if;
end Validate;
------------------------------------------------------------------------
function Validate_Compression (File : in Extended_File_Type)
return Boolean is
begin
if ((File.Descriptor /= System_File.Descriptor) and
(File.Mode = Read_Only) and
(File.Blocks = Max_File_Size/2)) then
return True;
else
return False;
end if;
end Validate_Compression;
 
end CA11006_0.CA11006_1; -- Child package body File_Package.Operations
 
--=================================================================--
 
with CA11006_0.CA11006_1; -- with Child package File_Package.Operations
with Report;
 
procedure CA11006 is
 
package File renames CA11006_0;
package File_Ops renames CA11006_0.CA11006_1;
 
Validation_File_Mode : File.File_Mode := File.Read_Only;
Validation_File,
Storage_Copy : File_Ops.Extended_File_Type;
 
begin
 
Report.Test ("CA11006", "Check that the private part of a child " &
"library unit can utilize its parent " &
"unit's private definition");
 
File_Ops.Create_File (Validation_File_Mode, Validation_File);
 
if not File_Ops.Validate (Validation_File) then
Report.Failed ("Incorrect initialization of file");
end if;
 
File_Ops.Compress_File (Validation_File, Storage_Copy);
 
if not (File_Ops.Validate (Validation_File) and
File_Ops.Validate_Compression (Storage_Copy))
then
Report.Failed ("Incorrect compression of file");
end if;
 
Report.Result;
 
end CA11006;
/ca11d012.a
0,0 → 1,73
-- CA11D012.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:
-- See CA11D013.AM
--
-- TEST DESCRIPTION:
-- See CA11D013.AM
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FA11D00.A
-- CA11D010.A
-- CA11D011.A
-- => CA11D012.A
-- CA11D013.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Dec 94 SAIC Declared child function specification
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
--
--!
 
with Report;
 
-- Child function of FA11D00.
-- Does not divide zero complex numbers.
 
function FA11D00.CA11D012 (Left, Right : Complex_Type)
return Complex_Type;
 
--=======================================================================--
 
function FA11D00.CA11D012 (Left, Right : Complex_Type)
return Complex_Type is -- Divide_Complex
 
begin
-- Zero is declared in parent package.
 
if Right.Real = Zero.Real or Right.Imag = Zero.Imag then
raise Divide_Error; -- Reference to exception in parent package.
Report.Failed ("Program control not transferred by raise in " &
"child function FA11D00.CA11D012");
else
return ( Real => (Left.Real / Right.Real),
Imag => (Left.Imag / Right.Imag) );
end if;
 
end FA11D00.CA11D012; -- Divide_Complex
/ca1022a0.ada
0,0 → 1,43
-- CA1022A0.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.
--*
-- BHS 7/23/84
 
PACKAGE CA1022A0 IS
 
I : INTEGER := 2;
PROCEDURE P0 (X : IN OUT INTEGER );
 
END CA1022A0;
 
PACKAGE BODY CA1022A0 IS
 
PROCEDURE P0 (X : IN OUT INTEGER) IS
BEGIN
 
X := X + 1;
 
END P0;
 
END CA1022A0;
/ca1022a2.ada
0,0 → 1,33
-- CA1022A2.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.
--*
-- BHS 7/23/84
 
WITH CA1022A0;
FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS
BEGIN
 
RETURN TRUE;
 
END CA1022A2;
/ca1020e0.ada
0,0 → 1,53
-- CA1020E0.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 A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
-- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS.
 
-- HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
-- DECLARED WITHOUT A BODY.
 
GENERIC
C : INTEGER;
PROCEDURE GENPROC_CA1020E (X : OUT INTEGER);
 
WITH REPORT; USE REPORT;
PRAGMA ELABORATE (REPORT);
PROCEDURE GENPROC_CA1020E (X : OUT INTEGER) IS
BEGIN
X := IDENT_INT(C);
END GENPROC_CA1020E;
 
GENERIC
FUNCTION GENFUNC_CA1020E RETURN INTEGER;
 
FUNCTION GENFUNC_CA1020E RETURN INTEGER IS
BEGIN
RETURN 2;
END GENFUNC_CA1020E;
/ca1020e2.ada
0,0 → 1,51
-- CA1020E2.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 A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC
-- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS
-- GENERIC INSTANTIATIONS REPLACING LIBRARY UNITS CREATED IN
-- CA1020E1.
 
-- HISTORY:
-- JBG 05/28/85 CREATED ORIGINAL TEST.
-- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT
-- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST
-- DECLARED WITHOUT A BODY.
 
WITH GENPROC_CA1020E;
PRAGMA ELABORATE (GENPROC_CA1020E);
PROCEDURE CA1020E_PROC1 IS NEW GENPROC_CA1020E(1);
 
WITH GENFUNC_CA1020E;
PRAGMA ELABORATE (GENFUNC_CA1020E);
FUNCTION CA1020E_FUNC1 IS NEW GENFUNC_CA1020E;
 
WITH GENPROC_CA1020E;
PRAGMA ELABORATE (GENPROC_CA1020E);
PROCEDURE CA1020E_PROC2 IS NEW GENPROC_CA1020E(5);
 
WITH GENFUNC_CA1020E;
PRAGMA ELABORATE (GENFUNC_CA1020E);
FUNCTION CA1020E_FUNC2 IS NEW GENFUNC_CA1020E;
/ca1022a4.ada
0,0 → 1,36
-- CA1022A4.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.
--*
-- RECOMPILATION OF PROCEDURE CA1022A1.
 
-- BHS 7/23/84
 
WITH CA1022A0;
PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS
BEGIN
 
Y := 3;
CA1022A0.P0 (Y);
 
END CA1022A1;
/ca5003a1.ada
0,0 → 1,34
-- CA5003A1.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH CA5003A0;
USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
PACKAGE CA5003A1 IS
 
A1 : INTEGER := SHOW_ELAB ('1');
 
END CA5003A1;
/ca2001h0.ada
0,0 → 1,40
-- CA2001H0.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.
--*
-- WKB 6/25/81
-- JBG 8/25/83
 
FUNCTION CA2001H0 RETURN INTEGER IS
 
PACKAGE CA2001H1 IS
I : INTEGER := 0;
END CA2001H1;
 
PACKAGE BODY CA2001H1 IS SEPARATE;
 
BEGIN
RETURN CA2001H1.I;
 
END CA2001H0;
/ca1022a6.ada
0,0 → 1,66
-- CA1022A6M.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 SUBPROGRAM BODY IS INITIALLY COMPILED WITH A CONTEXT
-- CLAUSE AND A UNIT NAMED IN THE CONTEXT CLAUSE IS RECOMPILED, THEN AN
-- ATTEMPT TO COMPILE THE BODY AGAIN WILL SUCCEED IF THE CONTEXT CLAUSE
-- IS PRESENT.
-- CHECK THAT IF THE RECOMPILED UNIT IS NOT NEEDED IN THE SUBPROGRAM
-- BODY, THE BODY CAN BE SUCCESSFULLY RECOMPILED WITHOUT MENTIONING THE
-- RECOMPILED UNIT.
 
-- SEPARATE FILES ARE:
-- CA1022A0 A LIBRARY PACKAGE.
-- CA1022A1 A LIBRARY PROCEDURE.
-- CA1022A2 A LIBRARY FUNCTION.
-- CA1022A3 A LIBRARY PACKAGE (CA1022A0).
-- CA1022A4 A LIBRARY PROCEDURE (CA1022A1).
-- CA1022A5 A LIBRARY FUNCTION (CA1022A2).
-- CA1022A6M THE MAIN PROCEDURE.
 
-- BHS 7/23/84
 
WITH CA1022A1, CA1022A2;
WITH REPORT; USE REPORT;
PROCEDURE CA1022A6M IS
 
I : INTEGER := 1;
 
BEGIN
 
TEST ("CA1022A", "USE OF CONTEXT CLAUSES NAMING RECOMPILED " &
"UNITS WITH RECOMPILED SUBPROGRAMS");
 
CA1022A1(I);
IF I /= 5 THEN
FAILED ("PROCEDURE CA1022A1 NOT INVOKED CORRECTLY");
END IF;
 
IF CA1022A2 THEN
FAILED ("FUNCTION CA1022A2 NOT INVOKED CORRECTLY");
END IF;
 
RESULT;
 
END CA1022A6M;
/ca5003a3.ada
0,0 → 1,34
-- CA5003A3.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH CA5003A0, CA5003A2;
USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
PACKAGE CA5003A3 IS
 
A3 : INTEGER := SHOW_ELAB ('3');
 
END CA5003A3;
/ca2001h2.ada
0,0 → 1,38
-- CA2001H2.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.
--*
-- WKB 6/25/81
-- JBG 8/25/83
 
FUNCTION CA2001H0 RETURN INTEGER IS
 
PACKAGE CA2001H1 IS
I : INTEGER := 2;
END CA2001H1;
 
BEGIN
 
RETURN CA2001H1.I;
 
END CA2001H0;
/ca5003a5.ada
0,0 → 1,34
-- CA5003A5.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
 
WITH CA5003A0, CA5003A3, CA5003A4;
USE CA5003A0; PRAGMA ELABORATE (CA5003A0);
PACKAGE CA5003A5 IS
 
A5 : INTEGER := SHOW_ELAB ('5');
 
END CA5003A5;
/ca140231.a
0,0 → 1,59
-- CA140231.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:
-- See CA140232.AM.
--
-- TEST DESCRIPTION:
-- See CA140232.AM.
--
-- TEST FILES:
-- This test consists of the following files:
-- CA140230.A
-- -> CA140231.A
-- CA140232.AM
-- CA140233.A
--
-- PASS/FAIL CRITERIA:
-- See CA140232.AM.
--
-- CHANGE HISTORY:
-- 07 DEC 96 SAIC ACVC 2.1: Initial version.
-- 13 SEP 99 RLB Changed to C-test (by AI-00077).
-- 20 MAR 00 RLB Removed special requirements, because there
-- aren't any.
--
--!
 
function CA14023_1 (P1, P2 : Data_type) return Data_type is
begin
if Floor > P1 and Floor > P2 then
return Floor;
elsif P2 > P1 then
return P2;
else
return P1;
end if;
end CA14023_1;
/ca11011.a
0,0 → 1,271
-- CA11011.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 child package can use entities declared in the
-- private part of the parent unit of its parent unit.
--
-- TEST DESCRIPTION:
-- Declare a parent package containing private types and objects
-- used by the system. Declare a public child package that
-- provides a visible interface to the system functionality.
-- Declare a private grandchild package that uses the visible grandparent
-- components to provide the actual functionality to the system.
--
-- The public child (parent of the private grandchild) uses the
-- functionality of its private child (grandchild package) to provide
-- the visible interface to operations of the system.
--
-- The test itself will utilize the visible interface provided in the
-- public child package to demonstrate a possible solution to file
-- management.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
package CA11011_0 is -- Package OS.
 
type File_Descriptor_Type is private;
 
Default_Descriptor : constant File_Descriptor_Type;
First_File : constant File_Descriptor_Type;
 
procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
Status : out Boolean);
 
function Final_Conditions_Valid (Key : File_Descriptor_Type)
return Boolean;
 
 
private
 
type File_Descriptor_Type is new Integer;
type File_Name_Type is new String (1 .. 11);
type Permission_Type is (None, User, System);
type File_Mode_Type is (Read_Only, Write_Only, Read_Write);
type File_Status_Type is (Open, Closed);
 
Default_Descriptor : constant File_Descriptor_Type := 0;
First_File : constant File_Descriptor_Type := 1;
Default_Permission : constant Permission_Type := None;
Default_Mode : constant File_Mode_Type := Read_Only;
Default_Status : constant File_Status_Type := Closed;
Default_Filename : constant File_Name_Type := " ";
 
Init_Permission : constant Permission_Type := User;
Init_Mode : constant File_Mode_Type := Read_Write;
Init_Status : constant File_Status_Type := Open;
An_Ada_File_Name : constant File_Name_Type := "AdaFileName";
 
Max_Files : constant File_Descriptor_Type := 10;
 
type File_Type is tagged
record
Descriptor : File_Descriptor_Type := Default_Descriptor;
Name : File_Name_Type := Default_Filename;
Acct_Access : Permission_Type := Default_Permission;
Mode : File_Mode_Type := Default_Mode;
Current_Status : File_Status_Type := Default_Status;
end record;
 
type File_Array_Type is array (1 .. Max_Files) of File_Type;
 
File_Table : File_Array_Type;
File_Counter : Integer := 0;
 
--
 
function Get_File_Name return File_Name_Type;
 
end CA11011_0; -- Package OS.
 
--=================================================================--
 
package body CA11011_0 is -- Package body OS.
 
function Get_File_Name return File_Name_Type is
begin
return (An_Ada_File_Name);
end Get_File_Name;
---------------------------------------------------------------------
procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type;
Status : out Boolean) is
begin
Status := False;
if (File_Table(Key).Descriptor = Default_Descriptor) and then
(File_Table(Key).Name = Default_Filename) and then
(File_Table(Key).Acct_Access = Default_Permission) and then
(File_Table(Key).Mode = Default_Mode) and then
(File_Table(Key).Current_Status = Default_Status)
then
Status := True;
end if;
end Verify_Initial_Conditions;
---------------------------------------------------------------------
function Final_Conditions_Valid (Key : File_Descriptor_Type)
return Boolean is
begin
if ((File_Table(Key).Descriptor = First_File) and then
(File_Table(Key).Name = An_Ada_File_Name) and then
(File_Table(Key).Acct_Access = Init_Permission) and then
not ((File_Table(Key).Mode = Default_Mode) or else
(File_Table(Key).Current_Status = Default_Status)))
then
return (True);
else
return (False);
end if;
end Final_Conditions_Valid;
 
end CA11011_0; -- Package body OS.
 
--=================================================================--
 
package CA11011_0.CA11011_1 is -- Package OS.File_Manager
 
procedure Create_File (File_Key : in File_Descriptor_Type);
 
end CA11011_0.CA11011_1; -- Package OS.File_Manager
 
--=================================================================--
 
-- The Subprogram that performs the actual file operations is contained in a
-- private package so that it is not accessible to any client.
-- Default parameters are used in most cases in the subprogram calls, since
-- the caller does not have visibility to these private types.
 
-- Package OS.File_Manager.Internals
private package CA11011_0.CA11011_1.CA11011_2 is
 
Private_File_Counter : Integer renames File_Counter; -- Grandparent
-- object.
procedure Create
(Key : in File_Descriptor_Type;
File_Name : in File_Name_Type := Get_File_Name; -- Grandparent
-- prvt type,
-- prvt functn.
File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent
-- prvt type,
-- prvt const.
File_Access : in Permission_Type := Init_Permission; -- Grandparent
-- prvt type,
-- prvt const.
File_Status : in File_Status_Type := Init_Status); -- Grandparent
-- prvt type,
-- prvt const.
 
end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals
 
--=================================================================--
 
-- Package Body OS.File_Manager.Internals
package body CA11011_0.CA11011_1.CA11011_2 is
 
procedure Create
(Key : in File_Descriptor_Type;
File_Name : in File_Name_Type := Get_File_Name;
File_Mode : in File_Mode_Type := Init_Mode;
File_Access : in Permission_Type := Init_Permission;
File_Status : in File_Status_Type := Init_Status) is
begin
Private_File_Counter := Private_File_Counter + 1;
File_Table(Key).Descriptor := Key; -- Grandparent object.
File_Table(Key).Name := File_Name;
File_Table(Key).Mode := File_Mode;
File_Table(Key).Acct_Access := File_Access;
File_Table(Key).Current_Status := File_Status;
end Create;
 
end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals
 
--=================================================================--
 
with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals
 
package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager
 
package Internal renames CA11011_0.CA11011_1.CA11011_2;
 
-- This subprogram utilizes a call to a subprogram contained in a private
-- child to perform the actual processing.
 
procedure Create_File (File_Key : in File_Descriptor_Type) is
begin
Internal.Create (Key => File_Key); -- Other parameters are defaults,
-- since they are of private types
-- from the parent package.
-- File_Descriptor_Type is private,
-- but declared in visible part of
-- parent spec.
end Create_File;
 
end CA11011_0.CA11011_1; -- Package body OS.File_Manager
 
--=================================================================--
 
with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager
with Report;
 
procedure CA11011 is
 
package OS renames CA11011_0;
package File_Manager renames CA11011_0.CA11011_1;
 
Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File;
TC_Status : Boolean := False;
 
begin
 
-- This test indicates one approach to file management operations.
-- It is not intended to demonstrate full functionality, but rather
-- that the use of a private child package can provide a solution
-- to a typical user situation.
 
Report.Test ("CA11011", "Check that a private child package can use " &
"entities declared in the private part of the " &
"parent unit of its parent unit");
 
OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status);
 
if not TC_Status then
Report.Failed ("Initial condition failure");
end if;
 
-- Perform file initializations.
 
File_Manager.Create_File (File_Key => Data_Base_File_Key);
 
TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key);
 
if not TC_Status then
Report.Failed ("Bad status return from Create_File");
end if;
 
Report.Result;
 
end CA11011;
/ca11015.a
0,0 → 1,312
-- CA11015.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 generic child of a non-generic package can use its
-- parent's declarations and operations. Check that the instantiation
-- of the generic child can correctly use the operations.
--
-- TEST DESCRIPTION:
-- Declare a map abstraction in a package which manages basic physical
-- maps. Declare a generic child of this package which defines copies
-- of maps of any discrete type, i.e., population, density, or weather.
--
-- In the main program, declare an instance of the child. Check that
-- the operations in the parent and instance of the child package
-- perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Simulates map of physical features, i.e., desert, forest, water,
-- or plains.
 
package CA11015_0 is
type Map_Type is private;
subtype Latitude is integer range 1 .. 9;
subtype Longitude is integer range 1 .. 7;
 
type Physical_Features is (Desert, Forest, Water, Plains, Unexplored);
type Page_Type is range 0 .. 80;
Terra_Incognita : exception;
 
-- Use geographic database to initialize the basic map.
 
procedure Initialize_Basic_Map (Map : in out Map_Type);
 
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type) return Physical_Features;
 
function Next_Page return Page_Type;
 
private
type Map_Type is array (Latitude, Longitude) of Physical_Features;
Basic_Map : Map_Type;
Page : Page_Type := 0; -- Location for each copy of Map.
 
end CA11015_0;
 
--==================================================================--
 
package body CA11015_0 is
 
procedure Initialize_Basic_Map (Map : in out Map_Type) is
-- Not a real initialization. Real application can use geographic
-- database to create the basic map.
begin
for I in Latitude'first .. Latitude'last loop
for J in 1 .. 2 loop
Map (I, J) := Unexplored;
end loop;
for J in 3 .. 4 loop
Map (I, J) := Desert;
end loop;
for J in 5 .. 7 loop
Map (I, J) := Plains;
end loop;
end loop;
 
end Initialize_Basic_Map;
---------------------------------------------------
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type)
return Physical_Features is
begin
return (Map (Lat, Long));
end Get_Physical_Feature;
---------------------------------------------------
function Next_Page return Page_Type is
begin
Page := Page + 1;
return (Page);
end Next_Page;
 
---------------------------------------------------
begin -- CA11015_0
-- Initialize a basic map.
Initialize_Basic_Map (Basic_Map);
 
end CA11015_0;
 
--==================================================================--
 
-- Generic child package of physical map. Instantiate this package to
-- create map copy with a new geographic feature, i.e., population, density,
-- or weather.
 
generic
 
type Generic_Feature is (<>); -- Any geographic feature, i.e., population,
-- density, or weather that can be
-- characterized by a scalar value.
 
package CA11015_0.CA11015_1 is
 
type Feature_Map is private;
 
function Get_Feature_Val (Lat : Latitude;
Long : Longitude;
Map : Feature_Map) return Generic_Feature;
 
procedure Set_Feature_Val (Lat : in Latitude;
Long : in Longitude;
Fea : in Generic_Feature;
Map : in out Feature_Map);
 
function Check_Page (Map : Feature_Map;
Page_No : Page_Type) return boolean;
 
private
type Feature_Type is array (Latitude, Longitude) of Generic_Feature;
 
type Feature_Map is
record
Feature : Feature_Type;
Page : Page_Type := Next_Page; -- Operation from parent.
end record;
 
end CA11015_0.CA11015_1;
 
--==================================================================--
 
package body CA11015_0.CA11015_1 is
 
function Get_Feature_Val (Lat : Latitude;
Long : Longitude;
Map : Feature_Map) return Generic_Feature is
begin
return (Map.Feature (Lat, Long));
end Get_Feature_Val;
---------------------------------------------------
procedure Set_Feature_Val (Lat : in Latitude;
Long : in Longitude;
Fea : in Generic_Feature;
Map : in out Feature_Map) is
begin
if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored
-- Parent's operation,
-- Parent's private object.
then
raise Terra_Incognita; -- Exception from parent.
else
Map.Feature (Lat, Long) := Fea;
end if;
end Set_Feature_Val;
---------------------------------------------------
function Check_Page (Map : Feature_Map;
Page_No : Page_Type) return boolean is
begin
return (Map.Page = Page_No);
end Check_Page;
 
end CA11015_0.CA11015_1;
 
--==================================================================--
 
with CA11015_0.CA11015_1; -- Generic map operation,
-- implicitly withs parent, basic map
-- application.
with Report;
 
procedure CA11015 is
 
begin
 
Report.Test ("CA11015", "Check that an instantiation of a child package " &
"of a non-generic package can use its parent's " &
"declarations and operations");
 
-- An application creates a population map using an integer type.
 
Population_Map_Subtest:
declare
type Population_Type is range 0 .. 10_000;
 
-- Declare instance of the child generic map package for one
-- particular integer type.
 
package Population is new CA11015_0.CA11015_1 (Population_Type);
 
Population_Map_Latitude : CA11015_0.Latitude := 1;
-- parent's type
Population_Map_Longitude : CA11015_0.Longitude := 5;
-- parent's type
Pop_Map : Population.Feature_Map;
Pop : Population_Type := 1000;
 
begin
Population.Set_Feature_Val (Population_Map_Latitude,
Population_Map_Longitude,
Pop,
Pop_Map);
 
If not ( (Population.Get_Feature_Val (Population_Map_Latitude,
Population_Map_Longitude, Pop_Map) = Pop) or
(Population.Check_Page (Pop_Map, 1)) ) then
Report.Failed ("Population map contains incorrect values");
end if;
 
end Population_Map_Subtest;
 
-- An application creates a weather map using an enumeration type.
 
Weather_Map_Subtest:
declare
type Weather_Type is (Hot, Cold, Mild);
 
-- Declare instance of the child generic map package for one
-- particular enumeration type.
 
package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type);
 
Weather_Map_Latitude : CA11015_0.Latitude := 2;
-- parent's type
Weather_Map_Longitude : CA11015_0.Longitude := 6;
-- parent's type
Weather_Map : Weather_Pkg.Feature_Map;
Weather : Weather_Type := Mild;
 
begin
Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude,
Weather_Map_Longitude,
Weather,
Weather_Map);
 
if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude,
Weather_Map_Longitude, Weather_Map) /= Weather) or
not (Weather_Pkg.Check_Page (Weather_Map, 2)) )
then
Report.Failed ("Weather map contains incorrect values");
end if;
 
end Weather_Map_Subtest;
 
-- During processing, the application may erroneously attempts to create
-- a density map on an unexplored area. This would result in the raising
-- of an exception.
 
Density_Map_Subtest:
declare
type Density_Type is (High, Medium, Low);
 
-- Declare instance of the child generic map package for one
-- particular enumeration type.
 
package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type);
 
Density_Map_Latitude : CA11015_0.Latitude := 7;
-- parent's type
Density_Map_Longitude : CA11015_0.Longitude := 2;
-- parent's type
Density : Density_Type := Low;
Density_Map : Density_Pkg.Feature_Map;
 
begin
Density_Pkg.Set_Feature_Val (Density_Map_Latitude,
Density_Map_Longitude,
Density,
Density_Map);
 
Report.Failed ("Exception not raised in child generic package");
 
exception
 
when CA11015_0.Terra_Incognita => -- parent's exception,
null; -- raised in child.
 
when others =>
Report.Failed ("Others exception is raised");
 
end Density_Map_Subtest;
 
Report.Result;
 
end CA11015;
/ca1012a0.ada
0,0 → 1,41
-- CA1012A0.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.
--*
-- GENERIC PROCEDURE DECLARATION.
-- BODY IS IN CA1012A1.DEP.
-- INSTANTIATION IS IN CA1012A4M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- WKB 07/20/81 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
-- AND CLARIFY POSSIBLE NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
GENERIC
TYPE INDEX IS RANGE <>;
PROCEDURE CA1012A0 (I : IN OUT INDEX);
/ca2003a0.ada
0,0 → 1,55
-- CA2003A0M.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 SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED
-- PRIOR TO ITS BODY_STUB.
 
-- SEPARATE FILES ARE:
-- CA2003A0M THE MAIN PROCEDURE.
-- CA2003A1 A SUBUNIT PROCEDURE BODY.
 
-- WKB 6/26/81
-- JRK 6/26/81
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2003A0M IS
 
I : INTEGER := 1;
 
PROCEDURE CA2003A1 IS SEPARATE;
 
PACKAGE P IS
I : INTEGER := 2;
END P;
 
BEGIN
TEST ("CA2003A", "A SUBUNIT HAS VISIBILITY OF IDENTIFIERS " &
"DECLARED BEFORE ITS BODY_STUB");
 
 
CA2003A1;
 
RESULT;
END CA2003A0M;
/ca1012a2.ada
0,0 → 1,41
-- CA1012A2.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.
--*
-- GENERIC FUNCTION DECLARATION.
-- BODY IS IN CA1012A3.DEP.
-- INSTANTIATION IS IN CA1012A4M.DEP.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- WKB 07/20/81 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES
-- AND POSSIBLE NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
GENERIC
TYPE ELEMENT IS RANGE <>;
FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT;
/ca11019.a
0,0 → 1,306
-- CA11019.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 body of the parent package may depend on one of its own
-- private generic children.
--
-- TEST DESCRIPTION:
-- A scenario is created that demonstrates the potential of adding a
-- generic private child during code maintenance without distubing a
-- large subsystem. After child is added to the subsystem, a maintainer
-- decides to take advantage of the new functionality and rewrites
-- the parent's body.
--
-- Declare a data collection abstraction in a package. Declare a private
-- generic child of this package which provides parameterized code that
-- have been written once and will be used three times to implement the
-- services of the parent package. In the parent body, instantiate the
-- private child.
--
-- In the main program, check that the operations in the parent,
-- and instance of the private child package perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1
--
--!
package CA11019_0 is
-- parent
 
type Data_Record is tagged private;
type Data_Collection is private;
---
---
subtype Data_1 is integer range 0 .. 100;
procedure Add_1 (Data : Data_1; To : in out Data_Collection);
function Statistical_Op_1 (Data : Data_Collection) return Data_1;
---
subtype Data_2 is integer range -100 .. 1000;
procedure Add_2 (Data : Data_2; To : in out Data_Collection);
function Statistical_Op_2 (Data : Data_Collection) return Data_2;
---
subtype Data_3 is integer range -10_000 .. 10_000;
procedure Add_3 (Data : Data_3; To : in out Data_Collection);
function Statistical_Op_3 (Data : Data_Collection) return Data_3;
---
 
private
 
type Data_Ptr is access Data_Record'class;
subtype Sequence_Number is positive range 1 .. 512;
 
type Data_Record is tagged
record
Next : Data_Ptr := null;
Seq : Sequence_Number;
end record;
---
type Data_Collection is
record
First : Data_Ptr := null;
Last : Data_Ptr := null;
end record;
end CA11019_0;
-- parent
 
--=================================================================--
 
-- This generic package provides parameterized code that has been
-- written once and will be used three times to implement the services
-- of the parent package.
 
private
generic
type Data_Type is range <>;
 
package CA11019_0.CA11019_1 is
-- parent.child
 
type Data_Elem is new Data_Record with
record
Value : Data_Type;
end record;
 
Next_Avail_Seq_No : Sequence_Number := 1;
 
procedure Sequence (Ptr : Data_Ptr);
-- the child must be private for this procedure to know details of
-- the implementation of data collections
 
procedure Add (Datum : Data_Type; To : in out Data_Collection);
 
function Op (Data : Data_Collection) return Data_Type;
-- op models a complicated operation that whose code can be
-- used for various data types
 
 
end CA11019_0.CA11019_1;
-- parent.child
 
--=================================================================--
 
package body CA11019_0.CA11019_1 is
-- parent.child
 
procedure Sequence (Ptr : Data_Ptr) is
begin
Ptr.Seq := Next_Avail_Seq_No;
Next_Avail_Seq_No := Next_Avail_Seq_No + 1;
end Sequence;
 
---------------------------------------------------------
 
procedure Add (Datum : Data_Type; To : in out Data_Collection) is
Ptr : Data_Ptr;
begin
if To.First = null then
-- assign new record with data value to
-- to.next <- null;
To.First := new Data_Elem'(Next => null,
Value => Datum,
Seq => 1);
Sequence (To.First);
To.Last := To.First;
else
-- chase to end of list
Ptr := To.First;
while Ptr.Next /= null loop
Ptr := Ptr.Next;
end loop;
-- and add element there
Ptr.Next := new Data_Elem'(Next => null,
Value => Datum,
Seq => 1);
Sequence (Ptr.Next);
To.Last := Ptr.Next;
end if;
 
end Add;
 
---------------------------------------------------------
 
function Op (Data : Data_Collection) return Data_Type is
-- for simplicity, just return the maximum of the data set
Max : Data_Type := Data_Elem( Data.First.all ).Value;
-- assuming non-empty collection
Ptr : Data_Ptr := Data.First;
 
begin
-- no error checking
while Ptr.Next /= null loop
if Data_Elem( Ptr.Next.all ).Value > Max then
Max := Data_Elem( Ptr.Next.all ).Value;
end if;
Ptr := Ptr.Next;
end loop;
return Max;
end Op;
 
end CA11019_0.CA11019_1;
-- parent.child
 
--=================================================================--
 
-- parent body depends on private generic child
with CA11019_0.CA11019_1; -- Private generic child.
 
pragma Elaborate (CA11019_0.CA11019_1);
package body CA11019_0 is
 
-- instantiate the generic child with data types needed by the
-- package interface services
package Data_1_Ops is new CA11019_1
(Data_Type => Data_1);
package Data_2_Ops is new CA11019_1
(Data_Type => Data_2);
 
package Data_3_Ops is new CA11019_1
(Data_Type => Data_3);
 
---------------------------------------------------------
 
procedure Add_1 (Data : Data_1; To : in out Data_Collection) is
begin
-- maybe do other stuff here
Data_1_Ops.Add (Data, To);
-- and here
end;
 
---------------------------------------------------------
 
function Statistical_Op_1 (Data : Data_Collection) return Data_1 is
begin
-- maybe use generic operation(s) in some complicated ways
-- (but simplified out, for the sake of testing)
return Data_1_Ops.Op (Data);
end;
 
---------------------------------------------------------
 
procedure Add_2 (Data : Data_2; To : in out Data_Collection) is
begin
Data_2_Ops.Add (Data, To);
end;
 
---------------------------------------------------------
 
function Statistical_Op_2 (Data : Data_Collection) return Data_2 is
begin
return Data_2_Ops.Op (Data);
end;
 
---------------------------------------------------------
 
procedure Add_3 (Data : Data_3; To : in out Data_Collection) is
begin
Data_3_Ops.Add (Data, To);
end;
 
---------------------------------------------------------
 
function Statistical_Op_3 (Data : Data_Collection) return Data_3 is
begin
return Data_3_Ops.Op (Data);
end;
 
end CA11019_0;
 
 
--=================================================--
 
with CA11019_0,
-- Main,
-- Main.Child is private
Report;
 
procedure CA11019 is
 
package Main renames CA11019_0;
 
Col_1,
Col_2,
Col_3 : Main.Data_Collection;
 
begin
 
Report.Test ("CA11019", "Check that body of a (non-generic) package " &
"may depend on its private generic child");
 
-- build a data collection
 
for I in 1 .. 10 loop
Main.Add_1 ( Main.Data_1(I), Col_1);
end loop;
 
if Main.Statistical_Op_1 (Col_1) /= 10 then
Report.Failed ("Wrong data_1 value returned");
end if;
 
for I in reverse 10 .. 20 loop
Main.Add_2 ( Main.Data_2(I * 10), Col_2);
end loop;
 
if Main.Statistical_Op_2 (Col_2) /= 200 then
Report.Failed ("Wrong data_2 value returned");
end if;
 
for I in 0 .. 10 loop
Main.Add_3 ( Main.Data_3(I + 5), Col_3);
end loop;
 
if Main.Statistical_Op_3 (Col_3) /= 15 then
Report.Failed ("Wrong data_3 value returned");
end if;
 
Report.Result;
 
end CA11019;
/ca3011a1.ada
0,0 → 1,42
-- CA3011A1.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.
--*
-- A SUBUNIT OF A GENERIC UNIT.
-- THE GENERIC UNIT IS IN CA3011A0.
-- INSTANTIATION IS IN CA0011A4M.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- RJW 09/22/86 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA3011A0)
FUNCTION CA3011A1 RETURN T IS
 
BEGIN
RETURN X;
END CA3011A1;
/ca1014a1.ada
0,0 → 1,34
-- CA1014A1.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.
--*
-- JRK 5/20/81
 
SEPARATE (CA1014A0M)
PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS
 
BEGIN
 
I := I + 1;
 
END CA1014A1;
/ca1012a4.ada
0,0 → 1,74
-- CA1012A4M.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 GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE
-- COMPILED SEPARATELY.
 
-- SEPARATE FILES ARE:
-- CA1012A0 A LIBRARY GENERIC PROCEDURE DECLARATION.
-- CA1012A1 A LIBRARY GENERIC PROCEDURE BODY (CA1012A0).
-- CA1012A2 A LIBRARY GENERIC FUNCTION DECLARATION.
-- CA1012A3 A LIBRARY GENERIC FUNCTION BODY (CA1012A2).
-- CA1012A4M THE MAIN PROCEDURE.
 
-- APPLICABILITY CRITERIA:
-- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS.
-- THIS WAS NOT REQUIRED FOR ADA 83.
 
-- HISTORY:
-- WKB 07/20/81 CREATED ORIGINAL TEST.
-- PWB 02/19/86 ADDED COMMENTS REGARDING NON-APPLICABILITY.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
-- RLB 09/15/99 REMOVED OBSOLETE COMMENT.
 
WITH REPORT, CA1012A0, CA1012A2;
USE REPORT;
PROCEDURE CA1012A4M IS
 
N : INTEGER := 1;
 
SUBTYPE S50 IS INTEGER RANGE 1..50;
 
PROCEDURE P IS NEW CA1012A0 (S50);
 
FUNCTION F IS NEW CA1012A2 (INTEGER);
 
BEGIN
TEST ("CA1012A", "SEPARATELY COMPILED GENERIC SUBPROGRAM " &
"DECLARATIONS AND BODIES");
 
P(N);
IF N /= 2 THEN
FAILED ("PROCEDURE NOT INVOKED");
END IF;
 
N := 1;
IF F(N) /= 2 THEN
FAILED ("FUNCTION NOT INVOKED");
END IF;
 
RESULT;
END CA1012A4M;
/ca3011a3.ada
0,0 → 1,43
-- CA3011A3.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.
--*
-- A SUBUNIT OF A GENERIC UNIT.
-- THE GENERIC UNIT IS IN CA3011A0.
-- INSTANTIATION IS IN CA3011A4M.
 
-- APPLICABILITY CRITERIA:
-- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS.
 
-- HISTORY:
-- RJW 09/22/86 CREATED ORIGINAL TEST.
-- BCB 01/05/88 MODIFIED HEADER.
-- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95.
 
SEPARATE (CA3011A0)
PACKAGE BODY CA3011A3 IS
FUNCTION CA3011A3F RETURN T IS
BEGIN
RETURN X;
END;
END CA3011A3;
/ca2007a0.ada
0,0 → 1,77
-- CA2007A0M.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 SUBUNIT PACKAGES ARE ELABORATED IN THE ORDER IN
-- WHICH THEIR BODY STUBS APPEAR, NOT (NECESSARILY) IN THE
-- ORDER IN WHICH THEY ARE COMPILED.
 
-- SEPARATE FILES ARE:
-- CA2007A0M THE MAIN PROCEDURE.
-- CA2007A1 A SUBUNIT PACKAGE BODY.
-- CA2007A2 A SUBUNIT PACKAGE BODY.
-- CA2007A3 A SUBUNIT PACKAGE BODY.
 
-- WKB 7/1/81
-- JRK 7/1/81
 
WITH REPORT;
USE REPORT;
PROCEDURE CA2007A0M IS
 
ELAB_ORDER : STRING (1..3) := " ";
NEXT : NATURAL := 1;
 
PACKAGE CALL_TEST IS
END CALL_TEST;
 
PACKAGE BODY CALL_TEST IS
BEGIN
TEST ("CA2007A", "CHECK THAT SUBUNIT PACKAGES ARE " &
"ELABORATED IN THE ORDER IN WHICH THEIR " &
"BODY STUBS APPEAR");
END CALL_TEST;
 
PACKAGE CA2007A3 IS
END CA2007A3;
 
PACKAGE BODY CA2007A3 IS SEPARATE;
 
PACKAGE CA2007A2 IS
END CA2007A2;
 
PACKAGE BODY CA2007A2 IS SEPARATE;
 
PACKAGE CA2007A1 IS
END CA2007A1;
 
PACKAGE BODY CA2007A1 IS SEPARATE;
 
BEGIN
 
IF ELAB_ORDER /= "321" THEN
FAILED ("INCORRECT ELABORATION ORDER");
END IF;
 
RESULT;
END CA2007A0M;
/ca1014a3.ada
0,0 → 1,34
-- CA1014A3.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.
--*
-- JRK 5/20/81
 
SEPARATE (CA1014A0M)
FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS
 
BEGIN
RETURN -I;
 
END CA1014A3;
/ca5003b0.ada
0,0 → 1,51
-- CA5003B0.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.
--*
-- WKB 7/22/81
-- JBG 10/6/83
-- BHS 8/02/84
-- JRK 9/20/84
 
 
PACKAGE CA5003B0 IS
 
ORDER : STRING (1..4) := " ";
 
INDEX : NATURAL := 1;
 
FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER;
 
END CA5003B0;
 
 
PACKAGE BODY CA5003B0 IS
 
FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS
BEGIN
ORDER (INDEX) := UNIT;
INDEX := INDEX + 1;
RETURN INDEX - 1;
END SHOW_ELAB;
 
END CA5003B0;
/ca2007a2.ada
0,0 → 1,36
-- CA2007A2.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.
--*
-- WKB 7/1/81
 
SEPARATE (CA2007A0M)
 
PACKAGE BODY CA2007A2 IS
 
BEGIN
 
ELAB_ORDER (NEXT) := '2';
NEXT := NEXT + 1;
 
END CA2007A2;
/ca5003b2.ada
0,0 → 1,45
-- CA5003B2.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.
--*
-- BHS 8/02/84
-- JRK 9/20/84
 
WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
SEPARATE (CA5003B1)
PACKAGE BODY CA5003B2 IS
 
A2 : INTEGER := SHOW_ELAB ('2');
 
PROCEDURE P1 IS
BEGIN
NULL;
END P1;
 
PACKAGE CA5003B4 IS
PROCEDURE P2;
END CA5003B4;
 
PACKAGE BODY CA5003B4 IS SEPARATE;
 
END CA5003B2;
/ca5003b4.ada
0,0 → 1,40
-- CA5003B4.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.
--*
-- BHS 8/02/84
-- JRK 9/20/84
 
WITH CA5003B3; -- MUST BE ELABORATED BEFORE CA5003B1.
WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0);
SEPARATE (CA5003B1.CA5003B2)
PACKAGE BODY CA5003B4 IS
 
A4 : INTEGER := SHOW_ELAB ('4');
 
PROCEDURE P2 IS
BEGIN
NULL;
END P2;
 
END CA5003B4;
/ca11b02.a
0,0 → 1,169
-- CA11B02.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 type derived in a client of a public child inherits
-- primitive operations from parent.
--
-- TEST DESCRIPTION:
-- Declare a root record type with discriminant in a package
-- specification. Declare a primitive subprogram for the type
-- (foundation code).
--
-- Add a public child to the above package. Derive a new type
-- with constraint to the discriminant record type from the parent
-- package. Declare a new primitive subprogram to write to the child
-- derived type.
--
-- In the main program, "with" the child. Derive a new type using the
-- record type from the child package. Access the inherited operations
-- from both parent and child packages.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11B00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Child package of FA11B00.
package FA11B00.CA11B02_0 is -- Application_Two_Widget
-- This public child declares a derived type from its parent. It
-- represents processing of widgets in a window system.
 
-- Dimension of app2_widget is limited to 5000 pixels.
 
type App2_Widget is new App1_Widget (Maximum_Size => 5000);
-- Derived record of parent type.
 
-- Inherits procedure App1_Widget_Specific_Oper from parent.
 
 
-- Primitive operation of type App2_Widget.
 
procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
S : in Widget_Size);
-- Primitive operation of type App2_Widget.
 
procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
Loc : in Widget_Location);
 
end FA11B00.CA11B02_0; -- Application_Two_Widget
 
 
--=======================================================================--
 
 
package body FA11B00.CA11B02_0 is -- Application_Two_Widget
 
procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget;
S : in Widget_Size) is
begin
The_Widget.Size := S;
end App2_Widget_Specific_Op1;
 
--==============================================--
 
procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget;
Loc : in Widget_Location) is
begin
The_Widget.Location := Loc;
end App2_Widget_Specific_Op2;
 
end FA11B00.CA11B02_0; -- Application_Two_Widget
 
 
--=======================================================================--
 
with FA11B00.CA11B02_0; -- Application_Two_Widget
-- implicitly with Application_One_Widget.
with Report;
 
procedure CA11B02 is
package Application_One_Widget renames FA11B00;
 
package Application_Two_Widget renames FA11B00.CA11B02_0;
 
use Application_One_Widget ;
use Application_Two_Widget ;
 
type Emulator_Widget is new App2_Widget; -- Derived record of
-- parent type.
 
White_Widget, Amber_Widget : Emulator_Widget;
 
 
begin
 
Report.Test ("CA11B02", "Check that a type derived in client of a " &
"public child inherits primitive operations from parent");
 
App1_Widget_Specific_Oper (C => White, L => "Line Editor ",
The_Widget => White_Widget, I => 10);
-- Inherited from Application_One_Widget.
If White_Widget.Color /= White or
White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or
White_Widget.Label /= "Line Editor "
then
Report.Failed ("Incorrect result for White_Widget");
end if;
 
-- perform an App2_Widget specific operation.
 
App2_Widget_Specific_Op1 (White_Widget, S => (100, 200));
 
If White_Widget.Size.X_Length /= 100 or
White_Widget.Size.Y_Length /= 200
then
Report.Failed ("Incorrect size for White_Widget");
end if;
 
App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor ");
-- Inherited from Application_One_Widget.
 
-- perform an App2_Widget specific operations.
 
App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget);
App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760));
 
If Amber_Widget.Color /= Amber or
Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or
Amber_Widget.Label /= "Screen Editor " or
Amber_Widget.Size /= (1024,100) or
Amber_Widget.Location.X_Location /= 1024 or
Amber_Widget.Location.Y_Location /= 760
then
Report.Failed ("Incorrect result for Amber_Widget");
end if;
 
Report.Result;
 
end CA11B02;
/ca110041.a
0,0 → 1,118
-- CA110041.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:
-- See CA110042.AM
--
-- TEST DESCRIPTION:
-- See CA110042.AM
--
-- TEST FILES:
-- The following files comprise this test:
--
-- CA110040.A
-- => CA110041.A
-- CA110042.AM
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 26 Apr 96 SAIC ACVC 2.1: Modified prologue.
--
--!
 
package CA110040.CA110041 is -- Child Package Computer_System.Manager
 
type User_Account is new Account with private;
 
procedure Initialize_User_Account (Acct : out User_Account);
 
private
 
-- The private portion of this spec demonstrates that components contained
-- in the visible part of the parent are directly visible in the private
-- part of a public child.
 
type Account_Access_Type is (None, Guest, User, System);
 
type User_Account is new Account with -- Parent type.
record
Privilege : Account_Access_Type := None;
end record;
 
System_Account : User_Account :=
(User_ID => Administrator_Account.User_ID, -- Parent constant.
Privilege => System); -- User_ID has been
-- set to 1.
Auditor_Account : User_Account :=
(User_ID => Next_Available_ID, -- Parent function.
Privilege => System); -- User_ID has been
-- set to 2.
Total_Authorized_Accounts : System_Account_Capacity
renames Total_Accounts; -- Parent object.
 
Unauthorized_Account : exception
renames Illegal_Account; -- Parent exception
 
end CA110040.CA110041; -- Child Package Computer_System.Manager
 
--=================================================================--
 
-- Child Package body Computer_System.Manager
package body CA110040.CA110041 is
 
function Account_Limit_Reached return Boolean is
begin
if Total_Authorized_Accounts = Maximum_System_Accounts then
return (True);
else
return (False);
end if;
end Account_Limit_Reached;
---------------------------------------------------------------
function Valid_Account (Acct : User_Account) return Boolean is
Result : Boolean := False;
begin
if (Acct.User_ID /= System_Account.User_ID) and
(Acct.User_ID /= Auditor_Account.User_ID)
then
Result := True;
end if;
return (Result);
end Valid_Account;
---------------------------------------------------------------
procedure Initialize_User_Account (Acct : out User_Account) is
begin
if Account_Limit_Reached then
raise Account_Limit_Exceeded;
else
Acct.User_ID := Next_Available_ID;
Acct.Privilege := User;
end if;
if not Valid_Account (Acct) then
raise Unauthorized_Account;
end if;
end Initialize_User_Account;
 
end CA110040.CA110041; -- Child Package body Computer_System.Manager
/ca11d02.a
0,0 → 1,393
-- CA11D02.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 exception declared in a package can be raised by a
-- child of a child package. Check that it can be renamed in the
-- child of the child package and raised with the correct effect.
--
-- TEST DESCRIPTION:
-- Declare a package which defines complex number abstraction with
-- user-defined exceptions (foundation code).
--
-- Add a public child package to the above package. Declare two
-- subprograms for the parent type.
--
-- Add a public grandchild package to the foundation package. Declare
-- subprograms to raise exceptions.
--
-- In the main program, "with" the grandchild package, then check that
-- the exceptions are raised and handled as expected. Ensure that
-- exceptions are:
-- 1) raised in the public grandchild package and handled/reraised to
-- be handled by the main program.
-- 2) raised and handled locally by the "others" handler in the
-- public grandchild package.
-- 3) raised in the public grandchild and propagated to the main
-- program.
--
-- TEST FILES:
-- This test depends on the following foundation code:
--
-- FA11D00.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
 
-- Child package of FA11D00.
 
package FA11D00.CA11D02_0 is -- Basic_Complex
 
function "+" (Left, Right : Complex_Type)
return Complex_Type; -- Add two complex numbers.
 
function "*" (Left, Right : Complex_Type)
return Complex_Type; -- Multiply two complex numbers.
 
end FA11D00.CA11D02_0; -- Basic_Complex
 
--=======================================================================--
 
package body FA11D00.CA11D02_0 is -- Basic_Complex
 
function "+" (Left, Right : Complex_Type) return Complex_Type is
begin
return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) );
end "+";
--------------------------------------------------------------
function "*" (Left, Right : Complex_Type) return Complex_Type is
begin
return ( Real => (Left.Real * Right.Real),
Imag => (Left.Imag * Right.Imag) );
end "*";
 
end FA11D00.CA11D02_0; -- Basic_Complex
 
--=======================================================================--
 
-- Child package of FA11D00.CA11D02_0.
-- Grandchild package of FA11D00.
 
package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
 
Inverse_Error : exception renames Divide_Error; -- Reference to exception
-- in grandparent package.
Array_Size : constant := 2;
 
type Complex_Array_Type is
array (1 .. Array_Size) of Complex_Type; -- Reference to type
-- in parent package.
 
function Multiply (Left : Complex_Array_Type; -- Multiply two complex
Right : Complex_Array_Type) -- arrays.
return Complex_Array_Type;
 
function Add (Left, Right : Complex_Array_Type) -- Add two complex
return Complex_Array_Type; -- arrays.
 
procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex
Left : in out Complex_Array_Type); -- array.
end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
 
--=======================================================================--
 
with Report;
 
 
package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex
 
function Multiply (Left : Complex_Array_Type;
Right : Complex_Array_Type)
return Complex_Array_Type is
 
-- This procedure will raise an exception depending on the input
-- parameter. The exception will be handled locally by the
-- "others" handler.
 
Result : Complex_Array_Type := (others => Zero);
 
subtype Vector_Size is Positive range Left'Range;
 
begin
if Left = Result or else Right = Result then -- Do not multiply zero.
raise Multiply_Error; -- Refence to exception in
-- grandparent package.
Report.Failed ("Program control not transferred by raise");
else
for I in Vector_Size loop
Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*".
end loop;
end if;
return (Result);
exception
when others =>
Report.Comment ("Exception is handled by others in Multiplication");
TC_Handled_In_Grandchild_Pkg_Func := true;
return (Zero, Zero);
end Multiply;
--------------------------------------------------------------
function Add (Left, Right : Complex_Array_Type)
return Complex_Array_Type is
 
-- This function will raise an exception depending on the input
-- parameter. The exception will be propagated and handled
-- by the caller.
 
Result : Complex_Array_Type := (others => Zero);
 
subtype Vector_Size is Positive range Left'Range;
 
begin
if Left = Result or Right = Result then -- Do not add zero.
raise Add_Error; -- Refence to exception in
-- grandparent package.
Report.Failed ("Program control not transferred by raise");
else
for I in Vector_Size loop
Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+".
end loop;
end if;
return (Result);
end Add;
--------------------------------------------------------------
procedure Inverse (Right : in Complex_Array_Type;
Left : in out Complex_Array_Type) is
 
-- This function will raise an exception depending on the input
-- parameter. The exception will be handled/reraised to be
-- handled by the caller.
 
Result : Complex_Array_Type := (others => Zero);
 
Array_With_Zero : boolean := false;
 
begin
for I in 1 .. Right'Length loop
if Right(I) = Zero then -- Check for zero.
Array_With_Zero := true;
end if;
end loop;
 
If Array_With_Zero then
raise Inverse_Error; -- Do not inverse zero.
Report.Failed ("Program control not transferred by raise");
else
for I in 1 .. Array_Size loop
Left(I).Real := - Right(I).Real;
Left(I).Imag := - Right(I).Imag;
end loop;
end if;
 
exception
when Inverse_Error =>
TC_Handled_In_Grandchild_Pkg_Proc := true;
Left := Result;
raise; -- Reraise the Inverse_Error exception in the subtest.
Report.Failed ("Exception not reraised in handler");
 
when others =>
Report.Failed ("Unexpected exception in procedure Inverse");
end Inverse;
 
end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex
 
--=======================================================================--
 
with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex,
-- implicitly with Basic_Complex.
with Report;
 
procedure CA11D02 is
 
package Complex_Pkg renames FA11D00;
package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1;
 
use Complex_Pkg;
use Array_Complex_Pkg;
 
begin
 
Report.Test ("CA11D02", "Check that an exception declared in a package " &
"can be raised by a child of a child package");
 
Multiply_Complex_Subtest:
declare
Operand_1 : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (5))),
Complex (Int_Type (Report.Ident_Int (2)),
Int_Type (Report.Ident_Int (8))) );
Operand_2 : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (1)),
Int_Type (Report.Ident_Int (2))),
Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (6))) );
Operand_3 : Complex_Array_Type := ( Zero, Zero);
Mul_Result : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (10))),
Complex (Int_Type (Report.Ident_Int (6)),
Int_Type (Report.Ident_Int (48))) );
Complex_No : Complex_Array_Type := (others => Zero);
 
begin
If (Multiply (Operand_1, Operand_2) /= Mul_Result) then
Report.Failed ("Incorrect results from multiplication");
end if;
 
-- Error is raised and exception will be handled in grandchild package.
 
Complex_No := Multiply (Operand_1, Operand_3);
 
if Complex_No /= (Zero, Zero) then
Report.Failed ("Exception was not raised in multiplication");
end if;
 
exception
when Multiply_Error =>
Report.Failed ("Exception raised in multiplication and " &
"propagated to caller");
TC_Handled_In_Grandchild_Pkg_Func := false;
-- Improper exception handling in caller.
 
when others =>
Report.Failed ("Unexpected exception in multiplication");
TC_Handled_In_Grandchild_Pkg_Func := false;
-- Improper exception handling in caller.
 
end Multiply_Complex_Subtest;
 
 
Add_Complex_Subtest:
declare
Operand_1 : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (2)),
Int_Type (Report.Ident_Int (7))),
Complex (Int_Type (Report.Ident_Int (5)),
Int_Type (Report.Ident_Int (8))) );
Operand_2 : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (4)),
Int_Type (Report.Ident_Int (1))),
Complex (Int_Type (Report.Ident_Int (2)),
Int_Type (Report.Ident_Int (3))) );
Operand_3 : Complex_Array_Type := ( Zero, Zero);
Add_Result : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (6)),
Int_Type (Report.Ident_Int (8))),
Complex (Int_Type (Report.Ident_Int (7)),
Int_Type (Report.Ident_Int (11))) );
Complex_No : Complex_Array_Type := (others => Zero);
 
begin
Complex_No := Add (Operand_1, Operand_2);
 
If (Complex_No /= Add_Result) then
Report.Failed ("Incorrect results from addition");
end if;
 
-- Error is raised in grandchild package and exception
-- will be propagated to caller.
 
Complex_No := Add (Operand_1, Operand_3);
 
if Complex_No = Add_Result then
Report.Failed ("Exception was not raised in addition");
end if;
 
exception
when Add_Error =>
TC_Propagated_To_Caller := true; -- Exception is propagated.
 
when others =>
Report.Failed ("Unexpected exception in addition subtest");
TC_Propagated_To_Caller := false; -- Improper exception handling
-- in caller.
end Add_Complex_Subtest;
 
Inverse_Complex_Subtest:
declare
Operand_1 : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (1)),
Int_Type (Report.Ident_Int (5))),
Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (11))) );
Operand_3 : Complex_Array_Type
:= ( Zero, Complex (Int_Type (Report.Ident_Int (3)),
Int_Type (Report.Ident_Int (6))) );
Inv_Result : Complex_Array_Type
:= ( Complex (Int_Type (Report.Ident_Int (-1)),
Int_Type (Report.Ident_Int (-5))),
Complex (Int_Type (Report.Ident_Int (-3)),
Int_Type (Report.Ident_Int (-11))) );
Complex_No : Complex_Array_Type := (others => Zero);
 
begin
Inverse (Operand_1, Complex_No);
 
if (Complex_No /= Inv_Result) then
Report.Failed ("Incorrect results from inverse");
end if;
 
-- Error is raised in grandchild package and exception
-- will be handled/reraised to caller.
 
Inverse (Operand_3, Complex_No);
 
Report.Failed ("Exception was not handled in inverse");
 
exception
when Inverse_Error =>
if not TC_Handled_In_Grandchild_Pkg_Proc then
Report.Failed ("Exception was not raised in inverse");
else
TC_Handled_In_Caller := true; -- Exception is reraised from
-- child package.
end if;
 
when others =>
Report.Failed ("Unexpected exception in inverse");
TC_Handled_In_Caller := false;
-- Improper exception handling in caller.
 
end Inverse_Complex_Subtest;
 
if not (TC_Handled_In_Caller and -- Check to see that all
TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled
TC_Handled_In_Grandchild_Pkg_Func and -- in proper location.
TC_Propagated_To_Caller)
then
Report.Failed ("Exceptions handled in incorrect locations");
end if;
 
Report.Result;
 
end CA11D02;

powered by: WebSVN 2.1.0

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