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/cd
    from Rev 294 to Rev 338
    ↔ Reverse comparison
  •

Rev 294 → Rev 338

/cd72a01.a
0,0 → 1,165
--
-- CD72A01.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 package System.Address_To_Access_Conversions may be
-- instantiated for various simple types.
--
-- Check that To_Pointer and To_Address are inverse operations.
--
-- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
-- X that allows Unchecked_Access.
--
-- Check that To_Pointer(Null_Address) returns null.
--
-- TEST DESCRIPTION:
-- This test checks that the semantics provided in
-- Address_To_Access_Conversions are present and operate
-- within expectations (to the best extent possible in a portable
-- implementation independent fashion).
--
-- The functions Address_To_Hex and Hex_To_Address test the invertability
-- of the To_Integer and To_Address functions, along with a great deal
-- of optimizer chaff and protection from the fact that type
-- Storage_Elements.Integer_Address may be either a modular or a signed
-- integer type.
--
-- This test has some interesting usage paradigms in that users
-- occasionally want to store address information in a transportable
-- fashion, and often resort to some textual representation of values.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
-- CHANGE HISTORY:
-- 13 JUL 95 SAIC Initial version (CD72001)
-- 08 FEB 96 SAIC Revised (split) version for 2.1
-- 07 MAY 96 SAIC Additional subtest added for 2.1
-- 16 FEB 98 EDS Modified documentation.
--!
 
with Report;
with Impdef;
with FD72A00;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;
procedure CD72A01 is
use System;
use FD72A00;
 
package Number_ATAC is
new System.Address_To_Access_Conversions(Number); -- ANX-C RQMT
 
use type Number_ATAC.Object_Pointer;
 
type Data is record
One, Two: aliased Number;
end record;
 
package Data_ATAC is
new System.Address_To_Access_Conversions(Data); -- ANX-C RQMT
 
use type Data_ATAC.Object_Pointer;
 
type Test_Cases is ( Addr_Type, Record_Type );
 
type Naive_Dynamic_String is access String;
 
type String_Store is array(Test_Cases) of Naive_Dynamic_String;
 
The_Strings : String_Store;
 
-- create several aliased objects with distinct values
 
My_Number : aliased Number := Number'First;
My_Data : aliased Data := (Number'First,Number'Last);
 
use type System.Storage_Elements.Integer_Address;
 
begin -- Main test procedure.
 
Report.Test ("CD72A01", "Check package " &
"System.Address_To_Access_Conversions " &
"for simple types" );
-- take several pointer objects, convert them to addresses, and store
-- the address as a hexadecimal representation for later reconversion
 
The_Strings(Addr_Type) := new String'(
Address_To_Hex(Number_ATAC.To_Address(My_Number'Access)) );
 
The_Strings(Record_Type) := new String'(
Address_To_Hex(Data_ATAC.To_Address(My_Data'Access)) );
 
-- now, reconvert the hexadecimal address values back to pointers,
-- and check that the dereferenced pointer still designates the
-- value placed at that location. The use of the intermediate
-- string representation should foil even the cleverest of optimizers
 
if Number_ATAC.To_Pointer(
Hex_To_Address(The_Strings(Addr_Type))).all
/= Number'First then
Report.Failed("Number reconversion");
end if;
 
if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type))).all
/= (Number'First,Number'Last) then
Report.Failed("Data reconversion");
end if;
 
-- check that the resulting values are equal to the 'Unchecked_Access
-- of the value
 
if Number_ATAC.To_Pointer(
Hex_To_Address(The_Strings(Addr_Type)))
/= My_Number'Unchecked_Access then
Report.Failed("Number Unchecked_Access");
end if;
 
if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type)))
/= My_Data'Unchecked_Access then
Report.Failed("Data Unchecked_Access");
end if;
 
if Number_ATAC.To_Pointer(System.Null_Address) /= null then
Report.Failed("To_Pointer(Null_Address) /= null");
end if;
 
if Number_ATAC.To_Address(null) /= System.Null_Address then
Report.Failed("To_Address(null) /= Null_Address");
end if;
 
Report.Result;
 
end CD72A01;
/cd5012a.ada
0,0 → 1,78
-- CD5012A.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
-- ENUMERATION TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
 
-- HISTORY:
-- DHH 09/15/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
WITH SPPRT13;
PROCEDURE CD5012A IS
 
BEGIN
 
TEST ("CD5012A", "AN ADDRESS CLAUSE CAN BE " &
"GIVEN FOR A VARIABLE OF AN ENUMERATION " &
"TYPE IN THE DECLARATIVE PART OF A " &
"GENERIC SUBPROGRAM");
 
DECLARE
TYPE NON_CHAR IS (RED, BLUE, GREEN);
 
COLOR : NON_CHAR;
TEST_VAR : ADDRESS := COLOR'ADDRESS;
 
GENERIC
PROCEDURE GENPROC;
 
PROCEDURE GENPROC IS
 
HUE : NON_CHAR := GREEN;
FOR HUE USE AT
SPPRT13.VARIABLE_ADDRESS;
BEGIN
IF EQUAL (3, 3) THEN
HUE := RED;
END IF;
IF HUE /= RED THEN
FAILED ("WRONG VALUE FOR VARIABLE IN " &
"GENERIC PROCEDURE");
END IF;
IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
FAILED ("WRONG ADDRESS FOR VARIABLE " &
"IN GENERIC PROCEDURE");
END IF;
END GENPROC;
 
PROCEDURE PROC IS NEW GENPROC;
BEGIN
PROC;
END;
RESULT;
END CD5012A;
/cd7202a.ada
0,0 → 1,55
-- CD7202A.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:
-- THE 'ADDRESS ATTRIBUTE CAN BE USED IN A COMPILATION UNIT EVEN IF
-- A WITH CLAUSE FOR PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT.
 
-- HISTORY:
-- DHH 08/31/88 CREATED ORIGINAL TEST.
 
WITH SYSTEM;
PACKAGE CD7202A_SYS IS
SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS;
END CD7202A_SYS;
 
WITH CD7202A_SYS;
WITH REPORT; USE REPORT;
PROCEDURE CD7202A IS
 
INT : INTEGER := 2;
 
BOOL : BOOLEAN := (INT'ADDRESS IN CD7202A_SYS.MY_ADDRESS);
 
BEGIN
TEST ("CD7202A", "THE 'ADDRESS ATTRIBUTE CAN BE USED IN A" &
" COMPILATION UNIT EVEN IF A WITH CLAUSE FOR " &
"PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT");
 
IF NOT IDENT_BOOL(BOOL) THEN
FAILED("ADDRESS ATTRIBUTE INCORRECT");
END IF;
 
RESULT;
END CD7202A;
/cd5012e.ada
0,0 → 1,76
-- CD5012E.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
-- FIXED POINT TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
 
-- HISTORY:
-- DHH 09/15/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
WITH SPPRT13;
PROCEDURE CD5012E IS
 
BEGIN
 
TEST ("CD5012E", "AN ADDRESS CLAUSE CAN BE " &
"GIVEN FOR A VARIABLE OF A FIXED POINT " &
"TYPE IN THE DECLARATIVE PART OF A " &
"GENERIC SUBPROGRAM");
 
DECLARE
 
GENERIC
PROCEDURE GENPROC;
 
PROCEDURE GENPROC IS
 
TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0;
 
TESTFIX : FIXED := 0.0;
FOR TESTFIX USE AT SPPRT13.VARIABLE_ADDRESS;
BEGIN
IF EQUAL (3, 3) THEN
TESTFIX := 1.0;
END IF;
IF TESTFIX /= 1.0 THEN
FAILED ("WRONG VALUE FOR VARIABLE IN " &
"A GENERIC PROCEDURE");
END IF;
IF TESTFIX'ADDRESS /=
SPPRT13.VARIABLE_ADDRESS THEN
FAILED ("WRONG ADDRESS FOR VARIABLE " &
"IN A GENERIC PROCEDURE");
END IF;
END GENPROC;
 
PROCEDURE PROC IS NEW GENPROC;
BEGIN
PROC;
END;
RESULT;
END CD5012E;
/cd2c11a.tst
0,0 → 1,140
--CD2C11A.TST
 
-- 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:
-- IF A TASK STORAGE SIZE SPECIFICATION IS GIVEN FOR A TASK
-- TYPE, THEN OPERATIONS ON VALUES OF THE TASK TYPE ARE NOT
-- AFFECTED.
 
-- MACRO SUBSTITUTION:
-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
-- THE ACTIVATION OF A TASK.
 
-- HISTORY
-- DHH 09/24/87 CREATED ORIGINAL TEST.
-- RJW 07/06/88 REVISED THE TEST TO REMOVE UNINITIALIZED 'IN OUT'
-- PARAMETER. CHANGED EXTENSION TO 'TST'.
 
WITH REPORT; USE REPORT;
PROCEDURE CD2C11A IS
 
TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
 
BEGIN
 
TEST ("CD2C11A", "IF A TASK STORAGE SIZE SPECIFICATION IS " &
"GIVEN FOR A TASK TYPE, THEN OPERATIONS " &
"ON VALUES OF THE TASK TYPE ARE NOT AFFECTED");
 
DECLARE
PACKAGE PACK IS
 
TYPE FLT IS DIGITS 1;
 
TASK TYPE TTYPE IS
ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER);
ENTRY MULT(Y : IN FLT; Z : IN OUT FLT);
END TTYPE;
 
 
M : INTEGER := 81;
N : INTEGER := 0;
V,W : FLT RANGE 1.0..512.0 := 2.0;
 
FOR TTYPE'STORAGE_SIZE USE TASK_STORAGE_SIZE;
 
T : TTYPE;
 
END PACK;
 
PACKAGE BODY PACK IS
FUNCTION IDENT_FLT(FT : FLT) RETURN FLT IS
BEGIN
IF EQUAL(5,5) THEN
RETURN FT;
ELSE
RETURN 0.0;
END IF;
END IDENT_FLT;
 
TASK BODY TTYPE IS
ITEMP : INTEGER := 0;
FTEMP : FLT := 0.0;
BEGIN
ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER) DO
ITEMP := J;
IF EQUAL(3,3) THEN
K := ITEMP;
ELSE
K := 0;
END IF;
END ADD;
ACCEPT MULT(Y : IN FLT; Z : IN OUT FLT) DO
FTEMP := Y;
IF EQUAL(3,3) THEN
Z := FTEMP;
ELSE
Z := 0.0;
END IF;
END MULT;
END TTYPE;
 
PROCEDURE TEST_TASK(G : IN TTYPE;
S : IN FLT; T : IN OUT FLT) IS
R : FLT := 4.0;
BEGIN
IF NOT (G'CALLABLE) OR G'TERMINATED THEN
FAILED("TASK INSIDE PROCEDURE IS SHOWING " &
"WRONG VALUE FOR 'CALLABLE OR " &
"'TERMINATED");
END IF;
G.MULT(S,T);
END TEST_TASK;
 
BEGIN
 
IF TTYPE'STORAGE_SIZE < IDENT_INT(TASK_STORAGE_SIZE) THEN
FAILED("ACTUAL 'STORAGE_SIZE USED IS SMALLER " &
"THAN SIZE REQUESTED");
END IF;
 
T.ADD(M,N);
 
IF M /= IDENT_INT(N) THEN
FAILED("TASK CALL PARAMETERS NOT EQUAL");
END IF;
 
V := IDENT_FLT(13.0);
TEST_TASK(T,V,W);
IF V /= IDENT_FLT(W) THEN
FAILED("TASK AS PARAMETER FAILED");
END IF;
 
END PACK;
BEGIN
NULL;
END;
 
RESULT;
END CD2C11A;
/cd7101d.ada
0,0 → 1,53
-- CD7101D.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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM,
-- INTEGER'FIRST >= MIN_INT AND INTEGER'LAST <= MAX_INT.
 
-- HISTORY:
-- JET 09/10/87 CREATED ORIGINAL TEST.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
 
PROCEDURE CD7101D IS
 
BEGIN
 
TEST ("CD7101D", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " &
"SYSTEM, INTEGER'FIRST >= MIN_INT AND INTEGER'" &
"LAST <= MAX_INT");
 
IF INTEGER'POS (INTEGER'FIRST) < SYSTEM.MIN_INT THEN
FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
END IF;
 
IF INTEGER'POS (INTEGER'LAST) > SYSTEM.MAX_INT THEN
FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
END IF;
 
RESULT;
 
END CD7101D;
/cd30001.a
0,0 → 1,284
-- CD30001.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 X'Address produces a useful result when X is an aliased
-- object.
-- Check that X'Address produces a useful result when X is an object of
-- a by-reference type.
-- Check that X'Address produces a useful result when X is an entity
-- whose Address has been specified.
--
-- Check that aliased objects and subcomponents are allocated on storage
-- element boundaries. Check that objects and subcomponents of by
-- reference types are allocated on storage element boundaries.
--
-- Check that for an array X, X'Address points at the first component
-- of the array, and not at the array bounds.
--
-- TEST DESCRIPTION:
-- This test defines a data structure (an array of records) where each
-- aspect of the data structure is aliased. The test checks 'Address
-- for each "layer" of aliased objects.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 22 JUL 95 SAIC Initial version
-- 08 MAY 96 SAIC Reinforced for 2.1
-- 16 FEB 98 EDS Modified documentation
--!
 
----------------------------------------------------------------- CD30001_0
 
with SPPRT13;
package CD30001_0 is
 
-- Check that X'Address produces a useful result when X is an aliased
-- object.
-- Check that X'Address produces a useful result when X is an object of
-- a by-reference type.
-- Check that X'Address produces a useful result when X is an entity
-- whose Address has been specified.
-- (using the new form of "for X'Address use ...")
--
-- Check that aliased objects and subcomponents are allocated on storage
-- element boundaries. Check that objects and subcomponents of by
-- reference types are allocated on storage element boundaries.
 
type Simple_Enum_Type is (Just, A, Little, Bit);
 
type Data is record
Aliased_Comp_1 : aliased Simple_Enum_Type;
Aliased_Comp_2 : aliased Simple_Enum_Type;
end record;
 
type Array_W_Aliased_Comps is array(1..2) of aliased Data;
 
Aliased_Object : aliased Array_W_Aliased_Comps;
 
Specific_Object : aliased Array_W_Aliased_Comps;
for Specific_Object'Address use SPPRT13.Variable_Address2; -- ANX-C RQMT.
 
procedure TC_Check_Aliased_Addresses;
 
procedure TC_Check_Specific_Addresses;
 
procedure TC_Check_By_Reference_Types;
 
end CD30001_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;
package body CD30001_0 is
 
package Simple_Enum_Type_Ref_Conv is
new System.Address_To_Access_Conversions(Simple_Enum_Type);
 
package Data_Ref_Conv is new System.Address_To_Access_Conversions(Data);
 
package Array_W_Aliased_Comps_Ref_Conv is
new System.Address_To_Access_Conversions(Array_W_Aliased_Comps);
 
use type System.Address;
use type System.Storage_Elements.Integer_Address;
use type System.Storage_Elements.Storage_Offset;
 
procedure TC_Check_Aliased_Addresses is
use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
use type Data_Ref_Conv.Object_Pointer;
use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
 
begin
 
-- Check the object Aliased_Object
 
if Aliased_Object'Address not in System.Address then
Report.Failed("Aliased_Object'Address not an address");
end if;
 
if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(Aliased_Object'Address)
/= Aliased_Object'Unchecked_Access then
Report.Failed
("'Unchecked_Access does not match expected address value");
end if;
 
-- Check the element Aliased_Object(1)
 
if Data_Ref_Conv.To_Address( Aliased_Object(1)'Access )
/= Aliased_Object(1)'Address then
Report.Failed
("Array element 'Access does not match expected address value");
end if;
 
-- Check that Array'Address points at the first component...
 
if Array_W_Aliased_Comps_Ref_Conv.To_Address( Aliased_Object'Access )
/= Aliased_Object(1)'Address then
Report.Failed
("Address of array object does not equal address of first component");
end if;
 
-- Check the components of Aliased_Object(2)
 
if Simple_Enum_Type_Ref_Conv.To_Address(
Aliased_Object(2).Aliased_Comp_1'Unchecked_Access)
not in System.Address then
Report.Failed("Component 2 'Unchecked_Access not a valid address");
end if;
 
if Aliased_Object(2).Aliased_Comp_2'Address not in System.Address then
Report.Failed("Component 2 not located at a valid address ");
end if;
 
end TC_Check_Aliased_Addresses;
 
procedure TC_Check_Specific_Addresses is
use type System.Address;
use type System.Storage_Elements.Integer_Address;
use type Simple_Enum_Type_Ref_Conv.Object_Pointer;
use type Data_Ref_Conv.Object_Pointer;
use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer;
begin
 
-- Check the object Specific_Object
 
if System.Storage_Elements.To_Integer(Specific_Object'Address)
/= System.Storage_Elements.To_Integer(SPPRT13.Variable_Address2) then
Report.Failed
("Specific_Object not at address specified in representation clause");
end if;
 
if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(SPPRT13.Variable_Address2)
/= Specific_Object'Unchecked_Access then
Report.Failed("Specific_Object'Unchecked_Access not expected value");
end if;
 
-- Check the element Specific_Object(1)
 
if Data_Ref_Conv.To_Address( Specific_Object(1)'Access )
/= Specific_Object(1)'Address then
Report.Failed
("Specific Array element 'Access does not correspond to the "
& "elements 'Address");
end if;
 
-- Check that Array'Address points at the first component...
 
if Array_W_Aliased_Comps_Ref_Conv.To_Address( Specific_Object'Access )
/= Specific_Object(1)'Address then
Report.Failed
("Address of array object does not equal address of first component");
end if;
 
-- Check the components of Specific_Object(2)
 
if Simple_Enum_Type_Ref_Conv.To_Address(
Specific_Object(1).Aliased_Comp_1'Access)
not in System.Address then
Report.Failed("Access value of first record component for object at " &
"specific address not a valid address");
end if;
 
if Specific_Object(2).Aliased_Comp_2'Address not in System.Address then
Report.Failed("Second record component for object at specific " &
"address not located at a valid address");
end if;
 
end TC_Check_Specific_Addresses;
 
-- Check that X'Address produces a useful result when X is an object of
-- a by-reference type.
 
type Tagged_But_Not_Exciting is tagged record
A_Bit_Of_Data : Boolean;
end record;
 
Tagged_Object : Tagged_But_Not_Exciting;
 
procedure Muck_With_Addresses( It : in out Tagged_But_Not_Exciting;
Its_Address : in System.Address ) is
begin
if It'Address /= Its_Address then
Report.Failed("Address of object passed by reference does not " &
"match address of object passed" );
end if;
end Muck_With_Addresses;
 
procedure TC_Check_By_Reference_Types is
begin
Muck_With_Addresses( Tagged_Object, Tagged_Object'Address );
end TC_Check_By_Reference_Types;
 
end CD30001_0;
 
------------------------------------------------------------------- CD30001
 
with Report;
with CD30001_0;
procedure CD30001 is
 
begin -- Main test procedure.
 
Report.Test ("CD30001",
"Check that X'Address produces a useful result when X is " &
"an aliased object, or an entity whose Address has been " &
"specified" );
-- Check that X'Address produces a useful result when X is an aliased
-- object.
--
-- Check that aliased objects and subcomponents are allocated on storage
-- element boundaries. Check that objects and subcomponents of by
-- reference types are allocated on storage element boundaries.
 
CD30001_0.TC_Check_Aliased_Addresses;
 
-- Check that X'Address produces a useful result when X is an entity
-- whose Address has been specified.
 
CD30001_0.TC_Check_Specific_Addresses;
 
-- Check that X'Address produces a useful result when X is an object of
-- a by-reference type.
 
CD30001_0.TC_Check_By_Reference_Types;
 
Report.Result;
 
end CD30001;
/cd5012i.ada
0,0 → 1,87
-- CD5012I.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN
-- ACCESS TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM.
 
-- HISTORY:
-- DHH 09/17/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
WITH SPPRT13;
PROCEDURE CD5012I IS
 
BEGIN
 
TEST ("CD5012I", "AN ADDRESS CLAUSE CAN BE " &
"GIVEN FOR A VARIABLE OF AN ACCESS " &
"TYPE IN THE DECLARATIVE PART OF A " &
"GENERIC SUBPROGRAM");
 
DECLARE
 
GENERIC
PROCEDURE GENPROC;
 
PROCEDURE GENPROC IS
 
TYPE CELL;
TYPE POINTER IS ACCESS CELL;
TYPE CELL IS
RECORD
VALUE : INTEGER;
NEXT : POINTER;
END RECORD;
 
C,PTR : POINTER := NULL;
 
FOR PTR USE AT
SPPRT13.VARIABLE_ADDRESS;
BEGIN
PTR := NEW CELL'(0,NULL);
C := PTR;
 
IF EQUAL (3, 3) THEN
PTR.VALUE := 1;
PTR.NEXT := C;
END IF;
IF PTR.ALL /= (1,C) THEN
FAILED ("WRONG VALUE FOR VARIABLE IN " &
"A GENERIC PROCEDURE");
END IF;
IF PTR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
FAILED ("WRONG ADDRESS FOR VARIABLE " &
"IN A GENERIC PROCEDURE");
END IF;
END GENPROC;
 
PROCEDURE PROC IS NEW GENPROC;
BEGIN
PROC;
END;
RESULT;
END CD5012I;
/cd1009t.tst
0,0 → 1,77
-- CD1009T.TST
 
-- 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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
-- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL
-- TYPE DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE
-- PART OF THE SAME PACKAGE.
 
-- MACRO SUBSTITUTION:
-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR
-- THE ACTIVATION OF A TASK.
 
-- HISTORY:
-- VCL 10/21/87 CREATED ORIGINAL TEST.
-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED
-- EXTENSION FROM '.DEP' TO '.TST'.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009T IS
BEGIN
TEST ("CD1009T", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
"PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " &
"TYPE, WHOSE FULL TYPE DECLARATION IS A " &
"TASK TYPE, DECLARED IN THE VISIBLE PART OF " &
"THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE;
 
TYPE CHECK_TYPE_1;
TYPE ACC IS ACCESS CHECK_TYPE_1;
 
TASK TYPE CHECK_TYPE_1 IS END CHECK_TYPE_1;
PRIVATE
FOR CHECK_TYPE_1'STORAGE_SIZE
USE SPECIFIED_SIZE;
END PACK;
 
PACKAGE BODY PACK IS
TASK BODY CHECK_TYPE_1 IS
I : INTEGER;
BEGIN
NULL;
END CHECK_TYPE_1;
END PACK;
 
USE PACK;
BEGIN
IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
END IF;
END;
 
RESULT;
END CD1009T;
/cd70001.a
0,0 → 1,201
--
-- CD70001.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 package System includes Max_Base_Digits, Address,
-- Null_Address, Word_Size, functions "<", "<=", ">", ">=", "="
-- (with Address parameters and Boolean results), Bit_Order,
-- Default_Bit_Order, Any_Priority, Interrupt_Priority,
-- and Default_Priority.
--
-- Check that package System.Storage_Elements includes all required
-- types and operations.
--
-- TEST DESCRIPTION:
-- The test checks for the existence of the names additional
-- to package system above those names tested for in 9Xbasic.
--
-- This test checks that the semantics provided in Storage_Elements
-- are present and operate marginally within expectations (to the best
-- extent possible in a portable implementation independent fashion).
--
--
-- CHANGE HISTORY:
-- 09 MAY 95 SAIC Initial version
-- 27 JAN 96 SAIC Revised for 2.1; Allow negative address delta
--
--!
 
with Report;
with Ada.Text_IO;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;
procedure CD70001 is
use System;
 
procedure CD70 is
 
type Int_Max is range Min_Int .. Max_Int;
 
My_Int : Int_Max := System.Max_Base_Digits + System.Word_Size;
 
An_Address : Address;
An_Other_Address : Address := An_Address'Address;
 
begin -- 7.0
 
 
if Default_Bit_Order not in High_Order_First..Low_Order_First then
Report.Failed ("Default_Bit_Order invalid");
end if;
 
if Bit_Order'Pos(High_Order_First) /= 0 then
Report.Failed ("Bit_Order'Pos(High_Order_First) /= 0");
end if;
 
if Bit_Order'Pos(Low_Order_First) /= 1 then
Report.Failed ("Bit_Order'Pos(Low_Order_First) /= 1");
end if;
 
An_Address := My_Int'Address;
 
if An_Address = Null_Address then
Report.Failed ("Null_Address matched a real address");
end if;
 
 
if An_Address'Address /= An_Other_Address then
Report.Failed("Value set at elaboration not equal to itself");
end if;
 
if An_Address'Address > An_Other_Address
and An_Address'Address < An_Other_Address then
Report.Failed("Address is both greater and less!");
end if;
 
if not (An_Address'Address >= An_Other_Address
and An_Address'Address <= An_Other_Address) then
Report.Failed("Address comparisons wrong");
end if;
 
 
if Priority'First /= Any_Priority'First then
Report.Failed ("Priority'First /= Any_Priority'First");
end if;
 
if Interrupt_Priority'First /= Priority'Last+1 then
Report.Failed ("Interrupt_Priority'First /= Priority'Last+1");
end if;
 
if Interrupt_Priority'Last /= Any_Priority'Last then
Report.Failed ("Interrupt_Priority'Last /= Any_Priority'Last");
end if;
 
if Default_Priority /= ((Priority'First + Priority'Last)/2) then
Report.Failed ("Default_Priority wrong value");
end if;
 
end CD70;
 
procedure CD71 is
use System.Storage_Elements;
 
Storehouse_1 : Storage_Array(0..127);
Storehouse_2 : Storage_Array(0..127);
 
House_Offset : Storage_Offset;
 
begin -- 7.1
 
 
if Storage_Count'First /= 0 then
Report.Failed ("Storage_Count'First /= 0");
end if;
 
if Storage_Count'Last /= Storage_Offset'Last then
Report.Failed ("Storage_Count'Last /= Storage_Offset'Last");
end if;
 
 
if Storage_Element'Size /= Storage_Unit then
Report.Failed ("Storage_Element'Size /= Storage_Unit");
end if;
 
if Storage_Array'Component_Size /= Storage_Unit then
Report.Failed ("Storage_Array'Element_Size /= Storage_Unit");
end if;
 
if Storage_Element'Last+1 /= 0 then
Report.Failed ("Storage_Element not modular");
end if;
 
 
-- "+", "-"( Address, Storage_Offset) and inverse
 
House_Offset := Storehouse_2'Address - Storehouse_1'Address;
-- Address - Address = Offset
-- Note that House_Offset may be a negative value
 
if House_Offset + Storehouse_1'Address /= Storehouse_2'Address then
-- Offset + Address = Address
Report.Failed ("Storage arithmetic non-linear O+A");
end if;
 
if Storehouse_1'Address + House_Offset /= Storehouse_2'Address then
-- Address + Offset = Address
Report.Failed ("Storage arithmetic non-linear A+O");
end if;
 
if Storehouse_2'Address - House_Offset /= Storehouse_1'Address then
-- Address - Offset = Address
Report.Failed ("Storage arithmetic non-linear A-O");
end if;
 
if (Storehouse_2'Address mod abs(House_Offset) > abs(House_Offset)) then
-- "mod"( Address, Storage_Offset)
Report.Failed("Mod arithmetic");
end if;
 
 
if Storehouse_1'Address
/= To_Address(To_Integer(Storehouse_1'Address)) then
Report.Failed("To_Address, To_Integer not symmetric");
end if;
 
end CD71;
 
 
begin -- Main test procedure.
 
Report.Test ("CD70001", "Check package System" );
 
CD70;
 
CD71;
 
Report.Result;
 
end CD70001;
/cd5012m.ada
0,0 → 1,78
-- CD5012M.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A
-- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A GENERIC
-- SUBPROGRAM.
 
-- HISTORY:
-- DHH 09/15/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
WITH SPPRT13;
PROCEDURE CD5012M IS
 
BEGIN
 
TEST ("CD5012M", "AN ADDRESS CLAUSE CAN BE " &
"GIVEN FOR A VARIABLE OF A LIMITED " &
"PRIVATE TYPE IN THE DECLARATIVE " &
"PART OF A GENERIC SUBPROGRAM");
 
DECLARE
 
PACKAGE P IS
TYPE FIXED IS LIMITED PRIVATE;
 
PRIVATE
TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0;
END P;
 
USE P;
 
GENERIC
PROCEDURE GENPROC;
 
PROCEDURE GENPROC IS
 
TESTFIX : FIXED;
 
FOR TESTFIX USE AT
SPPRT13.VARIABLE_ADDRESS;
BEGIN
IF TESTFIX'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN
FAILED ("WRONG ADDRESS FOR LIMITED PRIVATE " &
"TYPE VARIABLE IN GENERIC PROCEDURE");
END IF;
END GENPROC;
 
PROCEDURE PROC IS NEW GENPROC;
BEGIN
PROC;
END;
RESULT;
END CD5012M;
/cda201b.ada
0,0 → 1,63
-- CDA201B.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR
-- CONVERSION BETWEEN FLOAT AND BOOLEAN ARRAY TYPES.
 
-- HISTORY:
-- JET 09/12/88 CREATED ORIGINAL TEST.
-- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
-- GJD 11/15/95 REMOVED USE OF OBSOLETE ADA 83 ATTRIBUTE (LARGE).
 
WITH REPORT; USE REPORT;
WITH UNCHECKED_CONVERSION;
PROCEDURE CDA201B IS
 
TYPE BOOL_ARR IS ARRAY (1..FLOAT'SIZE) OF BOOLEAN;
PRAGMA PACK (BOOL_ARR);
 
B : BOOL_ARR;
 
FUNCTION FLT_TO_BOOL IS NEW UNCHECKED_CONVERSION(FLOAT, BOOL_ARR);
 
FUNCTION BOOL_TO_FLT IS NEW UNCHECKED_CONVERSION(BOOL_ARR, FLOAT);
 
BEGIN
TEST ("CDA201B", "CHECK THAT UNCHECKED_CONVERSION CAN BE " &
"INSTANTIATED FOR CONVERSION BETWEEN " &
"FLOAT AND BOOLEAN ARRAY TYPES");
 
B := FLT_TO_BOOL(FLOAT'LAST + FLOAT(IDENT_INT(0)));
 
FOR J IN B'RANGE LOOP
B(J) := B(J+IDENT_INT(0));
END LOOP;
 
IF BOOL_TO_FLT(B) /= FLOAT'LAST THEN
FAILED("INCORRECT RESULT FROM FLOAT-ARRAY-FLOAT");
END IF;
 
RESULT;
END CDA201B;
/cd2d11a.ada
0,0 → 1,214
-- CD2D11A.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 IF A SMALL SPECIFICATION IS GIVEN FOR A
-- FIXED POINT TYPE, THEN ARITHMETIC OPERATIONS ON VALUES OF THE
-- TYPE ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
 
-- HISTORY:
-- BCB 09/01/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH REPORT; USE REPORT;
PROCEDURE CD2D11A IS
 
BASIC_SMALL : CONSTANT := 2.0 ** (-4);
 
TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0;
 
TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0;
 
FOR CHECK_TYPE'SMALL USE BASIC_SMALL;
 
CNEG1 : CHECK_TYPE := -3.5;
CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
CPOS2 : CHECK_TYPE := 3.5;
CZERO : CHECK_TYPE;
 
TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE;
CHARRAY : ARRAY_TYPE :=
(-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5);
 
TYPE REC_TYPE IS RECORD
COMPN1 : CHECK_TYPE := -3.5;
COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0);
COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0);
COMPP2 : CHECK_TYPE := 3.5;
END RECORD;
 
CHREC : REC_TYPE;
 
FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN FX;
ELSE
RETURN 0.0;
END IF;
END IDENT;
 
PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE;
N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE;
CZOUT : OUT CHECK_TYPE) IS
BEGIN
 
IF IDENT (N1_IN) + P1_IN NOT IN
-2.875 .. -2.8125 OR
P2_INOUT - IDENT (P1_IN) NOT IN
2.8125 .. 2.875 THEN
FAILED ("INCORRECT RESULTS FOR " &
"BINARY ADDING OPERATORS - 1");
END IF;
 
IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR
IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN
FAILED ("INCORRECT RESULTS FOR " &
"UNARY ADDING OPERATORS - 1");
END IF;
 
IF CHECK_TYPE (N1_IN * IDENT (P1_IN)) NOT IN
-2.4375 .. -2.1875 OR
CHECK_TYPE (IDENT (N2_INOUT) / P2_INOUT) NOT IN
-0.125 .. -0.0625 THEN
FAILED ("INCORRECT RESULTS FOR " &
"MULTIPLYING OPERATORS - 1");
END IF;
 
IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR
IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN
FAILED ("INCORRECT RESULTS FOR " &
"ABSOLUTE VALUE OPERATORS - 1");
END IF;
 
CZOUT := 0.0;
 
END PROC;
 
BEGIN
TEST ("CD2D11A", "CHECK THAT IF A SMALL SPECIFICATION IS " &
"GIVEN FOR AN FIXED POINT TYPE, THEN " &
"ARITHMETIC OPERATIONS ON VALUES OF THE " &
"TYPE ARE NOT AFFECTED BY THE REPRESENTATION " &
"CLAUSE");
 
PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO);
 
IF IDENT (CZERO) /= 0.0 THEN
FAILED ("INCORRECT VALUE FOR OUT PARAMETER");
END IF;
 
IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR
CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN
FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2");
END IF;
 
IF +IDENT (CNEG2) NOT IN -0.375 .. -0.3125 OR
IDENT (-CPOS1) NOT IN -0.6875 .. -0.625 THEN
FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2");
END IF;
 
IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR
CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN
-0.125 .. -0.0625 THEN
FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2");
END IF;
 
IF ABS IDENT (CNEG2) NOT IN 0.3125 .. 0.375 OR
IDENT (ABS CPOS1) NOT IN 0.625 .. 0.6875 THEN
FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
"OPERATORS - 2");
END IF;
 
IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR
CNEG2 IN -0.25 .. 0.0 OR
IDENT (CNEG2) IN -1.0 .. -0.4375 THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
END IF;
 
IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN
-2.875 .. -2.8125 OR
CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN
2.8125 .. 2.875 THEN
FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3");
END IF;
 
IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR
IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN
FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3");
END IF;
 
IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN
-2.4375 .. -2.1875 OR
CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN
-0.125 .. -0.0625 THEN
FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3");
END IF;
 
IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR
IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN
FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
"OPERATORS - 3");
END IF;
 
IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR
CHARRAY (1) IN -0.25 .. 0.0 OR
IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
END IF;
 
IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN
-2.875 .. -2.8125 OR
CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN
2.8125 .. 2.875 THEN
FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4");
END IF;
 
IF +IDENT (CHREC.COMPN2) NOT IN -0.375 .. -0.3125 OR
IDENT (-CHREC.COMPP1) NOT IN -0.6875 .. -0.625 THEN
FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4");
END IF;
 
IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN
-2.4375 .. -2.1875 OR
CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN
-0.125 .. -0.0625 THEN
FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4");
END IF;
 
IF ABS IDENT (CHREC.COMPN2) NOT IN 0.3125 .. 0.375 OR
IDENT (ABS CHREC.COMPP1) NOT IN 0.625 .. 0.6875 THEN
FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " &
"OPERATORS - 4");
END IF;
 
IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR
CHREC.COMPN2 IN -0.25 .. 0.0 OR
IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
END IF;
 
RESULT;
END CD2D11A;
/cd2a24a.ada
0,0 → 1,226
-- CD2A24A.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION
-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
-- THEN OPERATIONS ON VALUES OF SUCH A TYPE WITH THE SMALLEST
-- APPROPRIATE SIGNED SIZE ARE NOT AFFECTED BY THE
-- REPRESENTATION CLAUSE.
 
-- HISTORY:
-- JET 08/19/87 CREATED ORIGINAL TEST.
-- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
-- REPRESENTATION CLAUSE.
-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
 
WITH REPORT; USE REPORT;
WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
PROCEDURE CD2A24A IS
 
BASIC_SIZE : CONSTANT := 4;
 
TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
 
FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5);
 
FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
 
C0 : CHECK_TYPE := ZERO;
C1 : CHECK_TYPE := ONE;
C2 : CHECK_TYPE := TWO;
 
TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
 
TYPE REC_TYPE IS RECORD
COMP0 : CHECK_TYPE := ZERO;
COMP1 : CHECK_TYPE := ONE;
COMP2 : CHECK_TYPE := TWO;
END RECORD;
 
CHREC : REC_TYPE;
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN ONE;
END IF;
END IDENT;
 
PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
 
PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
CIO1, CIO2 : IN OUT CHECK_TYPE;
CO2 : OUT CHECK_TYPE) IS
BEGIN
IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND
(CI0 NOT IN IDENT (ONE) .. CIO2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " &
"- 1");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR
CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR
CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1");
END IF;
 
IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR
CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1");
END IF;
 
CO2 := TWO;
 
END PROC;
 
BEGIN
TEST ("CD2A24A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " &
"AN ENUMERATION REPRESENTATION CLAUSE ARE " &
"GIVEN FOR AN ENUMERATION TYPE, THEN " &
"OPERATIONS ON VALUES OF SUCH A TYPE WITH " &
"THE SMALLEST APPROPRIATE SIGNED SIZE ARE " &
"NOT AFFECTED BY THE REPRESENTATION CLAUSE");
 
CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
PROC (ZERO, TWO, C1, C2, C2);
 
IF C1 /= ONE OR C2 /= TWO THEN
FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE");
END IF;
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND
(C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
END IF;
 
IF CHECK_TYPE'LAST /= IDENT (TWO) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2");
END IF;
 
IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2");
END IF;
 
IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2");
END IF;
 
IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2");
END IF;
 
IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
END IF;
 
IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
(IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
(CHARRAY (1) <= IDENT (ONE)) AND
(IDENT (TWO) = CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
END IF;
 
IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
(CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR
CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR
CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3");
END IF;
 
IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR
CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3");
END IF;
 
IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
END IF;
 
IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
(IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
(CHREC.COMP1 <= IDENT (ONE)) AND
(IDENT (TWO) = CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
END IF;
 
IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
(CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
END IF;
 
IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4");
END IF;
 
IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR
CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4");
END IF;
 
IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4");
END IF;
 
 
RESULT;
 
END CD2A24A;
/cd2a24e.ada
0,0 → 1,220
-- CD2A24E.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 IF A SIZE CLAUSE AND AN ENUMERATION
-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
-- AND THE SMALLEST SIZE APPROPRIATE FOR AN UNSIGNED REPRESENTATION
-- IS SPECIFIED, THEN OPERATIONS ON THE TYPE ARE NOT AFFECTED.
 
-- HISTORY:
-- JET 08/19/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
 
WITH REPORT; USE REPORT;
PROCEDURE CD2A24E IS
 
BASIC_SIZE : CONSTANT := 3;
 
TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
 
FOR CHECK_TYPE USE (ZERO => 3, ONE => 4,
TWO => 5);
 
FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
 
C0 : CHECK_TYPE := ZERO;
C1 : CHECK_TYPE := ONE;
C2 : CHECK_TYPE := TWO;
 
TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
 
TYPE REC_TYPE IS RECORD
COMP0 : CHECK_TYPE := ZERO;
COMP1 : CHECK_TYPE := ONE;
COMP2 : CHECK_TYPE := TWO;
END RECORD;
 
CHREC : REC_TYPE;
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN ONE;
END IF;
END IDENT;
 
PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
CIO1, CIO2 : IN OUT CHECK_TYPE;
CO2 : OUT CHECK_TYPE) IS
BEGIN
IF NOT ((CI0 < IDENT (ONE)) AND
(IDENT (CI2) > IDENT (CIO1)) AND
(CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
"- 1");
END IF;
 
IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1");
END IF;
 
IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR
CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1");
END IF;
 
IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1");
END IF;
 
 
CO2 := TWO;
 
END PROC;
 
BEGIN
TEST ("CD2A24E", "CHECK THAT IF A SIZE CLAUSE AND AN ENUMERATION " &
"REPRESENTATION CLAUSE ARE GIVEN FOR AN " &
"ENUMERATION TYPE, AND THE SMALLEST SIZE " &
"APPROPRIATE FOR AN UNSIGNED REPRESENTATION " &
"IS SPECIFIED, THEN OPERATIONS ON THE TYPE " &
"ARE NOT AFFECTED");
 
PROC (ZERO, TWO, C1, C2, C2);
 
IF C1 /= ONE OR C2 /= TWO THEN
FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE");
END IF;
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((IDENT (C1) IN C1 .. C2) AND
(C0 NOT IN IDENT (ONE) .. C2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
END IF;
 
IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
CHECK_TYPE'VAL (1) /= IDENT (C1) OR
CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2");
END IF;
 
IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2");
END IF;
 
IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE");
END IF;
 
IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
(IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
(CHARRAY (1) <= IDENT (ONE)) AND
(IDENT (TWO) = CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
END IF;
 
IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
(CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
END IF;
 
IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR
CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR
CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3");
END IF;
 
IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR
CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3");
END IF;
 
IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3");
END IF;
 
IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
END IF;
 
IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
(IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
(CHREC.COMP1 <= IDENT (ONE)) AND
(IDENT (TWO) = CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
END IF;
 
IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
(CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR
CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4");
END IF;
 
IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4");
END IF;
 
RESULT;
END CD2A24E;
/cd2a32j.ada
0,0 → 1,135
-- CD2A32J.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE
-- UNSIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN BE
-- PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES.
 
-- HISTORY:
-- JET 08/12/87 CREATED ORIGINAL TEST.
-- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON
-- 'SIZE CHECKS.
-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
 
WITH REPORT; USE REPORT;
 
PROCEDURE CD2A32J IS
 
TYPE BASIC_INT IS RANGE 0 .. 126;
BASIC_SIZE : CONSTANT := 7;
 
FOR BASIC_INT'SIZE USE BASIC_SIZE;
 
BEGIN
 
TEST ("CD2A32J", "CHECK THAT WHEN A SIZE SPECIFICATION " &
"OF THE SMALLEST APPROPRIATE UNSIGNED SIZE " &
"IS GIVEN FOR AN INTEGER TYPE, THE TYPE " &
"CAN BE PASSED AS AN ACTUAL PARAMETER TO " &
"GENERIC PROCEDURES");
 
DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE.
 
GENERIC
TYPE GPARM IS RANGE <>;
PROCEDURE GENPROC;
 
PROCEDURE GENPROC IS
 
SUBTYPE INT IS GPARM;
 
I0 : INT := 0;
I1 : INT := 63;
I2 : INT := 126;
 
FUNCTION IDENT (I : INT) RETURN INT IS
BEGIN
IF EQUAL (0,0) THEN
RETURN I;
ELSE
RETURN 0;
END IF;
END IDENT;
 
BEGIN -- GENPROC.
 
IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR INT'SIZE");
END IF;
 
IF I0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR I0'SIZE");
END IF;
 
IF NOT ((I0 < IDENT (1)) AND
(IDENT (I2) > IDENT (I1)) AND
(I1 <= IDENT (63)) AND
(IDENT (126) = I2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
"OPERATORS");
END IF;
 
IF NOT (((I0 + I2) = I2) AND
((I2 - I1) = I1) AND
((I1 * IDENT (2)) = I2) AND
((I2 / I1) = IDENT (2)) AND
((I1 ** 1) = IDENT (63)) AND
((I2 REM 10) = IDENT (6)) AND
((I1 MOD 10) = IDENT (3))) THEN
FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " &
"OPERATORS");
END IF;
 
IF INT'POS (I0) /= IDENT_INT (0) OR
INT'POS (I1) /= IDENT_INT (63) OR
INT'POS (I2) /= IDENT_INT (126) THEN
FAILED ("INCORRECT VALUE FOR INT'POS");
END IF;
 
IF INT'SUCC (I0) /= IDENT (1) OR
INT'SUCC (I1) /= IDENT (64) THEN
FAILED ("INCORRECT VALUE FOR INT'SUCC");
END IF;
 
IF INT'IMAGE (I0) /= IDENT_STR (" 0") OR
INT'IMAGE (I1) /= IDENT_STR (" 63") OR
INT'IMAGE (I2) /= IDENT_STR (" 126") THEN
FAILED ("INCORRECT VALUE FOR INT'IMAGE");
END IF;
 
END GENPROC;
 
PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT);
 
BEGIN
 
NEWPROC;
 
END;
 
RESULT;
 
END CD2A32J;
/cd2a24i.ada
0,0 → 1,126
-- CD2A24I.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 IF A SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE
-- SIZE FOR A SIGNED REPRESENTATION) AND AN ENUMERATION
-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE,
-- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN
-- INSTANTIATION.
 
-- HISTORY:
-- JET 08/19/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES.
 
WITH REPORT; USE REPORT;
PROCEDURE CD2A24I IS
 
TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
BASIC_SIZE : CONSTANT := 4;
 
FOR BASIC_ENUM USE (ZERO => 3, ONE => 4,
TWO => 5);
 
FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
 
BEGIN
TEST ("CD2A24I", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " &
"SMALLEST APPROPRIATE SIZE FOR A SIGNED " &
"REPRESENTATION) AND AN ENUMERATION " &
"REPRESENTATION CLAUSE ARE GIVEN FOR AN " &
"ENUMERATION TYPE, THEN THE TYPE CAN BE USED " &
"AS AN ACTUAL PARAMETER IN AN INSTANTIATION");
 
 
DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
 
GENERIC
TYPE GPARM IS (<>);
PROCEDURE GENPROC (C0, C1, C2: GPARM);
 
PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
 
SUBTYPE CHECK_TYPE IS GPARM;
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN C1;
END IF;
END IDENT;
 
BEGIN -- GENPROC.
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((C0 < IDENT (C1)) AND
(IDENT (C2) > IDENT (C1)) AND
(C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
"OPERATORS");
END IF;
 
IF CHECK_TYPE'FIRST /= IDENT (C0) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
END IF;
 
IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS");
END IF;
 
IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC");
END IF;
 
IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE");
END IF;
 
END GENPROC;
 
PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
 
BEGIN
 
NEWPROC (ZERO, ONE, TWO);
 
END;
 
RESULT;
 
END CD2A24I;
/cd3021a.ada
0,0 → 1,66
-- CD3021A.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE AGGREGATE IN AN ENUMERATION REPRESENTATION CLAUSE
-- IS NOT AMBIGUOUS EVEN IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY
-- TYPES WITH THE ENUMERATION TYPE AS THE INDEX SUBTYPE.
 
-- HISTORY:
-- BCB 09/30/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
-- CHECKS FOR FAILURE.
 
WITH REPORT; USE REPORT;
 
PROCEDURE CD3021A IS
 
TYPE ENUM IS (A,B,C);
 
TYPE ARR1 IS ARRAY(ENUM) OF INTEGER;
TYPE ARR2 IS ARRAY(ENUM) OF INTEGER;
TYPE ARR3 IS ARRAY(ENUM) OF INTEGER;
 
FOR ENUM USE (A => 1,B => 2,C => 3);
 
A1 : ARR1 := (A => 5,B => 6,C => 13);
A2 : ARR2 := (A => 1,B => 2,C => 3);
A3 : ARR3 := (A => 0,B => 1,C => 2);
 
BEGIN
 
TEST ("CD3021A", "CHECK THAT THE AGGREGATE IN AN ENUMERATION " &
"REPRESENTATION CLAUSE IS NOT AMBIGUOUS EVEN " &
"IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY " &
"TYPES WITH THE ENUMERATION TYPE AS THE INDEX " &
"SUBTYPE");
 
IF (A1 /= (IDENT_INT (5), IDENT_INT (6), IDENT_INT (13))) OR
(A2 /= (IDENT_INT (1), IDENT_INT (2), IDENT_INT (3))) OR
(A3 /= (IDENT_INT (0), IDENT_INT (1), IDENT_INT (2))) THEN
FAILED ("INCORRECT VALUES FOR ARRAYS");
END IF;
 
RESULT;
END CD3021A;
/cd1009b.ada
0,0 → 1,80
-- CD1009B.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE
-- OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION TYPE DECLARED
-- IN THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/07/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009B IS
BEGIN
TEST ("CD1009B", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " &
"OR PRIVATE PART OF A PACKAGE FOR AN " &
"ENUMERATION TYPE DECLARED IN THE VISIBLE " &
"PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
 
TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3);
FOR CHECK_TYPE_1'SIZE
USE SPECIFIED_SIZE;
 
TYPE CHECK_TYPE_2 IS (A0, A1, A2, A3);
PRIVATE
FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
X : CHECK_TYPE_1 := A0;
Y : CHECK_TYPE_2 := A2;
BEGIN
IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
END IF;
 
IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
END IF;
 
IF X'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT'SIZE IS TOO SMALL --" &
CHECK_TYPE_1'IMAGE(X));
END IF;
 
IF Y'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT'SIZE IS TOO SMALL --" &
CHECK_TYPE_2'IMAGE(Y));
END IF;
 
END;
 
RESULT;
END CD1009B;
/cd1009d.ada
0,0 → 1,84
-- CD1009D.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE
-- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED IN
-- THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/07/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009D IS
BEGIN
TEST ("CD1009D", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " &
"OR PRIVATE PART OF A PACKAGE FOR A " &
"FIXED POINT TYPE DECLARED IN THE VISIBLE " &
"PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0;
 
SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE;
 
TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
FOR CHECK_TYPE_1'SIZE
USE SPECIFIED_SIZE;
 
TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
PRIVATE
FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
 
X: CHECK_TYPE_1 := 0.5;
Y: CHECK_TYPE_2 := 0.5;
 
BEGIN
IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
END IF;
 
IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
END IF;
 
IF X'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT SIZE IS TOO SMALL -- " &
"VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) );
END IF;
 
IF Y'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT SIZE IS TOO SMALL -- " &
"VALUE IS" & INTEGER'IMAGE ( INTEGER(Y) ) );
END IF;
 
END;
 
RESULT;
END CD1009D;
/cdb0a01.a
0,0 → 1,305
-- CDB0A01.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 storage pool may be user_determined, and that storage
-- is allocated by calling Allocate.
--
-- Check that a storage.pool may be specified using 'Storage_Pool
-- and that S'Storage_Pool denotes the storage pool of the type S.
--
-- TEST DESCRIPTION:
-- The package System.Storage_Pools is exercised by two very similar
-- packages which define a tree type and exercise it in a simple manner.
-- One package uses a user defined pool. The other package uses a
-- storage pool assigned by the implementation; Storage_Size is
-- specified for this pool.
-- The dispatching procedures Allocate and Deallocate are tested as an
-- intentional side effect of the tree packages.
--
-- For completeness, the actions of the tree packages are checked for
-- correct operation.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FDB0A00.A (foundation code)
-- CDB0A01.A
--
--
-- CHANGE HISTORY:
-- 02 JUN 95 SAIC Initial version
-- 07 MAY 96 SAIC Removed ambiguity with CDB0A02
-- 13 FEB 97 PWB.CTA Corrected lexically ordered string literal
--!
 
---------------------------------------------------------------- CDB0A01_1
 
---------------------------------------------------------- FDB0A00.Pool1
 
package FDB0A00.Pool1 is
User_Pool : Stack_Heap( 5_000 );
end FDB0A00.Pool1;
 
---------------------------------------------------------- FDB0A00.Comparator
 
with System.Storage_Pools;
package FDB0A00.Comparator is
 
function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
return Boolean;
 
end FDB0A00.Comparator;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
package body FDB0A00.Comparator is
 
function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
return Boolean is
use type System.Address;
begin
return A'Address = B'Address;
end "=";
 
end FDB0A00.Comparator;
 
---------------------------------------------------------------- CDB0A01_2
 
with FDB0A00.Pool1;
package CDB0A01_2 is
 
type Cell;
type User_Pool_Tree is access Cell;
 
for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool;
 
type Cell is record
Data : Character;
Left,Right : User_Pool_Tree;
end record;
 
procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree );
 
procedure Traverse( The_Tree : User_Pool_Tree );
 
procedure Defoliate( The_Tree : in out User_Pool_Tree );
 
end CDB0A01_2;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
with Unchecked_Deallocation;
package body CDB0A01_2 is
procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree);
 
-- Sort: zeros on the left, ones on the right...
procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is
begin
if On_Tree = null then
On_Tree := new Cell'(Item,null,null);
elsif Item > On_Tree.Data then
Insert(Item,On_Tree.Right);
else
Insert(Item,On_Tree.Left);
end if;
end Insert;
 
procedure Traverse( The_Tree : User_Pool_Tree ) is
begin
if The_Tree = null then
null; -- how very symmetrical
else
Traverse(The_Tree.Left);
TCTouch.Touch(The_Tree.Data);
Traverse(The_Tree.Right);
end if;
end Traverse;
 
procedure Defoliate( The_Tree : in out User_Pool_Tree ) is
begin
 
if The_Tree.Left /= null then
Defoliate(The_Tree.Left);
end if;
 
if The_Tree.Right /= null then
Defoliate(The_Tree.Right);
end if;
 
Deallocate(The_Tree);
 
end Defoliate;
 
end CDB0A01_2;
 
---------------------------------------------------------------- CDB0A01_3
 
with FDB0A00.Pool1;
package CDB0A01_3 is
 
type Cell;
type System_Pool_Tree is access Cell;
 
for System_Pool_Tree'Storage_Size use 2000;
 
-- assumptions: Cell is <= 20 storage_units
-- Tree building exercise requires O(15) cells
-- 2000 > 20 * 15 by a generous margin
 
type Cell is record
Data: Character;
Left,Right : System_Pool_Tree;
end record;
 
procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree );
 
procedure Traverse( The_Tree : System_Pool_Tree );
 
procedure Defoliate( The_Tree : in out System_Pool_Tree );
 
end CDB0A01_3;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with TCTouch;
with Unchecked_Deallocation;
package body CDB0A01_3 is
procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree);
 
-- Sort: zeros on the left, ones on the right...
procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is
begin
if On_Tree = null then
On_Tree := new Cell'(Item,null,null);
elsif Item > On_Tree.Data then
Insert(Item,On_Tree.Right);
else
Insert(Item,On_Tree.Left);
end if;
end Insert;
 
procedure Traverse( The_Tree : System_Pool_Tree ) is
begin
if The_Tree = null then
null; -- how very symmetrical
else
Traverse(The_Tree.Left);
TCTouch.Touch(The_Tree.Data);
Traverse(The_Tree.Right);
end if;
end Traverse;
 
procedure Defoliate( The_Tree : in out System_Pool_Tree ) is
begin
 
if The_Tree.Left /= null then
Defoliate(The_Tree.Left);
end if;
 
if The_Tree.Right /= null then
Defoliate(The_Tree.Right);
end if;
 
Deallocate(The_Tree);
 
end Defoliate;
 
end CDB0A01_3;
 
------------------------------------------------------------------ CDB0A01
 
with Report;
with TCTouch;
with FDB0A00.Comparator;
with FDB0A00.Pool1;
with CDB0A01_2;
with CDB0A01_3;
 
procedure CDB0A01 is
 
Banyan : CDB0A01_2.User_Pool_Tree;
Torrey : CDB0A01_3.System_Pool_Tree;
 
use type CDB0A01_2.User_Pool_Tree;
use type CDB0A01_3.System_Pool_Tree;
 
Countess : constant String := "Ada Augusta Lovelace";
Cenosstu : constant String := " AALaaacdeeglostuuv";
Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA";
Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
 
begin -- Main test procedure.
 
Report.Test ("CDB0A01", "Check that a storage pool may be " &
"user_determined, and that storage is " &
"allocated by calling Allocate. Check that " &
"a storage.pool may be specified using " &
"'Storage_Pool and that S'Storage_Pool denotes " &
"the storage pool of the type S" );
 
-- Check that S'Storage_Pool denotes the storage pool for the type S.
 
TCTouch.Assert(
FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
CDB0A01_2.User_Pool_Tree'Storage_Pool ),
"'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree");
 
TCTouch.Assert_Not(
FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
CDB0A01_3.System_Pool_Tree'Storage_Pool ),
"'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree");
 
-- Check that storage is allocated by calling Allocate.
 
for Count in Countess'Range loop
CDB0A01_2.Insert( Countess(Count), Banyan );
end loop;
TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" );
 
for Count in Countess'Range loop
CDB0A01_3.Insert( Countess(Count), Torrey );
end loop;
TCTouch.Validate("", "Allocate calls via CDB0A01_3" );
 
CDB0A01_2.Traverse(Banyan);
TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
 
CDB0A01_3.Traverse(Torrey);
TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
 
CDB0A01_2.Defoliate(Banyan);
TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
 
CDB0A01_3.Defoliate(Torrey);
TCTouch.Validate("", "Deforestation of Torrey" );
TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
 
Report.Result;
 
end CDB0A01;
/cd1009f.ada
0,0 → 1,83
-- CD1009F.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE
-- OR PRIVATE PART OF A PACKAGE FOR A TWO-DIMENSIONAL ARRAY TYPE
-- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/07/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009F IS
BEGIN
TEST ("CD1009F", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
"OR PRIVATE PART OF A PACKAGE FOR A " &
"TWO-DIMENSIONAL ARRAY TYPE DECLARED IN THE " &
"VISIBLE PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 25;
 
TYPE CHECK_TYPE_1 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER;
FOR CHECK_TYPE_1'SIZE
USE SPECIFIED_SIZE;
X : CHECK_TYPE_1 := ( OTHERS =>
( OTHERS => IDENT_INT(1) ) );
 
TYPE CHECK_TYPE_2 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER;
PRIVATE
FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
 
Y : CHECK_TYPE_2 := ( OTHERS =>
( OTHERS => IDENT_INT(5) ) );
BEGIN
IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
END IF;
 
IF X'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
"REPRESENTATIVE VALUE IS" &
INTEGER'IMAGE( X( IDENT_INT(1), IDENT_INT(2) ) ) );
END IF;
 
IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT");
END IF;
 
IF Y'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " &
INTEGER'IMAGE( Y( IDENT_INT(1), IDENT_INT(2) ) ) );
END IF;
END;
 
RESULT;
END CD1009F;
/cd1009h.ada
0,0 → 1,79
-- CD1009H.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE
-- PART OF A PACKAGE FOR A PRIVATE TYPE DECLARED IN THE VISIBLE
-- PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 09/18/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009H IS
BEGIN
TEST ("CD1009H", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " &
"PRIVATE PART OF A PACKAGE FOR A PRIVATE " &
"TYPE DECLARED IN THE VISIBLE PART OF THE " &
"SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
 
TYPE CHECK_TYPE_1 IS PRIVATE;
C1 : CONSTANT CHECK_TYPE_1;
FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING;
PRIVATE
TYPE CHECK_TYPE_1 IS RANGE 0 .. 7;
FOR CHECK_TYPE_1'SIZE
USE SPECIFIED_SIZE;
C1 : CONSTANT CHECK_TYPE_1 := CHECK_TYPE_1(IDENT_INT(1));
END PACK;
 
USE PACK;
X : CHECK_TYPE_1 := C1;
 
PACKAGE BODY PACK IS
FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING IS
BEGIN
RETURN INTEGER'IMAGE ( INTEGER (A) );
END IMAGE;
END PACK;
 
BEGIN
IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT");
END IF;
 
IF X'SIZE < SPECIFIED_SIZE THEN
FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " &
"VALUE IS" & IMAGE(X));
END IF;
 
END;
 
RESULT;
END CD1009H;
/cd33002.a
0,0 → 1,140
-- CD33002.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 Component_Sizes that are multiples of the word
-- size are supported.
--
-- Check that for such Component_Sizes arrays contain no gaps between
-- components.
--
-- TEST DESCRIPTION:
-- This test defines three array types and specifies their layouts
-- using representation specifications for the 'Component_Size and
-- pragma Packs for each. It then checks that the implied assumptions
-- about the resulting layout actually can be made.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 22 JUL 95 SAIC Initial version
-- 07 MAY 96 SAIC Revised for 2.1
-- 24 AUG 96 SAIC Additional 2.1 revisions
-- 16 FEB 98 EDS Modify documentation.
--!
 
----------------------------------------------------------------- CD33002_0
 
with System;
package CD33002_0 is
 
S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
 
type Nibble is mod 2**4;
 
type Byte is mod 2**8;
 
type Word_Stuff is array(Natural range <>) of Byte;
for Word_Stuff'Component_Size
use System.Word_Size; -- ANX-C RQMT.
pragma Pack(Word_Stuff); -- ANX-C RQMT.
 
type Double_Stuff is array(Natural range <>) of Byte;
for Double_Stuff'Component_Size
use System.Word_Size * 2; -- multiple -- ANX-C RQMT.
 
type Address_Calculator is record
Item_1 : Nibble;
Item_2 : Nibble;
end record;
 
for Address_Calculator use record
Item_1 at 0 range 0..3;
Item_2 at 1 range 0..3;
end record;
 
-- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1
-- it therefore follows that:
-- Address_Calculator'Size = 2 * Addressable_Unit'Size
 
end CD33002_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
-- there is no package body CD33002_0
 
------------------------------------------------------------------- CD33002
 
with Report;
with TCTouch;
with System.Storage_Elements;
with CD33002_0;
procedure CD33002 is
 
use type System.Storage_Elements.Storage_Offset;
 
A_Word : CD33002_0.Word_Stuff(0..15);
A_Double : CD33002_0.Double_Stuff(0..15);
 
procedure Unexpected( Message : String; Wanted, Got: Integer ) is
begin
Report.Failed ( Message & " Wanted:"
& Integer'Image(Wanted) & " Got:" & Integer'Image(Got) );
end Unexpected;
 
begin -- Main test procedure.
 
Report.Test ("CD33002", "Check that Component_Sizes that are multiples "
& "of the word size are supported. Check that for "
& "such Component_Sizes arrays contain no gaps "
& "between components" );
 
if A_Word'Size /= CD33002_0.Word_Stuff'Component_Size * 16 then
Unexpected("Word Size",
CD33002_0.Word_Stuff'Component_Size * 16,
A_Word'Size );
end if;
 
if A_Double'Size /= CD33002_0.Double_Stuff'Component_Size * 16 then
Unexpected("Double word Size",
CD33002_0.Double_Stuff'Component_Size * 16,
A_Double'Size );
end if;
 
 
Report.Result;
 
end CD33002;
/cdd2a02.a
0,0 → 1,345
-- CDD2A02.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. These rights include rights to use, duplicate,
-- release or disclose the released technical data and computer software
-- in whole or in part, in any manner and for any purpose whatsoever, and
-- to have or permit others to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the Read, Write, Input, and Output attributes are inherited
-- for untagged derived types. (Defect Report 8652/0040,
-- as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
-- 13.13.2(25/1)).
--
-- CHANGE HISTORY:
-- 30 JUL 2001 PHL Initial version.
-- 5 DEC 2001 RLB Reformatted for ACATS.
--
--!
with Ada.Streams;
use Ada.Streams;
with FDD2A00;
use FDD2A00;
with Report;
use Report;
procedure CDD2A02 is
 
type Int is range 1 .. 10;
type Str is array (Int range <>) of Character;
 
procedure Read (Stream : access Root_Stream_Type'Class;
Item : out Int'Base);
procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
 
for Int'Read use Read;
for Int'Write use Write;
for Int'Input use Input;
for Int'Output use Output;
 
 
type Parent (D1, D2 : Int; B : Boolean) is
record
S : Str (D1 .. D2);
case B is
when False =>
C1 : Integer;
when True =>
C2 : Float;
end case;
end record;
 
procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
function Input (Stream : access Root_Stream_Type'Class) return Parent;
procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
 
for Parent'Read use Read;
for Parent'Write use Write;
for Parent'Input use Input;
for Parent'Output use Output;
 
 
procedure Actual_Read
(Stream : access Root_Stream_Type'Class; Item : out Int) is
begin
Integer'Read (Stream, Integer (Item));
end Actual_Read;
 
procedure Actual_Write
(Stream : access Root_Stream_Type'Class; Item : Int) is
begin
Integer'Write (Stream, Integer (Item));
end Actual_Write;
 
function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
begin
return Int (Integer'Input (Stream));
end Actual_Input;
 
procedure Actual_Output
(Stream : access Root_Stream_Type'Class; Item : Int) is
begin
Integer'Output (Stream, Integer (Item));
end Actual_Output;
 
 
procedure Actual_Read
(Stream : access Root_Stream_Type'Class; Item : out Parent) is
begin
case Item.B is
when False =>
Item.C1 := 7;
when True =>
Float'Read (Stream, Item.C2);
end case;
Str'Read (Stream, Item.S);
end Actual_Read;
 
procedure Actual_Write
(Stream : access Root_Stream_Type'Class; Item : Parent) is
begin
case Item.B is
when False =>
null; -- Don't write C1
when True =>
Float'Write (Stream, Item.C2);
end case;
Str'Write (Stream, Item.S);
end Actual_Write;
 
function Actual_Input
(Stream : access Root_Stream_Type'Class) return Parent is
D1, D2 : Int;
B : Boolean;
begin
Int'Read (Stream, D2);
Boolean'Read (Stream, B);
Int'Read (Stream, D1);
 
declare
Item : Parent (D1 => D1, D2 => D2, B => B);
begin
Parent'Read (Stream, Item);
return Item;
end;
 
end Actual_Input;
 
procedure Actual_Output
(Stream : access Root_Stream_Type'Class; Item : Parent) is
begin
Int'Write (Stream, Item.D2);
Boolean'Write (Stream, Item.B);
Int'Write (Stream, Item.D1);
Parent'Write (Stream, Item);
end Actual_Output;
 
package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
Actual_Write => Actual_Write,
Actual_Input => Actual_Input,
Actual_Read => Actual_Read,
Actual_Output => Actual_Output);
 
package Parent_Ops is
new Counting_Stream_Ops (T => Parent,
Actual_Write => Actual_Write,
Actual_Input => Actual_Input,
Actual_Read => Actual_Read,
Actual_Output => Actual_Output);
 
procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
renames Int_Ops.Read;
procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
renames Int_Ops.Write;
function Input (Stream : access Root_Stream_Type'Class) return Int'Base
renames Int_Ops.Input;
procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
renames Int_Ops.Output;
 
procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
renames Parent_Ops.Read;
procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
renames Parent_Ops.Write;
function Input (Stream : access Root_Stream_Type'Class) return Parent
renames Parent_Ops.Input;
procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
renames Parent_Ops.Output;
 
begin
Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
"attributes are inherited for untagged derived types");
 
Test1:
declare
type Derived1 is new Parent;
S : aliased My_Stream (1000);
X1 : Derived1 (D1 => Int (Ident_Int (2)),
D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
Y1 : Derived1 := (D1 => 3,
D2 => 6,
B => False,
S => Str (Ident_Str ("3456")),
C1 => Ident_Int (100));
X2 : Derived1 (D1 => Int (Ident_Int (2)),
D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
begin
X1.S := Str (Ident_Str ("bcde"));
X1.C2 := Float (Ident_Int (4));
 
Derived1'Write (S'Access, X1);
if Int_Ops.Get_Counts /=
(Read => 0, Write => 0, Input => 0, Output => 0) then
Failed ("Error writing discriminants - 1");
end if;
if Parent_Ops.Get_Counts /=
(Read => 0, Write => 1, Input => 0, Output => 0) then
Failed ("Didn't call inherited Write - 1");
end if;
 
Derived1'Read (S'Access, X2);
if Int_Ops.Get_Counts /=
(Read => 0, Write => 0, Input => 0, Output => 0) then
Failed ("Error reading discriminants - 1");
end if;
if Parent_Ops.Get_Counts /=
(Read => 1, Write => 1, Input => 0, Output => 0) then
Failed ("Didn't call inherited Read - 1");
end if;
 
if X2 /= (D1 => 2,
D2 => 5,
B => True,
S => Str (Ident_Str ("bcde")),
C2 => Float (Ident_Int (4))) then
Failed
("Inherited Read and Write are not inverses of each other - 1");
end if;
 
Derived1'Output (S'Access, Y1);
if Int_Ops.Get_Counts /=
(Read => 0, Write => 2, Input => 0, Output => 0) then
Failed ("Error writing discriminants - 2");
end if;
if Parent_Ops.Get_Counts /=
(Read => 1, Write => 2, Input => 0, Output => 1) then
Failed ("Didn't call inherited Output - 2");
end if;
 
declare
Y2 : Derived1 := Derived1'Input (S'Access);
begin
if Int_Ops.Get_Counts /=
(Read => 2, Write => 2, Input => 0, Output => 0) then
Failed ("Error reading discriminants - 2");
end if;
if Parent_Ops.Get_Counts /=
(Read => 2, Write => 2, Input => 1, Output => 1) then
Failed ("Didn't call inherited Input - 2");
end if;
 
if Y2 /= (D1 => 3,
D2 => 6,
B => False,
S => Str (Ident_Str ("3456")),
C1 => Ident_Int (7)) then
Failed
("Inherited Input and Output are not inverses of each other - 2");
end if;
end;
end Test1;
 
Test2:
declare
type Derived2 (D : Int) is new Parent (D1 => D,
D2 => D,
B => False);
S : aliased My_Stream (1000);
X1 : Derived2 (D => Int (Ident_Int (7)));
Y1 : Derived2 := (D => 8,
S => Str (Ident_Str ("8")),
C1 => Ident_Int (200));
X2 : Derived2 (D => Int (Ident_Int (7)));
begin
X1.S := Str (Ident_Str ("g"));
X1.C1 := Ident_Int (4);
 
Derived2'Write (S'Access, X1);
if Int_Ops.Get_Counts /=
(Read => 2, Write => 2, Input => 0, Output => 0) then
Failed ("Error writing discriminants - 3");
end if;
if Parent_Ops.Get_Counts /=
(Read => 2, Write => 3, Input => 1, Output => 1) then
Failed ("Didn't call inherited Write - 3");
end if;
 
Derived2'Read (S'Access, X2);
if Int_Ops.Get_Counts /=
(Read => 2, Write => 2, Input => 0, Output => 0) then
Failed ("Error reading discriminants - 3");
end if;
if Parent_Ops.Get_Counts /=
(Read => 3, Write => 3, Input => 1, Output => 1) then
Failed ("Didn't call inherited Read - 3");
end if;
 
if X2 /= (D => 7,
S => Str (Ident_Str ("g")),
C1 => Ident_Int (7)) then
Failed
("Inherited Read and Write are not inverses of each other - 3");
end if;
 
Derived2'Output (S'Access, Y1);
if Int_Ops.Get_Counts /=
(Read => 2, Write => 4, Input => 0, Output => 0) then
Failed ("Error writing discriminants - 4");
end if;
if Parent_Ops.Get_Counts /=
(Read => 3, Write => 4, Input => 1, Output => 2) then
Failed ("Didn't call inherited Output - 4");
end if;
 
declare
Y2 : Derived2 := Derived2'Input (S'Access);
begin
if Int_Ops.Get_Counts /=
(Read => 4, Write => 4, Input => 0, Output => 0) then
Failed ("Error reading discriminants - 4");
end if;
if Parent_Ops.Get_Counts /=
(Read => 4, Write => 4, Input => 2, Output => 2) then
Failed ("Didn't call inherited Input - 4");
end if;
 
if Y2 /= (D => 8,
S => Str (Ident_Str ("8")),
C1 => Ident_Int (7)) then
Failed
("Inherited Input and Output are not inverses of each other - 4");
end if;
end;
end Test2;
 
Result;
end CDD2A02;
/cd1009j.ada
0,0 → 1,66
-- CD1009J.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
-- VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ACCESS TYPE
-- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/07/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009J IS
BEGIN
TEST ("CD1009J", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
"VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN " &
"ACCESS TYPE DECLARED IN THE VISIBLE PART OF " &
"THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10;
 
TYPE CHECK_TYPE_1 IS ACCESS INTEGER;
FOR CHECK_TYPE_1'STORAGE_SIZE
USE SPECIFIED_SIZE;
 
TYPE CHECK_TYPE_2 IS ACCESS INTEGER;
PRIVATE
FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
BEGIN
IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
END IF;
 
IF CHECK_TYPE_2'STORAGE_SIZE < SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL");
END IF;
END;
 
RESULT;
END CD1009J;
/cd1009l.ada
0,0 → 1,69
-- CD1009L.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 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE OR
-- PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED
-- IN THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- VCL 10/08/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CHANGED
-- COMMENT FROM FLOATING POINT TO FIXED POINT.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009L IS
BEGIN
TEST ("CD1009L", "A 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
"OR PRIVATE PART OF A PACKAGE FOR A " &
"FIXED POINT TYPE DECLARED IN THE VISIBLE " &
"PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
TYPE SPECIFIED IS DELTA 2.0 ** (-2) RANGE 0.0 .. 1.0;
 
SPECIFIED_SMALL : CONSTANT := SPECIFIED'SMALL;
 
TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
FOR CHECK_TYPE_1'SMALL
USE SPECIFIED_SMALL;
 
TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0;
PRIVATE
FOR CHECK_TYPE_2'SMALL USE SPECIFIED_SMALL;
END PACK;
 
USE PACK;
BEGIN
IF CHECK_TYPE_1'SMALL /= SPECIFIED_SMALL THEN
FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_1'SMALL");
END IF;
 
IF CHECK_TYPE_2'SMALL /= SPECIFIED_SMALL THEN
FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_2'SMALL");
END IF;
END;
 
RESULT;
END CD1009L;
/cd2a21a.ada
0,0 → 1,215
-- CD2A21A.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
-- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE
-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE.
 
-- HISTORY:
-- RJW 07/28/87 CREATED ORIGINAL TEST.
-- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
-- REPRESENTATION CLAUSE.
-- JRL 03/26/92 ELIMINATED REDUNDANT TESTING.
 
WITH REPORT; USE REPORT;
WITH LENGTH_CHECK; -- CONTAINS A CALLED TO 'FAILED'.
PROCEDURE CD2A21A IS
 
BASIC_SIZE : CONSTANT := INTEGER'SIZE/2;
 
TYPE CHECK_TYPE IS (ZERO, ONE, TWO);
 
FOR CHECK_TYPE'SIZE USE BASIC_SIZE;
 
C0 : CHECK_TYPE := ZERO;
C1 : CHECK_TYPE := ONE;
C2 : CHECK_TYPE := TWO;
 
TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE;
CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO);
 
TYPE REC_TYPE IS RECORD
COMP0 : CHECK_TYPE := ZERO;
COMP1 : CHECK_TYPE := ONE;
COMP2 : CHECK_TYPE := TWO;
END RECORD;
 
CHREC : REC_TYPE;
 
PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN ONE;
END IF;
END IDENT;
 
PROCEDURE PROC (CI0, CI2 : CHECK_TYPE;
CIO1, CIO2 : IN OUT CHECK_TYPE;
CO2 : OUT CHECK_TYPE) IS
BEGIN
IF NOT ((CI0 < IDENT (ONE)) AND
(IDENT (CI2) > IDENT (CIO1)) AND
(CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
"- 1");
END IF;
 
IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1");
END IF;
 
IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR
CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1");
END IF;
 
IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1");
END IF;
 
CO2 := TWO;
 
END PROC;
 
BEGIN
TEST ("CD2A21A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
"GIVEN FOR AN ENUMERATION TYPE, THEN " &
"OPERATIONS ON VALUES OF SUCH A TYPE ARE " &
"NOT AFFECTED BY THE REPRESENTATION CLAUSE");
 
PROC (ZERO, TWO, C1, C2, C2);
CHECK_1 (TWO, INTEGER'SIZE/2, "CHECK_TYPE");
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((IDENT (C1) IN C1 .. C2) AND
(C0 NOT IN IDENT (ONE) .. C2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2");
END IF;
 
IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
CHECK_TYPE'VAL (1) /= IDENT (C1) OR
CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2");
END IF;
 
IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2");
END IF;
 
IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE");
END IF;
 
IF NOT ((CHARRAY (0) < IDENT (ONE)) AND
(IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND
(CHARRAY (1) <= IDENT (ONE)) AND
(IDENT (TWO) = CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
END IF;
 
IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND
(CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3");
END IF;
 
IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR
CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR
CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3");
END IF;
 
IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR
CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3");
END IF;
 
IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3");
END IF;
 
IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE");
END IF;
 
IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND
(IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND
(CHREC.COMP1 <= IDENT (ONE)) AND
(IDENT (TWO) = CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
END IF;
 
IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND
(CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR
CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4");
END IF;
 
IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4");
END IF;
 
RESULT;
END CD2A21A;
/cd1009n.ada
0,0 → 1,147
-- CD1009N.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN
-- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE
-- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- VCL 10/08/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
-- CHECKS FOR FAILURE.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE CD1009N IS
BEGIN
TEST ("CD1009N", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
"IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " &
"FOR A RECORD TYPE DECLARED IN THE " &
"VISIBLE PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
SYSTEM.STORAGE_UNIT;
 
TYPE CHECK_TYPE_1 IS
RECORD
I1 : INTEGER RANGE 0 .. 255;
B1 : BOOLEAN;
B2 : BOOLEAN;
I2 : INTEGER RANGE 0 .. 15;
END RECORD;
FOR CHECK_TYPE_1 USE
RECORD
I1 AT 0 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
B1 AT 1 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
B2 AT 2 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
I2 AT 3 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
END RECORD;
 
TYPE CHECK_TYPE_2 IS
RECORD
I1 : INTEGER RANGE 0 .. 255;
B1 : BOOLEAN;
B2 : BOOLEAN;
I2 : INTEGER RANGE 0 .. 15;
END RECORD;
 
PRIVATE
FOR CHECK_TYPE_2 USE
RECORD
I1 AT 0 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
B1 AT 1 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
B2 AT 2 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
I2 AT 3 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
END RECORD;
END PACK;
 
USE PACK;
 
R1 : CHECK_TYPE_1;
 
R2 : CHECK_TYPE_2;
BEGIN
IF R1.I1'FIRST_BIT /= 0 OR
R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I1'POSITION /= 0 THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
END IF;
 
IF R1.B1'FIRST_BIT /= 0 OR
R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
END IF;
 
IF R1.B2'FIRST_BIT /= 0 OR
R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
END IF;
 
IF R1.I2'FIRST_BIT /= 0 OR
R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
END IF;
 
 
IF R2.I1'FIRST_BIT /= 0 OR
R2.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
R2.I1'POSITION /= 0 THEN
FAILED ("INCORRECT REPRESENTATION FOR R2.I1");
END IF;
 
IF R2.B1'FIRST_BIT /= 0 OR
R2.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R2.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R2.B1");
END IF;
 
IF R2.B2'FIRST_BIT /= 0 OR
R2.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R2.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R2.B2");
END IF;
 
IF R2.I2'FIRST_BIT /= 0 OR
R2.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
R2.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R2.I2");
END IF;
END;
 
RESULT;
END CD1009N;
/cd2a21c.ada
0,0 → 1,116
-- CD2A21C.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 SIZE SPECIFICATION CAN BE GIVEN FOR AN ENUMERATION
-- TYPE:
-- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE
-- DECLARED IN THE VISIBLE PART;
-- FOR A DERIVED ENUMERATION TYPE;
-- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS
-- AN ENUMERATION TYPE.
 
-- HISTORY:
-- PWB 06/17/87 CREATED ORIGINAL TEST.
-- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
-- REPRESENTATION CLAUSE.
-- JRL 03/26/92 REMOVED TESTING OF NONOBJECTIVE TYPES.
 
WITH REPORT; USE REPORT;
WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
PROCEDURE CD2A21C IS
 
TYPE BASIC_ENUM IS (A, B, C, D, E);
SPECIFIED_SIZE : CONSTANT := BASIC_ENUM'SIZE;
 
MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE);
 
TYPE DERIVED_ENUM IS NEW BASIC_ENUM;
FOR DERIVED_ENUM'SIZE USE SPECIFIED_SIZE;
 
PACKAGE P IS
TYPE ENUM_IN_P IS (A1, B1, C1, D1, E1, F1, G1);
FOR ENUM_IN_P'SIZE USE SPECIFIED_SIZE;
TYPE PRIVATE_ENUM IS PRIVATE;
TYPE ALT_ENUM_IN_P IS (A2, B2, C2, D2, E2, F2, G2);
PRIVATE
TYPE PRIVATE_ENUM IS (A3, B3, C3, D3, E3, F3, G3);
FOR ALT_ENUM_IN_P'SIZE USE SPECIFIED_SIZE;
END P;
 
TYPE DERIVED_PRIVATE_ENUM IS NEW P.PRIVATE_ENUM;
FOR DERIVED_PRIVATE_ENUM'SIZE USE SPECIFIED_SIZE;
 
USE P;
 
PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_ENUM);
PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (ENUM_IN_P);
PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_ENUM_IN_P);
 
BEGIN
 
TEST("CD2A21C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN " &
"IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " &
"FOR ENUMERATION TYPES DECLARED IN THE VISIBLE " &
"PART, AND FOR DERIVED ENUMERATION " &
"TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " &
"DECLARATIONS ARE AS ENUMERATION TYPES");
 
CHECK_1 (C, SPECIFIED_SIZE, "DERIVED_ENUM");
CHECK_2 (C1, SPECIFIED_SIZE, "ENUM_IN_P");
CHECK_3 (C2, SPECIFIED_SIZE, "ALT_ENUM_IN_P");
 
IF DERIVED_ENUM'SIZE /= MINIMUM_SIZE THEN
FAILED ("DERIVED_ENUM'SIZE SHOULD NOT BE GREATER THAN" &
INTEGER'IMAGE(MINIMUM_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_ENUM'SIZE));
END IF;
 
IF ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN
FAILED ("ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
INTEGER'IMAGE(MINIMUM_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(ENUM_IN_P'SIZE));
END IF;
 
IF ALT_ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN
FAILED ("ALT_ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" &
INTEGER'IMAGE(MINIMUM_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(ALT_ENUM_IN_P'SIZE));
END IF;
 
IF DERIVED_PRIVATE_ENUM'SIZE /= MINIMUM_SIZE THEN
 
FAILED ("DERIVED_PRIVATE_ENUM'SIZE SHOULD NOT BE GREATER " &
"THAN " & INTEGER'IMAGE(MINIMUM_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_PRIVATE_ENUM'SIZE));
END IF;
 
RESULT;
 
END CD2A21C;
/cd1c03b.ada
0,0 → 1,78
-- CD1C03B.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE SIZE OF A DERIVED TYPE IS INHERITED FROM THE
-- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A PRAGMA
-- PACK.
 
-- HISTORY:
-- JET 09/16/87 CREATED ORIGINAL TEST.
-- PWB 03/27/89 MODIFIED COMPARISON OF OBJECT SIZE TO PARENT SIZE.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1C03B IS
 
TYPE ENUM IS (E1, E2, E3);
 
TYPE NORMAL_TYPE IS ARRAY (1 .. 100) OF ENUM;
 
TYPE PARENT_TYPE IS ARRAY (1 .. 100) OF ENUM;
PRAGMA PACK (PARENT_TYPE);
 
TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
X : DERIVED_TYPE := (OTHERS => ENUM'FIRST);
 
BEGIN
 
TEST("CD1C03B", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " &
"INHERITED FROM THE PARENT IF THE SIZE OF " &
"THE PARENT WAS DETERMINED BY A PRAGMA PACK");
 
IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN
COMMENT ("PRAGMA PACK HAD NO EFFECT ON THE SIZE OF " &
"PARENT_TYPE, WHICH IS" &
INTEGER'IMAGE(PARENT_TYPE'SIZE));
ELSIF PARENT_TYPE'SIZE > IDENT_INT (NORMAL_TYPE'SIZE) THEN
FAILED ("PARENT_TYPE'SIZE SHOULD NOT BE GREATER THAN" &
INTEGER'IMAGE(NORMAL_TYPE'SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(PARENT_TYPE'SIZE));
END IF;
 
IF DERIVED_TYPE'SIZE > IDENT_INT (PARENT_TYPE'SIZE) THEN
FAILED ("DERIVED_TYPE'SIZE SHOULD NOT BE GREATER THAN" &
INTEGER'IMAGE(PARENT_TYPE'SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_TYPE'SIZE));
END IF;
 
IF X'SIZE < DERIVED_TYPE'SIZE THEN
FAILED ("OBJECT SIZE TOO LARGE. FIRST VALUE IS " &
ENUM'IMAGE ( X(1) ) );
END IF;
 
RESULT;
 
END CD1C03B;
/cd1009p.ada
0,0 → 1,66
-- CD1009P.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART
-- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION
-- IS AN ENUMERATION TYPE, DECLARED IN THE VISIBLE PART OF THE SAME
-- PACKAGE.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/09/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009P IS
BEGIN
TEST ("CD1009P", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " &
"PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " &
"WHOSE FULL DECLARATION IS AN ENUMERATION " &
"TYPE, DECLARED IN THE VISIBLE PART OF THE " &
"SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE;
 
TYPE CHECK_TYPE_1;
TYPE ACC IS ACCESS CHECK_TYPE_1;
 
TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3);
 
PRIVATE
FOR CHECK_TYPE_1'SIZE
USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
BEGIN
IF CHECK_TYPE_1'SIZE > SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'SIZE IS TOO LARGE");
END IF;
END;
 
RESULT;
END CD1009P;
/cd2a21e.ada
0,0 → 1,153
-- CD2A21E.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
-- ENUMERATION TYPE, THEN SUCH A TYPE CAN
-- BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC PROCEDURE.
 
-- HISTORY:
-- JET 08/18/87 CREATED ORIGINAL TEST.
-- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
-- REPRESENTATION CLAUSE.
-- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE
-- SPECIFICATION IS OBEYED.
-- LDC 10/03/90 ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION,
-- AND EXPLICIT CONVERSION.
-- JRL 03/26/92 ELIMINATED REDUNDANT TESTING.
 
WITH REPORT; USE REPORT;
WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
PROCEDURE CD2A21E IS
 
TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
BASIC_SIZE : CONSTANT := INTEGER'SIZE / 2;
 
FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
 
BEGIN
TEST ("CD2A21E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " &
"GIVEN FOR AN ENUMERATION TYPE, " &
"THEN SUCH A TYPE CAN BE " &
"PASSED AS AN ACTUAL PARAMETER TO A GENERIC " &
"PROCEDURE");
 
DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
 
GENERIC
TYPE GPARM IS (<>);
PROCEDURE GENPROC (C0, C1, C2: GPARM);
 
PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
 
SUBTYPE CHECK_TYPE IS GPARM;
 
C3 : GPARM;
 
CHECKVAR : CHECK_TYPE;
 
PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN C1;
END IF;
END IDENT;
 
BEGIN -- GENPROC.
 
CHECKVAR := IDENT (C0);
 
CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE");
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((IDENT (C1) IN C1 .. C2) AND
(IDENT(C0) NOT IN IDENT (C1) .. C2)) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " &
"OPERATORS");
END IF;
 
IF CHECK_TYPE'LAST /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST");
END IF;
 
IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR
CHECK_TYPE'VAL (1) /= IDENT (C1) OR
CHECK_TYPE'VAL (2) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL");
END IF;
 
IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR
CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED");
END IF;
 
IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR
CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR
CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE");
END IF;
 
CHECKVAR := CHECK_TYPE'VALUE ("ONE");
C3 := GPARM(CHECKVAR);
IF C3 /= IDENT(C1) THEN
FAILED ("INCORRECT VALUE FOR CONVERSION");
END IF;
 
CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM");
 
 
IF CHECK_TYPE'(C2) /= IDENT(C2) THEN
FAILED ("INCORRECT VALUE FOR QUALIFICATION");
END IF;
 
C3 := CHECK_TYPE'VALUE ("TWO");
IF C3 /= IDENT(C2) THEN
FAILED ("INCORRECT VALUE FOR ASSIGNMENT");
END IF;
 
END GENPROC;
 
PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
 
BEGIN
 
NEWPROC (ZERO, ONE, TWO);
 
END;
 
RESULT;
 
END CD2A21E;
/cd1009r.ada
0,0 → 1,64
-- CD1009R.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE
-- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL
-- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART OF
-- THE SAME PACKAGE.
 
-- HISTORY:
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- VCL 10/21/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1009R IS
BEGIN
TEST ("CD1009R", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " &
"PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " &
"TYPE, WHOSE FULL TYPE DECLARATION IS AN " &
"ACCESS TYPE, DECLARED IN THE VISIBLE PART OF " &
"THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10;
 
TYPE CHECK_TYPE_1;
TYPE ACC IS ACCESS CHECK_TYPE_1;
 
TYPE CHECK_TYPE_1 IS ACCESS INTEGER;
PRIVATE
FOR CHECK_TYPE_1'STORAGE_SIZE
USE SPECIFIED_SIZE;
END PACK;
 
USE PACK;
BEGIN
IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN
FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL");
END IF;
END;
 
RESULT;
END CD1009R;
/cd1c03f.ada
0,0 → 1,76
-- CD1C03F.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE VALUE OF 'SMALL FOR A DERIVED FIXED POINT TYPE
-- IS INHERITED FROM THE PARENT IF THE VALUE OF 'SMALL FOR THE
-- PARENT WAS DETERMINED BY A 'SMALL SPECIFICATION CLAUSE.
 
-- HISTORY:
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- JET 09/17/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1C03F IS
 
SPECIFIED_SMALL : CONSTANT := 0.25;
 
TYPE FLT IS NEW FLOAT;
 
TYPE PARENT_TYPE IS DELTA 1.0 RANGE 0.0 .. 100.0;
 
FOR PARENT_TYPE'SMALL USE SPECIFIED_SMALL;
 
TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
 
FUNCTION IDENT_FLT (F : FLT) RETURN FLT IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN F;
ELSE
RETURN 0.0;
END IF;
END;
 
BEGIN
 
TEST("CD1C03F", "CHECK THAT THE VALUE OF 'SMALL FOR A " &
"DERIVED FIXED POINT TYPE IS INHERITED " &
"FROM THE PARENT IF THE VALUE OF 'SMALL " &
"FOR THE PARENT WAS DETERMINED BY A 'SMALL " &
"SPECIFICATION CLAUSE");
 
IF PARENT_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN
FAILED ("PARENT_TYPE'SMALL SHOULD BE EQUAL TO " &
"THE SPECIFIED VALUE");
END IF;
 
IF DERIVED_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN
FAILED ("DERIVED_TYPE'SMALL SHOULD BE EQUAL TO " &
"THE SPECIFIED VALUE");
END IF;
 
RESULT;
 
END CD1C03F;
/cd1c03h.ada
0,0 → 1,122
-- CD1C03H.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE RECORD SIZE AND THE COMPONENT POSITIONS AND
-- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE
-- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY A
-- RECORD REPRESENTATION CLAUSE.
 
-- HISTORY:
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- JET 09/17/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
WITH SYSTEM; USE SYSTEM;
 
PROCEDURE CD1C03H IS
 
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
SYSTEM.STORAGE_UNIT;
 
TYPE E_TYPE IS (RED, BLUE, GREEN);
 
TYPE PARENT_TYPE IS
RECORD
I : INTEGER RANGE 0 .. 127 := 127;
C : CHARACTER := 'S';
B : BOOLEAN := FALSE;
E : E_TYPE := BLUE;
END RECORD;
 
FOR PARENT_TYPE USE
RECORD
C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1;
I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1;
E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
END RECORD;
 
TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
 
P_REC : PARENT_TYPE;
REC : DERIVED_TYPE;
 
BEGIN
 
TEST("CD1C03H", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " &
"POSITIONS AND SIZES OF A DERIVED RECORD " &
"TYPE ARE INHERITED FROM THE PARENT IF THOSE " &
"ASPECTS OF THE PARENT WERE DETERMINED BY " &
"A RECORD REPRESENTATION CLAUSE");
 
IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN
FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " &
"PARENT_TYPE");
END IF;
 
IF REC.I'SIZE /= P_REC.I'SIZE OR
REC.C'SIZE /= P_REC.C'SIZE OR
REC.B'SIZE /= P_REC.B'SIZE OR
REC.E'SIZE /= P_REC.E'SIZE THEN
FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " &
"INHERITED FROM PARENT_TYPE");
END IF;
 
REC := (12, 'T', TRUE, RED);
 
IF (REC.I /= 12) OR (REC.C /= 'T') OR
(NOT REC.B) OR (REC.E /= RED) THEN
FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " &
"INCORRECT");
END IF;
 
IF REC.I'POSITION /= P_REC.I'POSITION OR
REC.C'POSITION /= P_REC.C'POSITION OR
REC.B'POSITION /= P_REC.B'POSITION OR
REC.E'POSITION /= P_REC.E'POSITION THEN
FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " &
"NOT INHERITED FROM PARENT_TYPE");
END IF;
 
IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR
REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR
REC.B'FIRST_BIT /= P_REC.B'FIRST_BIT OR
REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN
FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
"NOT INHERITED FROM PARENT_TYPE");
END IF;
 
IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR
REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR
REC.B'LAST_BIT /= P_REC.B'LAST_BIT OR
REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN
FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
"NOT INHERITED FROM PARENT_TYPE");
END IF;
 
RESULT;
 
END CD1C03H;
/cd1009v.ada
0,0 → 1,76
-- CD1009V.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN
-- THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE
-- FULL TYPE DECLARATION IS AN ENUMERATION TYPE DECLARED IN THE
-- VISIBLE PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- VCL 10/21/87 CREATED ORIGINAL TEST.
-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP'
-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES.
 
WITH REPORT; USE REPORT;
WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'.
PROCEDURE CD1009V IS
BEGIN
TEST ("CD1009V", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " &
"GIVEN IN THE PRIVATE PART OF A " &
"PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL " &
"TYPE DECLARATION IS AN ENUMERATION TYPE, " &
"DECLARED IN THE VISIBLE PART OF THE SAME " &
"PACKAGE");
DECLARE
PACKAGE PACK IS
TYPE CHECK_TYPE_1;
TYPE ACC IS ACCESS CHECK_TYPE_1;
 
TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8);
PRIVATE
 
FOR CHECK_TYPE_1 USE (A0 => 9,
A2 => 13,
A4 => 15,
A8 => 18);
TYPE INT1 IS RANGE 9 .. 18;
FOR INT1'SIZE USE CHECK_TYPE_1'SIZE;
 
PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1);
 
END PACK;
 
PACKAGE BODY PACK IS
BEGIN
CHECK_1 (A2, 13, "CHECK_TYPE_1");
END PACK;
 
USE PACK;
BEGIN
NULL;
END;
 
RESULT;
END CD1009V;
/cd1009x.ada
0,0 → 1,105
-- CD1009X.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN
-- IN THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE
-- FULL TYPE DECLARATION IS A RECORD TYPE DECLARED IN THE VISIBLE
-- PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- VCL 10/21/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
-- CHECKS FOR FAILURE.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE CD1009X IS
BEGIN
TEST ("CD1009X", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
"IN THE PRIVATE PART OF A PACKAGE FOR AN " &
"INCOMPLETE TYPE, WHOSE FULL TYPE DECLARATION " &
"IS A RECORD TYPE DECLARED IN THE " &
"VISIBLE PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
SYSTEM.STORAGE_UNIT;
 
TYPE CHECK_TYPE_1;
TYPE ACC IS ACCESS CHECK_TYPE_1;
 
TYPE CHECK_TYPE_1 IS
RECORD
I1 : INTEGER RANGE 0 .. 255;
B1 : BOOLEAN;
B2 : BOOLEAN;
I2 : INTEGER RANGE 0 .. 15;
END RECORD;
PRIVATE
FOR CHECK_TYPE_1 USE
RECORD
I1 AT 0 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
B1 AT 1 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
B2 AT 2 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
I2 AT 3 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
END RECORD;
END PACK;
 
USE PACK;
 
R1 : CHECK_TYPE_1;
BEGIN
IF R1.I1'FIRST_BIT /= 0 OR
R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I1'POSITION /= 0 THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
END IF;
 
IF R1.B1'FIRST_BIT /= 0 OR
R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
END IF;
 
IF R1.B2'FIRST_BIT /= 0 OR
R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
END IF;
 
IF R1.I2'FIRST_BIT /= 0 OR
R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
END IF;
END;
 
RESULT;
END CD1009X;
/cdd2001.a
0,0 → 1,203
-- CDD2001.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. These rights include rights to use, duplicate,
-- release or disclose the released technical data and computer software
-- in whole or in part, in any manner and for any purpose whatsoever, and
-- to have or permit others to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the default implementation of Read and Input raise End_Error
-- if the end of stream is reached before the reading of a value is
-- completed. (Defect Report 8652/0045,
-- Technical Corrigendum 13.13.2(35.1/1)).
--
-- CHANGE HISTORY:
-- 12 FEB 2001 PHL Initial version.
-- 29 JUN 2001 RLB Reformatted for ACATS.
--
--!
 
with Ada.Streams;
use Ada.Streams;
package CDD2001_0 is
 
type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with
record
First : Stream_Element_Offset := 1;
Last : Stream_Element_Offset := 0;
Contents : Stream_Element_Array (1 .. Size);
end record;
 
procedure Clear (Stream : in out My_Stream);
 
procedure Read (Stream : in out My_Stream;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
 
procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array);
 
end CDD2001_0;
 
package body CDD2001_0 is
 
procedure Clear (Stream : in out My_Stream) is
begin
Stream.First := 1;
Stream.Last := 0;
end Clear;
 
procedure Read (Stream : in out My_Stream;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset) is
begin
if Item'Length >= Stream.Last - Stream.First + 1 then
Item (Item'First .. Item'First + Stream.Last - Stream.First) :=
Stream.Contents (Stream.First .. Stream.Last);
Last := Item'First + Stream.Last - Stream.First;
Stream.First := Stream.Last + 1;
else
Item := Stream.Contents (Stream.First ..
Stream.First + Item'Length - 1);
Last := Item'Last;
Stream.First := Stream.First + Item'Length;
end if;
end Read;
 
procedure Write (Stream : in out My_Stream;
Item : in Stream_Element_Array) is
begin
Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item;
Stream.Last := Stream.Last + Item'Length;
end Write;
 
end CDD2001_0;
 
with Ada.Exceptions;
use Ada.Exceptions;
with CDD2001_0;
use CDD2001_0;
with Io_Exceptions;
use Io_Exceptions;
with Report;
use Report;
procedure CDD2001 is
 
subtype Int is Integer range -20 .. 20;
 
type R (D : Int) is
record
C1 : Character := Ident_Char ('a');
case D is
when 0 .. 20 =>
C2 : String (1 .. D) := (others => Ident_Char ('b'));
when others =>
C3, C4 : Float := Float (-D);
end case;
end record;
 
S : aliased My_Stream (200);
 
begin
Test
("CDD2001",
"Check that the default implementation of Read and Input " &
"raise End_Error if the end of stream is reached before the " &
"reading of a value is completed");
 
Read:
declare
X : R (Ident_Int (13));
begin
Clear (S);
 
-- A complete object.
R'Write (S'Access, X);
X.C1 := Ident_Char ('A');
X.C2 := (others => Ident_Char ('B'));
R'Read (S'Access, X);
if X.C1 /= Ident_Char ('a') or X.C2 /=
(1 .. 13 => Ident_Char ('b')) then
Failed ("Read did not produce the expected result");
end if;
 
Clear (S);
 
-- Not enough data.
Character'Write (S'Access, 'a');
String'Write (S'Access, "bbb");
 
begin
R'Read (S'Access, X);
Failed
("No exception raised when the end of stream is reached " &
"before the reading of a value is completed - 1");
exception
when End_Error =>
null;
when E: others =>
Failed ("Wrong Exception " & Exception_Name (E) &
" - " & Exception_Information (E) &
" - " & Exception_Message (E) & " - 1");
end;
 
end Read;
 
Input:
declare
X : R (Ident_Int (-11));
begin
Clear (S);
 
-- A complete object.
R'Output (S'Access, X);
X.C1 := Ident_Char ('A');
X.C3 := 4.0;
X.C4 := 5.0;
X := R'Input (S'Access);
if X.C1 /= Ident_Char ('a') or X.C3 /= 11.0 or X.C4 /= 11.0 then
Failed ("Input did not produce the expected result");
end if;
 
Clear (S);
 
-- Not enough data.
Integer'Output (S'Access, Ident_Int (-11)); -- The discriminant
Character'Output (S'Access, 'a');
Float'Output (S'Access, 11.0);
 
begin
X := R'Input (S'Access);
Failed
("No exception raised when the end of stream is reached " &
"before the reading of a value is completed - 2");
exception
when End_Error =>
null;
when E: others =>
Failed ("Wrong exception " & Exception_Name (E) &
" - " & Exception_Message (E) & " - 2");
end;
 
end Input;
 
Result;
end CDD2001;
 
/cd1009z.ada
0,0 → 1,115
-- CD1009Z.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE
-- PRIVATE PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE, WHOSE
-- FULL TYPE DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE
-- PART OF THE SAME PACKAGE.
 
-- HISTORY:
-- VCL 10/09/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED
-- CHECKS FOR FAILURE.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE CD1009Z IS
BEGIN
TEST ("CD1009Z", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " &
"IN THE PRIVATE PART OF A PACKAGE FOR A " &
"LIMITED PRIVATE TYPE, WHOSE FULL TYPE " &
"DECLARATION IS A RECORD TYPE DECLARED IN THE " &
"VISIBLE PART OF THE SAME PACKAGE");
DECLARE
PACKAGE PACK IS
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
SYSTEM.STORAGE_UNIT;
 
TYPE CHECK_TYPE_1 IS LIMITED PRIVATE;
 
PROCEDURE P;
PRIVATE
TYPE CHECK_TYPE_1 IS
RECORD
I1 : INTEGER RANGE 0 .. 255;
B1 : BOOLEAN;
B2 : BOOLEAN;
I2 : INTEGER RANGE 0 .. 15;
END RECORD;
FOR CHECK_TYPE_1 USE
RECORD
I1 AT 0 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
B1 AT 1 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
B2 AT 2 * UNITS_PER_INTEGER
RANGE 0 .. BOOLEAN'SIZE - 1;
I2 AT 3 * UNITS_PER_INTEGER
RANGE 0 .. INTEGER'SIZE - 1;
END RECORD;
END PACK;
 
PACKAGE BODY PACK IS
PROCEDURE P IS
R1 : CHECK_TYPE_1;
BEGIN
IF R1.I1'FIRST_BIT /= 0 OR
R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I1'POSITION /= 0 THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I1");
END IF;
 
IF R1.B1'FIRST_BIT /= 0 OR
R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B1'POSITION /= 1 * UNITS_PER_INTEGER
THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B1");
END IF;
 
IF R1.B2'FIRST_BIT /= 0 OR
R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR
R1.B2'POSITION /= 2 * UNITS_PER_INTEGER
THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.B2");
END IF;
 
IF R1.I2'FIRST_BIT /= 0 OR
R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR
R1.I2'POSITION /= 3 * UNITS_PER_INTEGER
THEN
FAILED ("INCORRECT REPRESENTATION FOR R1.I2");
END IF;
END P;
END PACK;
 
USE PACK;
 
BEGIN
P;
END;
 
RESULT;
END CD1009Z;
/cd72a02.a
0,0 → 1,225
-- CD72A02.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 package System.Address_To_Access_Conversions may be
-- instantiated for various composite types.
--
-- Check that To_Pointer and To_Address are inverse operations.
--
-- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an
-- X that allows Unchecked_Access.
--
-- Check that To_Pointer(Null_Address) returns null.
--
-- TEST DESCRIPTION:
-- This test is identical to CD72A01 with the exception that it tests
-- the composite types where CD72A01 tests "simple" types.
--
-- This test checks that the semantics provided in
-- Address_To_Access_Conversions are present and operate
-- within expectations (to the best extent possible in a portable
-- implementation independent fashion).
--
-- The functions Address_To_Hex and Hex_To_Address test the invertability
-- of the To_Integer and To_Address functions, along with a great deal
-- of optimizer chaff and protection from the fact that type
-- Storage_Elements.Integer_Address may be either a modular or a signed
-- integer type.
--
-- This test has some interesting usage paradigms in that users
-- occasionally want to store address information in a transportable
-- fashion, and often resort to some textual representation of values.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 13 JUL 95 SAIC Initial version (CD72001)
-- 08 FEB 96 SAIC Split from CD72001 by reviewer request for 2.1
-- 12 NOV 96 SAIC Corrected typo in RM ref
-- 16 FEB 98 EDS Modified documentation.
-- 22 JAN 02 RLB Corrected test description.
--!
 
with Report;
with Impdef;
with FD72A00;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;
procedure CD72A02 is
use System;
use FD72A00;
 
type Tagged_Record is tagged record
Value : Natural;
end record;
 
package Class_ATAC is
new System.Address_To_Access_Conversions(Tagged_Record'Class);
-- ANX-C RQMT
 
use type Class_ATAC.Object_Pointer;
 
task type TC_Task_Type is
entry E;
entry F;
end TC_Task_Type;
 
package Task_ATAC is
new System.Address_To_Access_Conversions(TC_Task_Type);
-- ANX-C RQMT
 
use type Task_ATAC.Object_Pointer;
 
task body TC_Task_Type is
begin
select
accept E;
or
accept F;
Report.Failed("Task rendezvoused on wrong path");
end select;
end TC_Task_Type;
 
protected type TC_Protec is
procedure E;
procedure F;
private
Visited : Boolean := False;
end TC_Protec;
 
package Protected_ATAC is
new System.Address_To_Access_Conversions(TC_Protec);
-- ANX-C RQMT
 
use type Protected_ATAC.Object_Pointer;
 
protected body TC_Protec is
procedure E is
begin
Visited := True;
end E;
procedure F is
begin
if not Visited then
Report.Failed("Protected Object took wrong path");
end if;
end F;
end TC_Protec;
 
type Test_Cases is ( Tagged_Type, Task_Type, Protected_Type );
 
type Naive_Dynamic_String is access String;
 
type String_Store is array(Test_Cases) of Naive_Dynamic_String;
 
The_Strings : String_Store;
 
-- create several aliased objects with distinct values
 
My_Rec : aliased Tagged_Record := (Value => Natural'Last);
My_Task : aliased TC_Task_Type;
My_Prot : aliased TC_Protec;
 
use type System.Storage_Elements.Integer_Address;
 
begin -- Main test procedure.
 
Report.Test ("CD72A02", "Check package " &
"System.Address_To_Access_Conversions " &
"for composite types" );
 
-- take several pointer objects, convert them to addresses, and store
-- the address as a hexadecimal representation for later reconversion
 
The_Strings(Tagged_Type) := new String'(
Address_To_Hex(Class_ATAC.To_Address(My_Rec'Access)) );
 
The_Strings(Task_Type) := new String'(
Address_To_Hex(Task_ATAC.To_Address(My_Task'Access)) );
 
The_Strings(Protected_Type) := new String'(
Address_To_Hex(Protected_ATAC.To_Address(My_Prot'Access)) );
 
-- now, reconvert the hexadecimal address values back to pointers,
-- and check that the dereferenced pointer still designates the
-- value placed at that location. The use of the intermediate
-- string representation should foil even the cleverest of optimizers
 
if Tagged_Record(Class_ATAC.To_Pointer(
Hex_To_Address(The_Strings(Tagged_Type))).all)
/= Tagged_Record'(Value => Natural'Last) then
Report.Failed("Tagged_Record reconversion");
end if;
 
Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type))).E;
 
begin
select -- allow for task to have completed.
My_Task.F; -- should not happen, will call Report.Fail in task
else
null; -- expected case, "Report.Pass;"
end select;
exception
when Tasking_Error => null; -- task terminated, which is OK
end;
 
Protected_ATAC.To_Pointer(
Hex_To_Address(The_Strings(Protected_Type))).E;
My_Prot.F; -- checks that call to E occurred
 
 
-- check that the resulting values are equal to the 'Unchecked_Access
-- of the value
 
if Class_ATAC.To_Pointer(Hex_To_Address(The_Strings(Tagged_Type)))
/= My_Rec'Unchecked_Access then
Report.Failed("Tagged_Record Unchecked_Access");
end if;
 
if Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type)))
/= My_Task'Unchecked_Access then
Report.Failed("Task Unchecked_Access");
end if;
 
if Protected_ATAC.To_Pointer(
Hex_To_Address(The_Strings(Protected_Type)))
/= My_Prot'Unchecked_Access then
Report.Failed("Protected Unchecked_Access");
end if;
 
Report.Result;
 
end CD72A02;
/cd3014a.ada
0,0 → 1,132
-- CD3014A.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 ENUMERATION TYPE WITH A REPRESENTATION CLAUSE CAN
-- BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN
-- GENERIC INSTANTIATIONS.
 
-- HISTORY
-- DHH 09/30/87 CREATED ORIGINAL TEST.
-- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO
-- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES.
-- REVISED CHECK FOR ARRAY INDEXING.
-- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR
-- MESSAGE.
 
WITH REPORT; USE REPORT;
PROCEDURE CD3014A IS
 
BEGIN
 
TEST ("CD3014A", "CHECK THAT AN ENUMERATION TYPE WITH A " &
"REPRESENTATION CLAUSE CAN BE USED CORRECTLY " &
"IN ORDERING RELATIONS, INDEXING ARRAYS, AND " &
"IN GENERIC INSTANTIATIONS");
 
DECLARE
PACKAGE PACK IS
 
TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y');
 
FOR HUE USE (RED => 8, BLUE => 9,
YELLOW => 10, 'R' => 11,
'B' => 12, 'Y' => 13);
 
TYPE BASE IS ARRAY(HUE) OF INTEGER;
COLOR,BASIC : HUE;
BARRAY : BASE;
 
TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED);
 
FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16,
YELLOW => 19, BLUE => 41, RED => 46);
 
TYPE BASE1 IS ARRAY(HUE1) OF INTEGER;
COLOR1,BASIC1 : HUE1;
BARRAY1 : BASE1;
 
GENERIC
TYPE ENUM IS (<>);
PROCEDURE CHANGE(X,Y : IN OUT ENUM);
 
END PACK;
 
PACKAGE BODY PACK IS
 
PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS
T : ENUM;
BEGIN
T := X;
X := Y;
Y := T;
END CHANGE;
 
PROCEDURE PROC IS NEW CHANGE(HUE);
PROCEDURE PROC1 IS NEW CHANGE(HUE1);
 
BEGIN
BASIC := RED;
COLOR := HUE'SUCC(BASIC);
BASIC1 := RED;
COLOR1 := HUE1'PRED(BASIC1);
IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR
COLOR > 'B') OR
NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND
'Y' <= COLOR1 AND COLOR1 > 'B') THEN
FAILED("ORDERING RELATIONS ARE INCORRECT");
END IF;
 
PROC(BASIC,COLOR);
PROC1(BASIC1,COLOR1);
 
IF COLOR /= RED OR COLOR1 /= RED THEN
FAILED("VALUES OF PARAMETERS TO INSTANCE OF " &
"GENERIC UNIT NOT CORRECT AFTER CALL");
END IF;
 
BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
 
BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3),
IDENT_INT(4),IDENT_INT(5),IDENT_INT(6));
 
IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR
BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR
BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR
NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND
BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND
BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1)
THEN
FAILED("INDEXING ARRAY FAILURE");
END IF;
 
END PACK;
BEGIN
NULL;
END;
 
RESULT;
END CD3014A;
/cd7002a.ada
0,0 → 1,52
-- CD7002A.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 VARIABLE OF TYPE ADDRESS CAN BE DECLARED IN A UNIT
-- WHICH HAS A WITH CLAUSE NAMING SYSTEM.
 
-- HISTORY:
-- DHH 08/31/88 CREATED ORIGINAL TEST.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE CD7002A IS
 
I : INTEGER;
 
OBJECT : SYSTEM.ADDRESS := I'ADDRESS;
 
SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS;
 
BEGIN
TEST ("CD7002A", "CHECK THAT A VARIABLE OF TYPE ADDRESS CAN BE " &
"DECLARED IN A UNIT WHICH HAS A WITH CLAUSE " &
"NAMING SYSTEM");
 
IF NOT IDENT_BOOL(OBJECT IN MY_ADDRESS) THEN
FAILED("INCORRECT RESULT");
END IF;
 
RESULT;
END CD7002A;
/cd3014c.ada
0,0 → 1,85
-- CD3014C.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN IN
-- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN
-- THE VISIBLE PART.
 
-- HISTORY
-- DHH 09/30/87 CREATED ORIGINAL TEST
-- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED
-- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR
-- REPRESENTATION CLAUSE.
 
WITH REPORT; USE REPORT;
WITH ENUM_CHECK; -- CONTAINS CALL TO 'FAILED'
PROCEDURE CD3014C IS
 
BEGIN
 
TEST ("CD3014C", "CHECK THAT AN ENUMERATION " &
"REPRESENTATION CLAUSE CAN BE GIVEN IN THE " &
"VISIBLE OR PRIVATE PART OF A PACKAGE FOR " &
"A TYPE DECLARED IN THE VISIBLE PART");
 
DECLARE
PACKAGE PACK IS
 
TYPE HUE IS (RED,BLUE,YELLOW);
TYPE NEWHUE IS (RED,BLUE,YELLOW);
 
FOR HUE USE
(RED => 8, BLUE => 16,
YELLOW => 32);
A : HUE := BLUE;
PRIVATE
 
FOR NEWHUE USE (RED => 8, BLUE => 16, YELLOW => 32);
 
B : NEWHUE := RED;
 
TYPE INT_HUE IS RANGE 8 .. 32;
FOR INT_HUE'SIZE USE HUE'SIZE;
 
TYPE INT_NEW IS RANGE 8 .. 32;
FOR INT_NEW'SIZE USE NEWHUE'SIZE;
 
PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE);
PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW);
 
END PACK;
 
PACKAGE BODY PACK IS
BEGIN
CHECK_HUE (RED, 8, "HUE");
CHECK_NEW (YELLOW, 32, "NEWHUE");
END PACK;
 
BEGIN
NULL;
END;
 
RESULT;
END CD3014C;
/cd5014a.ada
0,0 → 1,84
-- CD5014A.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN
-- ENUMERATION TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE
-- PART OF THE SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014A IS
 
BEGIN
 
TEST ("CD5014A", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE VISIBLE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF AN " &
"ENUMERATION TYPE, WHERE THE VARIABLE IS " &
"DECLARED IN THE VISIBLE PART OF THE " &
"SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE ENUM_TYPE IS (RED,BLUE,GREEN);
ENUM_OBJ1 : ENUM_TYPE := RED;
FOR ENUM_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
ENUM_OBJ1 := BLUE;
END IF;
 
IF ENUM_OBJ1 /= BLUE THEN
FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE");
END IF;
 
IF ENUM_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014A;
/cd5014c.ada
0,0 → 1,84
-- CD5014C.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER
-- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
-- SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014C IS
 
BEGIN
 
TEST ("CD5014C", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE PRIVATE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF AN INTEGER " &
"TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
"VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE INTEGER_TYPE IS RANGE 0 .. 100;
INTEGER_OBJ1 : INTEGER_TYPE := 50;
PRIVATE
FOR INTEGER_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
INTEGER_OBJ1 := 7;
END IF;
 
IF INTEGER_OBJ1 /= 7 THEN
FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE");
END IF;
 
IF INTEGER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014C;
/cd20001.a
0,0 → 1,275
-- CD20001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that for packed records the components are packed as tightly
-- as possible subject to the Size of the component subtypes.
-- Specifically check that Boolean objects are packed one to a bit.
--
-- Check that the Component_Size for a packed array type is less than
-- or equal to the smallest of those factors of the word size that are
-- greater than or equal to the Size of the component subtype.
--
-- TEST DESCRIPTION:
-- This test defines and packs several types, and checks that the sizes
-- of the resulting objects is as expected.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as
-- inapplicable. Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 22 JUL 95 SAIC Initial version
-- 08 MAY 96 SAIC Strengthened for 2.1
-- 29 JAN 98 EDS Deleted check that Component_Size is really a
-- factor of Word_Size.
--!
 
----------------------------------------------------------------- CD20001_0
 
with System;
package CD20001_0 is
 
type Wordlong_Bool_Array is array(1..System.Word_Size) of Boolean;
pragma Pack(Wordlong_Bool_Array); -- ANX-C RQMT
 
type Def_Rep_Components is range 0..2**(System.Storage_Unit-2);
 
type Spec_Rep_Components is range 0..2**(System.Storage_Unit-2);
for Spec_Rep_Components'Size use System.Storage_Unit; -- ANX-C RQMT
 
type Packed_Array_Def_Components is array(1..32) of Def_Rep_Components;
pragma Pack(Packed_Array_Def_Components); -- ANX-C RQMT
 
type Packed_Array_Spec_Components is array(1..32) of Spec_Rep_Components;
pragma Pack(Packed_Array_Spec_Components); -- ANX-C RQMT
 
procedure TC_Check_Values;
 
end CD20001_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with TCTouch;
package body CD20001_0 is
 
procedure TC_Check_Values is
My_Word : Wordlong_Bool_Array := (others => False);
 
Cited_Unit : Spec_Rep_Components := 0;
 
Packed_Array : Packed_Array_Def_Components := (others => 0);
 
Cited_Packed : Packed_Array_Spec_Components := (others => 0);
 
begin
TCTouch.Assert( My_Word'Size = System.Word_Size,
"pragma Pack on array of Booleans does not pack one Boolean per bit" );
 
TCTouch.Assert( My_Word'Component_Size = 1,
"size of Boolean array component not 1 bit");
 
TCTouch.Assert( Cited_Unit'Size = System.Storage_Unit,
"Object specified to be Storage_Unit bits not " &
"Storage_Unit bits in size");
 
TCTouch.Assert( Packed_Array'Component_Size <= System.Storage_Unit,
"Packed array component expected to be less than or " &
"equal to Storage_Unit bits in size is greater than " &
"Storage_Unit bits in size");
 
TCTouch.Assert( Cited_Packed'Component_Size = System.Storage_Unit,
"Array component specified to be Storage_Unit " &
"bits not Storage_Unit bits in size");
 
end TC_Check_Values;
 
end CD20001_0;
 
----------------------------------------------------------------- CD20001_1
 
with System;
package CD20001_1 is
 
type Bits_2 is range 0..2**2-1;
for Bits_2'Size use 2; -- ANX-C RQMT
 
type Bits_3 is range 0..2**3-1;
for Bits_3'Size use 3; -- ANX-C RQMT
 
type Bits_7 is range 0..2**7-1;
for Bits_7'Size use 7; -- ANX-C RQMT
 
type Bits_8 is range 0..2**8-1;
for Bits_8'Size use 8; -- ANX-C RQMT
 
type Bits_9 is range 0..2**9-1;
for Bits_9'Size use 9; -- ANX-C RQMT
 
type Bits_15 is range 0..2**15-1;
for Bits_15'Size use 15; -- ANX-C RQMT
 
type Pact_Aray_2 is array(0..31) of Bits_2;
pragma Pack( Pact_Aray_2 ); -- ANX-C RQMT
 
type Pact_Aray_3 is array(0..31) of Bits_3;
pragma Pack( Pact_Aray_3 ); -- ANX-C RQMT
 
type Pact_Aray_7 is array(0..31) of Bits_7;
pragma Pack( Pact_Aray_7 ); -- ANX-C RQMT
 
type Pact_Aray_8 is array(0..31) of Bits_8;
pragma Pack( Pact_Aray_8 ); -- ANX-C RQMT
 
type Pact_Aray_9 is array(0..31) of Bits_9;
pragma Pack( Pact_Aray_9 ); -- ANX-C RQMT
 
type Pact_Aray_15 is array(0..31) of Bits_15;
pragma Pack( Pact_Aray_15 ); -- ANX-C RQMT
 
 
procedure TC_Check_Values;
 
end CD20001_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with TCTouch;
package body CD20001_1 is
 
function Next_Factor ( Value : Positive ) return Integer is
-- Returns the factor of Word_Size that is next larger than Value.
-- If Value is greater than Word_Size, then returns Word_Size.
Test : Integer := Value;
Found : Boolean := False;
begin -- Next_Factor
while not Found and Test <= System.Word_Size loop
if System.Word_Size mod Test = 0 then
Found := True;
else
Test := Test + 1;
end if;
end loop;
if Found then
return Test;
else
return System.Word_Size;
end if;
end Next_Factor;
 
procedure TC_Check_Values is
begin
if Pact_Aray_2'Component_Size > Next_Factor ( Bits_2'Size ) then
Report.Failed
( "2 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_2'Component_Size <= Pact_Aray_2'Size,
"2 bit Component_Size greater than array size" );
 
if Pact_Aray_3'Component_Size > Next_Factor ( Bits_3'Size ) then
Report.Failed
( "3 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_3'Component_Size <= Pact_Aray_3'Size,
"3 bit Component_Size greater than array size" );
 
if Pact_Aray_7'Component_Size > Next_Factor ( Bits_7'Size ) then
Report.Failed
( "7 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_7'Component_Size <= Pact_Aray_7'Size,
"7 bit Component_Size greater than array size" );
 
if Pact_Aray_8'Component_Size > Next_Factor ( Bits_8'Size ) then
Report.Failed
( "8 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_8'Component_Size <= Pact_Aray_8'Size,
"8 bit Component_Size greater than array size" );
 
if System.Word_Size > 8 then
 
if Pact_Aray_9'Component_Size > Next_Factor ( Bits_9'Size ) then
Report.Failed
( "9 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_9'Component_Size <= Pact_Aray_9'Size,
"9 bit Component_Size greater than array size" );
 
if Pact_Aray_15'Component_Size > Next_Factor ( Bits_15'Size ) then
Report.Failed
( "15 bit element Packed Array'Component_Size too big" );
end if;
 
TCTouch.Assert( Pact_Aray_15'Component_Size <= Pact_Aray_15'Size,
"15 bit Component_Size greater than array size" );
 
end if;
 
end TC_Check_Values;
 
end CD20001_1;
 
------------------------------------------------------------------- CD20001
 
with Report;
with CD20001_0;
with CD20001_1;
 
procedure CD20001 is
 
begin -- Main test procedure.
 
Report.Test ("CD20001", "Check that packed records are packed as tightly " &
"as possible. Check that Boolean objects are " &
"packed one to a bit. " &
"Check that the Component_Size for a packed " &
"array type is the value which is less than or " &
"equal to the Size of the component type, " &
"rounded up to the nearest factor of word_size" );
CD20001_0.TC_Check_Values;
 
CD20001_1.TC_Check_Values;
 
Report.Result;
 
end CD20001;
/cd5014e.ada
0,0 → 1,84
-- CD5014E.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING
-- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
-- OF THE SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 08/19/87 CREATED ORIGINAL TEST.
-- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014E IS
 
BEGIN
 
TEST ("CD5014E", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE VISIBLE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF A FLOATING " &
"POINT TYPE, WHERE THE VARIABLE IS DECLARED " &
"IN THE VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE FLOAT_TYPE IS DIGITS SYSTEM.MAX_DIGITS
RANGE 0.0 .. 100.0;
FLOAT_OBJ1 : FLOAT_TYPE := 50.0;
FOR FLOAT_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
FLOAT_OBJ1 := 5.0;
END IF;
 
IF FLOAT_OBJ1 /= 5.0 THEN
FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE");
END IF;
 
IF FLOAT_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014E;
/cd7103d.ada
0,0 → 1,52
-- CD7103D.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE CONSTANT FINE_DELTA = 2.0 ** (- MAX_MANTISSA).
 
-- HISTORY:
-- BCB 09/10/87 CREATED ORIGINAL TEST.
 
-- DTN 11/21/91 DELETED SUBPART (A). CHANGED EXTENSION FROM '.TST' TO
-- '.ADA'.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
 
PROCEDURE CD7103D IS
 
MANTISSA_VAL : CONSTANT := 2.0 ** (-SYSTEM.MAX_MANTISSA);
 
BEGIN
 
TEST ("CD7103D", "CHECK THAT THE CONSTANT FINE_DELTA " &
"= 2.0 ** (- MAX_MANTISSA)");
 
IF SYSTEM.FINE_DELTA /= MANTISSA_VAL THEN
FAILED ("INCORRECT VALUE FOR SYSTEM.FINE_DELTA");
END IF;
 
RESULT;
 
END CD7103D;
/cd300050.am
0,0 → 1,154
-- CD30005.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 Address clauses are supported for imported subprograms.
--
-- TEST DESCRIPTION:
-- This test imports a simple C function and specifies it's location.
--
-- The implementation may choose to implement
-- Impdef.CD30005_1_Foreign_Address so as to dynamically call a C
-- function that returns the appropriate address for the external
-- function identified by Impdef.CD30005_1_External_Name.
--
-- TEST FILES:
-- CD300050.AM
-- CD300051.C -- the C function: (included below for reference)
--
-- SPECIAL REQUIREMENTS:
-- The file CD300051.C must be compiled with a C compiler.
-- Implementation dialects of C may require alteration of the C program
-- syntax. The program is included here for reference:
--
-- int _cd30005_1( Value )
-- {
-- /* int Value */
--
-- return Value + 1;
-- }
--
-- Implementations may require special linkage commands to include the
-- C code.
--
-- APPLICABILITY CRITERIA:
-- This test is not applicable to implementations not providing an interface
-- to C language units. OTHERWISE:
--
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 22 JUL 95 SAIC Initial version
-- 30 APR 96 SAIC Added commentary for 2.1
-- 09 MAY 96 SAIC Changed reporting for 2.1
-- 04 NOV 96 SAIC Added use type System.Address
-- 16 FEB 98 EDS Modified documentation.
-- 29 JUN 98 EDS Modified main program name.
--!
 
----------------------------------------------------------------- CD30005_0
 
with Impdef;
package CD30005_0 is
 
-- Check that Address clauses are supported for imported subprograms.
 
type External_Func_Ref is access function(N:Integer) return Integer;
pragma Convention( C, External_Func_Ref );
 
 
function CD30005_1( I: Integer ) return Integer;
 
pragma Import( C, CD30005_1,
Impdef.CD30005_1_External_Name ); -- N/A => ERROR.
 
for CD30005_1'Address use
Impdef.CD30005_1_Foreign_Address; -- ANX-C RQMT.
 
procedure TC_Check_Imports;
 
end CD30005_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
with Report;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;
package body CD30005_0 is
 
use type System.Address;
 
procedure TC_Check_Imports is
S : External_Func_Ref := CD30005_1'Access;
I,K : Integer := 99;
begin
 
K := S.all(I);
if K /= 100 then
Report.Failed("C program returned" & Integer'Image(K));
end if;
 
I := CD30005_1( I );
if I /= 100 then
Report.Failed("C program returned" & Integer'Image(I));
end if;
 
if CD30005_1'Address /= Impdef.CD30005_1_Foreign_Address then
Report.Failed("Address not that specified");
end if;
 
end TC_Check_Imports;
 
end CD30005_0;
 
------------------------------------------------------------------- CD300050
 
with Report;
with CD30005_0;
 
procedure CD300050 is
 
begin -- Main test procedure.
 
Report.Test ("CD30005",
"Check that Address clauses are supported for imported " &
"subprograms" );
-- Check that Address clauses are supported for imported subprograms.
 
CD30005_0.TC_Check_Imports;
 
Report.Result;
 
end CD300050;
/cd30002.a
0,0 → 1,207
-- CD30002.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 implementation supports Alignments for subtypes and
-- objects specified as factors and multiples of the number of storage
-- elements per word, unless those values cannot be loaded and stored.
-- Check that the largest alignment returned by default is supported.
--
-- Check that the implementation supports Alignments supported by the
-- target linker for stand-alone library-level objects of statically
-- constrained subtypes.
--
-- TEST DESCRIPTION:
-- This test defines several types and objects, specifying various
-- alignments for them (as factors and multiples of the number of
-- storage elements per word). It then checks the alignments by
-- declaring some objects, and checking that the integer values of
-- their addresses is mod the specified alignment. This will not
-- prevent false passes where the lucky compiler gets it right by
-- chance, but will catch compilers that specifically do not obey
-- the alignment clauses.
--
-- APPLICABILITY CRITERIA:
-- All implementations must attempt to compile this test.
--
-- For implementations validating against Systems Programming Annex (C):
-- this test must execute and report PASSED.
--
-- For implementations not validating against Annex C:
-- this test may report compile time errors at one or more points
-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable.
-- Otherwise, the test must execute and report PASSED.
--
--
-- CHANGE HISTORY:
-- 22 JUL 95 SAIC Initial version
-- 09 MAY 96 SAIC Strengthened for 2.1
-- 26 FEB 97 PWB.CTA Allowed for unexpected word sizes
-- 16 FEB 98 EDS Modified documentation.
-- 26 SEP 98 RLB Fixed value on line 130 so check and dec. match.
-- 30 OCT 98 RLB Split Multiple_Alignment and revised the
-- calculation to work on all targets.
-- 18 JAN 99 RLB Repaired again to work on targets where word size
-- equals storage unit.
--!
 
----------------------------------------------------------------- CD30002_0
 
with Impdef;
with System.Storage_Elements;
package CD30002_0 is
 
S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit;
-- Must be 1 or greater.
 
Multiple_Type_Alignment : constant :=
Integer'Min ( Impdef.Max_Default_Alignment,
2 * S_Units_per_Word );
-- Calculate a reasonable alignment, but not larger than the
-- implementation is required to support.
 
Multiple_Object_Alignment : constant :=
Integer'Min ( Impdef.Max_Linker_Alignment,
2 * S_Units_per_Word );
-- Calculate a reasonable object alignment, but not larger than
-- the implementation is required to support.
 
Small_Alignment : constant :=
Integer'Max ( S_Units_per_Word / 2, 1);
-- Calculate a reasonable small alignment, but not less than 1.
-- (If S_Units_per_Word = 1, 1/2 => 0 which causes problems
-- verifying alignment.)
 
subtype Storage_Element is System.Storage_Elements.Storage_Element;
 
type Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
for Some_Stuff'Alignment
use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
 
Library_Level_Object : Some_Stuff;
for Library_Level_Object'Alignment
use Impdef.Max_Linker_Alignment; -- ANX-C RQMT.
 
type Quarter is mod 4; -- two bits
for Quarter'Alignment use Small_Alignment; -- ANX-C RQMT.
 
type Half is mod 16; -- nibble
for Half'Alignment use Multiple_Type_Alignment; -- ANX-C RQMT.
type O_Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element;
type O_Quarter is mod 4; -- two bits
 
type O_Half is mod 16; -- nibble
 
end CD30002_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 
-- there is no package body CD30002_0
 
------------------------------------------------------------------- CD30002
 
with Report;
with Impdef;
with CD30002_0;
with System.Storage_Elements;
procedure CD30002 is
 
My_Stuff : CD30002_0.Some_Stuff;
-- Impdef.Max_Default_Alignment
 
My_Quarter : CD30002_0.Quarter;
-- CD30002_0.S_Units_per_Word / 2
 
My_Half : CD30002_0.Half;
-- CD30002_0.S_Units_per_Word * 2
 
Stuff_Object : CD30002_0.O_Some_Stuff;
for Stuff_Object'Alignment
use Impdef.Max_Default_Alignment; -- ANX-C RQMT.
 
Quarter_Object : CD30002_0.O_Quarter;
for Quarter_Object'Alignment
use CD30002_0.Small_Alignment; -- ANX-C RQMT.
 
Half_Object : CD30002_0.O_Half;
for Half_Object'Alignment
use CD30002_0.Multiple_Object_Alignment; -- ANX-C RQMT.
 
subtype IntAdd is System.Storage_Elements.Integer_Address;
use type System.Storage_Elements.Integer_Address;
 
function A2I(Value: System.Address) return IntAdd renames
System.Storage_Elements.To_Integer;
 
NAC : constant String := " not aligned correctly";
 
begin -- Main test procedure.
 
Report.Test ("CD30002", "Check that the implementation supports " &
"Alignments for subtypes and objects specified " &
"as factors and multiples of the number of " &
"storage elements per word, unless those values " &
"cannot be loaded and stored. Check that the " &
"largest alignment returned by default is " &
"supported. Check that the implementation " &
"supports Alignments supported by the target " &
"linker for stand-alone library-level objects " &
"of statically constrained subtypes" );
 
if A2I(CD30002_0.Library_Level_Object'Address)
mod Impdef.Max_Linker_Alignment /= 0 then
Report.Failed("Library_Level_Object" & NAC);
end if;
 
if A2I(My_Stuff'Address) mod Impdef.Max_Default_Alignment /= 0 then
Report.Failed("Max alignment subtype" & NAC);
end if;
 
if A2I(My_Quarter'Address) mod (CD30002_0.Small_Alignment) /= 0 then
Report.Failed("Factor of words subtype" & NAC);
end if;
 
if A2I(My_Half'Address) mod (CD30002_0.Multiple_Type_Alignment) /= 0 then
Report.Failed("Multiple of words subtype" & NAC);
end if;
 
if A2I(Stuff_Object'Address) mod Impdef.Max_Default_Alignment /= 0 then
Report.Failed("Stuff alignment object" & NAC);
end if;
 
if A2I(Quarter_Object'Address)
mod (CD30002_0.Small_Alignment) /= 0 then
Report.Failed("Factor of words object" & NAC);
end if;
 
if A2I(Half_Object'Address) mod (CD30002_0.Multiple_Object_Alignment) /= 0 then
Report.Failed("Multiple of words object" & NAC);
end if;
 
Report.Result;
 
end CD30002;
/cd7204c.ada
0,0 → 1,91
-- CD7204C.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE PREFIX OF THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT
-- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES
-- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE
-- IS GIVEN.
 
-- HISTORY:
-- BCB 09/14/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
 
PROCEDURE CD7204C IS
 
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1)/SYSTEM.STORAGE_UNIT;
 
TYPE BASIC_REC IS RECORD
CHECK_INT : INTEGER;
CHECK_CHAR : CHARACTER;
END RECORD;
 
FOR BASIC_REC USE
RECORD
CHECK_INT AT 0 RANGE 0..INTEGER'SIZE - 1;
CHECK_CHAR AT 1*UNITS_PER_INTEGER
RANGE 0..CHARACTER'SIZE - 1;
END RECORD;
 
CHECK_REC : BASIC_REC;
 
BEGIN
 
TEST ("CD7204C", "THE PREFIX OF THE 'POSITION, " &
"'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " &
"DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " &
"RETURN APPROPRIATE VALUES WHEN A RECORD " &
"REPRESENTATION CLAUSE IS GIVEN");
 
IF CHECK_REC.CHECK_INT'POSITION /= 0 THEN
FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_INT");
END IF;
 
IF CHECK_REC.CHECK_INT'FIRST_BIT /= IDENT_INT (0) THEN
FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_INT");
END IF;
 
IF CHECK_REC.CHECK_INT'LAST_BIT /= INTEGER'SIZE - 1 THEN
FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_INT");
END IF;
 
IF CHECK_REC.CHECK_CHAR'POSITION /= IDENT_INT (UNITS_PER_INTEGER)
THEN FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_CHAR");
END IF;
 
IF CHECK_REC.CHECK_CHAR'FIRST_BIT /= 0 THEN
FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_CHAR");
END IF;
 
IF CHECK_REC.CHECK_CHAR'LAST_BIT /= IDENT_INT (CHARACTER'SIZE - 1)
THEN FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_CHAR");
END IF;
 
RESULT;
 
END CD7204C;
/cd5014g.ada
0,0 → 1,84
-- CD5014G.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED
-- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF
-- THE SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014G IS
 
BEGIN
 
TEST ("CD5014G", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE PRIVATE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF A FIXED " &
"POINT TYPE, WHERE THE VARIABLE IS DECLARED " &
"IN THE VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE FIXED_TYPE IS DELTA 0.5 RANGE 0.0 .. 100.0;
FIXED_OBJ1 : FIXED_TYPE := 50.0;
PRIVATE
FOR FIXED_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
FIXED_OBJ1 := 5.0;
END IF;
 
IF FIXED_OBJ1 /= 5.0 THEN
FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE");
END IF;
 
IF FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014G;
/cd5014i.ada
0,0 → 1,83
-- CD5014I.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY
-- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
-- SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014I IS
 
BEGIN
 
TEST ("CD5014I", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE VISIBLE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF AN ARRAY " &
"TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
"VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE ARR_TYPE IS ARRAY (1..2) OF INTEGER;
ARR_OBJ1 : ARR_TYPE := (5,10);
FOR ARR_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
ARR_OBJ1 := (13,21);
END IF;
 
IF ARR_OBJ1 /= (13,21) THEN
FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE");
END IF;
 
IF ARR_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014I;
/cd2a91c.tst
0,0 → 1,134
-- CD2A91C.TST
 
-- 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 SIZE SPECIFICATION FOR A TASK TYPE CAN BE GIVEN IN
-- THE VISIBLE OR PRIVATE PART OF A PACKAGE.
 
-- MACRO SUBSTITUTION:
-- $TASK_SIZE IS THE NUMBER OF BITS NEEDED BY THE IMPLEMENTATION TO
-- HOLD ANY POSSIBLE OBJECT OF THE TASK TYPE "BASIC_TYPE".
 
-- HISTORY:
-- BCB 09/08/87 CREATED ORIGINAL TEST.
-- RJW 05/12/89 MODIFIED CHECKS INVOLVING 'SIZE ATTRIBUTE.
-- REMOVED APPLICABILTY CRITERIA.
-- DTN 11/20/91 DELETED SUBPARTS (B and C).
 
WITH REPORT; USE REPORT;
PROCEDURE CD2A91C IS
 
BASIC_SIZE : CONSTANT := $TASK_SIZE;
 
VAL : INTEGER := 1;
 
TASK TYPE BASIC_TYPE IS
ENTRY HERE(NUM : IN OUT INTEGER);
END BASIC_TYPE;
 
FOR BASIC_TYPE'SIZE USE BASIC_SIZE;
 
BASIC_TASK : BASIC_TYPE;
 
PACKAGE P IS
TASK TYPE TASK_IN_P IS
ENTRY HERE(NUM : IN OUT INTEGER);
END TASK_IN_P;
FOR TASK_IN_P'SIZE USE BASIC_SIZE;
TASK TYPE ALT_TASK_IN_P IS
ENTRY HERE(NUM : IN OUT INTEGER);
END ALT_TASK_IN_P;
PRIVATE
FOR ALT_TASK_IN_P'SIZE USE BASIC_SIZE;
END P;
 
USE P;
 
ALT_TASK : ALT_TASK_IN_P;
IN_TASK : TASK_IN_P;
 
TASK BODY BASIC_TYPE IS
BEGIN
SELECT
ACCEPT HERE(NUM : IN OUT INTEGER) DO
NUM := 0;
END HERE;
OR
TERMINATE;
END SELECT;
END BASIC_TYPE;
 
PACKAGE BODY P IS
TASK BODY TASK_IN_P IS
BEGIN
SELECT
ACCEPT HERE(NUM : IN OUT INTEGER) DO
NUM := 0;
END HERE;
OR
TERMINATE;
END SELECT;
END TASK_IN_P;
TASK BODY ALT_TASK_IN_P IS
BEGIN
SELECT
ACCEPT HERE(NUM : IN OUT INTEGER) DO
NUM := 0;
END HERE;
OR
TERMINATE;
END SELECT;
END ALT_TASK_IN_P;
END P;
 
BEGIN
TEST ("CD2A91C", "CHECK THAT A SIZE SPECIFICATION FOR A TASK " &
"TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE " &
"PART OF A PACKAGE");
 
BASIC_TASK.HERE(VAL);
 
IF VAL /= IDENT_INT (0) THEN
FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 1");
END IF;
 
VAL := 1;
 
ALT_TASK.HERE(VAL);
IF VAL /= IDENT_INT (0) THEN
FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 2");
END IF;
VAL := 1;
 
IN_TASK.HERE(VAL);
 
IF VAL /= IDENT_INT (0) THEN
FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 3");
END IF;
 
 
RESULT;
END CD2A91C;
/cd5014k.ada
0,0 → 1,87
-- CD5014K.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD
-- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
-- SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014K IS
 
BEGIN
 
TEST ("CD5014K", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE PRIVATE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF A RECORD " &
"TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
"VISIBLE PART OF THE SPECIFICATION");
 
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE REC_TYPE IS RECORD
VAL : INTEGER;
END RECORD;
REC_OBJ1 : REC_TYPE := (VAL => 10);
PRIVATE
FOR REC_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
REC_OBJ1.VAL := 100;
END IF;
 
IF REC_OBJ1.VAL /= 100 THEN
FAILED ("INCORRECT VALUE FOR RECORD VARIABLE COMPONENT");
END IF;
 
IF REC_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014K;
/cd2b11a.ada
0,0 → 1,214
-- CD2B11A.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 IF A COLLECTION SIZE SPECIFICATION CAN BE GIVEN FOR AN
-- ACCESS TYPE, THEN OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT
-- AFFECTED.
 
-- HISTORY:
-- BCB 11/01/88 CREATED ORIGINAL TEST.
-- RJW 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST.
-- ADDED CHECK FOR UNCHECKED_DEALLOCATION.
 
WITH REPORT; USE REPORT;
WITH SYSTEM;
WITH UNCHECKED_DEALLOCATION;
PROCEDURE CD2B11A IS
 
BASIC_SIZE : CONSTANT := 1024;
 
TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER;
TYPE ACC_TYPE IS ACCESS MAINTYPE;
SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3);
 
FOR ACC_TYPE'STORAGE_SIZE USE BASIC_SIZE;
 
TYPE RECORD_TYPE IS RECORD
COMP : ACC_TYPE;
END RECORD;
 
CHECK_TYPE1 : ACC_TYPE;
CHECK_TYPE2 : ACC_TYPE;
CHECK_TYPE3 : ACC_TYPE(1..3);
 
CHECK_ARRAY : ARRAY (1..2) OF ACC_TYPE;
 
CHECK_RECORD1 : RECORD_TYPE;
CHECK_RECORD2 : RECORD_TYPE;
 
CHECK_PARAM1 : ACC_TYPE;
CHECK_PARAM2 : ACC_TYPE;
 
CHECK_NULL : ACC_TYPE := NULL;
 
PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS
 
BEGIN
 
IF (ACC1.ALL /= ACC2.ALL) THEN
FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS " &
"- 1");
END IF;
 
IF EQUAL (3,3) THEN
ACC2 := ACC1;
END IF;
 
IF ACC2 /= ACC1 THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " &
"-1");
END IF;
 
IF (ACC1 IN ACC_RANGE) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 1");
END IF;
 
END PROC;
 
BEGIN
 
TEST ("CD2B11A", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " &
"CAN BE GIVEN FOR AN ACCESS TYPE, THEN " &
"OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " &
"NOT AFFECTED");
 
CHECK_PARAM1 := NEW MAINTYPE'(25,35,45);
CHECK_PARAM2 := NEW MAINTYPE'(25,35,45);
 
PROC (CHECK_PARAM1,CHECK_PARAM2);
 
IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN
FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE");
END IF;
 
CHECK_TYPE1 := NEW MAINTYPE'(25,35,45);
CHECK_TYPE2 := NEW MAINTYPE'(25,35,45);
CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3);
 
CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45);
CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45);
 
CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45);
CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45);
 
IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN
FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2");
END IF;
 
IF EQUAL (3,3) THEN
CHECK_TYPE2 := CHECK_TYPE1;
END IF;
 
IF CHECK_TYPE2 /= CHECK_TYPE1 THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2");
END IF;
 
IF (CHECK_TYPE1 IN ACC_RANGE) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2");
END IF;
 
IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN
FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3");
END IF;
 
IF EQUAL (3,3) THEN
CHECK_ARRAY (2) := CHECK_ARRAY (1);
END IF;
 
IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3");
END IF;
 
IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3");
END IF;
 
IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN
FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4");
END IF;
 
IF EQUAL (3,3) THEN
CHECK_RECORD2 := CHECK_RECORD1;
END IF;
 
IF CHECK_RECORD2 /= CHECK_RECORD1 THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4");
END IF;
 
IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN
FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4");
END IF;
 
IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST");
END IF;
 
IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST");
END IF;
 
DECLARE
TYPE ACC_CHAR IS ACCESS CHARACTER;
FOR ACC_CHAR'STORAGE_SIZE USE 128;
 
LIMIT : INTEGER :=
(ACC_CHAR'STORAGE_SIZE * SYSTEM.STORAGE_UNIT)/CHARACTER'SIZE;
 
ACC_ARRAY : ARRAY (1 .. LIMIT + 1) OF ACC_CHAR;
PLACE : INTEGER;
 
PROCEDURE FREE IS
NEW UNCHECKED_DEALLOCATION (CHARACTER, ACC_CHAR);
BEGIN
FOR I IN ACC_ARRAY'RANGE LOOP
ACC_ARRAY (IDENT_INT (I)) :=
NEW CHARACTER'
(IDENT_CHAR ((CHARACTER'VAL (I MOD 128))));
PLACE := I;
END LOOP;
FAILED ("NO EXCEPTION RAISED WHEN COLLECTION SIZE EXCEEDED");
EXCEPTION
WHEN STORAGE_ERROR =>
BEGIN
FOR I IN 1 .. PLACE LOOP
IF I MOD 2 = 0 THEN
FREE (ACC_ARRAY (IDENT_INT (I)));
END IF;
END LOOP;
 
FOR I IN 1 .. PLACE LOOP
IF I MOD 2 = 1 AND THEN
IDENT_CHAR (ACC_ARRAY (I).ALL) /=
CHARACTER'VAL (I MOD IDENT_INT (128)) THEN
FAILED ("INCORRECT VALUE IN ARRAY");
END IF;
END LOOP;
END;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED");
END;
 
RESULT;
END CD2B11A;
/cd5014m.ada
0,0 → 1,88
-- CD5014M.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS
-- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF
-- THE SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014M IS
 
BEGIN
 
TEST ("CD5014M", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE VISIBLE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF AN ACCESS " &
"TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
"VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE ACCESS_TYPE;
TYPE POINTER_TYPE IS ACCESS ACCESS_TYPE;
TYPE ACCESS_TYPE IS RECORD
VAL1 : INTEGER;
NEXT : POINTER_TYPE;
END RECORD;
POINTER_OBJ1 : POINTER_TYPE := NEW ACCESS_TYPE'(0,NULL);
FOR POINTER_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
POINTER_OBJ1 := NEW ACCESS_TYPE'(10,NULL);
END IF;
 
IF POINTER_OBJ1.ALL /= (10,NULL) THEN
FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE");
END IF;
 
IF POINTER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014M;
/cd1c04a.ada
0,0 → 1,147
-- CD1C04A.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 SIZE CLAUSE CAN BE GIVEN FOR A DERIVED TYPE, A
-- DERIVED PRIVATE TYPE, AND A DERIVED LIMITED PRIVATE TYPE EVEN
-- IF THE SIZE IS INHERITED FROM THE PARENT, AND THAT THE SIZE
-- CLAUSES FOR THE DERIVED TYPES OVERRIDE THE PARENTS'.
 
-- HISTORY:
-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST
-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'.
-- JET 09/16/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
PROCEDURE CD1C04A IS
 
SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2;
 
TYPE PARENT_TYPE IS RANGE 0 .. 100;
 
FOR PARENT_TYPE'SIZE USE INTEGER'SIZE;
 
TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
 
FOR DERIVED_TYPE'SIZE USE SPECIFIED_SIZE;
 
PACKAGE P IS
TYPE PRIVATE_PARENT IS PRIVATE;
TYPE LIM_PRIV_PARENT IS LIMITED PRIVATE;
PRIVATE
TYPE PRIVATE_PARENT IS RANGE 0 .. 100;
FOR PRIVATE_PARENT'SIZE USE INTEGER'SIZE;
TYPE LIM_PRIV_PARENT IS RANGE 0 .. 100;
FOR LIM_PRIV_PARENT'SIZE USE INTEGER'SIZE;
END P;
 
USE P;
 
TYPE DERIVED_PRIVATE_TYPE IS NEW PRIVATE_PARENT;
 
FOR DERIVED_PRIVATE_TYPE'SIZE USE SPECIFIED_SIZE;
 
TYPE DERIVED_LIM_PRIV_TYPE IS NEW LIM_PRIV_PARENT;
 
FOR DERIVED_LIM_PRIV_TYPE'SIZE USE SPECIFIED_SIZE;
 
DT : DERIVED_TYPE := 100;
DPT : DERIVED_PRIVATE_TYPE;
DLPT : DERIVED_LIM_PRIV_TYPE;
 
BEGIN
 
TEST("CD1C04A", "CHECK THAT A SIZE CLAUSE CAN BE GIVEN FOR " &
"A DERIVED TYPE, A DERIVED PRIVATE TYPE, AND " &
"A DERIVED LIMITED PRIVATE TYPE EVEN IF THE " &
"SIZE IS INHERITED FROM THE PARENT, AND THAT " &
"THE SIZE CLAUSES FOR THE DERIVED TYPES " &
"OVERRIDE THE PARENTS'");
 
IF PARENT_TYPE'SIZE /= IDENT_INT (INTEGER'SIZE) THEN
FAILED ("PARENT_TYPE'SIZE SHOULD BE " &
INTEGER'IMAGE(INTEGER'SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(PARENT_TYPE'SIZE));
END IF;
 
IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DERIVED_TYPE'SIZE SHOULD BE " &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_TYPE'SIZE));
END IF;
 
IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DT'SIZE));
END IF;
 
IF PRIVATE_PARENT'SIZE < IDENT_INT (INTEGER'SIZE) THEN
FAILED ("PRIVATE_PARENT'SIZE SHOULD NOT BE LESS THAN" &
INTEGER'IMAGE(INTEGER'SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(PRIVATE_PARENT'SIZE));
END IF;
 
IF DERIVED_PRIVATE_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DERIVED_PRIVATE_TYPE'SIZE SHOULD BE " &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_PRIVATE_TYPE'SIZE));
END IF;
 
IF DPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DPT'SIZE SHOULD NOT BE LESS THAN" &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DPT'SIZE));
END IF;
 
IF LIM_PRIV_PARENT'SIZE /= IDENT_INT (INTEGER'SIZE) THEN
FAILED ("LIM_PRIV_PARENT'SIZE SHOULD BE" &
INTEGER'IMAGE(INTEGER'SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(LIM_PRIV_PARENT'SIZE));
END IF;
 
IF DERIVED_LIM_PRIV_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DERIVED_LIM_PRIV_TYPE'SIZE SHOULD BE " &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DERIVED_LIM_PRIV_TYPE'SIZE));
END IF;
 
IF DLPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN
FAILED ("DLPT'SIZE SHOULD NOT BE LESS THAN" &
INTEGER'IMAGE(SPECIFIED_SIZE) &
". ACTUAL SIZE IS" &
INTEGER'IMAGE(DLPT'SIZE));
END IF;
 
RESULT;
 
END CD1C04A;
/cd5014o.ada
0,0 → 1,85
-- CD5014O.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE
-- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE
-- SPECIFICATION.
 
 
-- HISTORY:
-- CDJ 07/24/87 CREATED ORIGINAL TEST.
-- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
-- MCH 04/03/90 ADDED INSTANTIATION.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014O IS
 
BEGIN
 
TEST ("CD5014O", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE PRIVATE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF A PRIVATE " &
"TYPE, WHERE THE VARIABLE IS DECLARED IN THE " &
"VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
PACKAGE PKG IS
TYPE PRIVATE_TYPE IS PRIVATE;
PRIVATE
TYPE PRIVATE_TYPE IS RANGE 1 .. 20;
PRIVATE_OBJ1 : PRIVATE_TYPE := 5;
FOR PRIVATE_OBJ1 USE AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF EQUAL(3,3) THEN
PRIVATE_OBJ1 := 9;
END IF;
 
IF PRIVATE_OBJ1 /= 9 THEN
FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE");
END IF;
 
IF PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE");
END IF;
END PKG;
 
PACKAGE INSTANTIATE IS NEW PKG;
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014O;
/cd2d13a.ada
0,0 → 1,66
-- CD2D13A.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 SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE
-- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED
-- IN THE VISIBLE PART.
 
-- HISTORY:
-- BCB 09/01/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; WITH TEXT_IO;
WITH REPORT; USE REPORT;
PROCEDURE CD2D13A IS
 
SPECIFIED_SMALL : CONSTANT := 2.0 ** (-4);
 
PACKAGE P IS
TYPE FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0;
FOR FIXED_IN_P'SMALL USE SPECIFIED_SMALL;
TYPE ALT_FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0;
PRIVATE
FOR ALT_FIXED_IN_P'SMALL USE SPECIFIED_SMALL;
END P;
 
USE P;
 
BEGIN
 
TEST("CD2D13A", "A SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE " &
"OR PRIVATE PART OF A PACKAGE FOR A FIXED " &
"POINT TYPE DECLARED IN THE VISIBLE PART");
 
IF FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN
FAILED ("INCORRECT VALUE FOR FIXED_IN_P'SMALL");
END IF;
 
IF ALT_FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN
FAILED ("INCORRECT VALUE FOR ALT_FIXED_IN_P'SMALL");
END IF;
 
RESULT;
 
END CD2D13A;
/cd2b11e.ada
0,0 → 1,76
-- CD2B11E.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT THE EXPRESSION IN A COLLECTION SIZE CLAUSE
-- FOR AN ACCESS TYPE IN A GENERIC UNIT NEED NOT BE STATIC.
 
-- HISTORY:
-- BCB 09/23/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH REPORT; USE REPORT;
 
PROCEDURE CD2B11E IS
 
B : BOOLEAN;
 
BEGIN
 
TEST ("CD2B11E", "CHECK THAT THE EXPRESSION IN A COLLECTION " &
"SIZE CLAUSE FOR AN ACCESS TYPE IN A " &
"GENERIC UNIT NEED NOT BE STATIC");
 
DECLARE
 
GENERIC
FUNCTION FUNC RETURN BOOLEAN;
 
FUNCTION FUNC RETURN BOOLEAN IS
 
TYPE TEST_TYPE IS ACCESS INTEGER;
FOR TEST_TYPE'STORAGE_SIZE USE 256;
 
TYPE ACC_TYPE IS ACCESS INTEGER;
FOR ACC_TYPE'STORAGE_SIZE
USE IDENT_INT (256);
 
BEGIN -- FUNC.
 
IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN
FAILED ("INCORRECT VALUE FOR STORAGE_SIZE");
END IF;
 
RETURN TRUE;
 
END FUNC;
 
FUNCTION NEWFUNC IS NEW FUNC;
 
BEGIN
B := NEWFUNC;
END;
 
RESULT;
END CD2B11E;
/cd1c04e.ada
0,0 → 1,124
-- CD1C04E.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR
-- A DERIVED RECORD TYPE EVEN IF THE REPRESENTATION IS INHERITED
-- FROM THE PARENT, AND THAT THE REPRESENTATION CLAUSE FOR THE
-- DERIVED TYPE OVERRIDES THAT OF THE PARENT TYPE.
 
-- HISTORY:
-- PWB 03/25/89 DELETED CHECKS OF COMPONENT'SIZE; CHANGED
-- EXTENSION FROM '.ADA' TO '.DEP'.
-- JET 09/21/87 CREATED ORIGINAL TEST.
 
WITH REPORT; USE REPORT;
WITH SYSTEM; USE SYSTEM;
 
PROCEDURE CD1C04E IS
 
UNITS_PER_INTEGER : CONSTANT :=
(INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) /
SYSTEM.STORAGE_UNIT;
 
TYPE E_TYPE IS (RED, BLUE, GREEN);
 
TYPE PARENT_TYPE IS
RECORD
I : INTEGER RANGE 0 .. 127 := 127;
C : CHARACTER := 'S';
B : BOOLEAN := FALSE;
E : E_TYPE := BLUE;
END RECORD;
 
FOR PARENT_TYPE USE
RECORD
C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1;
I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1;
E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1;
END RECORD;
 
TYPE DERIVED_TYPE IS NEW PARENT_TYPE;
 
FOR DERIVED_TYPE USE
RECORD
C AT 1 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1;
B AT 3 * UNITS_PER_INTEGER RANGE 1 .. BOOLEAN'SIZE + 1;
I AT 5 * UNITS_PER_INTEGER RANGE 1 .. INTEGER'SIZE/2 + 1;
E AT 7 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1;
END RECORD;
 
P_REC : PARENT_TYPE;
REC : DERIVED_TYPE;
 
BEGIN
 
TEST("CD1C04E", "CHECK THAT A RECORD REPRESENTATION CLAUSE " &
"CAN BE GIVEN FOR A DERIVED RECORD TYPE EVEN " &
"IF THE REPRESENTATION IS INHERITED FROM " &
"THE PARENT, AND THAT THE REPRESENTATION " &
"CLAUSE FOR THE DERIVED TYPE OVERRIDES THAT " &
"OF THE PARENT TYPE");
 
IF DERIVED_TYPE'SIZE = IDENT_INT (PARENT_TYPE'SIZE) THEN
FAILED ("DERIVED_TYPE'SIZE WAS INHERITED FROM " &
"PARENT_TYPE");
END IF;
 
REC := (12, 'T', TRUE, RED);
 
IF (REC.I /= 12) OR (REC.C /= 'T') OR
(NOT REC.B) OR (REC.E /= RED) THEN
FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " &
"INCORRECT");
END IF;
 
IF REC.I'POSITION = P_REC.I'POSITION OR
REC.C'POSITION = P_REC.C'POSITION OR
REC.B'POSITION = P_REC.B'POSITION OR
REC.E'POSITION = P_REC.E'POSITION THEN
FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " &
"INHERITED FROM PARENT_TYPE");
END IF;
 
IF REC.I'FIRST_BIT = P_REC.I'FIRST_BIT OR
REC.C'FIRST_BIT = P_REC.C'FIRST_BIT OR
REC.B'FIRST_BIT = P_REC.B'FIRST_BIT OR
REC.E'FIRST_BIT = P_REC.E'FIRST_BIT THEN
FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
"INHERITED FROM PARENT_TYPE");
END IF;
 
IF REC.I'LAST_BIT = P_REC.I'LAST_BIT OR
REC.C'LAST_BIT = P_REC.C'LAST_BIT OR
REC.B'LAST_BIT = P_REC.B'LAST_BIT OR
REC.E'LAST_BIT = P_REC.E'LAST_BIT THEN
FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " &
"INHERITED FROM PARENT_TYPE");
END IF;
 
RESULT;
 
END CD1C04E;
/cd2a22j.ada
0,0 → 1,125
-- CD2A22J.ADA
 
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN
-- ENUMERATION TYPE, THEN SUCH A TYPE OF THE SMALLEST APPROPRIATE
-- UNSIGNED SIZE CAN BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC
-- PROCEDURE.
 
-- HISTORY:
-- JET 08/13/87 CREATED ORIGINAL TEST.
-- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED
-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON
-- REPRESENTATION CLAUSE.
-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING.
 
WITH REPORT; USE REPORT;
WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'.
PROCEDURE CD2A22J IS
 
TYPE BASIC_ENUM IS (ZERO, ONE, TWO);
BASIC_SIZE : CONSTANT := 2;
 
FOR BASIC_ENUM'SIZE USE BASIC_SIZE;
 
BEGIN
TEST ("CD2A22J", "CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN " &
"FOR AN ENUMERATION TYPE, THEN SUCH A TYPE OF " &
"THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE " &
"PASSED AS AN ACTUAL PARAMETER TO A GENERIC " &
"PROCEDURE");
 
DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE.
 
GENERIC
TYPE GPARM IS (<>);
PROCEDURE GENPROC (C0, C1, C2: GPARM);
 
PROCEDURE GENPROC (C0, C1, C2: GPARM) IS
 
SUBTYPE CHECK_TYPE IS GPARM;
 
FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN CH;
ELSE
RETURN C1;
END IF;
END IDENT;
 
PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE);
 
BEGIN -- GENPROC.
CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE");
 
IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE");
END IF;
 
IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN
FAILED ("INCORRECT VALUE FOR C0'SIZE");
END IF;
 
IF NOT ((C0 < IDENT (C1)) AND
(IDENT (C2) > IDENT (C1)) AND
(C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN
FAILED ("INCORRECT RESULTS FOR RELATIONAL " &
"OPERATORS");
END IF;
 
IF CHECK_TYPE'FIRST /= IDENT (C0) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST");
END IF;
 
IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR
CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR
CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS");
END IF;
 
IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR
CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC");
END IF;
 
IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR
CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR
CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN
FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE");
END IF;
 
END GENPROC;
 
PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM);
 
BEGIN
 
NEWPROC (ZERO, ONE, TWO);
 
END;
 
RESULT;
END CD2A22J;
/cd5014y.ada
0,0 → 1,74
-- CD5014Y.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART
-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL
-- PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART
-- OF THE SPECIFICATION.
 
-- HISTORY:
-- BCB 10/08/87 CREATED ORIGINAL TEST.
-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'.
 
WITH SYSTEM; USE SYSTEM;
WITH SPPRT13; USE SPPRT13;
WITH REPORT; USE REPORT;
 
PROCEDURE CD5014Y IS
 
BEGIN
 
TEST ("CD5014Y", " AN ADDRESS CLAUSE CAN BE GIVEN " &
"IN THE VISIBLE PART OF A GENERIC PACKAGE " &
"SPECIFICATION FOR A VARIABLE OF A FORMAL " &
"PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED " &
"IN THE VISIBLE PART OF THE SPECIFICATION");
 
DECLARE
 
GENERIC
TYPE FORM_PRIVATE_TYPE IS PRIVATE;
PACKAGE PKG IS
FORM_PRIVATE_OBJ1 : FORM_PRIVATE_TYPE;
FOR FORM_PRIVATE_OBJ1 USE
AT VARIABLE_ADDRESS;
END PKG;
 
PACKAGE BODY PKG IS
BEGIN
IF FORM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN
FAILED ("INCORRECT ADDRESS FOR FORMAL PRIVATE " &
"VARIABLE");
END IF;
END PKG;
 
PACKAGE PACK IS NEW PKG(FORM_PRIVATE_TYPE => INTEGER);
 
BEGIN
NULL;
END;
 
RESULT;
END CD5014Y;
/cd7101g.tst
0,0 → 1,70
-- CD7101G.TST
 
-- 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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM AND
-- A PREDEFINED INTEGER TYPE I OTHER THAN INTEGER, SHORT_INTEGER,
-- AND LONG_INTEGER, I'FIRST >= MIN_INT AND I'LAST <= MAX_INT.
 
-- APPLICABILITY CRITERIA:
-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT HAVE
-- A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER,
-- AND LONG_INTEGER.
 
-- IF NO SUCH TYPE EXISTS, THEN THE DECLARATION OF TEST_VAR
-- MUST BE REJECTED.
 
-- HISTORY:
-- JET 09/10/87 CREATED ORIGINAL TEST.
 
-- $NAME IS THE NAME OF A PREDEFINED INTEGER TYPE OTHER THAN
-- INTEGER, SHORT_INTEGER, AND LONG_INTEGER, IF ANY SUCH TYPE
-- EXISTS.
 
WITH SYSTEM;
WITH REPORT; USE REPORT;
 
PROCEDURE CD7101G IS
 
TEST_VAR : $NAME := 0; -- N/A => ERROR.
 
BEGIN
 
TEST ("CD7101G", "CHECK THAT FOR MIN_INT AND MAX_INT IN " &
"PACKAGE SYSTEM AND A PREDEFINED INTEGER " &
"TYPE I OTHER THAN INTEGER, SHORT_INTEGER, " &
"AND LONG_INTEGER, I'FIRST >= MIN_INT AND " &
"I'LAST <= MAX_INT");
 
IF $NAME'POS ($NAME'FIRST) < SYSTEM.MIN_INT THEN
FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT");
END IF;
 
IF $NAME'POS ($NAME'LAST) > SYSTEM.MAX_INT THEN
FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT");
END IF;
 
RESULT;
 
END CD7101G;
/cd300051.c
0,0 → 1,57
/*
-- CD30051.C
--
-- 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.
--*
--
-- FUNCTION NAME: _cd3005_1
--
-- FUNCTION DESCRIPTION:
-- This C function returns the sum of its parameter and 1 through
-- the function name. The parameter is unchanged.
--
-- INPUTS:
-- This function requires that one parameter, of type int, be passed
-- to it.
--
-- PROCESSING:
-- The function will calculate the sum of its parameter and 1
-- and return this value as the function result through the function
-- name.
--
-- OUTPUTS:
-- The sum of the parameter and 1 is returned through function name.
--
-- CHANGE HISTORY:
-- 12 Oct 95 SAIC Initial prerelease version.
-- 14 Feb 97 PWB.CTA Created this file from code appearing in
-- CD30005.A (as comments).
--!
*/
int _cd30005_1( Value )
{
/* int Value */
 
return Value + 1;
}
cd300051.c Property changes : Added: svn:eol-style ## -0,0 +1 ## +native \ No newline at end of property Added: svn:keywords ## -0,0 +1 ## +Id \ No newline at end of property Index: cd5011a.ada =================================================================== --- cd5011a.ada (nonexistent) +++ cd5011a.ada (revision 338) @@ -0,0 +1,87 @@ +-- CD5011A.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN +-- ENUMERATION TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + +-- HISTORY: +-- PWB 08/06/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; +PROCEDURE CD5011A IS + + TYPE ENUM IS (RED, BLUE, 'R', 'B'); + + PROCEDURE MIX IS + HUE : ENUM := RED; + FOR HUE USE + AT SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + HUE := BLUE; + END IF; + IF HUE /= BLUE THEN + FAILED ("WRONG VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + END MIX; + + FUNCTION FIX RETURN BOOLEAN IS + LETTER : ENUM := 'R'; + FOR LETTER USE AT + SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + LETTER := 'B'; + END IF; + IF LETTER /= ENUM'LAST THEN + FAILED ("WRONG VALUE FOR VARIABLE IN FUNCTION"); + END IF; + IF LETTER'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN FUNCTION"); + END IF; + RETURN EQUAL(3,3); + END FIX; + +BEGIN + + TEST ("CD5011A", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ENUMERATION " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM."); + + IF NOT FIX THEN + FAILED ("FUNCTION FIX YIELDS WRONG VALUE"); + END IF; + + MIX; + RESULT; + +END CD5011A; Index: cd5003b.ada =================================================================== --- cd5003b.ada (nonexistent) +++ cd5003b.ada (revision 338) @@ -0,0 +1,77 @@ +-- CD5003B.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 NAMING 'SYSTEM' NEED NOT BE GIVEN FOR +-- A PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH' +-- CLAUSE IS GIVEN FOR THE PROCEDURE SPECIFICATION. + +-- HISTORY: +-- VCL 09/04/87 CREATED ORIGINAL TEST. +-- RJW 10/13/88 INITIALIZED THE VARIABLE "CHECK_VAR". +-- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY +-- CRITERIA AND N/A ERROR MESSAGES. + +WITH SYSTEM; +PROCEDURE CD5003B; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +PROCEDURE CD5003B IS + TYPE ENUM IS (A0, A1, A2, A3, A4, A5); + + TEST_VAR : ENUM := A0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_ENUM (P : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN A0; + END IF; + END IDENT_ENUM; + +BEGIN + TEST ("CD5003B", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " & + "NEED NOT BE GIVEN FOR A PROCEDURE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE PROCEDURE " & + "SPECIFICATION"); + + TEST_VAR := IDENT_ENUM (A3); + + IF TEST_VAR /= A3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; +END CD5003B; Index: cd5011c.ada =================================================================== --- cd5011c.ada (nonexistent) +++ cd5011c.ada (revision 338) @@ -0,0 +1,69 @@ +-- CD5011C.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF +-- AN INTEGER TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY. + +-- HISTORY: +-- JET 09/11/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011C IS + + PACKAGE CD5011C_PACKAGE IS + END CD5011C_PACKAGE; + + PACKAGE BODY CD5011C_PACKAGE IS + + INT : INTEGER := 0; + FOR INT USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST ("CD5011C", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN INTEGER " & + "TYPE IN THE DECLARATIVE PART OF A " & + "PACKAGE BODY"); + + IF EQUAL (3, 3) THEN + INT := 5; + END IF; + IF INT /= IDENT_INT (5) THEN + FAILED ("WRONG VALUE FOR VARIABLE IN PACKAGE"); + END IF; + IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE"); + END IF; + END; + +BEGIN + + RESULT; + +END CD5011C; Index: cd4051a.ada =================================================================== --- cd4051a.ada (nonexistent) +++ cd4051a.ada (revision 338) @@ -0,0 +1,92 @@ +-- CD4051A.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR +-- DERIVED TYPES WHOSE PARENT TYPES ARE RECORD TYPES WITHOUT +-- DISCRIMINANTS. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- RJW 08/25/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD4051A IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + INT_COMP AT 0 + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + +BEGIN + TEST ("CD4051A", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITHOUT DISCRIMINANTS"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; +END CD4051A; Index: cd5003d.ada =================================================================== --- cd5003d.ada (nonexistent) +++ cd5003d.ada (revision 338) @@ -0,0 +1,88 @@ +-- CD5003D.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS +-- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING +-- THE PROCEDURE SPECIFICATION. + +-- HISTORY: +-- VCL 09/08/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +PACKAGE CD5003D_PACK2 IS + PROCEDURE CD5003D_PROC2; +END CD5003D_PACK2; + +WITH SYSTEM; +PACKAGE BODY CD5003D_PACK2 IS + PROCEDURE CD5003D_PROC2 IS SEPARATE; +END CD5003D_PACK2; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +SEPARATE (CD5003D_PACK2) +PROCEDURE CD5003D_PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD := 0.0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIXD; +BEGIN + TEST ("CD5003D", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A PROCEDURE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE PROCEDURE SPECIFICATION"); + + TEST_VAR := IDENT_FIXD (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; +END CD5003D_PROC2; + +WITH CD5003D_PACK2; USE CD5003D_PACK2; +PROCEDURE CD5003D IS +BEGIN + CD5003D_PROC2; +END CD5003D; Index: cd5011e.ada =================================================================== --- cd5011e.ada (nonexistent) +++ cd5011e.ada (revision 338) @@ -0,0 +1,70 @@ +-- CD5011E.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A +-- FLOATING POINT TYPE IN THE DECLARATIVE PART OF A BLOCK +-- STATEMENT. + +-- HISTORY: +-- JET 09/11/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011E IS + +BEGIN + + TEST ("CD5011E", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A FLOATING POINT " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + FP : FLOAT := 3.0; + FOR FP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + FP := 2.0; + END IF; + + IF FP /= 2.0 THEN + FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK"); + END IF; + + IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK"); + END IF; + + END; + + RESULT; + +END CD5011E; Index: cd4051c.ada =================================================================== --- cd4051c.ada (nonexistent) +++ cd4051c.ada (revision 338) @@ -0,0 +1,108 @@ +-- CD4051C.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR +-- A DERIVED TYPE WHOSE PARENT TYPE IS A RECORD WITH A +-- DISCRIMINANT. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- RJW 08/25/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD4051C IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0..BOOLEAN'SIZE - 1; + INT_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 2*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE (TRUE) := (TRUE, 1, 'A'); + +BEGIN + TEST ("CD4051C", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITH DISCRIMINANTS"); + + IF CHECK_RECORD.DISC'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'LAST_BIT /= BOOLEAN'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF DISC"); + END IF; + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= + IDENT_INT (INTEGER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (2 * UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; +END CD4051C; Index: cd5003f.ada =================================================================== --- cd5003f.ada (nonexistent) +++ cd5003f.ada (revision 338) @@ -0,0 +1,91 @@ +-- CD5003F.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A GENERIC PACKAGE BODY CONTAINING AN ADDRESS CLAUSE +-- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE GENERIC PACKAGE +-- SPECIFICATION. + +-- HISTORY: +-- VCL 09/09/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +WITH SYSTEM; +GENERIC +PACKAGE CD5003F_PACK2 IS + PROCEDURE REQUIRE_BODY; +END CD5003F_PACK2; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CD5003F_PACK2 IS + TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER; + + TEST_VAR : ATYPE := (OTHERS => 0); + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN (OTHERS => 0); + END IF; + END IDENT; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN + TEST ("CD5003F", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A GENERIC PACKAGE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE GENERIC " & + "PACKAGE SPECIFICATION"); + + TEST_VAR := IDENT (ATYPE'(OTHERS => 3)); + + IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; +END CD5003F_PACK2; + +WITH CD5003F_PACK2; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CD5003F IS + PACKAGE CD5003F_PACK3 IS NEW CD5003F_PACK2; +BEGIN + RESULT; +END CD5003F; Index: cd5011g.ada =================================================================== --- cd5011g.ada (nonexistent) +++ cd5011g.ada (revision 338) @@ -0,0 +1,72 @@ +-- CD5011G.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A +-- FIXED POINT TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + +-- HISTORY: +-- JET 09/11/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011G IS + + TYPE FIX_TYPE IS DELTA 0.125 RANGE 0.0 .. 10.0; + + PROCEDURE CD5011G_PROC IS + + FP : FIX_TYPE := 2.0; + FOR FP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + FP := 3.0; + END IF; + + IF FP /= 3.0 THEN + FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + + IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + + END CD5011G_PROC; + +BEGIN + TEST ("CD5011G", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A FIXED POINT " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM"); + + CD5011G_PROC; + + RESULT; + +END CD5011G; Index: cd3015f.ada =================================================================== --- cd3015f.ada (nonexistent) +++ cd3015f.ada (revision 338) @@ -0,0 +1,93 @@ +-- CD3015F.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED +-- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A GENERIC +-- PACKAGE FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE +-- NO ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + +-- HISTORY +-- DHH 10/01/87 CREATED ORIGINAL TEST +-- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED +-- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR +-- REPRESENTATION CLAUSE. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3015F IS + +BEGIN + + TEST ("CD3015F", "CHECK THAT AN " & + "ENUMERATION REPRESENTATION CLAUSE FOR A " & + "DERIVED TYPE CAN BE GIVEN IN THE VISIBLE OR " & + "PRIVATE PART OF A GENERIC PACKAGE FOR A " & + "DERIVED TYPE DECLARED IN THE VISIBLE PART, " & + "WHERE NO ENUMERATION CLAUSE HAS BEEN GIVEN " & + "FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + PRIVATE + FOR NEWHUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE INT_HUE IS RANGE 8 .. 13; + FOR INT_HUE'SIZE USE HUE'SIZE; + + TYPE INT_NEW IS RANGE 8 .. 13; + FOR INT_NEW'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE); + PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + BEGIN + CHECK_HUE (RED, 8, "HUE"); + CHECK_HUE ('R', 11, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; +END CD3015F; Index: cdb0a02.a =================================================================== --- cdb0a02.a (nonexistent) +++ cdb0a02.a (revision 338) @@ -0,0 +1,329 @@ +-- CDB0A02.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 several access types can share the same pool. +-- +-- Check that any exception propagated by Allocate is +-- propagated by the allocator. +-- +-- Check that for an access type S, S'Max_Size_In_Storage_Elements +-- denotes the maximum values for Size_In_Storage_Elements that will +-- be requested via Allocate. +-- +-- TEST DESCRIPTION: +-- After checking correct operation of the tree packages, the limits of +-- the storage pools (first the shared user defined storage pool, then +-- the system storage pool) are intentionally exceeded. The test checks +-- that the correct exception is raised. +-- +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- FDB0A00.A (foundation code) +-- CDB0A02.A +-- +-- +-- CHANGE HISTORY: +-- 10 AUG 95 SAIC Initial version +-- 07 MAY 96 SAIC Disambiguated for 2.1 +-- 13 FEB 97 PWB.CTA Reduced minimum allowable +-- Max_Size_In_Storage_Units, for implementations +-- with larger storage units +-- 25 JAN 01 RLB Removed dubious checks on Max_Size_In_Storage_Units; +-- tightened important one. + +--! + +---------------------------------------------------------- FDB0A00.Pool2 + +package FDB0A00.Pool2 is + Pond : Stack_Heap( 5_000 ); +end FDB0A00.Pool2; + +---------------------------------------------------------------- CDB0A02_2 + +with FDB0A00.Pool2; +package CDB0A02_2 is + + type Small_Cell; + type Small_Tree is access Small_Cell; + + for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- first usage + + type Small_Cell is record + Data: Character; + Left,Right : Small_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out Small_Tree ); + + procedure Traverse( The_Tree : Small_Tree ); + + procedure Defoliate( The_Tree : in out Small_Tree ); + + procedure TC_Exceed_Pool; + + Pool_Max_Elements : constant := 6000; + -- to guarantee overflow in TC_Exceed_Pool + +end CDB0A02_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +with Report; +with Unchecked_Deallocation; +package body CDB0A02_2 is + procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is + begin + if On_Tree = null then + On_Tree := new Small_Cell'(Item,null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : Small_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out Small_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + + procedure TC_Exceed_Pool is + Wild_Branch : Small_Tree; + begin + for Ever in 1..Pool_Max_Elements loop + Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch); + TCTouch.Validate("A","Allocating element for overflow"); + end loop; + Report.Failed(" Pool_Overflow not raised on exceeding user pool size"); + exception + when FDB0A00.Pool_Overflow => null; -- anticipated case + when others => + Report.Failed("wrong exception raised in user Exceed_Pool"); + end TC_Exceed_Pool; + +end CDB0A02_2; + +---------------------------------------------------------------- CDB0A02_3 + +-- This package is essentially identical to CDB0A02_2, except that the size +-- of a cell is significantly larger. This is used to check that different +-- access types may share a single pool + +with FDB0A00.Pool2; +package CDB0A02_3 is + + type Large_Cell; + type Large_Tree is access Large_Cell; + + for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- second usage + + type Large_Cell is record + Data: Character; + Extra_Data : String(1..2); + Left,Right : Large_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out Large_Tree ); + + procedure Traverse( The_Tree : Large_Tree ); + + procedure Defoliate( The_Tree : in out Large_Tree ); + +end CDB0A02_3; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +with Unchecked_Deallocation; +package body CDB0A02_3 is + procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is + begin + if On_Tree = null then + On_Tree := new Large_Cell'(Item,(Item,Item),null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : Large_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out Large_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + +end CDB0A02_3; + +------------------------------------------------------------------ CDB0A02 + +with Report; +with TCTouch; +with System.Storage_Elements; +with CDB0A02_2; +with CDB0A02_3; +with FDB0A00; + +procedure CDB0A02 is + + Banyan : CDB0A02_2.Small_Tree; + Torrey : CDB0A02_3.Large_Tree; + + use type CDB0A02_2.Small_Tree; + use type CDB0A02_3.Large_Tree; + + Countess1 : constant String := "Ada "; + Countess2 : constant String := "Augusta "; + Countess3 : constant String := "Lovelace"; + Cenosstu : constant String := " AALaaacdeeglostuuv"; + Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA" + & "AAAAAAAAAAAAAAAAAAAA"; + Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD"; + +begin -- Main test procedure. + + Report.Test ("CDB0A02", "Check that several access types can share " & + "the same pool. Check that any exception " & + "propagated by Allocate is propagated by the " & + "allocator. Check that for an access type S, " & + "S'Max_Size_In_Storage_Elements denotes the " & + "maximum values for Size_In_Storage_Elements " & + "that will be requested via Allocate" ); + + -- Check that access types can share the same pool. + + for Count in Countess1'Range loop + CDB0A02_2.Insert( Countess1(Count), Banyan ); + end loop; + + for Count in Countess1'Range loop + CDB0A02_3.Insert( Countess1(Count), Torrey ); + end loop; + + for Count in Countess2'Range loop + CDB0A02_2.Insert( Countess2(Count), Banyan ); + end loop; + + for Count in Countess2'Range loop + CDB0A02_3.Insert( Countess2(Count), Torrey ); + end loop; + + for Count in Countess3'Range loop + CDB0A02_2.Insert( Countess3(Count), Banyan ); + end loop; + + for Count in Countess3'Range loop + CDB0A02_3.Insert( Countess3(Count), Torrey ); + end loop; + + TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" ); + + + CDB0A02_2.Traverse(Banyan); + TCTouch.Validate(Cenosstu, "Traversal of Banyan" ); + + CDB0A02_3.Traverse(Torrey); + TCTouch.Validate(Cenosstu, "Traversal of Torrey" ); + + CDB0A02_2.Defoliate(Banyan); + TCTouch.Validate(Deallocation, "Deforestation of Banyan" ); + TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null"); + + CDB0A02_3.Defoliate(Torrey); + TCTouch.Validate(Deallocation, "Deforestation of Torrey" ); + TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null"); + + -- Check that for an access type S, S'Max_Size_In_Storage_Elements + -- denotes the maximum values for Size_In_Storage_Elements that will + -- be requested via Allocate. (Of course, all we can do is check that + -- whatever was requested of Allocate did not exceed the values of the + -- attributes.) + + TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 .. + System.Storage_Elements.Storage_Count'Max ( + CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements, + CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements), + "An object of excessive size was allocated. Size: " + & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request)); + + -- Check that an exception raised in Allocate is propagated by the allocator. + + CDB0A02_2.TC_Exceed_Pool; + + Report.Result; + +end CDB0A02; Index: cd1c06a.tst =================================================================== --- cd1c06a.tst (nonexistent) +++ cd1c06a.tst (revision 338) @@ -0,0 +1,100 @@ +-- CD1C06A.TST + +-- 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 EXPRESSION IN A TASK STORAGE SIZE CLAUSE +-- IS NOT EVALUATED AGAIN WHEN A DERIVED TYPE INHERITS THE +-- STORAGE SIZE OF THE PARENT. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- JET 09/21/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED +-- EXTENSION FROM '.DEP' TO '.TST'. + +WITH REPORT; USE REPORT; +PROCEDURE CD1C06A IS + + I : INTEGER := 0; + + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + FUNCTION COUNT_SIZE RETURN INTEGER IS + BEGIN + I := I + 1; + RETURN SPECIFIED_SIZE * I; + END; + +BEGIN + + TEST("CD1C06A", "CHECK THAT THE EXPRESSION IN A TASK STORAGE " & + "SIZE CLAUSE IS NOT EVALUATED AGAIN WHEN A " & + "DERIVED TYPE INHERITS THE STORAGE SIZE OF " & + "THE PARENT"); + + DECLARE + + TASK TYPE PARENT IS + ENTRY E; + END PARENT; + + FOR PARENT'STORAGE_SIZE USE COUNT_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT; + + TASK BODY PARENT IS + BEGIN + ACCEPT E DO + COMMENT ("ENTRY E ACCEPTED"); + END E; + END PARENT; + + BEGIN + IF PARENT'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN" & INTEGER'IMAGE (SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT'STORAGE_SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN" & INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + IF I > IDENT_INT (1) THEN + FAILED ("THE EXPRESSION FOR THE STORAGE SIZE " & + "SPECIFICATION WAS EVALUATED MORE THAN ONCE"); + END IF; + + END; + + RESULT; + +END CD1C06A; Index: cd5003h.ada =================================================================== --- cd5003h.ada (nonexistent) +++ cd5003h.ada (revision 338) @@ -0,0 +1,89 @@ +-- CD5003H.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A GENERIC PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS +-- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT +-- CONTAINING THE GENERIC PACKAGE SPECIFICATION. + +-- HISTORY: +-- VCL 09/09/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +WITH SYSTEM; +PACKAGE CD5003H_PACK3 IS + + PROCEDURE REQUIRE_BODY; + + GENERIC + PACKAGE PACK4 IS END PACK4; +END CD5003H_PACK3; + +PACKAGE BODY CD5003H_PACK3 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY PACK4 IS SEPARATE; +END CD5003H_PACK3; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +SEPARATE (CD5003H_PACK3) +PACKAGE BODY PACK4 IS + TEST_VAR : INTEGER := 0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; +BEGIN + TEST ("CD5003H", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A GENERIC PACKAGE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS " & + "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PACKAGE SPECIFICATION."); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; +END PACK4; + +WITH CD5003H_PACK3; USE CD5003H_PACK3; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CD5003H IS + PACKAGE PACK5 IS NEW PACK4; +BEGIN + RESULT; +END CD5003H; Index: cd5011i.ada =================================================================== --- cd5011i.ada (nonexistent) +++ cd5011i.ada (revision 338) @@ -0,0 +1,74 @@ +-- CD5011I.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF +-- AN ARRAY TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY. + +-- HISTORY: +-- JET 09/11/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011I IS + + PACKAGE CD5011I_PACKAGE IS + END CD5011I_PACKAGE; + + PACKAGE BODY CD5011I_PACKAGE IS + + INT : ARRAY (1 .. 10) OF INTEGER; + FOR INT USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST ("CD5011I", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ARRAY " & + "TYPE IN THE DECLARATIVE PART OF A " & + "PACKAGE BODY"); + + FOR I IN INT'RANGE LOOP + INT (I) := IDENT_INT (I); + END LOOP; + + FOR I IN INT'RANGE LOOP + IF INT (I) /= I THEN + FAILED ("WRONG VALUE FOR ELEMENT" & + INTEGER'IMAGE (I)); + END IF; + END LOOP; + + IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE"); + END IF; + END; + +BEGIN + + RESULT; + +END CD5011I; Index: cd3015h.ada =================================================================== --- cd3015h.ada (nonexistent) +++ cd3015h.ada (revision 338) @@ -0,0 +1,86 @@ +-- CD3015H.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED +-- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE +-- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE AN +-- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + +-- HISTORY +-- DHH 10/01/87 CREATED ORIGINAL TEST +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3015H IS + +BEGIN + + TEST ("CD3015H", "CHECK THAT AN ENUMERATION " & + "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " & + "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " & + "VISIBLE PART, WHERE AN ENUMERATION CLAUSE HAS " & + "BEEN GIVEN FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE + (RED => 8, BLUE => 9, YELLOW => 10); + + PRIVATE + + FOR NEWHUE USE (RED => 6, BLUE => 11, YELLOW => 18); + + TYPE INT1 IS RANGE 8 .. 10; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 6 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (RED, 8, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END PACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015H; Index: cd5011k.ada =================================================================== --- cd5011k.ada (nonexistent) +++ cd5011k.ada (revision 338) @@ -0,0 +1,75 @@ +-- CD5011K.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A +-- RECORD TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT. + +-- HISTORY: +-- JET 09/15/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011K IS + +BEGIN + + TEST ("CD5011K", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A RECORD " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + TYPE REC_TYPE IS RECORD + I : INTEGER := 12; + B : BOOLEAN := TRUE; + END RECORD; + + REC : REC_TYPE; + FOR REC USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + REC.I := 17; + REC.B := FALSE; + END IF; + + IF REC.I /= 17 OR REC.B THEN + FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK"); + END IF; + + IF REC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK"); + END IF; + + END; + + RESULT; + +END CD5011K; Index: cd5011m.ada =================================================================== --- cd5011m.ada (nonexistent) +++ cd5011m.ada (revision 338) @@ -0,0 +1,72 @@ +-- CD5011M.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF +-- AN ACCESS TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + +-- HISTORY: +-- JET 09/15/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011M IS + + TYPE ACC_TYPE IS ACCESS STRING; + + PROCEDURE CD5011M_PROC IS + + ACC : ACC_TYPE := NEW STRING'("THE QUICK BROWN FOX"); + FOR ACC USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + ACC := NEW STRING'("THE LAZY DOG"); + END IF; + + IF ACC.ALL /= IDENT_STR ("THE LAZY DOG") THEN + FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + + IF ACC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + + END CD5011M_PROC; + +BEGIN + TEST ("CD5011M", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ACCESS " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM"); + + CD5011M_PROC; + + RESULT; + +END CD5011M; Index: cdd2a03.a =================================================================== --- cdd2a03.a (nonexistent) +++ cdd2a03.a (revision 338) @@ -0,0 +1,325 @@ +-- CDD2A03.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the default Read and Write attributes for a limited type +-- extension are created from the parent type's attribute (which may be +-- user-defined) and those for the extension components, if the extension +-- components are non-limited or have user-defined attributes. Check that +-- such limited type extension attributes are callable (Defect Report +-- 8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence +-- of 13.13.2(9/1) and 13.13.2(36/1)). +-- +-- CHANGE HISTORY: +-- 1 AUG 2001 PHL Initial version. +-- 3 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Streams; +use Ada.Streams; +with FDD2A00; +use FDD2A00; +with Report; +use Report; +procedure CDD2A03 is + + Input_Output_Error : exception; + + type Int is range 1 .. 1000; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Lim is limited + record + C : Int; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim); + function Input (Stream : access Root_Stream_Type'Class) return Lim; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim); + + for Lim'Read use Read; + for Lim'Write use Write; + for Lim'Input use Input; + for Lim'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is tagged limited + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Lim) is + begin + Integer'Read (Stream, Integer (Item.C)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Write (Stream, Integer (Item.C)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is + Result : Lim; + begin + Result.C := Int (Integer'Input (Stream)); + return Result; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Output (Stream, Integer (Item.C)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + X : Parent (1, 1, True); + begin + raise Input_Output_Error; + return X; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + raise Input_Output_Error; + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Lim_Ops is new Counting_Stream_Ops (T => Lim, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim) + renames Lim_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Lim + renames Lim_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + + type Derived1 is new Parent with + record + C3 : Int; + end record; + + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False) with + record + C3 : Lim; + end record; + +begin + Test ("CDD2A03", + "Check that the default Read and Write attributes for a limited " & + "type extension are created from the parent type's " & + "attribute (which may be user-defined) and those for the " & + "extension components, if the extension components are " & + "non-limited or have user-defined attributes; check that such " & + "limited type extension attributes are callable"); + + Test1: + declare + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + X1.C3 := Int (Ident_Int (99)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call parent type's Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + end Test1; + + Test2: + declare + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + X1.C3.C := Int (Ident_Int (666)); + + Derived2'Write (S'Access, X1); + if Lim_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 2"); + end if; + + Derived2'Read (S'Access, X2); + if Lim_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 2"); + end if; + end Test2; + + Result; +end CDD2A03; Index: cd5011q.ada =================================================================== --- cd5011q.ada (nonexistent) +++ cd5011q.ada (revision 338) @@ -0,0 +1,91 @@ +-- CD5011Q.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A +-- PRIVATE TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT. + +-- HISTORY: +-- JET 09/15/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011Q IS + + PACKAGE P IS + TYPE PRIV_TYPE IS PRIVATE; + FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE; + FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN; + PRIVATE + TYPE PRIV_TYPE IS NEW INTEGER; + END P; + + PACKAGE BODY P IS + + FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE IS + BEGIN + RETURN PRIV_TYPE(I); + END; + + FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN (P = PRIV_TYPE(I)); + END; + + END P; + + USE P; + +BEGIN + + TEST ("CD5011Q", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A PRIVATE " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + PRIV : PRIV_TYPE := INT_TO_PRIV (12); + FOR PRIV USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + PRIV := INT_TO_PRIV (17); + + IF NOT EQUAL (PRIV, IDENT_INT (17)) THEN + FAILED ("INCORRECT VALUE FOR VARIABLE OF PRIVATE TYPE"); + END IF; + + IF PRIV'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE OF " & + "PRIVATE TYPE"); + END IF; + END; + + RESULT; + +END CD5011Q; Index: cd2a23a.ada =================================================================== --- cd2a23a.ada (nonexistent) +++ cd2a23a.ada (revision 338) @@ -0,0 +1,221 @@ +-- CD2A23A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION +-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, +-- THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT AFFECTED +-- BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 07/28/87 CREATED ORIGINAL TEST. +-- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON +-- REPRESENTATION CLAUSE. +-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD2A23A IS + + BASIC_SIZE : CONSTANT := INTEGER'SIZE/2; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND + (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR + CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR + CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1"); + END IF; + + IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR + CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + +BEGIN + TEST ("CD2A23A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " & + "AN ENUMERATION REPRESENTATION CLAUSE ARE " & + "GIVEN FOR AN ENUMERATION TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (TWO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3"); + END IF; + + IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4"); + END IF; + + IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4"); + END IF; + + IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4"); + END IF; + + + RESULT; + +END CD2A23A; Index: cd2a51a.ada =================================================================== --- cd2a51a.ada (nonexistent) +++ cd2a51a.ada (revision 338) @@ -0,0 +1,193 @@ +-- CD2A51A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR A +-- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE +-- SO THAT IT IS NOT A POWER OF TWO. +-- WMC 03/31/92 ELIMINATED TEST REDUNDANCIES. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A51A IS + + BASIC_SIZE : CONSTANT := 9; + + TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + TYPE CHECK_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + CNEG1 : CHECK_TYPE := -3.5; + CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + CPOS2 : CHECK_TYPE := 3.5; + CZERO : CHECK_TYPE; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := + (-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5); + + TYPE REC_TYPE IS RECORD + COMPN1 : CHECK_TYPE := -3.5; + COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + COMPP2 : CHECK_TYPE := 3.5; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE; + N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE; + CZOUT : OUT CHECK_TYPE) IS + BEGIN + + IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR + IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "UNARY ADDING OPERATORS - 1"); + END IF; + + IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "ABSOLUTE VALUE OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + +BEGIN + TEST ("CD2A51A", "CHECK THAT WHEN A SIZE SPECICFICATION IS " & + "GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF IDENT (CZERO) /= 0.0 THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF CHECK_TYPE'LAST < IDENT (3.9375) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF CHECK_TYPE'AFT /= BASIC_TYPE'AFT THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'AFT"); + END IF; + + IF CNEG1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR + CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2"); + END IF; + + IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2"); + END IF; + + IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR + CNEG2 IN -0.25 .. 0.0 OR + IDENT (CNEG2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3"); + END IF; + + IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR + CHARRAY (1) IN -0.25 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP1'SIZE"); + END IF; + + IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN + -2.875 .. -2.8125 OR + CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4"); + END IF; + + IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN + -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR + CHREC.COMPN2 IN -0.25 .. 0.0 OR + IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RESULT; + +END CD2A51A; Index: cd5011s.ada =================================================================== --- cd5011s.ada (nonexistent) +++ cd5011s.ada (revision 338) @@ -0,0 +1,89 @@ +-- CD5011S.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A +-- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + +-- HISTORY: +-- JET 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; + +PROCEDURE CD5011S IS + + PACKAGE P IS + TYPE LIMP_TYPE IS LIMITED PRIVATE; + PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE); + PRIVATE + TYPE LIMP_TYPE IS ARRAY (1 .. 10) OF INTEGER; + END P; + + PACKAGE BODY P IS + PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE) IS + BEGIN + FOR I IN LIMP'RANGE LOOP + LIMP (I) := IDENT_INT (I); + END LOOP; + + FOR I IN LIMP'RANGE LOOP + IF LIMP (I) /= I THEN + FAILED ("INCORRECT VALUE FOR ELEMENT" & + INTEGER'IMAGE (I)); + END IF; + END LOOP; + END TEST_LIMP; + END P; + + USE P; + + PROCEDURE CD5011S_PROC IS + + LIMP : LIMP_TYPE; + FOR LIMP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST_LIMP (LIMP); + + IF LIMP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE OF A LIMITED " & + "PRIVATE TYPE"); + END IF; + END; + +BEGIN + TEST ("CD5011S", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A LIMITED " & + "PRIVATE TYPE IN THE DECLARATIVE PART " & + "OF A SUBPROGRAM"); + + CD5011S_PROC; + + RESULT; + +END CD5011S; Index: cd2b16a.ada =================================================================== --- cd2b16a.ada (nonexistent) +++ cd2b16a.ada (revision 338) @@ -0,0 +1,85 @@ +-- CD2B16A.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: +-- IF A COLLECTION SIZE CLAUSE IS GIVEN FOR A PARENT ACCESS TYPE, +-- THEN THE DERIVED TYPE HAS THE SAME COLLECTION SIZE, WHETHER THE +-- DERIVED TYPE IS DECLARED BEFORE OR AFTER THE PARENT COLLECTION +-- SIZE SPECIFICATION. + +-- HISTORY: +-- DHH 09/29/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CD2B16A IS +BEGIN + TEST ("CD2B16A", "IF A COLLECTION SIZE IS GIVEN FOR A " & + "PARENT ACCESS TYPE, THEN THE DERIVED TYPE HAS " & + "THE SAME COLLECTION SIZE, WHETHER THE " & + "DERIVED TYPE IS DECLARED BEFORE OR AFTER " & + "THE PARENT COLLECTION SIZE SPECIFICATION"); + + DECLARE + + COLLECTION_SIZE : CONSTANT :=128; + TYPE V IS ARRAY(1..4) OF INTEGER; + + TYPE CELL IS + RECORD + VALUE : V; + END RECORD; + + TYPE LINK IS ACCESS CELL; + TYPE NEWLINK1 IS NEW LINK; + + FOR LINK'STORAGE_SIZE USE + COLLECTION_SIZE; + + TYPE NEWLINK2 IS NEW LINK; + + BEGIN -- ACTIVE DECLARE + + IF LINK'STORAGE_SIZE < COLLECTION_SIZE THEN + FAILED("STORAGE_SIZE SMALLER THAN STORAGE_SIZE " & + "SPECIFIED WAS ALLOCATED"); + END IF; + + IF LINK'STORAGE_SIZE /= NEWLINK1'STORAGE_SIZE THEN + FAILED("STORAGE_SIZE OF THE FIRST DERIVED TYPE" & + "IS NOT THE SAME SIZE AS THAT OF THE " & + "PARENT"); + END IF; + + IF LINK'STORAGE_SIZE /= NEWLINK2'STORAGE_SIZE THEN + FAILED("STORAGE_SIZE OF THE SECOND DERIVED TYPE" & + "IS NOT THE SAME SIZE AS THAT OF THE " & + "PARENT"); + END IF; + + END; --ACTIVE DECLARE + + RESULT; +END CD2B16A; Index: cd2a23e.ada =================================================================== --- cd2a23e.ada (nonexistent) +++ cd2a23e.ada (revision 338) @@ -0,0 +1,198 @@ +-- CD2A23E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION +-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, +-- THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL PARAMETER TO A +-- GENERIC PROCEDURE. + +-- HISTORY: +-- JET 08/18/87 CREATED ORIGINAL TEST. +-- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON +-- REPRESENTATION CLAUSE. +-- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE +-- SPECIFICATION IS OBEYED. +-- LDC 10/03/90 ADDED EXCEPTION HANDER FOR CHECK OF 'SUCC, 'PRED, +-- ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION, +-- AND EXPLICIT CONVERSION. +-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD2A23E IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 8; + + FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, TWO => 5); + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + +BEGIN + TEST ("CD2A23E", "CHECK THAT WHEN A SIZE SPECIFICATION AND AN " & + "ENUMERATION REPRESENTATION CLAUSE ARE " & + "GIVEN FOR AN ENUMERATION TYPE, " & + "THEN SUCH A TYPE CAN BE " & + "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " & + "PROCEDURE"); + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + C3 : GPARM; + + CHECKVAR : CHECK_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + + BEGIN -- GENPROC. + + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + + CHECKVAR := IDENT (C0); + + CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE"); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT(C0) < IDENT (C1)) AND + (IDENT(C2) > IDENT (C1)) AND + (IDENT(C1) <= IDENT (C1)) AND + (IDENT(C2) = IDENT (C2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (C0) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC"); + END IF; + + BEGIN + IF CHECK_TYPE'SUCC (IDENT(C2)) /= IDENT (C1) THEN + FAILED ("CONSTRAINT ERROR NOT RAISED FOR " & + "CHECK_TYPE'SUCC"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF 3 /= IDENT_INT(3) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION -1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "CHECK_TYPE'SUCC"); + END; + + BEGIN + IF CHECK_TYPE'PRED(IDENT(C0)) /= IDENT (C1) THEN + FAILED ("CONSTRAINT ERROR NOT RAISED FOR " & + "CHECK_TYPE'PRED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF 3 /= IDENT_INT(3) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION -2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "CHECK_TYPE'PRED"); + END; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE"); + END IF; + + CHECKVAR := CHECK_TYPE'VALUE ("ONE"); + C3 := GPARM(CHECKVAR); + IF C3 /= IDENT(C1) THEN + FAILED ("INCORRECT VALUE FOR CONVERSION"); + END IF; + + CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM"); + + + IF CHECK_TYPE'(C2) /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR QUALIFICATION"); + END IF; + + C3 := CHECK_TYPE'VALUE ("TWO"); + IF C3 /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR ASSIGNMENT"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + +END CD2A23E; Index: cd4041a.tst =================================================================== --- cd4041a.tst (nonexistent) +++ cd4041a.tst (revision 338) @@ -0,0 +1,92 @@ +-- CD4041A.TST + +-- 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 ALIGNMENT CLAUSE CAN BE GIVEN FOR A RECORD +-- REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 08/25/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED MOD 4 TO A MACRO VALUE AND CHANGED +-- EXTENSION FROM '.DEP' TO '.TST'. + +-- MACRO SUBSTITUTION: +-- $ALIGNMENT IS THE VALUE USED TO ALIGN A RECORD ON A BOUNDARY +-- DEFINED BY THE IMPLEMENTATION. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD4041A IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + FOR CHECK_CLAUSE USE + RECORD AT MOD $ALIGNMENT; + INT_COMP AT 0 + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + +BEGIN + TEST ("CD4041A", "CHECK THAT AN ALIGNMENT CLAUSE CAN BE " & + "GIVEN FOR A RECORD REPRESENTATION CLAUSE"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; +END CD4041A; Index: cd7101e.dep =================================================================== --- cd7101e.dep (nonexistent) +++ cd7101e.dep (revision 338) @@ -0,0 +1,62 @@ +-- CD7101E.DEP + +-- 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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM, +-- SHORT_INTEGER'FIRST >= MIN_INT AND SHORT_INTEGER'LAST <= MAX_INT. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO THOSE IMPLEMENTATIONS THAT +-- SUPPORT THE SHORT_INTEGER DATA TYPE. + +-- IF THE SHORT_INTEGER TYPE IS NOT SUPPORTED THEN THE +-- DECLARATION OF "TEST_VAR" MUST BE REJECTED. + +-- HISTORY: +-- JET 09/10/87 CREATED ORIGINAL TEST. + +WITH SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE CD7101E IS + + TEST_VAR : SHORT_INTEGER := 0; -- N/A => ERROR. + +BEGIN + + TEST ("CD7101E", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " & + "SYSTEM, SHORT_INTEGER'FIRST >= MIN_INT AND " & + "SHORT_INTEGER'LAST <= MAX_INT"); + + IF SHORT_INTEGER'POS (SHORT_INTEGER'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF SHORT_INTEGER'POS (SHORT_INTEGER'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + +END CD7101E; Index: cd1009k.tst =================================================================== --- cd1009k.tst (nonexistent) +++ cd1009k.tst (revision 338) @@ -0,0 +1,94 @@ +-- CD1009K.TST + +-- 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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE +-- VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TASK TYPE DECLARED IN +-- THE VISIBLE PART OF THE SAME PACKAGE. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- VCL 10/08/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED +-- EXTENSION FROM '.DEP' TO '.TST'. +-- TMB 02/29/96 EFFECT OF SETTING 'STORAGE_SIZE IS IMPLEMENTATION +-- DEPENDENT. +-- ONLY GUARANTEE WHEN EXAMINING 'STORAGE_SIZE IS THAT +-- IT IS NOT NEGATIVE. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009K IS +BEGIN + TEST ("CD1009K", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " & + "TASK TYPE DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TASK TYPE CHECK_TYPE_1 IS + END CHECK_TYPE_1; + + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + + TASK TYPE CHECK_TYPE_2 IS + END CHECK_TYPE_2; + + PRIVATE + FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + TASK BODY CHECK_TYPE_1 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_1; + + TASK BODY CHECK_TYPE_2 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_2; + + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < 0 THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL"); + END IF; + + IF CHECK_TYPE_2'STORAGE_SIZE < 0 THEN + FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL"); + END IF; + END; + + RESULT; +END CD1009K; Index: cd5012b.ada =================================================================== --- cd5012b.ada (nonexistent) +++ cd5012b.ada (revision 338) @@ -0,0 +1,77 @@ +-- CD5012B.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN +-- INTEGER TYPE IN THE DECLARATIVE PART OF A GENERIC PACKAGE BODY. + +-- HISTORY: +-- DHH 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; +PROCEDURE CD5012B IS + +BEGIN + + TEST ("CD5012B", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN INTEGER " & + "TYPE IN THE DECLARATIVE PART OF A " & + "GENERIC PACKAGE BODY"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + END GENPACK; + + PACKAGE BODY GENPACK IS + + INT2 : INTEGER :=2; + + FOR INT2 USE AT + SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + INT2 := 1; + END IF; + IF INT2 /= 1 THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PACKAGE BODY"); + END IF; + IF INT2'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PACKAGE BODY"); + END IF; + END GENPACK; + + PACKAGE PACK IS NEW GENPACK; + BEGIN + NULL; + END; + RESULT; +END CD5012B; Index: cd10001.a =================================================================== --- cd10001.a (nonexistent) +++ cd10001.a (revision 338) @@ -0,0 +1,300 @@ +-- CD10001.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 representation items may contain nonstatic expressions +-- in the case that each expression in the representation item is a +-- name that statically denotes a constant declared before the entity. +-- +-- +-- TEST DESCRIPTION: +-- For each of the specific items in the objective, this test checks +-- an example of each of the categories of representation specification +-- that are applicable to that objective, to wit: +-- address clause ....................... Expressions need not be static +-- alignment clause ..................... Expressions must be static +-- bit order clause ..................... Not tested +-- component size clause ................ Expressions must be static +-- enumeration representation clause .... Expressions must be static +-- external tag clause .................. Expressions must be static +-- Import, Export and Convention pragmas Not tested +-- input clause ......................... Not tested +-- output clause ........................ Not tested +-- Pack pragma .......................... Not tested +-- read clause .......................... Not tested +-- record representation clause ......... Expressions must be static +-- size clause .......................... Expressions must be static +-- small clause ......................... Expressions must be static +-- storage pool clause .................. Not tested +-- storage size clause .................. Expressions must be static +-- write clause ......................... Not tested +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute. +-- +-- For implementations not validating against Annex C: +-- if this test compiles without error messages at compilation, +-- it must bind and execute. +-- +-- PASS/FAIL CRITERIA: +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute, report PASSED, and complete normally, +-- otherwise the test FAILS +-- +-- For implementations not validating against Annex C: +-- PASSING behavior is: +-- this test executes, reports PASSED, and completes normally +-- or +-- this test executes and reports NOT_APPLICABLE +-- or +-- this test produces at least one error message at compilation, and +-- the error message is associated with one of the items marked: +-- -- N/A => ERROR. +-- +-- All other behaviors are FAILING. +-- + +-- CHANGE HISTORY: +-- 11 JUL 95 SAIC Initial version +-- 10 MAR 97 PWB.CTA Made Nonstatic_Entity nonstatic; changed +-- Tenths'Small from 1.0/32.0 to 1.0/10.0, +-- as expected by the later check; improved +-- internal documentation. +-- 16 FEB 98 EDS Modified test documentation. +-- 24 NOV 98 RLB Changed Tenths'Small to 1.0/32.0, as this is +-- necessary so that all implementations can +-- process this test. (3.5.9(21) means non-binary +-- smalls are optional.) +-- 11 MAR 99 RLB Merged versions. Most EDS changes removed (as +-- they made the test less applicable than the ACAA +-- version). +--! + +----------------------------------------------------------------- CD10001_0 + +with System; +with System.Storage_Elements; +with Impdef; +with SPPRT13; +package CD10001_0 is + + -- a few types and objects to work with. + + type Int is range -2048 .. 2047; + My_Int : Int := 1024; + + type Enumeration is (First, Second, Third, Fourth, Fifth); + + -- a few names that statically denote constants: + + Nonstatic_Entity : constant System.Address := -- Non-static + System.Storage_Elements."+" + ( SPPRT13.Variable_Address, + System.Storage_Elements.Storage_Offset'(0) ); + + Tag_String : constant String := Impdef.External_Tag_Value; -- Static + -- Check to ensure that Tag_String is static + Tag_String_Length : constant := Tag_String'Length; + + A_Reasonable_Size_Value : constant := System.Storage_Unit; -- Static + + Zero : constant := 0; -- Static + One : constant := 1; -- Static + Two : constant := 2; -- Static + Three : constant := 3; -- Static + Four : constant := 4; -- Static + Five : constant := 5; -- Static + + K : constant Int := My_Int; -- Non-Static + +-- Check that representation items containing nonstatic expressions are +-- supported in the case that the representation item is a name that +-- statically denotes a constant declared before the entity. +-- +-- address clause +-- Expression must be static - RM 13.3(12) + + Object_Address : Enumeration; + for Object_Address'Address use Nonstatic_Entity; -- N/A => ERROR. + +-- alignment clause +-- Expression must be static - RM 13.3(25) + + Object_Alignment : Enumeration; + for Object_Alignment'Alignment use One; -- N/A => ERROR. + +-- bit order clause +-- no interesting test can be specified + +-- component size clause +-- Expression must be static - RM 13.3(69) + + type Array_With_Components is array(1..10) of Enumeration; + for Array_With_Components'Component_Size + use A_Reasonable_Size_Value; -- N/A => ERROR. + +-- enumeration representation clause +-- Expressions must be static - RM 13.4(6) + + type Enumeration_1 is (First, Second, Third); + for Enumeration_1 use (First => One, Second => Two, Third => Three); + +-- external tag clause +-- Expression must be static - RM 13.3(75) + + type Some_Tagged_Type is tagged null record; + for Some_Tagged_Type'External_Tag use Tag_String; -- N/A => ERROR. + +-- Import, Export and Convention pragmas +-- no interesting test can be specified + +-- input clause +-- no interesting test can be specified + +-- output clause +-- no interesting test can be specified + +-- Pack pragma +-- no interesting test can be specified + +-- read clause +-- no interesting test can be specified + +-- record representation clause +-- Expressions must be static - RM 13.3(10) + + type Record_To_Layout is record + Bit_0 : Boolean; + Bit_1 : Boolean; + end record; + for Record_To_Layout use record -- N/A => ERROR. + Bit_0 at Zero range Zero..Zero; -- N/A => ERROR. + Bit_1 at Zero range Four..Four; -- N/A => ERROR. + end record; -- N/A => ERROR. + +-- size clause +-- Expression must be static - RM 13.3(41) + + Object_Size : Enumeration; + for Object_Size'Size use A_Reasonable_Size_Value; -- N/A => ERROR. + +-- small clause +-- Expression must be static - RM 3.5.10(2) + + type Tenths is delta 0.1 range 0.0..10.0; + for Tenths'Small use 1.0 / (Two ** Five); -- N/A => ERROR. + +-- storage pool clause +-- Not tested + +-- storage size clause +-- Expression may be non-static - RM 13.11(15) + type Reference is access Record_To_Layout; + for Reference'Storage_Size use Four * K; -- N/A => ERROR. + + +-- write clause +-- no interesting test can be specified + + procedure TC_Check_Values; + +end CD10001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body CD10001_0 is + + use type System.Address; + + procedure Assert( Truth : Boolean; Message: String ) is + begin + if not Truth then + TCTouch.Implementation_Check( Message ); + end if; + end Assert; + + procedure TC_Check_Values is + Record_Object : Record_To_Layout; + begin + + Assert(Object_Address'Address = Nonstatic_Entity, + "Object not at specified address"); + + Assert(Object_Alignment'Alignment >= One, + "Object not at specified alignment"); + + Assert(Array_With_Components'Component_Size = A_Reasonable_Size_Value, + "Array Components not specified size"); + +-- I don't see how to reliably check this one: +-- +-- type Enumeration_1 is (First, Second, Third); +-- for Enumeration_1 use (First => One, Second => Two, Third => Three); + + Assert(Some_Tagged_Type'External_Tag = Tag_String, + "External_Tag not specified value"); + Assert(Record_Object.Bit_0'First_Bit = Zero, + "Record object First_Bit not zero"); + + Assert(Record_Object.Bit_1'Last_Bit = Four, + "Record object Last_Bit not four"); + + Assert(Object_Size'Size = A_Reasonable_Size_Value, + "Object size not specified value"); + + Assert(Tenths'Small = 1.0 / Two ** Five, + "Tenths small not specified value"); + + Assert(Reference'Storage_Size = 4096, -- Four * K, + "Reference storage size not specified value"); + + end TC_Check_Values; + +end CD10001_0; + +------------------------------------------------------------------- CD10001 + +with Report; +with CD10001_0; + +procedure CD10001 is + +begin -- Main test procedure. + + Report.Test ("CD10001", "Check that representation items containing " & + "nonstatic expressions are supported in the " & + "case that the representation item is a name " & + "that statically denotes a constant declared " & + "before the entity" ); + + CD10001_0.TC_Check_Values; + + Report.Result; + +end CD10001; Index: cd5012f.ada =================================================================== --- cd5012f.ada (nonexistent) +++ cd5012f.ada (revision 338) @@ -0,0 +1,78 @@ +-- CD5012F.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 ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN +-- ARRAY TYPE IN THE DECLARATIVE PART OF A GENERIC +-- PACKAGE BODY. + +-- HISTORY: +-- DHH 09/17/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH SPPRT13; +PROCEDURE CD5012F IS + +BEGIN + + TEST ("CD5012F", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ARRAY " & + "TYPE IN THE DECLARATIVE " & + "PART OF A GENERIC PACKAGE BODY"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + END GENPACK; + + PACKAGE BODY GENPACK IS + ARRAY_VAR : ARRAY (0..4) OF INTEGER := (0,1,2,3,4); + + FOR ARRAY_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + + + BEGIN + IF EQUAL (3, 3) THEN + ARRAY_VAR := (4,3,2,1,0); + END IF; + IF ARRAY_VAR /= (4,3,2,1,0) THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PACKAGE BODY"); + END IF; + IF ARRAY_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PACKAGE BODY"); + END IF; + END GENPACK; + + PACKAGE PACK IS NEW GENPACK; + BEGIN + NULL; + END; + RESULT; +END CD5012F; Index: cd2c11d.tst =================================================================== --- cd2c11d.tst (nonexistent) +++ cd2c11d.tst (revision 338) @@ -0,0 +1,87 @@ +--CD2C11D.TST + +-- 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 EXPRESSION IN A TASK STORAGE SIZE CLAUSE NEED +-- NOT BE STATIC. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY +-- DHH 09/29/87 CREATED ORIGINAL TEST +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CD2C11D IS + +BEGIN + + TEST ("CD2C11D","THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE " & + "NEED NOT BE STATIC"); + + DECLARE + + STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + PACKAGE PACK IS + TASK TYPE CHECK_TYPE; + + FOR CHECK_TYPE'STORAGE_SIZE USE + STORAGE_SIZE; + TASK TYPE TTYPE IS + ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER); + END TTYPE; + + FOR TTYPE'STORAGE_SIZE USE IDENT_INT(STORAGE_SIZE); + + END PACK; + + PACKAGE BODY PACK IS + + TASK BODY TTYPE IS + BEGIN + ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER); + END TTYPE; + + TASK BODY CHECK_TYPE IS + BEGIN + NULL; + END CHECK_TYPE; + + BEGIN + + IF TTYPE'STORAGE_SIZE < IDENT_INT(STORAGE_SIZE) THEN + FAILED("STORAGE_SIZE SPECIFIED IS " & + "GREATER THAN MEMORY ALLOCATED"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; +END CD2C11D; Index: cd1c03e.tst =================================================================== --- cd1c03e.tst (nonexistent) +++ cd1c03e.tst (revision 338) @@ -0,0 +1,82 @@ +-- CD1C03E.TST + +-- 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 STORAGE SIZE OF A DERIVED TASK TYPE IS +-- INHERITED FROM THE PARENT IF THE STORAGE SIZE OF THE +-- PARENT WAS DETERMINED BY A TASK STORAGE SIZE CLAUSE. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- JET 09/16/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED +-- EXTENSION FROM '.DEP' TO '.TST'. + +WITH REPORT; USE REPORT; +PROCEDURE CD1C03E IS + + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TASK TYPE PARENT_TYPE IS + ENTRY E; + END PARENT_TYPE; + + FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + TASK BODY PARENT_TYPE IS + BEGIN + ACCEPT E DO + COMMENT ("ENTRY E ACCEPTED"); + END E; + END PARENT_TYPE; + +BEGIN + + TEST("CD1C03E", "CHECK THAT THE STORAGE SIZE OF A DERIVED " & + "TASK TYPE IS INHERITED FROM THE PARENT IF " & + "THE STORAGE SIZE OF THE PARENT WAS " & + "DETERMINED BY A TASK STORAGE SIZE CLAUSE"); + + IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'STORAGE_SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + RESULT; + +END CD1C03E; Index: cd30003.a =================================================================== --- cd30003.a (nonexistent) +++ cd30003.a (revision 338) @@ -0,0 +1,227 @@ +-- CD30003.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 Size clause for an object is supported if the specified +-- size is at least as large as the subtype's size, and correspond to a +-- size in storage elements that is a multiple of the object's (non-zero) +-- Alignment. RM 13.3(43) +-- +-- TEST DESCRIPTION: +-- This test defines several types and then asserts specific sizes for +-- the, it then checks that the size set is reported back. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 22 JUL 95 SAIC Initial version +-- 08 MAY 96 SAIC Corrected and strengthened for 2.1 +-- 14 FEB 97 PWB.CTA Changed 'Size specifications to multiples +-- of System.Storage_Unit; restricted 'Size spec +-- for enumeration object to max integer size. +-- 16 FEB 98 EDS Modify Documentation. +-- 25 JAN 99 RLB Repaired to properly set and check sizes. +-- 29 JAN 99 RLB Added Pack pragma needed for some implementations. +-- Corrected to support a Storage_Unit size < 8. +--! + +------------------------------------------------------------------- CD30003 + +with Report; +with System; +procedure CD30003 is + + --------------------------------------------------------------------------- + -- types and subtypes + --------------------------------------------------------------------------- + + type Bit is mod 2**1; + for Bit'Size use 1; -- ANX-C RQMT. + + type Byte is mod 2**8; + for Byte'Size use 8; -- ANX-C RQMT. + + type Smallword is mod 2**8; + for Smallword'size use 16; -- ANX-C RQMT. + + type Byte_Array is array(1..4) of Byte; + pragma Pack(Byte_Array); -- ANX-C RQMT. + -- size should be 32 + + type Smallword_Array is array(1..4) of Smallword; + pragma Pack(Smallword_Array); -- Required if Storage_Unit > 16. -- ANX-C RQMT. + + -- Use to calulate maximum required size: + type Max_Modular is mod System.Max_Binary_Modulus; + type Max_Integer is range System.Min_Int .. System.Max_Int; + Enum_Size : constant := Integer'Min (32, + Integer'Min (Max_Modular'Size, Max_Integer'Size)); + type Transmission_Data is ( Empty, Input, Output, IO, Control ); + for Transmission_Data'Size use Enum_Size; -- ANX-C RQMT. + + -- Sizes to try: + + -- The basic sizes are based on a "normal" Storage_Unit = 8 implementation. + -- We then use formulas to insure that the specified sizes meet the + -- the minimum level of support and AI-0051. + + Modular_Single_Size : constant := Integer'Min (((8 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + -- Calulate an appropriate, legal, and required to be supported size to + -- try, which is the size of Byte. Note that object sizes must be + -- a multiple of the storage unit for the compiler. + + Modular_Double_Size : constant := Integer'Min (((16 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + + Modular_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + + Array_Quad_Size : constant := ((4 * 8 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Array_Octo_Size : constant := ((4 * 16 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Rounded_Enum_Size : constant := ((Enum_Size + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Enum_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, + Integer'Min (Max_Modular'Size, Max_Integer'Size)); + + + --------------------------------------------------------------------------- + -- objects + --------------------------------------------------------------------------- + + Bit_8 : Bit :=0; + for Bit_8'Size use System.Storage_Unit; -- ANX-C RQMT. + + Bit_G : Bit :=0; + for Bit_G'Size use Modular_Double_Size; -- ANX-C RQMT. + + Byte_8 : Byte :=0; + for Byte_8'Size use Modular_Single_Size; -- ANX-C RQMT. + + Byte_G : Byte :=0; + for Byte_G'Size use Modular_Double_Size; -- ANX-C RQMT. + + Smallword_1 : Smallword :=0; + for Smallword_1'Size use Modular_Double_Size; -- ANX-C RQMT. + + Smallword_2 : Smallword :=0; + for Smallword_2'Size use Modular_Quad_Size; -- ANX-C RQMT. + + Byte_Array_1 : Byte_Array := (others=>0); + for Byte_Array_1'Size use Array_Quad_Size; -- ANX-C RQMT. + + Smallword_Array_1 : Smallword_Array := (others=>0); + for Smallword_Array_1'Size use Array_Octo_Size; -- ANX-C RQMT. + + Transmission_Data_1 : aliased Transmission_Data := Empty; + + Transmission_Data_2 : Transmission_Data := Control; + for Transmission_Data_2'Size use Enum_Quad_Size; -- ANX-C RQMT. + +begin -- Main test procedure. + + Report.Test ("CD30003", "Check that Size clauses are supported for " & + "values at least as large as the subtypes " & + "size, and correspond to a size in storage " & + "elements that is a multiple of the objects " & + "(non-zero) Alignment" ); + + if Bit_8'Size /= System.Storage_Unit then + Report.Failed("Expected Bit_8'Size =" & Integer'Image(System.Storage_Unit) + & " , actually =" & Integer'Image(Bit_8'Size)); + end if; + + if Bit_G'Size /= Modular_Double_Size then + Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size) + & " , actually =" & Integer'Image(Bit_G'Size)); + end if; + + if Byte_8'Size /= Modular_Single_Size then + Report.Failed("Expected Byte_8'Size =" & Integer'Image(Modular_Single_Size) + & " , actually =" & Integer'Image(Byte_8'Size)); + end if; + + if Byte_G'Size /= Modular_Double_Size then + Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size) + & " , actually =" & Integer'Image(Byte_G'Size)); + end if; + + if Smallword_1'Size /= Modular_Double_Size then + Report.Failed("Expected Smallword_1'Size =" & + Integer'Image(Modular_Double_Size) & + ", actually =" & Integer'Image(Smallword_1'Size)); + end if; + + if Smallword_2'Size /= Modular_Quad_Size then + Report.Failed("Expected Smallword_2'Size =" & + Integer'Image(Modular_Quad_Size) & + ", actually =" & Integer'Image(Smallword_2'Size)); + end if; + + if Byte_Array_1'Size /= Array_Quad_Size then + Report.Failed("Expected Byte_Array_1'Size =" & + Integer'Image(Array_Quad_Size) & + ", actually =" & Integer'Image(Byte_Array_1'Size)); + end if; + + if Smallword_Array_1'Size /= Array_Octo_Size then + Report.Failed( + "Expected Smallword_Array_1'Size =" & + Integer'Image(Array_Octo_Size) & + ", actually =" & Integer'Image(Smallword_Array_1'Size)); + end if; + + if Transmission_Data_1'Size /= Enum_Size and then + Transmission_Data_1'Size /= Rounded_Enum_Size then + Report.Failed( + "Expected Transmission_Data_1'Size =" & Integer'Image(Rounded_Enum_Size) & + ", actually =" & Integer'Image(Transmission_Data_1'Size)); + end if; + + if Transmission_Data_2'Size /= Enum_Quad_Size then + Report.Failed( + "Expected Transmission_Data_2'Size =" & Integer'Image(Enum_Quad_Size) & + ", actually =" & Integer'Image(Transmission_Data_2'Size)); + end if; + + Report.Result; + +end CD30003; Index: cd1009u.tst =================================================================== --- cd1009u.tst (nonexistent) +++ cd1009u.tst (revision 338) @@ -0,0 +1,84 @@ +-- CD1009U.TST + +-- 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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE +-- PART OF A PACKAGE FOR A LIMITED PRIVATE TYPE, WHOSE FULL TYPE +-- DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE PART OF THE +-- SAME PACKAGE. + +-- MACRO SUBSTITUTION: +-- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR +-- THE ACTIVATION OF A TASK. + +-- HISTORY: +-- VCL 10/09/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED +-- EXTENSION FROM '.DEP' TO '.TST'. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009U IS +BEGIN + TEST ("CD1009U", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A LIMITED " & + "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " & + "A TASK TYPE, DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE CHECK_TYPE_1 IS LIMITED PRIVATE; + + PROCEDURE P; + PRIVATE + TASK TYPE CHECK_TYPE_1 IS + END CHECK_TYPE_1; + + FOR CHECK_TYPE_1'STORAGE_SIZE USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " & + "SMALL"); + END IF; + END P; + + TASK BODY CHECK_TYPE_1 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_1; + END PACK; + + USE PACK; + BEGIN + P; + END; + + RESULT; +END CD1009U; Index: cda201a.ada =================================================================== --- cda201a.ada (nonexistent) +++ cda201a.ada (revision 338) @@ -0,0 +1,70 @@ +-- CDA201A.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR +-- CONVERSION BETWEEN INTEGER AND BOOLEAN ARRAY TYPES. + +-- HISTORY: +-- JET 09/12/88 CREATED ORIGINAL TEST. +-- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + +WITH REPORT; USE REPORT; +WITH UNCHECKED_CONVERSION; +PROCEDURE CDA201A IS + + TYPE BOOL_ARR IS ARRAY (1..INTEGER'SIZE) OF BOOLEAN; + PRAGMA PACK (BOOL_ARR); + + I : INTEGER; + B : BOOL_ARR; + + FUNCTION INT_TO_BOOL IS NEW + UNCHECKED_CONVERSION (INTEGER, BOOL_ARR); + + FUNCTION BOOL_TO_INT IS NEW UNCHECKED_CONVERSION(BOOL_ARR,INTEGER); + +BEGIN + TEST ("CDA201A", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR CONVERSION BETWEEN " & + "INTEGER AND BOOLEAN ARRAY TYPES"); + + I := BOOL_TO_INT((1..INTEGER'SIZE => IDENT_BOOL(TRUE))); + + IF INT_TO_BOOL(IDENT_INT(I)) /= (1..INTEGER'SIZE => TRUE) THEN + FAILED("INCORRECT RESULT FROM ARRAY-INTEGER-ARRAY"); + END IF; + + B := INT_TO_BOOL(IDENT_INT(-1)); + + FOR J IN B'RANGE LOOP + B(J) := IDENT_BOOL(B(J)); + END LOOP; + + IF BOOL_TO_INT(B) /= -1 THEN + FAILED("INCORRECT RESULT FROM INTEGER-ARRAY-INTEGER"); + END IF; + + RESULT; +END CDA201A; Index: cd90001.a =================================================================== --- cd90001.a (nonexistent) +++ cd90001.a (revision 338) @@ -0,0 +1,233 @@ +-- CD90001.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 Unchecked_Conversion is supported and is reversible in +-- the cases where: +-- Source'Size = Target'Size +-- Source'Alignment = Target'Alignment +-- Source and Target are both represented contiguously +-- Bit pattern in Source is a meaningful value of Target type +-- +-- TEST DESCRIPTION: +-- This test declares an enumeration type with a representation +-- specification that should fit neatly into an 8 bit object; and a +-- modular type that should also be able to fit easily into 8 bits; +-- uses size representation clauses on both of them for 8 bit +-- representations. It then defines two instances of +-- Unchecked_Conversion; to convert both ways between the types. +-- Using several distinctive values, it checks that the conversions +-- are performed, and reversible. +-- As a second case, the above is performed with an integer type and +-- a packed array of booleans. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 22 JUL 95 SAIC Initial version +-- 07 MAY 96 SAIC Changed Boolean to Character for 2.1 +-- 27 JUL 96 SAIC Allowed for partial N/A to be PASS +-- 14 FEB 97 PWB.CTA Corrected "=" to "/=" in alignment check. +-- 16 FEB 98 EDS Modified documentation. +--! + +----------------------------------------------------------------- CD90001_0 + +with Report; +with Unchecked_Conversion; +package CD90001_0 is + + -- Case 1 : Modular <=> Enumeration + + type Eight_Bits is mod 2**8; + for Eight_Bits'Size use 8; + + type User_Enums is ( One, Two, Four, Eight, + Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight ); + for User_Enums'Size use 8; + + for User_Enums use + ( One => 1, -- ANX-C RQMT. + Two => 2, -- ANX-C RQMT. + Four => 4, -- ANX-C RQMT. + Eight => 8, -- ANX-C RQMT. + Sixteen => 16, -- ANX-C RQMT. + Thirty_Two => 32, -- ANX-C RQMT. + Sixty_Four => 64, -- ANX-C RQMT. + One_Twenty_Eight => 128 ); -- ANX-C RQMT. + + function EB_2_UE is new Unchecked_Conversion( Eight_Bits, User_Enums ); + + function UE_2_EB is new Unchecked_Conversion( User_Enums, Eight_Bits ); + + procedure TC_Check_Case_1; + + -- Case 2 : Integer <=> Packed Character array + + type Signed_16 is range -2**15+1 .. 2**15-1; + -- +1, -1 allows for both 1's and 2's comp + + type Bits_16 is array(0..1) of Character; + pragma Pack(Bits_16); -- ANX-C RQMT. + + function S16_2_B16 is new Unchecked_Conversion( Signed_16, Bits_16 ); + + function B16_2_S16 is new Unchecked_Conversion( Bits_16, Signed_16 ); + + procedure TC_Check_Case_2; + +end CD90001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CD90001_0 is + + Check_List : constant array(1..8) of Eight_Bits + := ( 1, 2, 4, 8, 16, 32, 64, 128 ); + + Check_Enum : constant array(1..8) of User_Enums + := ( One, Two, Four, Eight, + Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight ); + + procedure TC_Check_Case_1 is + Mod_Value : Eight_Bits; + Enum_Val : User_Enums; + begin + for I in Check_List'Range loop + + if EB_2_UE(Check_List(I)) /= Check_Enum(I) then + Report.Failed("EB => UE conversion failed"); + end if; + + if Check_List(I) /= UE_2_EB(Check_Enum(I)) then + Report.Failed ("EU => EB conversion failed"); + end if; + + end loop; + end TC_Check_Case_1; + + procedure TC_Check_Case_2 is + S: Signed_16; + T,U: Signed_16; + B: Bits_16; + C,D: Bits_16; -- allow for byte swapping + begin + --FDEC_BA98_7654_3210 + S := 2#0011_0000_0111_0111#; + B := S16_2_B16( S ); + C := ( Character'Val(2#0011_0000#), Character'Val(2#0111_0111#) ); + D := ( Character'Val(2#0111_0111#), Character'Val(2#0011_0000#) ); + + if (B /= C) and (B /= D) then + Report.Failed("Int => Chararray conversion failed"); + end if; + + B := ( Character'Val(2#0011_1100#), Character'Val(2#0101_0101#) ); + S := B16_2_S16( B ); + T := 2#0011_1100_0101_0101#; + U := 2#0101_0101_0011_1100#; + + if (S /= T) and (S /= U) then + Report.Failed("Chararray => Int conversion failed"); + end if; + + end TC_Check_Case_2; + +end CD90001_0; + +------------------------------------------------------------------- CD90001 + +with Report; +with CD90001_0; + +procedure CD90001 is + + Eight_NA : Boolean := False; + Sixteen_NA : Boolean := False; + +begin -- Main test procedure. + + Report.Test ("CD90001", "Check that Unchecked_Conversion is supported " & + "and is reversible in appropriate cases" ); + Eight_Bit_Case: + begin + if CD90001_0.User_Enums'Size /= CD90001_0.Eight_Bits'Size then + Report.Comment("The sizes of the 8 bit types used in this test " + & "do not match" ); + Eight_NA := True; + elsif CD90001_0.User_Enums'Alignment /= CD90001_0.Eight_Bits'Alignment then + Report.Comment("The alignments of the 8 bit types used in this " + & "test do not match" ); + Eight_NA := True; + else + CD90001_0.TC_Check_Case_1; + end if; + + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised in 8 bit case"); + when others => + Report.Failed("Unexpected exception raised in 8 bit case"); + end Eight_Bit_Case; + + Sixteen_Bit_Case: + begin + if CD90001_0.Signed_16'Size /= CD90001_0.Bits_16'Size then + Report.Comment("The sizes of the 16 bit types used in this test " + & "do not match" ); + Sixteen_NA := True; + elsif CD90001_0.Signed_16'Alignment = CD90001_0.Bits_16'Alignment then + Report.Comment("The alignments of the 16 bit types used in this " + & "test do not match" ); + Sixteen_NA := True; + else + CD90001_0.TC_Check_Case_2; + end if; + + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised in 16 bit case"); + when others => + Report.Failed("Unexpected exception raised in 16 bit case"); + end Sixteen_Bit_Case; + + if Eight_NA and Sixteen_NA then + Report.Not_Applicable("No cases in this test apply"); + end if; + + Report.Result; + +end CD90001; Index: cda201c.ada =================================================================== --- cda201c.ada (nonexistent) +++ cda201c.ada (revision 338) @@ -0,0 +1,76 @@ +-- CDA201C.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR +-- CONVERSION BETWEEN CONSTRAINED ARRAY AND RECORD TYPES. + +-- HISTORY: +-- JET 09/12/88 CREATED ORIGINAL TEST. +-- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + +WITH REPORT; USE REPORT; +WITH UNCHECKED_CONVERSION; +PROCEDURE CDA201C IS + + TYPE INT IS NEW INTEGER; + + TYPE ARR IS ARRAY (1..2) OF INTEGER; + TYPE ARR2 IS ARRAY (ARR'RANGE) OF INT; + + TYPE REC IS RECORD + D : INTEGER; + I : INTEGER; + END RECORD; + + TYPE REC2 IS RECORD + D : INT; + I : INT; + END RECORD; + + A : ARR2; + R : REC2; + + FUNCTION ARR_CONV IS NEW UNCHECKED_CONVERSION(ARR, ARR2); + FUNCTION REC_CONV IS NEW UNCHECKED_CONVERSION(REC, REC2); + +BEGIN + TEST ("CDA201C", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR CONVERSION BETWEEN " & + "CONSTRAINED ARRAY AND RECORD TYPES"); + + A := ARR_CONV(ARR'(ARR'RANGE => IDENT_INT(-1))); + + IF A /= ARR2'(ARR'RANGE => -1) THEN + FAILED("INCORRECT RESULT FROM ARRAY CONVERSION"); + END IF; + + R := REC_CONV(REC'(D | I => IDENT_INT(1))); + + IF R /= REC2'(D => 1, I => 1) THEN + FAILED("INCORRECT RESULT FROM RECORD CONVERSION"); + END IF; + + RESULT; +END CDA201C; Index: cda201e.ada =================================================================== --- cda201e.ada (nonexistent) +++ cda201e.ada (revision 338) @@ -0,0 +1,120 @@ +-- CDA201E.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 UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR THE +-- CONVERSION OF AN ENUMERATION TYPE WITH A REPRESENTATION CLAUSE TO +-- INTEGER. + +-- HISTORY: +-- JET 09/23/88 CREATED ORIGINAL TEST. +-- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. +-- RJW 02/28/90 ADDED SIZE CLAUSE FOR TYPE STOOGE. +-- LDC 09/20/90 ADDED CHECK FOR CONVERSION FROM INT TO STOOGE, +-- ADDED COMMENT WHEN SIZES AREN'T EQUAL. + +WITH REPORT; USE REPORT; +WITH UNCHECKED_CONVERSION; +PROCEDURE CDA201E IS + + TYPE STOOGE IS (CURLY, MOE, LARRY); + FOR STOOGE USE (CURLY => -5, MOE => 13, LARRY => 127); + FOR STOOGE'SIZE USE 8; + + TYPE INT IS RANGE -128 .. 127; + FOR INT'SIZE USE 8; + + I : INT := 0; + NAME : STOOGE := CURLY; + + FUNCTION E_TO_I IS NEW UNCHECKED_CONVERSION(STOOGE, INT); + FUNCTION I_TO_E IS NEW UNCHECKED_CONVERSION(INT, STOOGE); + + FUNCTION ID(E : STOOGE) RETURN STOOGE IS + BEGIN + RETURN STOOGE'VAL(STOOGE'POS(E) + IDENT_INT(0)); + END ID; + + FUNCTION ID_INT (X : INT) RETURN INT IS + A : INTEGER := IDENT_INT(3); + BEGIN + IF EQUAL (A, IDENT_INT(3)) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN 0; -- NEVER EXECUTED. + END ID_INT; + +BEGIN + TEST ("CDA201E", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR THE CONVERSION OF AN " & + "ENUMERATION TYPE WITH A REPRESENTATION " & + "CLAUSE TO INTEGER"); + + IF I'SIZE /= NAME'SIZE THEN + COMMENT( "UNCHECKED_CONVERSION MIGHT BE INSTANTIATED WITH " & + "DIFFERNT SIZES"); + END IF; + + BEGIN + I := E_TO_I(ID(CURLY)); + IF I /= -5 THEN + FAILED ("INCORRECT VALUE OF CURLY: " & INT'IMAGE(I)); + END IF; + + I := E_TO_I(ID(MOE)); + IF I /= 13 THEN + FAILED ("INCORRECT VALUE OF MOE: " & INT'IMAGE(I)); + END IF; + + I := E_TO_I(ID(LARRY)); + IF I /= 127 THEN + FAILED ("INCORRECT VALUE OF LARRY: " & INT'IMAGE(I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION"); + END; + + BEGIN -- 2 + NAME := I_TO_E(ID_INT(-5)); + IF NAME /= CURLY THEN + FAILED ("INCORRECT VALUE OF -5 : " & STOOGE'IMAGE(NAME)); + END IF; + + NAME := I_TO_E(ID_INT(13)); + IF NAME /= MOE THEN + FAILED ("INCORRECT VALUE OF 13: " & STOOGE'IMAGE(NAME)); + END IF; + + NAME := I_TO_E(ID_INT(127)); + IF NAME /= LARRY THEN + FAILED ("INCORRECT VALUE OF 127: " & STOOGE'IMAGE(NAME)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION - 2"); + END; + + RESULT; +END CDA201E; Index: cd2a32a.ada =================================================================== --- cd2a32a.ada (nonexistent) +++ cd2a32a.ada (revision 338) @@ -0,0 +1,272 @@ +-- CD2A32A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN +-- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- WITH THE SMALLEST APPROPRIATE SIGNED SIZE ARE NOT +-- AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/10/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE +-- CHECKS AND ADDED REPRESENTAION CLAUSE CHECK. +-- RJW 03/28/90 REMOVED ERRONEOUS REFERENCES TO LENGTH_CHECK. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD2A32A IS + + BASIC_SIZE : CONSTANT := 7; + + TYPE INT IS RANGE -63 .. 63; + + FOR INT'SIZE USE BASIC_SIZE; + + I1 : INT := -63; + I2 : INT := 0; + I3 : INT := 63; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT; + PRAGMA PACK (ARRAY_TYPE); + INTARRAY : ARRAY_TYPE := (-63, 0, 63); + + TYPE REC_TYPE IS RECORD + COMPN : INT := -63; + COMPZ : INT := 0; + COMPP : INT := 63; + END RECORD; + PRAGMA PACK (REC_TYPE); + + IREC : REC_TYPE; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT); + + + PROCEDURE PROC (PIN, PIP : INT; + PIOZ, PIOP : IN OUT INT; + POP : OUT INT) IS + + BEGIN + IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PIN'SIZE"); + END IF; + + FOR P1 IN IDENT (PIN) .. IDENT (PIOP) LOOP + IF NOT (P1 IN PIN .. PIP) OR + (P1 NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 1"); + END IF; + END LOOP; + + IF NOT ((+PIP = PIOP) AND + (-PIN = PIP) AND + (ABS PIN = PIOP)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'VAL (-63) /= IDENT (PIN) OR + INT'VAL (0) /= IDENT (PIOZ) OR + INT'VAL (63) /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 1"); + END IF; + + IF INT'PRED (PIOZ) /= IDENT (-1) OR + INT'PRED (PIP) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 1"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (PIN) OR + INT'VALUE ("0") /= IDENT (PIOZ) OR + INT'VALUE ("63") /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 1"); + END IF; + + POP := 63; + + END PROC; + +BEGIN + TEST ("CD2A32A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE WITH " & + "THE SMALLEST APPROPRIATE SIGNED SIZE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (I1, 7, "INT"); + + PROC (-63, 63, I2, I3, I3); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + IF NOT ((I1 < IDENT (0)) AND + (IDENT (I3) > IDENT (I2)) AND + (I2 <= IDENT (0)) AND + (IDENT (63) = I3)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF NOT (((I1 + I3) = I2) AND + ((I2 - I3) = I1) AND + ((I3 * I2) = I2) AND + ((I2 / I1) = I2) AND + ((I1 ** 1) = I1) AND + ((I1 REM 10) = IDENT (-3)) AND + ((I3 MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'FIRST /= IDENT (-63) THEN + FAILED ("INCORRECT VALUE FOR INT'FIRST - 2"); + END IF; + + IF INT'POS (I1) /= IDENT_INT (-63) OR + INT'POS (I2) /= IDENT_INT ( 0) OR + INT'POS (I3) /= IDENT_INT ( 63) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 2"); + END IF; + + IF INT'SUCC (I1) /= IDENT (-62) OR + INT'SUCC (I2) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 2"); + END IF; + + IF INT'IMAGE (I1) /= IDENT_STR ("-63") OR + INT'IMAGE (I2) /= IDENT_STR (" 0") OR + INT'IMAGE (I3) /= IDENT_STR (" 63") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2"); + END IF; + + IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE"); + END IF; + + IF NOT ((INTARRAY(-1) < IDENT (0)) AND + (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND + (INTARRAY(0) <= IDENT (0)) AND + (IDENT (63) = INTARRAY (1))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP + IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT ((+INTARRAY(-1) = INTARRAY(-1)) AND + (-INTARRAY( 1) = INTARRAY(-1)) AND + (ABS INTARRAY(-1) = INTARRAY(1))) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'VAL (-63) /= IDENT (INTARRAY (-1)) OR + INT'VAL ( 0) /= IDENT (INTARRAY ( 0)) OR + INT'VAL ( 63) /= IDENT (INTARRAY ( 1)) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 3"); + END IF; + + IF INT'PRED (INTARRAY (0)) /= IDENT (-1) OR + INT'PRED (INTARRAY (1)) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 3"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (INTARRAY (-1)) OR + INT'VALUE ("0") /= IDENT (INTARRAY ( 0)) OR + INT'VALUE ("63") /= IDENT (INTARRAY ( 1)) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 3"); + END IF; + + IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE"); + END IF; + + IF NOT ((IREC.COMPN < IDENT (0)) AND + (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND + (IREC.COMPZ <= IDENT (0)) AND + (IDENT (63) = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP + IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT (((IREC.COMPN + IREC.COMPP) = IREC.COMPZ) AND + ((IREC.COMPZ - IREC.COMPP) = IREC.COMPN) AND + ((IREC.COMPP * IREC.COMPZ) = IREC.COMPZ) AND + ((IREC.COMPZ / IREC.COMPN) = IREC.COMPZ) AND + ((IREC.COMPN ** 1) = IREC.COMPN) AND + ((IREC.COMPN REM 10) = IDENT (-3)) AND + ((IREC.COMPP MOD 10) = IDENT ( 3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'POS (IREC.COMPN) /= IDENT_INT (-63) OR + INT'POS (IREC.COMPZ) /= IDENT_INT ( 0) OR + INT'POS (IREC.COMPP) /= IDENT_INT ( 63) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 4"); + END IF; + + IF INT'SUCC (IREC.COMPN) /= IDENT (-62) OR + INT'SUCC (IREC.COMPZ) /= IDENT ( 1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 4"); + END IF; + + IF INT'IMAGE (IREC.COMPN) /= IDENT_STR ("-63") OR + INT'IMAGE (IREC.COMPZ) /= IDENT_STR (" 0") OR + INT'IMAGE (IREC.COMPP) /= IDENT_STR (" 63") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 4"); + END IF; + + RESULT; +END CD2A32A; Index: cd2a32c.ada =================================================================== --- cd2a32c.ada (nonexistent) +++ cd2a32c.ada (revision 338) @@ -0,0 +1,128 @@ +-- CD2A32C.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 SIZE SPECIFICATION FOR AN INTEGER TYPE OF THE +-- SMALLEST APPROPRIATE SIGNED SIZE CAN BE GIVEN: +-- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE +-- DECLARED IN THE VISIBLE PART; +-- FOR A DERIVED INTEGER TYPE; +-- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS +-- AN INTEGER TYPE; +-- FOR AN INTEGER TYPE IN A GENERIC UNIT. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE +-- CHECKS, ADDED REPRESENTAION CLAUSE CHECK, AND +-- ADDED CHECK ON INTEGER IN A GENERIC UNIT. +-- BCB 10/03/90 CHANGED FAILED MESSAGES FROM "SHOULD NOT BE GREATER +-- THAN" TO "MUST BE EQUAL TO". +-- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A32C IS + + TYPE BASIC_INT IS RANGE -63 .. 63; + SPECIFIED_SIZE : CONSTANT := 7; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE -63 .. 63; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE -63 .. 63; + PRIVATE + TYPE PRIVATE_INT IS RANGE -63 .. 63; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + GENERIC + PACKAGE GENPACK IS + TYPE GEN_CHECK_INT IS RANGE -63 .. 63; + FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE; + END GENPACK; + + PACKAGE NEWPACK IS NEW GENPACK; + + USE NEWPACK; + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + +BEGIN + + TEST("CD2A32C", "CHECK THAT A SIZE SPECIFICATION " & + "FOR AN INTEGER TYPE OF THE SMALLEST " & + "APPROPRIATE SIGNED SIZE CAN BE GIVEN: IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " & + "TYPE DECLARED IN THE VISIBLE PART; FOR A " & + "DERIVED INTEGER TYPE; FOR A DERIVED PRIVATE " & + "TYPE WHOSE FULL DECLARATION IS AS AN INTEGER " & + "TYPE; FOR AN INTEGER TYPE IN A GENERIC UNIT"); + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_INT'SIZE)); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(INT_IN_P'SIZE)); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ALT_INT_IN_P'SIZE)); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE MUST BE EQUAL TO " & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE)); + END IF; + + IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GEN_CHECK_INT'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(GEN_CHECK_INT'SIZE)); + END IF; + + RESULT; + +END CD2A32C; Index: cd2a32e.ada =================================================================== --- cd2a32e.ada (nonexistent) +++ cd2a32e.ada (revision 338) @@ -0,0 +1,263 @@ +-- CD2A32E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN +-- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- WITH THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE NOT +-- AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON +-- 'SIZE CHECKS. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A32E IS + + BASIC_SIZE : CONSTANT := 7; + + TYPE INT IS RANGE 0 .. 126; + + FOR INT'SIZE USE BASIC_SIZE; + + I0 : INT := 0; + I1 : INT := 63; + I2 : INT := 126; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE 0 .. 2) OF INT; + INTARRAY : ARRAY_TYPE := (0, 63, 126); + + TYPE REC_TYPE IS RECORD + COMP0 : INT := 0; + COMP1 : INT := 63; + COMP2 : INT := 126; + END RECORD; + + IREC : REC_TYPE; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE PROC (PI0, PI2 : INT; + PIO1, PIO2 : IN OUT INT; + PO2 : OUT INT) IS + + BEGIN + IF PI0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PI0'SIZE"); + END IF; + + IF NOT ((PI0 < IDENT (1)) AND + (IDENT (PI2) > IDENT (PIO1)) AND + (PIO1 <= IDENT (63)) AND + (IDENT (126) = PI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF NOT (((PI0 + PI2) = PIO2) AND + ((PI2 - PIO1) = PIO1) AND + ((PIO1 * IDENT (2)) = PI2) AND + ((PIO2 / PIO1) = IDENT (2)) AND + ((PIO1 ** 1) = IDENT (63)) AND + ((PIO2 REM 10) = IDENT (6)) AND + ((PIO1 MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'POS (PI0) /= IDENT_INT (0) OR + INT'POS (PIO1) /= IDENT_INT (63) OR + INT'POS (PI2) /= IDENT_INT (126) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 1"); + END IF; + + IF INT'SUCC (PI0) /= IDENT (1) OR + INT'SUCC (PIO1) /= IDENT (64) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 1"); + END IF; + + IF INT'IMAGE (PI0) /= IDENT_STR (" 0") OR + INT'IMAGE (PIO1) /= IDENT_STR (" 63") OR + INT'IMAGE (PI2) /= IDENT_STR (" 126") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 1"); + END IF; + + PO2 := 126; + + END PROC; + +BEGIN + TEST ("CD2A32E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE WITH " & + "THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (0, 126, I1, I2, I2); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I0) .. IDENT (I2) LOOP + IF NOT (I IN I0 .. I2) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + END LOOP; + + IF NOT ((+I2 = I2) AND + (-I1 = -63) AND + (ABS I2 = I2)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'VAL (0) /= IDENT (I0) OR + INT'VAL (63) /= IDENT (I1) OR + INT'VAL (126) /= IDENT (I2) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 2"); + END IF; + + IF INT'PRED (I1) /= IDENT (62) OR + INT'PRED (I2) /= IDENT (125) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 2"); + END IF; + + IF INT'VALUE ("0") /= IDENT (I0) OR + INT'VALUE ("63") /= IDENT (I1) OR + INT'VALUE ("126") /= IDENT (I2) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 2"); + END IF; + + IF INTARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(1)'SIZE"); + END IF; + + IF NOT ((INTARRAY(0) < IDENT (1)) AND + (IDENT (INTARRAY(2)) > IDENT (INTARRAY(1))) AND + (INTARRAY(1) <= IDENT (63)) AND + (IDENT (126) = INTARRAY(2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(0)) .. IDENT (INTARRAY(2)) LOOP + IF NOT (I IN INTARRAY(0) .. INTARRAY(2)) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT (((INTARRAY(0) + INTARRAY(2)) = INTARRAY(2)) AND + ((INTARRAY(2) - INTARRAY(1)) = INTARRAY(1)) AND + ((INTARRAY(1) * IDENT (2)) = INTARRAY(2)) AND + ((INTARRAY(2) / INTARRAY(1)) = IDENT (2)) AND + ((INTARRAY(1) ** 1) = IDENT (63)) AND + ((INTARRAY(2) REM 10) = IDENT (6)) AND + ((INTARRAY(1) MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'POS (INTARRAY(0)) /= IDENT_INT (0) OR + INT'POS (INTARRAY(1)) /= IDENT_INT (63) OR + INT'POS (INTARRAY(2)) /= IDENT_INT (126) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 3"); + END IF; + + IF INT'SUCC (INTARRAY(0)) /= IDENT (1) OR + INT'SUCC (INTARRAY(1)) /= IDENT (64) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 3"); + END IF; + + IF INT'IMAGE (INTARRAY(0)) /= IDENT_STR (" 0") OR + INT'IMAGE (INTARRAY(1)) /= IDENT_STR (" 63") OR + INT'IMAGE (INTARRAY(2)) /= IDENT_STR (" 126") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3"); + END IF; + + IF IREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMP2'SIZE"); + END IF; + + IF NOT ((IREC.COMP0 < IDENT (1)) AND + (IDENT (IREC.COMP2) > IDENT (IREC.COMP1)) AND + (IREC.COMP1 <= IDENT (63)) AND + (IDENT (126) = IREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMP0) .. IDENT (IREC.COMP2) LOOP + IF NOT (I IN IREC.COMP0 .. IREC.COMP2) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT ((+IREC.COMP2 = IREC.COMP2) AND + (-IREC.COMP1 = -63) AND + (ABS IREC.COMP2 = IREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'VAL (0) /= IDENT (IREC.COMP0) OR + INT'VAL (63) /= IDENT (IREC.COMP1) OR + INT'VAL (126) /= IDENT (IREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 4"); + END IF; + + IF INT'PRED (IREC.COMP1) /= IDENT (62) OR + INT'PRED (IREC.COMP2) /= IDENT (125) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 4"); + END IF; + + IF INT'VALUE ("0") /= IDENT (IREC.COMP0) OR + INT'VALUE ("63") /= IDENT (IREC.COMP1) OR + INT'VALUE ("126") /= IDENT (IREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 4"); + END IF; + + RESULT; + +END CD2A32E; Index: cd2a32g.ada =================================================================== --- cd2a32g.ada (nonexistent) +++ cd2a32g.ada (revision 338) @@ -0,0 +1,131 @@ +-- CD2A32G.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 SIZE SPECIFICATION FOR AN INTEGER +-- TYPE OF THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE GIVEN: +-- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE +-- DECLARED IN THE VISIBLE PART; +-- FOR A DERIVED INTEGER TYPE; +-- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS +-- AN INTEGER TYPE; +-- FOR AN INTEGER TYPE GIVEN IN A GENERIC UNIT. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE +-- CHECKS, AND ADDED CHECK FOR 'SIZE IN A GENERIC +-- UNIT. +-- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A32G IS + + TYPE BASIC_INT IS RANGE 0 .. 126; + SPECIFIED_SIZE : CONSTANT := 7; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE 0 .. 126; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE 0 .. 126; + PRIVATE + TYPE PRIVATE_INT IS RANGE 0 .. 126; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + TYPE GEN_CHECK_INT IS RANGE 0 .. 126; + FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE; + + BEGIN + + IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GEN_CHECK_INT'SIZE SHOULD NOT BE GREATER " & + "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(GEN_CHECK_INT'SIZE)); + END IF; + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC; + +BEGIN + + TEST("CD2A32G", "CHECK THAT SIZE SPECIFICATIONS OF THE SMALLEST " & + "APPROPRIATE UNSIGNED SIZE CAN BE GIVEN " & + "IN THE VISIBLE OR PRIVATE PART OF PACKAGE FOR " & + "AN INTEGER TYPE DECLARED IN VISIBLE PART, " & + "FOR DERIVED INTEGER " & + "TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " & + "DECLARATION IS AS AN INTEGER TYPE AND FOR AN " & + "INTEGER TYPE GIVEN IN A GENERIC UNIT"); + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_INT'SIZE)); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(INT_IN_P'SIZE)); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ALT_INT_IN_P'SIZE)); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE SHOULD NOT BE GREATER " & + "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE)); + END IF; + + NEWPROC; + + RESULT; + +END CD2A32G; Index: cdd1001.a =================================================================== --- cdd1001.a (nonexistent) +++ cdd1001.a (revision 338) @@ -0,0 +1,94 @@ +-- CDD1001.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that components of Stream_Element_Array are aliased. (Defect +-- Report 8652/0044). +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations for which Stream_Element'Size is a multiple of +-- System.Storage_Unit, this test must execute. +-- +-- For other implementations, if this test compiles without error messages +-- at compilation, it must bind and execute. +-- +-- PASS/FAIL CRITERIA: +-- For implementations for which Stream_Element'Size is a multiple of +-- System.Storage_Unit, this test must execute, report PASSED, and +-- complete normally, otherwise the test FAILS. +-- +-- For other implementations: +-- PASSING behavior is: +-- this test executes, reports PASSED, and completes normally +-- or +-- this test produces at least one error message at compilation, and +-- the error message is associated with one of the items marked: +-- -- N/A => ERROR. +-- +-- All other behaviors are FAILING. +-- +-- +-- CHANGE HISTORY: +-- 12 FEB 2001 PHL Initial version +-- 15 MAR 2001 RLB Readied for release. + +--! +with Ada.Streams; +use Ada.Streams; +with Report; +use Report; +procedure CDD1001 is + + type Acc is access all Stream_Element; + + A : Stream_Element_Array + (Stream_Element_Offset (Ident_Int (1)) .. + Stream_Element_Offset (Ident_Int (10))); + B : array (A'Range) of Acc; +begin + Test ("CDD1001", + "Check that components of Stream_Element_Array are aliased"); + + for I in A'Range loop + A (I) := Stream_Element (Ident_Int (Integer (I)) * Ident_Int (3)); + end loop; + + for I in B'Range loop + B (I) := A (I)'Access; -- N/A => ERROR. + end loop; + + for I in B'Range loop + if B (I).all /= Stream_Element + (Ident_Int (Integer (I)) * Ident_Int (3)) then + Failed ("Unable to build access values desginating elements " & + "of a Stream_Element_Array"); + end if; + end loop; + + Result; +end CDD1001; + Index: cd2a32i.ada =================================================================== --- cd2a32i.ada (nonexistent) +++ cd2a32i.ada (revision 338) @@ -0,0 +1,135 @@ +-- CD2A32I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE +-- SIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN +-- BE PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON +-- 'SIZE CHECKS. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A32I IS + + TYPE BASIC_INT IS RANGE -63 .. 63; + BASIC_SIZE : CONSTANT := 7; + + FOR BASIC_INT'SIZE USE BASIC_SIZE; + +BEGIN + + TEST ("CD2A32I", "CHECK THAT WHEN A SIZE SPECIFICATION " & + "OF THE SMALLEST APPROPRIATE SIGNED SIZE " & + "IS GIVEN FOR AN INTEGER TYPE, " & + "THE TYPE " & + "CAN BE PASSED AS AN ACTUAL PARAMETER TO " & + "GENERIC PROCEDURES"); + + DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS RANGE <>; + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + SUBTYPE INT IS GPARM; + + I1 : INT := -63; + I2 : INT := 0; + I3 : INT := 63; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I1) .. IDENT (I3) LOOP + IF NOT (I IN I1 .. I3) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + END LOOP; + + IF NOT ((+I1 = I1) AND + (-I3 = I1) AND + (ABS I1 = I3)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS"); + END IF; + + IF INT'LAST /= IDENT (63) THEN + FAILED ("INCORRECT VALUE FOR INT'LAST"); + END IF; + + IF INT'VAL (-63) /= IDENT (I1) OR + INT'VAL (0) /= IDENT (I2) OR + INT'VAL (63) /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL"); + END IF; + + IF INT'PRED (I2) /= IDENT (-1) OR + INT'PRED (I3) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (I1) OR + INT'VALUE (" 0") /= IDENT (I2) OR + INT'VALUE (" 63") /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT); + + BEGIN + + NEWPROC; + + END; + + RESULT; + +END CD2A32I; Index: cd2a24j.ada =================================================================== --- cd2a24j.ada (nonexistent) +++ cd2a24j.ada (revision 338) @@ -0,0 +1,124 @@ +-- CD2A24J.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 IF A SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE +-- SIZE FOR AN UNSIGNED REPRESENTATION) AND AN ENUMERATION +-- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, +-- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN +-- INSTANTIATION. + +-- HISTORY: +-- JET 08/19/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A24J IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 3; + + FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, + TWO => 5); + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + +BEGIN + TEST ("CD2A24J", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " & + "SMALLEST APPROPRIATE SIZE FOR AN UNSIGNED " & + "REPRESENTATION) AND AN ENUMERATION " & + "REPRESENTATION CLAUSE ARE GIVEN FOR AN " & + "ENUMERATION TYPE, THEN THE TYPE CAN BE USED " & + "AS AN ACTUAL PARAMETER IN AN INSTANTIATION"); + + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (C1) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + +END CD2A24J; Index: cd5013a.ada =================================================================== --- cd5013a.ada (nonexistent) +++ cd5013a.ada (revision 338) @@ -0,0 +1,72 @@ +-- CD5013A.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ENUMERATION TYPE, +-- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013A IS + + TYPE ENUM_TYPE IS (ONE,TWO,THREE,FOUR,FIVE,SIX); + + PACKAGE PACK IS + CHECK_TYPE : ENUM_TYPE; + FOR CHECK_TYPE USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013A", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ENUMERATION TYPE, WHERE " & + "THE VARIABLE IS DECLARED IN THE VISIBLE PART " & + "OF THE SPECIFICATION"); + + CHECK_TYPE := ONE; + IF EQUAL(3,3) THEN + CHECK_TYPE := THREE; + END IF; + + IF CHECK_TYPE /= THREE THEN + FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE"); + END IF; + + IF CHECK_TYPE'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE"); + END IF; + + RESULT; +END CD5013A; Index: cd1009a.ada =================================================================== --- cd1009a.ada (nonexistent) +++ cd1009a.ada (revision 338) @@ -0,0 +1,80 @@ +-- CD1009A.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 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE +-- OR PRIVATE PART OF A PACKAGE FOR AN INTEGER TYPE DECLARED IN +-- THE VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- VCL 09/18/87 CREATED ORIGINAL TEST. +-- DHH 03/31/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED +-- CHECK FOR REPRESENTATION CLAUSES, AND CHANGED +-- SPECIFIED_SIZE TO 5. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1009A IS +BEGIN + TEST ("CD1009A", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR AN INTEGER " & + "TYPE DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE CHECK_TYPE_1 IS RANGE -8 .. 7; + FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE; + TYPE PACK_ARY IS ARRAY(1 .. 6) OF CHECK_TYPE_1; + PRAGMA PACK (PACK_ARY); + OBJ1 : PACK_ARY := (OTHERS => -7); + + TYPE CHECK_TYPE_2 IS RANGE -8 .. 7; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + OBJ2 : CHECK_TYPE_2 := -7; + PROCEDURE CHECK1 IS NEW LENGTH_CHECK (CHECK_TYPE_1); + PROCEDURE CHECK2 IS NEW LENGTH_CHECK (CHECK_TYPE_2); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK1 (OBJ1(IDENT_INT(1)), 5, "CHECK_TYPE_1"); + CHECK2 (OBJ2, 5, "CHECK_TYPE_2"); + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE"); + END IF; + END; + + RESULT; +END CD1009A; Index: cd5013c.ada =================================================================== --- cd5013c.ada (nonexistent) +++ cd5013c.ada (revision 338) @@ -0,0 +1,73 @@ +-- CD5013C.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER TYPE, WHERE +-- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013C IS + + TYPE INT_TYPE IS RANGE INTEGER'FIRST .. INTEGER'LAST; + + PACKAGE PACK IS + CHECK_VAR : INT_TYPE; + PRIVATE + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013C", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE PRIVATE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN INTEGER TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := 100; + IF EQUAL(3,3) THEN + CHECK_VAR := 10; + END IF; + + IF CHECK_VAR /= 10 THEN + FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE"); + END IF; + + RESULT; +END CD5013C; Index: cd5013e.ada =================================================================== --- cd5013e.ada (nonexistent) +++ cd5013e.ada (revision 338) @@ -0,0 +1,72 @@ +-- CD5013E.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING POINT TYPE, +-- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013E IS + + TYPE FLT_TYPE IS DIGITS 5 RANGE -1.0 .. 1.0; + + PACKAGE PACK IS + CHECK_VAR : FLT_TYPE; + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013E", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF A FLOATING POINT TYPE, " & + "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " & + "PART OF THE SPECIFICATION"); + + CHECK_VAR := 0.5; + IF EQUAL(3,3) THEN + CHECK_VAR := 0.0; + END IF; + + IF CHECK_VAR /= 0.0 THEN + FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE"); + END IF; + + RESULT; +END CD5013E; Index: cd1009e.ada =================================================================== --- cd1009e.ada (nonexistent) +++ cd1009e.ada (revision 338) @@ -0,0 +1,82 @@ +-- CD1009E.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE +-- OR PRIVATE PART OF A PACKAGE FOR A ONE-DIMENSIONAL ARRAY TYPE +-- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST +-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- VCL 10/07/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009E IS +BEGIN + TEST ("CD1009E", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "ONE-DIMENSIONAL ARRAY TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 5; + + TYPE CHECK_TYPE_1 IS ARRAY (1 ..5) OF INTEGER; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + X : CHECK_TYPE_1 := (OTHERS => IDENT_INT(1)); + + TYPE CHECK_TYPE_2 IS ARRAY (1 ..5) OF INTEGER; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + Y : CHECK_TYPE_2 := (OTHERS => IDENT_INT(5)); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "FIRST VALUE IS" & + INTEGER'IMAGE( X( IDENT_INT(1) ) ) ); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " & + "FIRST VALUE IS" & + INTEGER'IMAGE( Y( IDENT_INT(1) ) ) ); + END IF; + END; + + RESULT; +END CD1009E; Index: cd5013g.ada =================================================================== --- cd5013g.ada (nonexistent) +++ cd5013g.ada (revision 338) @@ -0,0 +1,74 @@ +-- CD5013G.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED POINT TYPE, +-- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013G IS + + TYPE FIX_TYPE IS DELTA 0.5 RANGE -7.5 .. 7.5; + + PACKAGE PACK IS + CHECK_VAR : FIX_TYPE; + PRIVATE + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013G", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE PRIVATE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF A FIXED POINT TYPE, " & + "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " & + "PART OF THE SPECIFICATION"); + + CHECK_VAR := 1.5; + IF EQUAL(3,3) THEN + CHECK_VAR := 5.0; + END IF; + + IF CHECK_VAR /= 5.0 THEN + FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE"); + END IF; + + RESULT; +END CD5013G; Index: cd1009g.ada =================================================================== --- cd1009g.ada (nonexistent) +++ cd1009g.ada (revision 338) @@ -0,0 +1,86 @@ +-- CD1009G.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE +-- OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE DECLARED IN +-- THE VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST +-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- VCL 10/07/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009G IS +BEGIN + TEST ("CD1009G", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE; + + TYPE CHECK_TYPE_1 IS + RECORD + I : INTEGER; + END RECORD; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + X : CHECK_TYPE_1 := ( I => IDENT_INT (1) ); + + TYPE CHECK_TYPE_2 IS + RECORD + I : INTEGER; + END RECORD; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + Y : CHECK_TYPE_2 := ( I => IDENT_INT (5) ); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & INTEGER'IMAGE( IDENT_INT( X.I) ) ); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " & + "VALUE IS" & INTEGER'IMAGE( IDENT_INT(Y.I) ) ); + END IF; + END; + + RESULT; +END CD1009G; Index: cd5013i.ada =================================================================== --- cd5013i.ada (nonexistent) +++ cd5013i.ada (revision 338) @@ -0,0 +1,73 @@ +-- CD5013I.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY TYPE, WHERE +-- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013I IS + + TYPE ARR_TYPE IS ARRAY(1..5) OF INTEGER; + + PACKAGE PACK IS + CHECK_VAR : ARR_TYPE; + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013I", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ARRAY TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := (1,2,3,4,5); + IF EQUAL(3,3) THEN + CHECK_VAR := (5,4,3,2,1); + END IF; + + IF CHECK_VAR /= (5,4,3,2,1) THEN + FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE"); + END IF; + + RESULT; +END CD5013I; Index: cd1009i.ada =================================================================== --- cd1009i.ada (nonexistent) +++ cd1009i.ada (revision 338) @@ -0,0 +1,69 @@ +-- CD1009I.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE +-- PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE DECLARED IN THE +-- VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- VCL 09/18/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK FOR +-- REPRESENTATION CLAUSES AND CHANGED THE TEST +-- EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1009I IS +BEGIN + TEST ("CD1009I", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A LIMITED-" & + "PRIVATE TYPE DECLARED IN THE VISIBLE PART " & + "OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE CHECK_TYPE_1 IS LIMITED PRIVATE; + PRIVATE + TYPE CHECK_TYPE_1 IS RANGE -8 .. 7; + FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE; + OBJ_CHECK : CHECK_TYPE_1 := -7; + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE_1); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (OBJ_CHECK, 5, "CHECK_TYPE_1"); + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE"); + END IF; + END; + + RESULT; +END CD1009I; Index: cd5013k.ada =================================================================== --- cd5013k.ada (nonexistent) +++ cd5013k.ada (revision 338) @@ -0,0 +1,78 @@ +-- CD5013K.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD TYPE, WHERE +-- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013K IS + + TYPE REC_TYPE IS RECORD + BOOL : BOOLEAN; + INT : INTEGER; + END RECORD; + + PACKAGE PACK IS + CHECK_VAR : REC_TYPE; + PRIVATE + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + PACKAGE BODY PACK IS + BEGIN + TEST ("CD5013K", "AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A RECORD " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN " & + "THE VISIBLE PART OF THE SPECIFICATION"); + + CHECK_VAR := (TRUE, IDENT_INT(5)); + IF EQUAL(3,3) THEN + CHECK_VAR := (FALSE, IDENT_INT(10)); + END IF; + + IF CHECK_VAR /= (FALSE, IDENT_INT (10)) THEN + FAILED ("INCORRECT VALUE FOR RECORD VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE"); + END IF; + END PACK; + +BEGIN + + RESULT; +END CD5013K; Index: cd5013m.ada =================================================================== --- cd5013m.ada (nonexistent) +++ cd5013m.ada (revision 338) @@ -0,0 +1,73 @@ +-- CD5013M.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS TYPE, WHERE +-- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013M IS + + TYPE ACC_TYPE IS ACCESS INTEGER; + + PACKAGE PACK IS + CHECK_VAR : ACC_TYPE; + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + +BEGIN + + TEST ("CD5013M", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ACCESS TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := NEW INTEGER'(100); + IF EQUAL(3,3) THEN + CHECK_VAR := NEW INTEGER'(25); + END IF; + + IF CHECK_VAR.ALL /= 25 THEN + FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE"); + END IF; + + RESULT; +END CD5013M; Index: cd1009m.ada =================================================================== --- cd1009m.ada (nonexistent) +++ cd1009m.ada (revision 338) @@ -0,0 +1,81 @@ +-- CD1009M.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN +-- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION +-- TYPE DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- VCL 10/08/87 CREATED ORIGINAL TEST. +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1009M IS +BEGIN + TEST ("CD1009M", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " & + "GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR AN ENUMERATION TYPE DECLARED IN " & + "THE VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8); + FOR CHECK_TYPE_1 USE (A0 => 0, + A2 => 1, + A4 => 2, + A8 => 3); + + TYPE CHECK_TYPE_2 IS (A0, A2, A4, A8); + TYPE INT1 IS RANGE 0 .. 3; + FOR INT1'SIZE USE CHECK_TYPE_1'SIZE; + + TYPE INT2 IS RANGE 2 .. 8; + + PRIVATE + FOR CHECK_TYPE_2 USE (A0 => 2, + A2 => 4, + A4 => 6, + A8 => 8); + FOR INT2'SIZE USE CHECK_TYPE_2'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(CHECK_TYPE_2, INT2); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (A4, 2, "CHECK_TYPE_1"); + CHECK_2 (A8, 8, "CHECK_TYPE_2"); + END PACK; + + USE PACK; + BEGIN + NULL; + END; + + RESULT; +END CD1009M; Index: cd5013o.ada =================================================================== --- cd5013o.ada (nonexistent) +++ cd5013o.ada (revision 338) @@ -0,0 +1,83 @@ +-- CD5013O.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF +-- A PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE TYPE, WHERE +-- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE +-- SPECIFICATION. + +-- HISTORY: +-- BCB 09/16/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH SPPRT13; USE SPPRT13; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE CD5013O IS + + PACKAGE P1 IS + END P1; + + PACKAGE PACK IS + TYPE F IS PRIVATE; + PRIVATE + TYPE F IS NEW INTEGER; + CHECK_VAR : F; + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + PACKAGE BODY P1 IS + BEGIN + TEST ("CD5013O", "AN ADDRESS CLAUSE CAN BE GIVEN" & + " IN THE PRIVATE PART OF A PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A " & + "PRIVATE TYPE, WHERE THE VARIABLE IS " & + "DECLARED IN THE VISIBLE PART OF THE " & + "SPECIFICATION"); + END P1; + + PACKAGE BODY PACK IS + BEGIN + CHECK_VAR := 100; + IF EQUAL(3,3) THEN + CHECK_VAR := 25; + END IF; + + IF CHECK_VAR /= 25 THEN + FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE"); + END IF; + END PACK; + +BEGIN + + RESULT; +END CD5013O; Index: cd1c03a.ada =================================================================== --- cd1c03a.ada (nonexistent) +++ cd1c03a.ada (revision 338) @@ -0,0 +1,84 @@ +-- CD1C03A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE SIZE OF A DERIVED TYPE IS INHERITED FROM THE +-- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A SIZE +-- CLAUSE. + +-- HISTORY: +-- JET 09/16/87 CREATED ORIGINAL TEST. +-- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK ON +-- REPRESENTATION CLAUSES, AND CHANGED THE TEST +-- EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1C03A IS + + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE PARENT_TYPE IS RANGE -8 .. 7; + + FOR PARENT_TYPE'SIZE USE SPECIFIED_SIZE; + PT : PARENT_TYPE := -7; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + DT : DERIVED_TYPE := -7; + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_TYPE); + PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (PARENT_TYPE); + +BEGIN + + TEST("CD1C03A", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " & + "INHERITED FROM THE PARENT IF THE SIZE OF " & + "THE PARENT WAS DETERMINED BY A SIZE CLAUSE"); + + IF PARENT_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'SIZE /= " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE /= " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'SIZE)); + END IF; + + IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DT'SIZE)); + END IF; + + CHECK_1 (DT, 5, "DERIVED_TYPE"); + CHECK_2 (PT, 5, "PARENT_TYPE"); + RESULT; + +END CD1C03A; Index: cd1009o.ada =================================================================== --- cd1009o.ada (nonexistent) +++ cd1009o.ada (revision 338) @@ -0,0 +1,75 @@ +-- CD1009O.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 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART +-- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION +-- IS AN INTEGER TYPE, DECLARED IN THE VISIBLE PART OF THE SAME +-- PACKAGE. + +-- HISTORY: +-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST +-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- VCL 10/08/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009O IS +BEGIN + TEST ("CD1009O", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE " & + "PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " & + "WHOSE FULL DECLARATION IS AN INTEGER " & + "TYPE, DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS RANGE 0 .. 7; + + PRIVATE + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + X : CHECK_TYPE_1 := CHECK_TYPE_1 (IDENT_INT(1)); + + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & CHECK_TYPE_1'IMAGE(X)); + END IF; + + END; + + RESULT; +END CD1009O; Index: cd1c03c.ada =================================================================== --- cd1c03c.ada (nonexistent) +++ cd1c03c.ada (revision 338) @@ -0,0 +1,71 @@ +-- CD1C03C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE COLLECTION SIZE OF A DERIVED TYPE IS +-- INHERITED FROM THE PARENT IF THE COLLECTION SIZE OF +-- THE PARENT WAS DETERMINED BY A COLLECTION SIZE CLAUSE. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- JET 09/16/87 CREATED ORIGINAL TEST. +-- RJW 02/10/88 RENAMED FROM CD1C03C.TST. REMOVED MACRO - +-- ACC_SIZE. + +WITH REPORT; USE REPORT; +PROCEDURE CD1C03C IS + + SPECIFIED_SIZE : CONSTANT := 512; + + TYPE PARENT_TYPE IS ACCESS STRING; + + FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + +BEGIN + + TEST("CD1C03C", "CHECK THAT THE COLLECTION SIZE OF A " & + "DERIVED TYPE IS INHERITED FROM THE PARENT " & + "IF THE COLLECTION SIZE OF THE PARENT WAS " & + "DETERMINED BY A COLLECTION SIZE CLAUSE"); + + IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN SPECIFIED_SIZE. " & + "ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE /= + IDENT_INT (PARENT_TYPE'STORAGE_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD BE " & + "EQUAL TO PARENT_TYPE'STORAGE_SIZE. " & + "ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + RESULT; + +END CD1C03C; Index: cd1009q.ada =================================================================== --- cd1009q.ada (nonexistent) +++ cd1009q.ada (revision 338) @@ -0,0 +1,75 @@ +-- CD1009Q.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 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE +-- PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION +-- IS A FIXED POINT TYPE, DECLARED IN THE VISIBLE PART OF THE SAME +-- PACKAGE. + +-- HISTORY: +-- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST +-- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- VCL 10/21/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009Q IS +BEGIN + TEST ("CD1009Q", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A AN " & + "INCOMPLETE TYPE, WHOSE FULL DECLARATION IS A " & + "FIXED POINT TYPE, DECLARED IN THE VISIBLE " & + "PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0; + + SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 2.0; + PRIVATE + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + X : CHECK_TYPE_1 := CHECK_TYPE_1 ( IDENT_INT (1) ); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) ); + END IF; + + END; + + RESULT; +END CD1009Q; Index: cd2a53a.ada =================================================================== --- cd2a53a.ada (nonexistent) +++ cd2a53a.ada (revision 338) @@ -0,0 +1,217 @@ +-- CD2A53A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A +-- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE +-- NOT AFFECTED BY THE REPRESENTATION CLAUSE. + +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C) +-- and which support decimal small values: +-- The test must compile, bind, execute, report PASSED, and +-- complete normally. +-- +-- For other implementations: +-- This test may produce at least one error message at compilation, +-- and the error message is associated with one of the items marked: +-- -- N/A => ERROR. +-- The test will be recorded as Not_Applicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- All other behaviors are FAILING. +-- +-- HISTORY: +-- BCB 08/24/87 CREATED ORIGINAL TEST. +-- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE +-- SO THAT IT IS NOT A POWER OF TWO. +-- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES. +-- RLB 11/24/98 Added Ada 95 applicability criteria. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A53A IS + BASIC_SIZE : CONSTANT := 15; + BASIC_SMALL : CONSTANT := 0.01; + + ZERO : CONSTANT := 0.0; + + TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0; + + FOR CHECK_TYPE'SMALL USE BASIC_SMALL; -- N/A => ERROR. + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; -- N/A => ERROR. + + CNEG1 : CHECK_TYPE := -2.7; + CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + CPOS2 : CHECK_TYPE := 2.7; + CZERO : CHECK_TYPE; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := + (-2.7, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 2.7); + + TYPE REC_TYPE IS RECORD + COMPF : CHECK_TYPE := -2.7; + COMPN : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + COMPP : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + COMPL : CHECK_TYPE := 2.7; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (CN1IN, CP1IN : CHECK_TYPE; + CN2INOUT,CP2INOUT : IN OUT CHECK_TYPE; + CZOUT : OUT CHECK_TYPE) IS + BEGIN + + IF IDENT (CN1IN) + CP1IN NOT IN -2.04 .. -2.03 OR + CP2INOUT - IDENT (CP1IN) NOT IN 2.03 .. 2.04 THEN + FAILED ("INCORRECT RESULTS FOR " & + "BINARY ADDING OPERATORS - 1"); + END IF; + + IF CHECK_TYPE (CN1IN * IDENT (CP1IN)) NOT IN + -1.81 .. -1.78 OR + CHECK_TYPE (IDENT (CN2INOUT) / CP2INOUT) NOT IN + -0.13 .. -0.12 THEN + FAILED ("INCORRECT RESULTS FOR " & + "MULTIPLYING OPERATORS - 1"); + END IF; + + IF IDENT (CP1IN) NOT IN 0.66 .. 0.670 OR + CN2INOUT IN -0.32 .. 0.0 OR + IDENT (CN2INOUT) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + +BEGIN + TEST ("CD2A53A", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " & + "ARE GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " & + "AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CZERO) /= ZERO THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF CHECK_TYPE'FIRST > IDENT (-3.99) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF CHECK_TYPE'SMALL /= BASIC_SMALL THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SMALL"); + END IF; + + IF CHECK_TYPE'FORE /= 2 THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FORE"); + END IF; + + IF +IDENT (CNEG2) NOT IN -0.34 .. -0.33 OR + IDENT (-CPOS1) NOT IN -0.67 .. -0.66 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2"); + END IF; + + IF ABS IDENT (CNEG2) NOT IN 0.33 .. 0.34 OR + IDENT (ABS CPOS1) NOT IN 0.66 .. 0.670 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN + -2.04 .. -2.03 OR + CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN + 2.03 .. 2.04 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3"); + END IF; + + IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN + -1.81 .. -1.78 OR + CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN + -0.13 .. -0.12 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.66 .. 0.670 OR + CHARRAY (1) IN -0.32 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE"); + END IF; + + IF +IDENT (CHREC.COMPN) NOT IN -0.34 .. -0.33 OR + IDENT (-CHREC.COMPP) NOT IN -0.67 .. -0.66 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4"); + END IF; + + IF ABS IDENT (CHREC.COMPN) NOT IN 0.33 .. 0.34 OR + IDENT (ABS CHREC.COMPP) NOT IN 0.66 .. 0.670 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP) NOT IN 0.66 .. 0.670 OR + CHREC.COMPN IN -0.32 .. 0.0 OR + IDENT (CHREC.COMPN) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RESULT; + +END CD2A53A; Index: cd1009s.ada =================================================================== --- cd1009s.ada (nonexistent) +++ cd1009s.ada (revision 338) @@ -0,0 +1,72 @@ +-- CD1009S.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 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE +-- PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE +-- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART +-- OF THE SAME PACKAGE. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- VCL 10/09/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1009S IS +BEGIN + TEST ("CD1009S", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, " & + "WHOSE FULL TYPE DECLARATION IS AN ACCESS " & + "TYPE, DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10; + + TYPE CHECK_TYPE_1 IS PRIVATE; + + PROCEDURE P; + PRIVATE + TYPE CHECK_TYPE_1 IS ACCESS INTEGER; + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " & + "SMALL"); + END IF; + END P; + END PACK; + + USE PACK; + BEGIN + P; + END; + + RESULT; +END CD1009S; Index: cd1c03g.ada =================================================================== --- cd1c03g.ada (nonexistent) +++ cd1c03g.ada (revision 338) @@ -0,0 +1,65 @@ +-- CD1C03G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE SIZE OF A DERIVED ENUMERATION TYPE IS +-- INHERITED FROM THE PARENT IF THE SIZE OF THE PARENT WAS +-- DETERMINED BY AN ENUMERATION REPRESENTATION CLAUSE. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- JET 09/17/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE CD1C03G IS + + TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW); + + TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW); + + FOR PARENT_TYPE USE + (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + +BEGIN + + TEST("CD1C03G", "CHECK THAT THE SIZE OF A DERIVED ENUMERATION " & + "TYPE IS INHERITED FROM THE PARENT IF THE " & + "SIZE OF THE PARENT WAS DETERMINED BY AN " & + "ENUMERATION REPRESENTATION CLAUSE"); + + IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN + COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " & + "REPRESENTATION CLAUSE"); + END IF; + + IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + RESULT; + +END CD1C03G; Index: cd2a53e.ada =================================================================== --- cd2a53e.ada (nonexistent) +++ cd2a53e.ada (revision 338) @@ -0,0 +1,235 @@ +-- CD2A53E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A +-- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE WHEN THE TYPE +-- IS PASSED AS A GENERIC ACTUAL PARAMETER. + +-- HISTORY: +-- BCB 08/24/87 CREATED ORIGINAL TEST. +-- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND CHANGED +-- OPERATORS ON 'SIZE TESTS. +-- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES. +-- MRM 07/16/92 FIX ALIGNMENT OF BLOCK BODY +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A53E IS + + BASIC_SIZE : CONSTANT := INTEGER'SIZE/2; + BASIC_SMALL : CONSTANT := 2.0 ** (-4); + B : BOOLEAN; + + TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0; + FOR CHECK_TYPE'SMALL USE BASIC_SMALL; + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + +BEGIN + + TEST ("CD2A53E", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " & + "ARE GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " & + "AFFECTED BY THE REPRESENTATION CLAUSE WHEN " & + "THE TYPE IS PASSED AS A GENERIC ACTUAL " & + "PARAMETER"); + + DECLARE + + GENERIC + + TYPE FIXED_ELEMENT IS DELTA <>; + + FUNCTION FUNC RETURN BOOLEAN; + + FUNCTION FUNC RETURN BOOLEAN IS + + ZERO : CONSTANT := 0.0; + + TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + CNEG1 : FIXED_ELEMENT := -3.5; + CNEG2 : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0); + CPOS1 : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0); + CPOS2 : FIXED_ELEMENT := 3.5; + CZERO : FIXED_ELEMENT; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF FIXED_ELEMENT; + CHARRAY : ARRAY_TYPE := + (-3.5, FIXED_ELEMENT (-1.0/3.0), FIXED_ELEMENT + (4.0/6.0), 3.5); + + TYPE REC_TYPE IS RECORD + COMPF : FIXED_ELEMENT := -3.5; + COMPN : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0); + COMPP : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0); + COMPL : FIXED_ELEMENT := 3.5; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : FIXED_ELEMENT) RETURN + FIXED_ELEMENT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (CN1IN, CP1IN : FIXED_ELEMENT; + CN2INOUT,CP2INOUT : IN OUT FIXED_ELEMENT; + CZOUT : OUT FIXED_ELEMENT) + IS + BEGIN + + IF +IDENT (CN2INOUT) NOT IN -0.375 .. -0.3125 OR + IDENT (-CP1IN) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "UNARY ADDING OPERATORS - 1"); + END IF; + + IF ABS IDENT (CN2INOUT) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CP1IN) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "ABSOLUTE VALUE OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + + BEGIN -- FUNC + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF IDENT (CZERO) /= ZERO THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF FIXED_ELEMENT'LAST < IDENT (3.9375) THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'LAST"); + END IF; + + IF FIXED_ELEMENT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SIZE"); + END IF; + + IF FIXED_ELEMENT'SMALL /= BASIC_SMALL THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SMALL"); + END IF; + + IF FIXED_ELEMENT'AFT /= 1 THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'AFT"); + END IF; + + IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR + CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING " & + "OPERATORS - 2"); + END IF; + + IF FIXED_ELEMENT (CNEG1 * IDENT (CPOS1)) NOT IN + -2.4375 .. -2.1875 OR + FIXED_ELEMENT (IDENT (CNEG2) / CPOS2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING " & + "OPERATORS - 2"); + END IF; + + IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR + CNEG2 IN -0.25 .. 0.0 OR + IDENT (CNEG2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING " & + "OPERATORS - 3"); + END IF; + + IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR + CHARRAY (1) IN -0.25 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE"); + END IF; + + IF IDENT (CHREC.COMPF) + CHREC.COMPP NOT IN + -2.875 .. -2.8125 OR + CHREC.COMPL - IDENT (CHREC.COMPP) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING " & + "OPERATORS - 4"); + END IF; + + IF FIXED_ELEMENT (CHREC.COMPF * IDENT (CHREC.COMPP)) + NOT IN -2.4375 .. -2.1875 OR + FIXED_ELEMENT (IDENT (CHREC.COMPN) / CHREC.COMPL) + NOT IN -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING " & + "OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP) NOT IN 0.625 .. 0.6875 OR + CHREC.COMPN IN -0.25 .. 0.0 OR + IDENT (CHREC.COMPN) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RETURN TRUE; + + END FUNC; + + FUNCTION NEWFUNC IS NEW FUNC(CHECK_TYPE); + BEGIN + B := NEWFUNC; + END; + + RESULT; + +END CD2A53E; Index: cd1c03i.ada =================================================================== --- cd1c03i.ada (nonexistent) +++ cd1c03i.ada (revision 338) @@ -0,0 +1,115 @@ +-- CD1C03I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE RECORD SIZE AND THE COMPONENT POSITIONS AND +-- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE +-- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY THE +-- PRAGMA PACK. + +-- HISTORY: +-- JET 09/17/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE CD1C03I IS + + TYPE E_TYPE IS (RED, BLUE, GREEN); + + TYPE PARENT_TYPE IS + RECORD + B1: BOOLEAN := TRUE; + I : INTEGER RANGE 0 .. 127 := 127; + C : CHARACTER := 'S'; + B2: BOOLEAN := FALSE; + E : E_TYPE := BLUE; + END RECORD; + + PRAGMA PACK (PARENT_TYPE); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + P_REC : PARENT_TYPE; + REC : DERIVED_TYPE; + +BEGIN + + TEST("CD1C03I", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " & + "POSITIONS AND SIZES OF A DERIVED RECORD " & + "TYPE ARE INHERITED FROM THE PARENT IF THOSE " & + "ASPECTS OF THE PARENT WERE DETERMINED BY " & + "THE PRAGMA PACK"); + + IF DERIVED_TYPE'SIZE /= PARENT_TYPE'SIZE THEN + FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + IF REC.I'SIZE /= P_REC.I'SIZE OR + REC.C'SIZE /= P_REC.C'SIZE OR + REC.B1'SIZE /= P_REC.B1'SIZE OR + REC.B2'SIZE /= P_REC.B2'SIZE OR + REC.E'SIZE /= P_REC.E'SIZE THEN + FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + REC := (FALSE, 12, 'T', TRUE, RED); + + IF (REC.I /= 12) OR (REC.C /= 'T') OR + REC.B1 OR (NOT REC.B2) OR (REC.E /= RED) THEN + FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " & + "INCORRECT"); + END IF; + + IF REC.I'POSITION /= P_REC.I'POSITION OR + REC.C'POSITION /= P_REC.C'POSITION OR + REC.B1'POSITION /= P_REC.B1'POSITION OR + REC.B2'POSITION /= P_REC.B2'POSITION OR + REC.E'POSITION /= P_REC.E'POSITION THEN + FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR + REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR + REC.B1'FIRST_BIT /= P_REC.B1'FIRST_BIT OR + REC.B2'FIRST_BIT /= P_REC.B2'FIRST_BIT OR + REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN + FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR + REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR + REC.B1'LAST_BIT /= P_REC.B1'LAST_BIT OR + REC.B2'LAST_BIT /= P_REC.B2'LAST_BIT OR + REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN + FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + RESULT; + +END CD1C03I; Index: cd1009w.ada =================================================================== --- cd1009w.ada (nonexistent) +++ cd1009w.ada (revision 338) @@ -0,0 +1,71 @@ +-- CD1009W.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 ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN +-- THE PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL +-- TYPE DECLARATION IS AN ENUMERATION TYPE, DECLARED IN THE +-- VISIBLE PART OF THE SAME PACKAGE. + +-- HISTORY: +-- VCL 10/09/87 CREATED ORIGINAL TEST. +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1009W IS +BEGIN + TEST ("CD1009W", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " & + "GIVEN IN THE PRIVATE PART OF A PACKAGE FOR " & + "A PRIVATE TYPE, WHOSE FULL TYPE DECLARATION " & + "IS AN ENUMERATION TYPE, DECLARED IN " & + "THE VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE CHECK_TYPE_1 IS PRIVATE; + PRIVATE + TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8); + FOR CHECK_TYPE_1 USE (A0 => 0, + A2 => 2, + A4 => 4, + A8 => 16); + TYPE INT1 IS RANGE 0 .. 16; + FOR INT1'SIZE USE CHECK_TYPE_1'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (A8, 16, "CHECK_TYPE_1"); + END PACK; + + USE PACK; + BEGIN + NULL; + END; + + RESULT; +END CD1009W; Index: cde0001.a =================================================================== --- cde0001.a (nonexistent) +++ cde0001.a (revision 338) @@ -0,0 +1,324 @@ +-- CDE0001.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 following names can be used in the declaration of a +-- generic formal parameter (object, array type, or access type) without +-- causing freezing of the named type: +-- (1) The name of a private type, +-- (2) A name that denotes a subtype of a private type, and +-- (3) A name that denotes a composite type with a subcomponent of a +-- private type (or subtype). +-- Check for untagged and tagged types. +-- +-- TEST DESCRIPTION: +-- This transition test defines private and limited private types, +-- subtypes of these private types, records and arrays of both types and +-- subtypes, a tagged type and a private extension. +-- This test creates examples where the above types are used in the +-- definition of several generic formal type parameters (object, array +-- type, or access type) in both visible and private parts. These +-- visible and private generic packages are instantiated in the body of +-- the public child and the private child, respectively. +-- The main program utilizes the functions declared in the public child +-- to verify results of the instantiations. +-- +-- Inspired by B74103F.ADA. +-- +-- +-- CHANGE HISTORY: +-- 12 Mar 96 SAIC Initial version for ACVC 2.1. +-- 05 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate for CDE0001. +-- 21 Nov 98 RLB Added pragma Elaborate for CDE0001 to CDE0001_3. +--! + +package CDE0001_0 is + + subtype Small_Int is Integer range 1 .. 2; + + type Private_Type is private; + type Limited_Private is limited private; + + subtype Private_Subtype is Private_Type; + subtype Limited_Private_Subtype is Limited_Private; + + type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype; + + type Rec_Of_Limited_Private is + record + C1 : Limited_Private; + end record; + + type Rec_Of_Private_SubType is + record + C1 : Private_SubType; + end record; + + type Tag_Type is tagged + record + C1 : Small_Int; + end record; + + type New_TagType is new Tag_Type with private; + + generic + + Formal_Obj01 : in out Private_Type; -- Formal objects defined + Formal_Obj02 : in out Limited_Private; -- by names of private + Formal_Obj03 : in out Private_Subtype; -- types, names that + Formal_Obj04 : in out Limited_Private_Subtype; -- denotes subtypes of + Formal_Obj05 : in out New_TagType; -- the private types. + + package CDE0001_1 is + procedure Assign_Objects; + + end CDE0001_1; + +private + + generic + -- Formal array types of a private type, a composite type with a + -- subcomponent of a private type. + + type Formal_Arr01 is array (Small_Int) of Private_Type; + type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private; + + -- Formal access types of composite types with a subcomponent of + -- a private subtype. + + type Formal_Acc01 is access Rec_Of_Private_Subtype; + type Formal_Acc02 is access Array_Of_LP_Subtype; + + package CDE0001_2 is + + procedure Assign_Arrays (P1 : out Formal_Arr01; + P2 : out Formal_Arr02); + + procedure Assign_Access (P1 : out Formal_Acc01; + P2 : out Formal_Acc02); + + end CDE0001_2; + + ---------------------------------------------------------- + type Private_Type is range 1 .. 10; + type Limited_Private is (Eh, Bee, Sea, Dee); + type New_TagType is new Tag_Type with + record + C2 : Private_Type; + end record; + +end CDE0001_0; + + --==================================================================-- + +package body CDE0001_0 is + + package body CDE0001_1 is + + procedure Assign_Objects is + begin + Formal_Obj01 := Private_Type'First; + Formal_Obj02 := Limited_Private'Last; + Formal_Obj03 := Private_Subtype'Last; + Formal_Obj04 := Limited_Private_Subtype'First; + Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last); + + end Assign_Objects; + + end CDE0001_1; + + --===========================================================-- + + package body CDE0001_2 is + + procedure Assign_Arrays (P1 : out Formal_Arr01; + P2 : out Formal_Arr02) is + begin + P1(1) := Private_Type'Pred(Private_Type'Last); + P1(2) := Private_Type'Succ(Private_Type'First); + P2(1).C1 := Limited_Private'Succ(Limited_Private'First); + P2(2).C1 := Limited_Private'Pred(Limited_Private'Last); + + end Assign_Arrays; + + ----------------------------------------------------------------- + procedure Assign_Access (P1 : out Formal_Acc01; + P2 : out Formal_Acc02) is + begin + P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last); + P2 := new Array_Of_LP_Subtype'(Eh, Dee); + + end Assign_Access; + + end CDE0001_2; + +end CDE0001_0; + + --==================================================================-- + +-- The following private child package instantiates its parent private generic +-- package. + +with CDE0001_0; +pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated. +private +package CDE0001_0.CDE0001_3 is + + type Arr01 is array (Small_Int) of Private_Type; + type Arr02 is array (Small_Int) of Rec_Of_Limited_Private; + type Acc01 is access Rec_Of_Private_Subtype; + type Acc02 is access Array_Of_LP_Subtype; + + package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02); + + Arr01_Obj : Arr01; + Arr02_Obj : Arr02; + Acc01_Obj : Acc01; + Acc02_Obj : Acc02; + +end CDE0001_0.CDE0001_3; + + --==================================================================-- + +package CDE0001_0.CDE0001_4 is + + -- The following functions check the private types defined in the parent + -- and the private child package from within the client program. + + function Verify_Objects return Boolean; + + function Verify_Arrays return Boolean; + + function Verify_Access return Boolean; + +end CDE0001_0.CDE0001_4; + + --==================================================================-- + +with CDE0001_0.CDE0001_3; -- private sibling. + +pragma Elaborate (CDE0001_0.CDE0001_3); + +package body CDE0001_0.CDE0001_4 is + + Obj1 : Private_Type := 2; + Obj2 : Limited_Private := Bee; + Obj3 : Private_Subtype := 3; + Obj4 : Limited_Private_Subtype := Sea; + Obj5 : New_TagType := (1, 5); + + -- Instantiate the generic package declared in the visible part of + -- the parent. + + package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5); + + --------------------------------------------------- + function Verify_Objects return Boolean is + Result : Boolean := False; + begin + if Obj1 = 1 and + Obj2 = Dee and + Obj3 = 10 and + Obj4 = Eh and + Obj5.C1 = 2 and + Obj5.C2 = 10 then + Result := True; + end if; + + return Result; + + end Verify_Objects; + + --------------------------------------------------- + function Verify_Arrays return Boolean is + Result : Boolean := False; + begin + if CDE0001_0.CDE0001_3.Arr01_Obj(1) = 9 and + CDE0001_0.CDE0001_3.Arr01_Obj(2) = 2 and + CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee and + CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea then + Result := True; + end if; + + return Result; + + end Verify_Arrays; + + --------------------------------------------------- + function Verify_Access return Boolean is + Result : Boolean := False; + begin + if CDE0001_0.CDE0001_3.Acc01_Obj.C1 = 10 and + CDE0001_0.CDE0001_3.Acc02_Obj(1) = Eh and + CDE0001_0.CDE0001_3.Acc02_Obj(2) = Dee then + Result := True; + end if; + + return Result; + + end Verify_Access; + +begin + + Formal_Obj_Pck.Assign_Objects; + + CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays + (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj); + CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access + (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj); + +end CDE0001_0.CDE0001_4; + + --==================================================================-- + +with Report; +with CDE0001_0.CDE0001_4; + +procedure CDE0001 is + +begin + + Report.Test ("CDE0001", "Check that the name of the private type, a " & + "name that denotes a subtype of the private type, or a " & + "name that denotes a composite type with a subcomponent " & + "of a private type can be used in the declaration of a " & + "generic formal type parameter without causing freezing " & + "of the named type"); + + if not CDE0001_0.CDE0001_4.Verify_Objects then + Report.Failed ("Wrong values for formal objects"); + end if; + + if not CDE0001_0.CDE0001_4.Verify_Arrays then + Report.Failed ("Wrong values for formal array types"); + end if; + + if not CDE0001_0.CDE0001_4.Verify_Access then + Report.Failed ("Wrong values for formal access types"); + end if; + + Report.Result; + +end CDE0001; Index: cd1009y.ada =================================================================== --- cd1009y.ada (nonexistent) +++ cd1009y.ada (revision 338) @@ -0,0 +1,115 @@ +-- CD1009Y.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 RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE +-- PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE +-- DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE PART +-- OF THE SAME PACKAGE. + +-- HISTORY: +-- VCL 10/09/87 CREATED ORIGINAL TEST. +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED +-- CHECKS FOR FAILURE. + +WITH SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CD1009Y IS +BEGIN + TEST ("CD1009Y", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE FOR A " & + "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " & + "A RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_TYPE_1 IS PRIVATE; + + PROCEDURE P; + PRIVATE + TYPE CHECK_TYPE_1 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + FOR CHECK_TYPE_1 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + R1 : CHECK_TYPE_1; + BEGIN + IF R1.I1'FIRST_BIT /= 0 OR + R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I1"); + END IF; + + IF R1.B1'FIRST_BIT /= 0 OR + R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B1'POSITION /= 1 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B1"); + END IF; + + IF R1.B2'FIRST_BIT /= 0 OR + R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B2'POSITION /= 2 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B2"); + END IF; + + IF R1.I2'FIRST_BIT /= 0 OR + R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I2'POSITION /= 3 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I2"); + END IF; + END P; + END PACK; + + USE PACK; + + BEGIN + P; + END; + + RESULT; +END CD1009Y; Index: cd3014d.ada =================================================================== --- cd3014d.ada (nonexistent) +++ cd3014d.ada (revision 338) @@ -0,0 +1,135 @@ +-- CD3014D.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 ENUMERATION TYPE WITH A REPRESENTATION CLAUSE IN A +-- GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING RELATIONS, +-- INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS. + +-- HISTORY +-- DHH 09/30/87 CREATED ORIGINAL TEST. +-- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO +-- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. +-- REVISED CHECK FOR ARRAY INDEXING. +-- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR +-- MESSAGE. + +WITH REPORT; USE REPORT; +PROCEDURE CD3014D IS + +BEGIN + + TEST ("CD3014D", "CHECK THAT AN ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " & + "BE USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED); + + FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16, + YELLOW => 19, BLUE => 41, RED => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'PRED(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND + 'Y' <= COLOR1 AND COLOR1 > 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND + BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND + BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; +END CD3014D; Index: cd3014f.ada =================================================================== --- cd3014f.ada (nonexistent) +++ cd3014f.ada (revision 338) @@ -0,0 +1,88 @@ +-- CD3014F.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN +-- IN THE VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A +-- TYPE DECLARED IN THE VISIBLE PART. + +-- HISTORY +-- DHH 09/30/87 CREATED ORIGINAL TEST +-- DHH 03/29/89 CHANGED FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. +-- RJW 09/18/89 REMOVED THE COMMENT "-- N/A => ERROR.". + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3014F IS + +BEGIN + + TEST ("CD3014F", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE CAN BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A GENERIC PACKAGE FOR " & + "A TYPE DECLARED IN THE VISIBLE PART"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y'); + TYPE NEWHUE IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + A : HUE := BLUE; + + TYPE INT1 IS RANGE 8 .. 13; + FOR INT1'SIZE USE HUE'SIZE; + + PRIVATE + + FOR NEWHUE USE (RED => 2, BLUE => 4, YELLOW => 6, + 'R' => 8, 'B' => 10, 'Y' => 12); + + B : NEWHUE := RED; + TYPE INT2 IS RANGE 2 .. 12; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + END GENPACK; + + PACKAGE BODY GENPACK IS + BEGIN + CHECK_1 ('B', 12, "HUE"); + CHECK_2 ('B', 10, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; +END CD3014F; Index: cd10002.a =================================================================== --- cd10002.a (nonexistent) +++ cd10002.a (revision 338) @@ -0,0 +1,1198 @@ +-- CD10002.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that operational items are allowed in some contexts where +-- representation items are not: +-- +-- 1 - Check that the name of an incompletely defined type can be used +-- when specifying an operational item. (RM95/TC1 7.3(5)). +-- +-- 2 - Check that operational items can be specified for a descendant of +-- a generic formal untagged type. (RM95/TC1 13.1(10)). +-- +-- 3 - Check that operational items can be specified for a derived +-- untagged type even if the parent type is a by-reference type or +-- has user-defined primitive subprograms. (RM95/TC1 13.1(11/1)). +-- +-- (Defect Report 8652/0009, as reflected in Technical Corrigendum 1). +-- +-- CHANGE HISTORY: +-- 19 JAN 2001 PHL Initial version. +-- 3 DEC 2001 RLB Reformatted for ACATS. +-- 3 OCT 2002 RLB Corrected incorrect type derivations. +-- +--! +with Ada.Streams; +use Ada.Streams; +package CD10002_0 is + + type Kinds is (Read, Write, Input, Output); + type Counts is array (Kinds) of Natural; + + generic + type T is private; + package Nonlimited_Stream_Ops is + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T); + function Input (Stream : access Root_Stream_Type'Class) return T; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T); + + function Get_Counts return Counts; + + end Nonlimited_Stream_Ops; + + generic + type T (<>) is limited private; -- Should be self-initializing. + C : in out T; + package Limited_Stream_Ops is + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T); + function Input (Stream : access Root_Stream_Type'Class) return T; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T); + + function Get_Counts return Counts; + + end Limited_Stream_Ops; + +end CD10002_0; + + +package body CD10002_0 is + + package body Nonlimited_Stream_Ops is + Cnts : Counts := (others => 0); + X : T; -- Initialized by Write/Output. + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is + begin + X := Item; + Cnts (Write) := Cnts (Write) + 1; + end Write; + + function Input (Stream : access Root_Stream_Type'Class) return T is + begin + Cnts (Input) := Cnts (Input) + 1; + return X; + end Input; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is + begin + Cnts (Read) := Cnts (Read) + 1; + Item := X; + end Read; + + procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is + begin + X := Item; + Cnts (Output) := Cnts (Output) + 1; + end Output; + + function Get_Counts return Counts is + begin + return Cnts; + end Get_Counts; + + end Nonlimited_Stream_Ops; + + package body Limited_Stream_Ops is + Cnts : Counts := (others => 0); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Write) := Cnts (Write) + 1; + end Write; + + function Input (Stream : access Root_Stream_Type'Class) return T is + begin + Cnts (Input) := Cnts (Input) + 1; + return C; + end Input; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is + begin + Cnts (Read) := Cnts (Read) + 1; + end Read; + + procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Output) := Cnts (Output) + 1; + end Output; + + function Get_Counts return Counts is + begin + return Cnts; + end Get_Counts; + + end Limited_Stream_Ops; + +end CD10002_0; + + +with Ada.Streams; +use Ada.Streams; +package CD10002_1 is + + type Dummy_Stream is new Root_Stream_Type with null record; + procedure Read (Stream : in out Dummy_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + procedure Write (Stream : in out Dummy_Stream; + Item : Stream_Element_Array); + +end CD10002_1; + + +with Report; +use Report; +package body CD10002_1 is + + procedure Read (Stream : in out Dummy_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Failed ("Unexpected call to the Read operation of Dummy_Stream"); + end Read; + + procedure Write (Stream : in out Dummy_Stream; + Item : Stream_Element_Array) is + begin + Failed ("Unexpected call to the Write operation of Dummy_Stream"); + end Write; + +end CD10002_1; + + +with Ada.Streams; +use Ada.Streams; +with CD10002_0; +package CD10002_Deriv is + + -- Parent has user-defined subprograms. + + type T1 is new Boolean; + function Is_Odd (X : Integer) return T1; + + type T2 is + record + F : Float; + end record; + procedure Print (X : T2); + + type T3 is array (Boolean) of Duration; + function "+" (L, R : T3) return T3; + + -- Parent is by-reference. No need to check the case where the parent + -- is tagged, because the defect report only deals with untagged types. + + task type T4 is + end T4; + + protected type T5 is + end T5; + + type T6 (D : access Integer := new Integer'(2)) is limited null record; + + type T7 is array (Character) of T6; + + package P is + type T8 is limited private; + private + type T8 is new T5; + end P; + + type Nt1 is new T1; + type Nt2 is new T2; + type Nt3 is new T3; + type Nt4 is new T4; + type Nt5 is new T5; + type Nt6 is new T6; + type Nt7 is new T7; + type Nt8 is new P.T8; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt1'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2); + function Input (Stream : access Root_Stream_Type'Class) return Nt2; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3); + function Input (Stream : access Root_Stream_Type'Class) return Nt3; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4); + function Input (Stream : access Root_Stream_Type'Class) return Nt4; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5); + function Input (Stream : access Root_Stream_Type'Class) return Nt5; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6); + function Input (Stream : access Root_Stream_Type'Class) return Nt6; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7); + function Input (Stream : access Root_Stream_Type'Class) return Nt7; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8); + function Input (Stream : access Root_Stream_Type'Class) return Nt8; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8); + + for Nt1'Write use Write; + for Nt1'Read use Read; + for Nt1'Output use Output; + for Nt1'Input use Input; + + for Nt2'Write use Write; + for Nt2'Read use Read; + for Nt2'Output use Output; + for Nt2'Input use Input; + + for Nt3'Write use Write; + for Nt3'Read use Read; + for Nt3'Output use Output; + for Nt3'Input use Input; + + for Nt4'Write use Write; + for Nt4'Read use Read; + for Nt4'Output use Output; + for Nt4'Input use Input; + + for Nt5'Write use Write; + for Nt5'Read use Read; + for Nt5'Output use Output; + for Nt5'Input use Input; + + for Nt6'Write use Write; + for Nt6'Read use Read; + for Nt6'Output use Output; + for Nt6'Input use Input; + + for Nt7'Write use Write; + for Nt7'Read use Read; + for Nt7'Output use Output; + for Nt7'Input use Input; + + for Nt8'Write use Write; + for Nt8'Read use Read; + for Nt8'Output use Output; + for Nt8'Input use Input; + + -- All these variables are self-initializing. + C4 : Nt4; + C5 : Nt5; + C6 : Nt6; + C7 : Nt7; + C8 : Nt8; + + package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base); + package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2); + package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3); + package Nt4_Ops is new CD10002_0.Limited_Stream_Ops (Nt4, C4); + package Nt5_Ops is new CD10002_0.Limited_Stream_Ops (Nt5, C5); + package Nt6_Ops is new CD10002_0.Limited_Stream_Ops (Nt6, C6); + package Nt7_Ops is new CD10002_0.Limited_Stream_Ops (Nt7, C7); + package Nt8_Ops is new CD10002_0.Limited_Stream_Ops (Nt8, C8); + +end CD10002_Deriv; + + +package body CD10002_Deriv is + + function Is_Odd (X : Integer) return T1 is + begin + return True; + end Is_Odd; + procedure Print (X : T2) is + begin + null; + end Print; + function "+" (L, R : T3) return T3 is + begin + return (False => L (False) + R (True), True => L (True) + R (False)); + end "+"; + task body T4 is + begin + null; + end T4; + protected body T5 is + end T5; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base + renames Nt1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base) + renames Nt1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2) + renames Nt2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt2 + renames Nt2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2) + renames Nt2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2) + renames Nt2_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3) + renames Nt3_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt3 + renames Nt3_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3) + renames Nt3_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3) + renames Nt3_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4) + renames Nt4_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt4 + renames Nt4_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4) + renames Nt4_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4) + renames Nt4_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5) + renames Nt5_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt5 + renames Nt5_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5) + renames Nt5_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5) + renames Nt5_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6) + renames Nt6_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt6 + renames Nt6_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6) + renames Nt6_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6) + renames Nt6_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt7 + renames Nt7_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7) + renames Nt7_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8) + renames Nt8_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt8 + renames Nt8_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8) + renames Nt8_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8) + renames Nt8_Ops.Output; + +end CD10002_Deriv; + + +with Ada.Streams; +use Ada.Streams; +with CD10002_0; +generic + type T1 is (<>); + type T2 is range <>; + type T3 is mod <>; + type T4 is digits <>; + type T5 is delta <>; + type T6 is delta <> digits <>; + type T7 is access T3; + type T8 is new Boolean; + type T9 is private; + type T10 (<>) is limited private; -- Should be self-initializing. + C10 : in out T10; + type T11 is array (T1) of T2; +package CD10002_Gen is + + -- Direct descendants. + type Nt1 is new T1; + type Nt2 is new T2; + type Nt3 is new T3; + type Nt4 is new T4; + type Nt5 is new T5; + type Nt6 is new T6; + type Nt7 is new T7; + type Nt8 is new T8; + type Nt9 is new T9; + type Nt10 is new T10; + type Nt11 is new T11; + + -- Indirect descendants (only pick two, a limited one and a non-limited + -- one). + type Nt12 is new Nt10; + type Nt13 is new Nt11; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt1'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt2'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt3'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt4'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt5'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt6'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7); + function Input (Stream : access Root_Stream_Type'Class) return Nt7; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt8'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9); + function Input (Stream : access Root_Stream_Type'Class) return Nt9; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10); + function Input (Stream : access Root_Stream_Type'Class) return Nt10; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11); + function Input (Stream : access Root_Stream_Type'Class) return Nt11; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12); + function Input (Stream : access Root_Stream_Type'Class) return Nt12; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13); + function Input (Stream : access Root_Stream_Type'Class) return Nt13; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13); + + for Nt1'Write use Write; + for Nt1'Read use Read; + for Nt1'Output use Output; + for Nt1'Input use Input; + + for Nt2'Write use Write; + for Nt2'Read use Read; + for Nt2'Output use Output; + for Nt2'Input use Input; + + for Nt3'Write use Write; + for Nt3'Read use Read; + for Nt3'Output use Output; + for Nt3'Input use Input; + + for Nt4'Write use Write; + for Nt4'Read use Read; + for Nt4'Output use Output; + for Nt4'Input use Input; + + for Nt5'Write use Write; + for Nt5'Read use Read; + for Nt5'Output use Output; + for Nt5'Input use Input; + + for Nt6'Write use Write; + for Nt6'Read use Read; + for Nt6'Output use Output; + for Nt6'Input use Input; + + for Nt7'Write use Write; + for Nt7'Read use Read; + for Nt7'Output use Output; + for Nt7'Input use Input; + + for Nt8'Write use Write; + for Nt8'Read use Read; + for Nt8'Output use Output; + for Nt8'Input use Input; + + for Nt9'Write use Write; + for Nt9'Read use Read; + for Nt9'Output use Output; + for Nt9'Input use Input; + + for Nt10'Write use Write; + for Nt10'Read use Read; + for Nt10'Output use Output; + for Nt10'Input use Input; + + for Nt11'Write use Write; + for Nt11'Read use Read; + for Nt11'Output use Output; + for Nt11'Input use Input; + + for Nt12'Write use Write; + for Nt12'Read use Read; + for Nt12'Output use Output; + for Nt12'Input use Input; + + for Nt13'Write use Write; + for Nt13'Read use Read; + for Nt13'Output use Output; + for Nt13'Input use Input; + + type Null_Record is null record; + + package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base); + package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2'Base); + package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3'Base); + package Nt4_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt4'Base); + package Nt5_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt5'Base); + package Nt6_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt6'Base); + package Nt7_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt7); + package Nt8_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt8'Base); + package Nt9_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt9); + package Nt11_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt11); + package Nt13_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt13); + + function Get_Nt10_Counts return CD10002_0.Counts; + function Get_Nt12_Counts return CD10002_0.Counts; + +end CD10002_Gen; + + +package body CD10002_Gen is + + use CD10002_0; + + Nt10_Cnts : Counts := (others => 0); + Nt12_Cnts : Counts := (others => 0); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base + renames Nt1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base) + renames Nt1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base) + renames Nt2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base + renames Nt2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2'Base) + renames Nt2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base) + renames Nt2_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base) + renames Nt3_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base + renames Nt3_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3'Base) + renames Nt3_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base) + renames Nt3_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base) + renames Nt4_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base + renames Nt4_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4'Base) + renames Nt4_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base) + renames Nt4_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base) + renames Nt5_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base + renames Nt5_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5'Base) + renames Nt5_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base) + renames Nt5_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base) + renames Nt6_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base + renames Nt6_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6'Base) + renames Nt6_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base) + renames Nt6_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt7 + renames Nt7_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7) + renames Nt7_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base) + renames Nt8_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base + renames Nt8_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8'Base) + renames Nt8_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base) + renames Nt8_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9) + renames Nt9_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt9 + renames Nt9_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9) + renames Nt9_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9) + renames Nt9_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10) is + begin + Nt10_Cnts (Write) := Nt10_Cnts (Write) + 1; + end Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt10 is + begin + Nt10_Cnts (Input) := Nt10_Cnts (Input) + 1; + return Nt10 (C10); + end Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10) is + begin + Nt10_Cnts (Read) := Nt10_Cnts (Read) + 1; + end Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10) is + begin + Nt10_Cnts (Output) := Nt10_Cnts (Output) + 1; + end Output; + function Get_Nt10_Counts return CD10002_0.Counts is + begin + return Nt10_Cnts; + end Get_Nt10_Counts; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11) + renames Nt11_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt11 + renames Nt11_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11) + renames Nt11_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11) + renames Nt11_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12) is + begin + Nt12_Cnts (Write) := Nt12_Cnts (Write) + 1; + end Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt12 is + begin + Nt12_Cnts (Input) := Nt12_Cnts (Input) + 1; + return Nt12 (C10); + end Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12) is + begin + Nt12_Cnts (Read) := Nt12_Cnts (Read) + 1; + end Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12) is + begin + Nt12_Cnts (Output) := Nt12_Cnts (Output) + 1; + end Output; + function Get_Nt12_Counts return CD10002_0.Counts is + begin + return Nt12_Cnts; + end Get_Nt12_Counts; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13) + renames Nt13_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt13 + renames Nt13_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13) + renames Nt13_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13) + renames Nt13_Ops.Output; + +end CD10002_Gen; + + +with Ada.Streams; +use Ada.Streams; +with CD10002_0; +package CD10002_Priv is + + External_Tag_1 : constant String := "Isaac Newton"; + External_Tag_2 : constant String := "Albert Einstein"; + + type T1 is tagged private; + type T2 is tagged + record + C : T1; + end record; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T1); + function Input (Stream : access Root_Stream_Type'Class) return T1; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T1); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T2); + function Input (Stream : access Root_Stream_Type'Class) return T2; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T2); + + for T1'Write use Write; + for T1'Input use Input; + + for T2'Read use Read; + for T2'Output use Output; + for T2'External_Tag use External_Tag_2; + + function Get_T1_Counts return CD10002_0.Counts; + function Get_T2_Counts return CD10002_0.Counts; + +private + + for T1'Read use Read; + for T1'Output use Output; + for T1'External_Tag use External_Tag_1; + + for T2'Write use Write; + for T2'Input use Input; + + type T1 is tagged null record; + + package T1_Ops is new CD10002_0.Nonlimited_Stream_Ops (T1); + package T2_Ops is new CD10002_0.Nonlimited_Stream_Ops (T2); + +end CD10002_Priv; + + +package body CD10002_Priv is + procedure Write (Stream : access Root_Stream_Type'Class; Item : T1) + renames T1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return T1 + renames T1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1) + renames T1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : T1) + renames T1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T2) + renames T2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return T2 + renames T2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2) + renames T2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : T2) + renames T2_Ops.Output; + + function Get_T1_Counts return CD10002_0.Counts renames T1_Ops.Get_Counts; + function Get_T2_Counts return CD10002_0.Counts renames T2_Ops.Get_Counts; +end CD10002_Priv; + + +with Ada.Streams; +use Ada.Streams; +with Report; +use Report; +with System; +with CD10002_0; +with CD10002_1; +with CD10002_Deriv; +with CD10002_Gen; +with CD10002_Priv; +procedure CD10002 is + + package Deriv renames CD10002_Deriv; + generic package Gen renames CD10002_Gen; + package Priv renames CD10002_Priv; + + type Stream_Ops is (Read, Write, Input, Output); + type Counts is array (Stream_Ops) of Natural; + + S : aliased CD10002_1.Dummy_Stream; + +begin + Test ("CD10002", + "Check that operational items are allowed in some contexts " & + "where representation items are not"); + + Test_Priv: + declare + X1 : Priv.T1; + X2 : Priv.T2; + use CD10002_0; + begin + Comment + ("Check that the name of an incompletely defined type can be " & + "used when specifying an operational item"); + + -- Partial view of a private type. + Priv.T1'Write (S'Access, X1); + Priv.T1'Read (S'Access, X1); + Priv.T1'Output (S'Access, X1); + X1 := Priv.T1'Input (S'Access); + + if Priv.Get_T1_Counts /= (1, 1, 1, 1) then + Failed ("Incorrect calls to the stream attributes for Priv.T1"); + elsif Priv.T1'External_Tag /= Priv.External_Tag_1 then + Failed ("Incorrect external tag for Priv.T1"); + end if; + + -- Incompletely defined but not private. + Priv.T2'Write (S'Access, X2); + Priv.T2'Read (S'Access, X2); + Priv.T2'Output (S'Access, X2); + X2 := Priv.T2'Input (S'Access); + + if Priv.Get_T2_Counts /= (1, 1, 1, 1) then + Failed ("Incorrect calls to the stream attributes for Priv.T2"); + elsif Priv.T2'External_Tag /= Priv.External_Tag_2 then + Failed ("Incorrect external tag for Priv.T2"); + end if; + + end Test_Priv; + + Test_Gen: + declare + + type Modular is mod System.Max_Binary_Modulus; + type Decimal is delta 1.0 digits 1; + type Access_Modular is access Modular; + type R9 is null record; + type R10 (D : access Integer) is limited null record; + type Arr is array (Character) of Integer; + + C10 : R10 (new Integer'(19)); + + package Inst is new Gen (T1 => Character, + T2 => Integer, + T3 => Modular, + T4 => Float, + T5 => Duration, + T6 => Decimal, + T7 => Access_Modular, + T8 => Boolean, + T9 => R9, + T10 => R10, + C10 => C10, + T11 => Arr); + + X1 : Inst.Nt1 := 'a'; + X2 : Inst.Nt2 := 0; + X3 : Inst.Nt3 := 0; + X4 : Inst.Nt4 := 0.0; + X5 : Inst.Nt5 := 0.0; + X6 : Inst.Nt6 := 0.0; + X7 : Inst.Nt7 := null; + X8 : Inst.Nt8 := Inst.False; + X9 : Inst.Nt9 := (null record); + X10 : Inst.Nt10 (D => new Integer'(5)); + Y10 : Integer; + X11 : Inst.Nt11 := (others => 0); + X12 : Inst.Nt12 (D => new Integer'(7)); + Y12 : Integer; + X13 : Inst.Nt13 := (others => 0); + use CD10002_0; + begin + Comment ("Check that operational items can be specified for a " & + "descendant of a generic formal untagged type"); + + Inst.Nt1'Write (S'Access, X1); + Inst.Nt1'Read (S'Access, X1); + Inst.Nt1'Output (S'Access, X1); + X1 := Inst.Nt1'Input (S'Access); + + if Inst.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt1"); + end if; + + Inst.Nt2'Write (S'Access, X2); + Inst.Nt2'Read (S'Access, X2); + Inst.Nt2'Output (S'Access, X2); + X2 := Inst.Nt2'Input (S'Access); + + if Inst.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt2"); + end if; + + Inst.Nt3'Write (S'Access, X3); + Inst.Nt3'Read (S'Access, X3); + Inst.Nt3'Output (S'Access, X3); + X3 := Inst.Nt3'Input (S'Access); + + if Inst.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt3"); + end if; + + Inst.Nt4'Write (S'Access, X4); + Inst.Nt4'Read (S'Access, X4); + Inst.Nt4'Output (S'Access, X4); + X4 := Inst.Nt4'Input (S'Access); + + if Inst.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt4"); + end if; + + Inst.Nt5'Write (S'Access, X5); + Inst.Nt5'Read (S'Access, X5); + Inst.Nt5'Output (S'Access, X5); + X5 := Inst.Nt5'Input (S'Access); + + if Inst.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt5"); + end if; + + Inst.Nt6'Write (S'Access, X6); + Inst.Nt6'Read (S'Access, X6); + Inst.Nt6'Output (S'Access, X6); + X6 := Inst.Nt6'Input (S'Access); + + if Inst.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt6"); + end if; + + Inst.Nt7'Write (S'Access, X7); + Inst.Nt7'Read (S'Access, X7); + Inst.Nt7'Output (S'Access, X7); + X7 := Inst.Nt7'Input (S'Access); + + if Inst.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt7"); + end if; + + Inst.Nt8'Write (S'Access, X8); + Inst.Nt8'Read (S'Access, X8); + Inst.Nt8'Output (S'Access, X8); + X8 := Inst.Nt8'Input (S'Access); + + if Inst.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt8"); + end if; + + Inst.Nt9'Write (S'Access, X9); + Inst.Nt9'Read (S'Access, X9); + Inst.Nt9'Output (S'Access, X9); + X9 := Inst.Nt9'Input (S'Access); + + if Inst.Nt9_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt9"); + end if; + + Inst.Nt10'Write (S'Access, X10); + Inst.Nt10'Read (S'Access, X10); + Inst.Nt10'Output (S'Access, X10); + Y10 := Inst.Nt10'Input (S'Access).D.all; + + if Inst.Get_Nt10_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt10"); + end if; + + Inst.Nt11'Write (S'Access, X11); + Inst.Nt11'Read (S'Access, X11); + Inst.Nt11'Output (S'Access, X11); + X11 := Inst.Nt11'Input (S'Access); + + if Inst.Nt11_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt11"); + end if; + + Inst.Nt12'Write (S'Access, X12); + Inst.Nt12'Read (S'Access, X12); + Inst.Nt12'Output (S'Access, X12); + Y12 := Inst.Nt12'Input (S'Access).D.all; + + if Inst.Get_Nt12_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt12"); + end if; + + Inst.Nt13'Write (S'Access, X13); + Inst.Nt13'Read (S'Access, X13); + Inst.Nt13'Output (S'Access, X13); + X13 := Inst.Nt13'Input (S'Access); + + if Inst.Nt13_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt13"); + end if; + end Test_Gen; + + Test_Deriv: + declare + X1 : Deriv.Nt1 := Deriv.False; + X2 : Deriv.Nt2 := (others => 0.0); + X3 : Deriv.Nt3 := (others => 0.0); + X4 : Deriv.Nt4; + Y4 : Boolean; + X5 : Deriv.Nt5; + Y5 : System.Address; + X6 : Deriv.Nt6; + Y6 : Integer; + X7 : Deriv.Nt7; + Y7 : Integer; + X8 : Deriv.Nt8; + Y8 : Integer; + use CD10002_0; + begin + Comment ("Check that operational items can be specified for a " & + "derived untagged type even if the parent type is a " & + "by-reference type, or has user-defined primitive " & + "subprograms"); + + Deriv.Nt1'Write (S'Access, X1); + Deriv.Nt1'Read (S'Access, X1); + Deriv.Nt1'Output (S'Access, X1); + X1 := Deriv.Nt1'Input (S'Access); + + if Deriv.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt1"); + end if; + + Deriv.Nt2'Write (S'Access, X2); + Deriv.Nt2'Read (S'Access, X2); + Deriv.Nt2'Output (S'Access, X2); + X2 := Deriv.Nt2'Input (S'Access); + + if Deriv.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt2"); + end if; + + Deriv.Nt3'Write (S'Access, X3); + Deriv.Nt3'Read (S'Access, X3); + Deriv.Nt3'Output (S'Access, X3); + X3 := Deriv.Nt3'Input (S'Access); + + if Deriv.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt3"); + end if; + + Deriv.Nt4'Write (S'Access, X4); + Deriv.Nt4'Read (S'Access, X4); + Deriv.Nt4'Output (S'Access, X4); + Y4 := Deriv.Nt4'Input (S'Access)'Terminated; + + if Deriv.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt4"); + end if; + + Deriv.Nt5'Write (S'Access, X5); + Deriv.Nt5'Read (S'Access, X5); + Deriv.Nt5'Output (S'Access, X5); + Y5 := Deriv.Nt5'Input (S'Access)'Address; + + if Deriv.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt5"); + end if; + + Deriv.Nt6'Write (S'Access, X6); + Deriv.Nt6'Read (S'Access, X6); + Deriv.Nt6'Output (S'Access, X6); + Y6 := Deriv.Nt6'Input (S'Access).D.all; + + if Deriv.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt6"); + end if; + + Deriv.Nt7'Write (S'Access, X7); + Deriv.Nt7'Read (S'Access, X7); + Deriv.Nt7'Output (S'Access, X7); + Y7 := Deriv.Nt7'Input (S'Access) ('a').D.all; + + if Deriv.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt7"); + end if; + + Deriv.Nt8'Write (S'Access, X8); + Deriv.Nt8'Read (S'Access, X8); + Deriv.Nt8'Output (S'Access, X8); + Y8 := Deriv.Nt8'Input (S'Access)'Size; + + if Deriv.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt8"); + end if; + end Test_Deriv; + + Result; +end CD10002; + + Index: cd7204b.ada =================================================================== --- cd7204b.ada (nonexistent) +++ cd7204b.ada (revision 338) @@ -0,0 +1,88 @@ +-- CD7204B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE PREFIX OF THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT +-- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES +-- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE IS +-- NOT PRESENT. + +-- HISTORY: +-- BCB 09/14/87 CREATED ORIGINAL TEST. +-- RJW 02/08/88 REVISED SO THAT TEST PASSES IF BOOLEAN'SIZE = 1. +-- RJW 05/31/90 CORRECTED COMPARISONS INVOLVING SIZES. +-- LDC 10/04/90 ADDED CHECK FOR 'POSITION. + +WITH REPORT; USE REPORT; + +PROCEDURE CD7204B IS + + TYPE BASIC_REC IS RECORD + CHECK_INT : INTEGER := 5; + CHECK_BOOL : BOOLEAN := TRUE; + END RECORD; + + CHECK_REC : BASIC_REC; + +BEGIN + + TEST ("CD7204B", "CHECK THAT THE PREFIX OF THE 'POSITION, " & + "'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " & + "DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " & + "RETURN APPROPRIATE VALUES WHEN A RECORD " & + "REPRESENTATION CLAUSE IS NOT PRESENT"); + + IF CHECK_REC.CHECK_INT'FIRST_BIT >= CHECK_REC.CHECK_INT'LAST_BIT + THEN FAILED ("INCORRECT VALUES FOR FIRST_BIT OR LAST_BIT " & + "OF CHECK_INT"); + END IF; + + IF (CHECK_REC.CHECK_INT'LAST_BIT - CHECK_REC.CHECK_INT'FIRST_BIT + + 1) < INTEGER'SIZE THEN + FAILED ("INCORRECT SIZE FOR CHECK_INT"); + END IF; + + IF CHECK_REC.CHECK_BOOL'POSITION <= CHECK_REC.CHECK_INT'POSITION + THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " & + "OR CHECK_BOOL"); + END IF; + + IF CHECK_REC.CHECK_INT'POSITION >= CHECK_REC.CHECK_BOOL'POSITION + THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " & + "OR CHECK_BOOL - 2"); + END IF; + + IF CHECK_REC.CHECK_BOOL'FIRST_BIT > CHECK_REC.CHECK_BOOL'LAST_BIT + THEN FAILED ("INCORRECT VALUE FOR FIRST_BIT OR LAST_BIT " & + "OF CHECK_BOOL"); + END IF; + + IF (CHECK_REC.CHECK_BOOL'LAST_BIT - CHECK_REC.CHECK_BOOL'FIRST_BIT + + 1) < BOOLEAN'SIZE THEN + FAILED ("INCORRECT SIZE FOR CHECK_BOOL"); + END IF; + + RESULT; + +END CD7204B; Index: cd40001.a =================================================================== --- cd40001.a (nonexistent) +++ cd40001.a (revision 338) @@ -0,0 +1,181 @@ +-- CD40001.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 Enumeration_Representation_Clauses are supported for +-- codes in the range System.Min_Int..System.Max_Int. +-- +-- TEST DESCRIPTION: +-- This test defines several types, and checks that the range of the +-- enumeration clause is as expected. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 22 JUL 95 SAIC Initial version +-- 07 MAY 96 SAIC Revised for 2.1 +-- 16 FEB 98 EDS Modified Documentation. +--! + +with System; +with Ada.Unchecked_Conversion; +package CD40001_0 is + + type Press_The_Bounds is ( Negative_Large, Positive_Large ); + + for Press_The_Bounds use + ( Negative_Large => System.Min_Int, -- ANX-C RQMT. + Positive_Large => System.Max_Int ); -- ANX-C RQMT. + + type Add_The_Bounds is + ( Monday, Tuesday, Wednesday, Thursday, Friday, Saturday); + + for Add_The_Bounds use + ( Monday => System.Min_Int, -- ANX-C RQMT. + Tuesday => System.Min_Int + 1, -- ANX-C RQMT. + Wednesday => System.Min_Int + 2, -- ANX-C RQMT. + Thursday => System.Min_Int + 3, -- ANX-C RQMT. + Friday => System.Min_Int + 4, -- ANX-C RQMT. + Saturday => System.Min_Int + 5 ); -- ANX-C RQMT. + + type Minus_The_Bounds is ( Jan, Feb, Mar, Apr); + + for Minus_The_Bounds use + ( Apr => System.Max_Int, -- ANX-C RQMT. + Mar => System.Max_Int - 1, -- ANX-C RQMT. + Feb => System.Max_Int - 2, -- ANX-C RQMT. + Jan => System.Max_Int - 3 ); -- ANX-C RQMT. + + type TC_Integer is range System.Min_Int..System.Max_Int; + + procedure TC_Check_Press; + + procedure TC_Check_Add; + + procedure TC_Check_Minus; + + function TC_Compare_Press is new Ada.Unchecked_Conversion + (Press_The_Bounds, TC_Integer); + + function TC_Compare_Add is new Ada.Unchecked_Conversion + (Add_The_Bounds, TC_Integer); + + function TC_Compare_Minus is new Ada.Unchecked_Conversion + (Minus_The_Bounds, TC_Integer); + +end CD40001_0; + + --==================================================================-- + +with Report; +package body CD40001_0 is + + procedure TC_Check_Press is + My_Press_First : Press_The_Bounds := Negative_Large; + My_Press_Last : Press_The_Bounds := Positive_Large; + begin + if TC_Compare_Press (My_Press_First) /= System.Min_Int or + TC_Compare_Press (My_Press_Last) /= System.Max_Int + then + Report.Failed + ("Expected enumeration size of System.Min_Int and System.Max_Int " & + "not available for this implementation"); + end if; + end TC_Check_Press; + + --------------------------------------------------------------------------- + procedure TC_Check_Add is + My_Monday : Add_The_Bounds := Monday; + My_Tuesday : Add_The_Bounds := Tuesday; + My_Wednesday : Add_The_Bounds := Wednesday; + My_Thursday : Add_The_Bounds := Thursday; + My_Friday : Add_The_Bounds := Friday; + My_Saturday : Add_The_Bounds := Saturday; + begin + if TC_Compare_Add (My_Monday) /= (System.Min_Int) or + TC_Compare_Add (My_Thursday) /= (System.Min_Int + 3) or + TC_Compare_Add (My_Wednesday) /= (System.Min_Int + 2) or + TC_Compare_Add (My_Tuesday) /= (System.Min_Int + 1) or + TC_Compare_Add (My_Saturday) /= (System.Min_Int + 5) or + TC_Compare_Add (My_Friday) /= (System.Min_Int + 4) + then + Report.Failed + ("Expected enumeration size of System.Min_Int, System.Min_Int + 1 " & + "through System.Min_Int + 5 not available for this implementation"); + end if; + end TC_Check_Add; + + --------------------------------------------------------------------------- + procedure TC_Check_Minus is + My_Jan : Minus_The_Bounds := Jan; + My_Feb : Minus_The_Bounds := Feb; + My_Mar : Minus_The_Bounds := Mar; + My_Apr : Minus_The_Bounds := Apr; + begin + if TC_Compare_Minus (My_Jan) /= (System.Max_Int - 3) or + TC_Compare_Minus (My_Feb) /= (System.Max_Int - 2) or + TC_Compare_Minus (My_Mar) /= (System.Max_Int - 1) or + TC_Compare_Minus (My_Apr) /= (System.Max_Int) + then + Report.Failed + ("Expected enumeration size of System.Max_Int, System.Max_Int - 1 " & + "through System.Max_Int - 3 not available for this implementation"); + end if; + end TC_Check_Minus; + +end CD40001_0; + + --==================================================================-- + +with Report; +with CD40001_0; + +procedure CD40001 is + +begin -- Main test procedure. + + Report.Test ("CD40001", "Check that Enumeration_Representation_Clauses " & + "are supported for codes in the range " & + "System.Min_Int..System.Max_Int" ); + + CD40001_0.TC_Check_Press; + + CD40001_0.TC_Check_Add; + + CD40001_0.TC_Check_Minus; + + Report.Result; + +end CD40001; Index: cd7305a.ada =================================================================== --- cd7305a.ada (nonexistent) +++ cd7305a.ada (revision 338) @@ -0,0 +1,52 @@ +-- CD7305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK, FOR DIGITS 5, THAT MACHINE_RADIX, MACHINE_MANTISSA, +-- MACHINE_EMAX, AND MACHINE_EMIN HAVE THE CORRECT VALUES. + +-- HISTORY: +-- DHH 09/15/88 CREATED ORIGINAL TEST. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE CD7305A IS + + TYPE T IS DIGITS 5; + + B : BOOLEAN := FALSE; + +BEGIN + TEST ("CD7305A", "CHECK, FOR DIGITS 5, THAT MACHINE_RADIX, " & + "MACHINE_MANTISSA, MACHINE_EMAX, AND " & + "MACHINE_EMIN HAVE THE CORRECT VALUES"); + + + IF T'MACHINE_RADIX < 2 OR + T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN + FAILED ("INCORRECT 'MACHINE_RADIX"); + END IF; + + RESULT; +END CD7305A; Index: cd30004.a =================================================================== --- cd30004.a (nonexistent) +++ cd30004.a (revision 338) @@ -0,0 +1,215 @@ +-- CD30004.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 unspecified Size of static discrete +-- subtypes is the number of bits needed to represent each value +-- belonging to the subtype using an unbiased representation, where +-- space for a sign bit is provided only in the event the subtype +-- contains negative values. Check that for first subtypes specified +-- Sizes are supported reflecting this representation. [ARM 95 13.3(55)]. +-- +-- TEST DESCRIPTION: +-- This test defines a few types that should have distinctly recognizable +-- sizes. A packed record which should result in very specific bits +-- sizes for it's components is used to check the first part of the +-- objective. The second part of the objective is checked by giving +-- sizes for a similar set of types. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- CHANGE HISTORY: +-- 22 JUL 95 SAIC Initial version +-- 06 MAY 96 SAIC Revised for 2.1 +-- 26 FEB 97 PWB.CTA Added pragma Pack for type Check_Record +-- 16 FEB 98 EDS Modified Documentation. +-- 06 JUL 99 RLB Repaired comments, removed junk test cases. +-- Added test cases to test that appropriate Size +-- clauses are allowed. + +--! +----------------------------------------------------------------- CD30004_0 + +package CD30004_0 is + +-- Check that the unspecified Size of static discrete and fixed point +-- subtypes are the number of bits needed to represent each value +-- belonging to the subtype using an unbiased representation, where +-- space for a sign bit is provided only in the event the subtype +-- contains negative values. Check that for first subtypes specified +-- Sizes are supported reflecting this representation. + + type Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit ); + + type Bits_3 is range 0..2**3-1; + + type Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp + + type Bits_14 is mod 2**14; + + type Check_Record is + record + B14 : Bits_14; + B2 : Bits_2; + B3 : Bits_3; + B5 : Bits_5; + C : Character; + end record; + pragma Pack ( Check_Record ); + + procedure TC_Check_Values; + procedure TC_Check_Specified_Sizes; + +end CD30004_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +with Report; +with Impdef; +package body CD30004_0 is + + procedure TC_Check_Values is + begin + + if Bits_2'Size /= 2 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_2'Size not 2 bits"); + else -- Recommended levels of support are not binding. + Report.Comment("Bits_2'Size not 2 bits"); + end if; + end if; + + if Bits_14'Size /= 14 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_14'Size not 14 bits"); + else + Report.Comment("Bits_14'Size not 14 bits"); + end if; + end if; + + if Bits_3'Size /= 3 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_3'Size not 3 bits"); + else + Report.Comment("Bits_3'Size not 3 bits"); + end if; + end if; + + if Bits_5'Size /= 5 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_5'Size not 5 bits"); + else + Report.Comment("Bits_5'Size not 5 bits"); + end if; + end if; + + if Character'Size /= 8 then + Report.Failed("Character'Size not 8 bits"); + end if; + + if Wide_Character'Size /= 16 then + Report.Failed("Wide_Character'Size not 16 bits"); + end if; + + end TC_Check_Values; + + type Spec_Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit ); + for Spec_Bits_2'Size use 2; -- ANX-C RQMT. + + type Spec_Bits_3 is range 0..2**3-1; + for Spec_Bits_3'Size use 3; -- ANX-C RQMT. + + type Spec_Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp + for Spec_Bits_5'Size use 5; -- ANX-C RQMT. + + type Spec_Bits_14 is mod 2**14; + for Spec_Bits_14'Size use 14; -- ANX-C RQMT. + + type Spec_Record is new Check_Record; + for Spec_Record'Size use 64; -- ANX-C RQMT. + + procedure TC_Check_Specified_Sizes is + + begin + + if Spec_Record'Size /= 64 then + Report.Failed("Spec_Record'Size not 64 bits"); + end if; + + if Spec_Bits_2'Size /= 2 then + Report.Failed("Spec_Bits_2'Size not 2 bits"); + end if; + + if Spec_Bits_14'Size /= 14 then + Report.Failed("Spec_Bits_14'Size not 14 bits"); + end if; + + if Spec_Bits_3'Size /= 3 then + Report.Failed("Spec_Bits_3'Size not 3 bits"); + end if; + + if Spec_Bits_5'Size /= 5 then + Report.Failed("Spec_Bits_5'Size not 5 bits"); + end if; + + end TC_Check_Specified_Sizes; + +end CD30004_0; + +------------------------------------------------------------------- CD30004 + +with Report; +with CD30004_0; + +procedure CD30004 is + +begin -- Main test procedure. + + Report.Test ("CD30004", "Check that the unspecified Size of static " & + "discrete and fixed point subtypes is the number of bits " & + "needed to represent each value belonging to the subtype " & + "using an unbiased representation, where space for a sign " & + "bit is provided only in the event the subtype contains " & + "negative values. Check that for first subtypes " & + "specified Sizes are supported reflecting this " & + "representation."); + + CD30004_0.TC_Check_Values; + + CD30004_0.TC_Check_Specified_Sizes; + + Report.Result; + +end CD30004; Index: cd2a83c.tst =================================================================== --- cd2a83c.tst (nonexistent) +++ cd2a83c.tst (revision 338) @@ -0,0 +1,101 @@ +-- CD2A83C.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT SIZE AND COLLECTION SIZE SPECIFICATIONS +-- FOR AN ACCESS TYPE CAN BE GIVEN IN THE VISIBLE OR +-- PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN +-- THE VISIBLE PART. + +-- HISTORY: +-- JET 09/01/87 CREATED ORIGINAL TEST. +-- DHH 04/11/89 CHANGED OPERATOR ON 'SIZE CHECKS AND REMOVED +-- APPLICABILITY CRITERIA. + +-- $ACC_SIZE IS THE SIZE IN BITS FOR AN ACCESS VARIABLE WHOSE +-- DESIGNATED TYPE IS A STRING TYPE. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A83C IS + + SPECIFIED_SIZE : CONSTANT := $ACC_SIZE; + COLL_SIZE : CONSTANT := 256; + + TYPE CHECK_ACC IS ACCESS STRING; + + FOR CHECK_ACC'STORAGE_SIZE USE COLL_SIZE; + + FOR CHECK_ACC'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE ACC_IN_P IS ACCESS STRING; + FOR ACC_IN_P'STORAGE_SIZE USE COLL_SIZE; + FOR ACC_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_ACC IS PRIVATE; + TYPE ALT_ACC_IN_P IS ACCESS STRING; + PRIVATE + TYPE PRIVATE_ACC IS ACCESS STRING; + FOR ALT_ACC_IN_P'STORAGE_SIZE USE COLL_SIZE; + FOR ALT_ACC_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + +BEGIN + + TEST("CD2A83C", "CHECK THAT WHEN SIZE AND COLLECTION SIZE " & + "SPECIFICATIONS FOR AN ACCESS TYPE, " & + "CAN BE GIVEN IN " & + "THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR " & + "A TYPE DECLARED IN THE VISIBLE PART"); + + IF CHECK_ACC'SIZE /= MINIMUM_SIZE THEN + FAILED ("CHECK_ACC'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF CHECK_ACC'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("CHECK_ACC'STORAGE_SIZE TOO SMALL"); + END IF; + + IF ACC_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ACC_IN_P'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("ACC_IN_P'STORAGE_SIZE TOO SMALL"); + END IF; + + IF ALT_ACC_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_ACC_IN_P'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF ALT_ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("ALT_ACC_IN_P'STORAGE_SIZE TOO SMALL"); + END IF; + + RESULT; + +END CD2A83C; Index: cd92001.a =================================================================== --- cd92001.a (nonexistent) +++ cd92001.a (revision 338) @@ -0,0 +1,229 @@ +-- CD92001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if X denotes a scalar object, X'Valid +-- yields true if an only if the object denoted by X is normal and +-- has a valid representation. +-- +-- TEST DESCRIPTION: +-- Using Unchecked_Conversion, Image and Value attributes, combined +-- with string manipulation, cause valid and invalid values to be +-- stored in various objects. Check their validity with the +-- attribute 'Valid. Invalid objects are created in a loop which +-- performs a simplistic check to ensure that the values being used +-- are indeed not valid, then assigns the value using an instance of +-- Unchecked_Conversion. The creation of the tables of valid values +-- is trivial. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- N/A => ERROR", in which case it may be graded as +-- inapplicable. Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 10 MAY 95 SAIC Initial version +-- 07 MAY 96 SAIC Changed U_C to Ada.U_C for 2.1 +-- 05 JAN 99 RLB Added Component_Size clauses to compensate +-- for the fact that there is no required size +-- for either the enumeration or modular components. +--! + +with Report; +with Ada.Unchecked_Conversion; +with System; +procedure CD92001 is + + type Sparse_Enumerated is + ( Help, Home, Page_Up, Del, EndK, + Page_Down, Up, Left, Down, Right ); + + for Sparse_Enumerated use ( Help => 2, + Home => 4, + Page_Up => 8, + Del => 16, + EndK => 32, + Page_Down => 64, + Up => 128, + Left => 256, + Down => 512, + Right => 1024 ); + + type Mod_10 is mod 10; + + type Default_Enumerated is ( Zero, One, Two, Three, Four, + Five, Six, Seven, Eight, Nine, + Clear, '=', '/', '*', '-', + '+', Enter ); + for Default_Enumerated'Size use 8; + + Default_Enumerated_Count : constant := 17; + + type Mod_By_Enum_Items is mod Default_Enumerated_Count; + + type Mod_Same_Size_As_Sparse_Enum is mod 2**12; + -- Sparse_Enumerated 'Size; + + type Mod_Same_Size_As_Def_Enum is mod 2**8; + -- Default_Enumerated'Size; + + subtype Test_Width is Positive range 1..100; + + -- Note: There is no required relationship between 'Size and 'Component_Size, + -- so we must use component_size clauses here. + -- We use the following expressions to insure that the component size is a + -- multiple of the Storage_Unit. + Sparse_Component_Size : constant := ((Sparse_Enumerated'Size / System.Storage_Unit) + + Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) * + System.Storage_Unit; + Default_Component_Size : constant := ((Default_Enumerated'Size / System.Storage_Unit) + + Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) * + System.Storage_Unit; + + type Sparse_Enum_Table is array(Test_Width) of Sparse_Enumerated; + for Sparse_Enum_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR. + type Def_Enum_Table is array(Test_Width) of Default_Enumerated; + for Def_Enum_Table'Component_Size use Default_Component_Size; -- N/A => ERROR. + + type Sparse_Mod_Table is + array(Test_Width) of Mod_Same_Size_As_Sparse_Enum; + for Sparse_Mod_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR. + + type Default_Mod_Table is + array(Test_Width) of Mod_Same_Size_As_Def_Enum; + for Default_Mod_Table'Component_Size use Default_Component_Size; -- N/A => ERROR. + + function UC_Sparse_Mod_Enum is + new Ada.Unchecked_Conversion( Sparse_Mod_Table, Sparse_Enum_Table ); + + function UC_Def_Mod_Enum is + new Ada.Unchecked_Conversion( Default_Mod_Table, Def_Enum_Table ); + + Valid_Sparse_Values : Sparse_Enum_Table; + Valid_Def_Values : Def_Enum_Table; + + Sample_Enum_Value_Table : Sparse_Mod_Table; + Sample_Def_Value_Table : Default_Mod_Table; + + + -- fill the Valid tables with valid values for conversion + procedure Fill_Valid is + K : Mod_10 := 0; + P : Mod_By_Enum_Items := 0; + begin + for I in Test_Width loop + Valid_Sparse_Values(I) := Sparse_Enumerated'Val( K ); + Valid_Def_Values(I) := Default_Enumerated'Val( Integer(P) ); + K := K +1; + P := P +1; + end loop; + end Fill_Valid; + + -- fill the Sample tables with invalid values for conversion + procedure Fill_Invalid is + K : Mod_Same_Size_As_Sparse_Enum := 1; + P : Mod_Same_Size_As_Def_Enum := 1; + begin + for I in Test_Width loop + K := K +13; + if K mod 2 = 0 then -- oops, that would be a valid value + K := K +1; + end if; + if P = Mod_Same_Size_As_Def_Enum'Last + or P < Default_Enumerated_Count then -- that would be valid + P := Default_Enumerated_Count + 1; + else + P := P +1; + end if; + Sample_Enum_Value_Table(I) := K; + Sample_Def_Value_Table(I) := P; + end loop; + + Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table); + Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table); + + end Fill_Invalid; + + -- fill the tables with second set of valid values for conversion + procedure Refill_Valid is + K : Mod_10 := 0; + P : Mod_By_Enum_Items := 0; + + Table : Array(Mod_10) of Mod_Same_Size_As_Sparse_Enum + := ( 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 ); + + begin + for I in Test_Width loop + Sample_Enum_Value_Table(I) := Table(K); + Sample_Def_Value_Table(I) := Mod_Same_Size_As_Def_Enum(P); + K := K +1; + P := P +1; + end loop; + Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table); + Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table); + end Refill_Valid; + + procedure Validate(Expect_Valid: Boolean) is + begin -- here's where we actually use the tested attribute + + for K in Test_Width loop + if Valid_Sparse_Values(K)'Valid /= Expect_Valid then + Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid) + & " for Sparse item " & Integer'Image(K) ); + end if; + end loop; + + for P in Test_Width loop + if Valid_Def_Values(P)'Valid /= Expect_Valid then + Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid) + & " for Default item " & Integer'Image(P) ); + end if; + end loop; + + end Validate; + +begin -- Main test procedure. + + Report.Test ("CD92001", "Check object attribute: X'Valid" ); + + Fill_Valid; + Validate(True); + + Fill_Invalid; + Validate(False); + + Refill_Valid; + Validate(True); + + Report.Result; + +end CD92001; Index: cd2b11b.ada =================================================================== --- cd2b11b.ada (nonexistent) +++ cd2b11b.ada (revision 338) @@ -0,0 +1,196 @@ +-- CD2B11B.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 IF A COLLECTION SIZE IS SPECIFIED FOR AN +-- ACCESS TYPE IN A GENERIC UNIT, THEN OPERATIONS ON VALUES OF THE +-- ACCESS TYPE ARE NOT AFFECTED. + +-- HISTORY: +-- BCB 09/23/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE CD2B11B IS + + BASIC_SIZE : CONSTANT := 1024; + B : BOOLEAN; + +BEGIN + + TEST ("CD2B11B", "CHECK THAT IF A COLLECTION SIZE IS SPECIFIED " & + "FOR AN ACCESS TYPE, THEN " & + "OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " & + "NOT AFFECTED"); + + DECLARE + + GENERIC + FUNCTION FUNC RETURN BOOLEAN; + + FUNCTION FUNC RETURN BOOLEAN IS + + TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE ACC_TYPE IS ACCESS MAINTYPE; + SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3); + + FOR ACC_TYPE'STORAGE_SIZE + USE BASIC_SIZE; + + TYPE RECORD_TYPE IS RECORD + COMP : ACC_TYPE; + END RECORD; + + CHECK_TYPE1 : ACC_TYPE; + CHECK_TYPE2 : ACC_TYPE; + CHECK_TYPE3 : ACC_TYPE(1..3); + + CHECK_ARRAY : ARRAY (1..3) OF ACC_TYPE; + + CHECK_RECORD1 : RECORD_TYPE; + CHECK_RECORD2 : RECORD_TYPE; + + CHECK_PARAM1 : ACC_TYPE; + CHECK_PARAM2 : ACC_TYPE; + + CHECK_NULL : ACC_TYPE := NULL; + + PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS + + BEGIN + + IF (ACC1.ALL /= ACC2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED " & + "OBJECTS - 1"); + END IF; + + IF EQUAL (3,3) THEN + ACC2 := ACC1; + END IF; + + IF ACC2 /= ACC1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF (ACC1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR " & + "MEMBERSHIP TEST - 1"); + END IF; + + END PROC; + + BEGIN -- FUNC. + + CHECK_PARAM1 := NEW MAINTYPE'(25,35,45); + CHECK_PARAM2 := NEW MAINTYPE'(25,35,45); + + PROC (CHECK_PARAM1,CHECK_PARAM2); + + IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN + FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE"); + END IF; + + CHECK_TYPE1 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE2 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3); + + CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45); + CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45); + + CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45); + CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45); + + IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_TYPE2 := CHECK_TYPE1; + END IF; + + IF CHECK_TYPE2 /= CHECK_TYPE1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 2"); + END IF; + + IF (CHECK_TYPE1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2"); + END IF; + + IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_ARRAY (2) := CHECK_ARRAY (1); + END IF; + + IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 3"); + END IF; + + IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3"); + END IF; + + IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_RECORD2 := CHECK_RECORD1; + END IF; + + IF CHECK_RECORD2 /= CHECK_RECORD1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 4"); + END IF; + + IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4"); + END IF; + + IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST"); + END IF; + + IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST"); + END IF; + + RETURN TRUE; + + END FUNC; + + FUNCTION NEWFUNC IS NEW FUNC; + + BEGIN + B := NEWFUNC; + END; + + RESULT; +END CD2B11B; Index: cd2a22a.ada =================================================================== --- cd2a22a.ada (nonexistent) +++ cd2a22a.ada (revision 338) @@ -0,0 +1,213 @@ +-- CD2A22A.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 IF A SIZE SPECIFICATION INDICATING THE SMALLEST SIZE +-- APPROPRIATE FOR A SIGNED REPRESENTATION IS GIVEN FOR AN +-- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- RJW 07/28/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A22A IS + + BASIC_SIZE : CONSTANT := 3; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((CI0 < IDENT (ONE)) AND + (IDENT (CI2) > IDENT (CIO1)) AND + (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1"); + END IF; + + IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR + CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1"); + END IF; + + IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + +BEGIN + TEST ("CD2A22A", "CHECK THAT IF A SIZE SPECIFICATION " & + "INDICATING THE SMALLEST SIZE APPROPRIATE " & + "FOR A SIGNED REPRESENTATION IS GIVEN " & + "FOR AN ENUMERATION TYPE, THEN OPERATIONS " & + "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " & + "BY THE REPRESENTATION CLAUSE"); + + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (ONE) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3"); + END IF; + + IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3"); + END IF; + + IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3"); + END IF; + + IF CHREC.COMP1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP1'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4"); + END IF; + + IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4"); + END IF; + + RESULT; +END CD2A22A; Index: cd2b11d.ada =================================================================== --- cd2b11d.ada (nonexistent) +++ cd2b11d.ada (revision 338) @@ -0,0 +1,54 @@ +-- CD2B11D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE EXPRESSION IN A COLLECTION SIZE CLAUSE +-- FOR AN ACCESS TYPE NEED NOT BE STATIC. + +-- HISTORY: +-- BCB 09/23/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE CD2B11D IS + + TYPE CHECK_TYPE IS ACCESS INTEGER; + FOR CHECK_TYPE'STORAGE_SIZE USE 256; + + TYPE ACC_TYPE IS ACCESS INTEGER; + FOR ACC_TYPE'STORAGE_SIZE USE IDENT_INT (256); + +BEGIN + + TEST ("CD2B11D", "CHECK THAT THE EXPRESSION IN A COLLECTION " & + "SIZE SPECIFICATION FOR AN ACCESS TYPE "& + "NEED NOT BE STATIC"); + + IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN + FAILED ("INCORRECT VALUE FOR STORAGE_SIZE"); + END IF; + + RESULT; +END CD2B11D; Index: cd2b11f.ada =================================================================== --- cd2b11f.ada (nonexistent) +++ cd2b11f.ada (revision 338) @@ -0,0 +1,88 @@ +-- CD2B11F.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 IF A COLLECTION SIZE SPECIFICATION IS GIVEN FOR AN +-- ACCESS TYPE WHOSE DESIGNATED TYPE IS A DISCRIMINATED RECORD, THEN +-- OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT AFFECTED. + +-- HISTORY: +-- BCB 09/29/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; USE REPORT; + +PROCEDURE CD2B11F IS + + BASIC_SIZE : CONSTANT := 1024; + + TYPE RECORD_TYPE(DISC : INTEGER := 100) IS RECORD + COMP1 : INTEGER; + COMP2 : INTEGER; + COMP3 : INTEGER; + END RECORD; + + TYPE ACC_RECORD IS ACCESS RECORD_TYPE; + FOR ACC_RECORD'STORAGE_SIZE USE BASIC_SIZE; + + CHECK_RECORD1 : ACC_RECORD; + CHECK_RECORD2 : ACC_RECORD; + +BEGIN + + TEST ("CD2B11F", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " & + "IS GIVEN FOR AN ACCESS TYPE WHOSE " & + "DESIGNATED TYPE IS A DISCRIMINATED RECORD, " & + "THEN OPERATIONS ON VALUES OF THE ACCESS TYPE " & + "ARE NOT AFFECTED"); + + CHECK_RECORD1 := NEW RECORD_TYPE; + CHECK_RECORD1.COMP1 := 25; + CHECK_RECORD1.COMP2 := 25; + CHECK_RECORD1.COMP3 := 150; + + IF ACC_RECORD'STORAGE_SIZE < BASIC_SIZE THEN + FAILED ("INCORRECT VALUE FOR RECORD TYPE ACCESS " & + "STORAGE_SIZE"); + END IF; + + IF CHECK_RECORD1.DISC /= IDENT_INT (100) THEN + FAILED ("INCORRECT VALUE FOR RECORD DISCRIMINANT"); + END IF; + + IF ((CHECK_RECORD1.COMP1 /= CHECK_RECORD1.COMP2) OR + (CHECK_RECORD1.COMP1 = CHECK_RECORD1.COMP3)) THEN + FAILED ("INCORRECT VALUE FOR RECORD COMPONENT"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_RECORD2 := CHECK_RECORD1; + END IF; + + IF CHECK_RECORD2 /= CHECK_RECORD1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATOR"); + END IF; + + RESULT; +END CD2B11F; Index: cd1c04d.ada =================================================================== --- cd1c04d.ada (nonexistent) +++ cd1c04d.ada (revision 338) @@ -0,0 +1,80 @@ +-- CD1C04D.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 ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN +-- FOR A DERIVED ENUMERATION TYPE EVEN IF THE REPRESENTATION IS +-- INHERITED FROM THE PARENT, AND THAT THE CLAUSE FOR THE DERIVED +-- TYPE OVERRIDES THAT OF THE PARENT. + +-- HISTORY: +-- JET 09/21/87 CREATED ORIGINAL TEST. +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD1C04D IS + + TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW); + + TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW); + + FOR PARENT_TYPE USE + (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + FOR DERIVED_TYPE USE + (RED => 16, BLUE => 17, GREEN => 18, YELLOW => 19); + + TYPE INT1 IS RANGE 16 .. 19; + FOR INT1'SIZE USE DERIVED_TYPE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(DERIVED_TYPE, INT1); + +BEGIN + + TEST("CD1C04D", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED ENUMERATION " & + "TYPE EVEN IF THE REPRESENTATION IS INHERITED " & + "FROM THE PARENT, AND THAT THE CLAUSE FOR THE " & + "DERIVED TYPE OVERRIDES THAT OF THE PARENT"); + + IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN + COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " & + "REPRESENTATION CLAUSE"); + END IF; + + IF DERIVED_TYPE'SIZE >= IDENT_INT (PARENT_TYPE'SIZE) THEN + COMMENT ("THE SPECIFICATION OF SMALLER VALUES FOR THE " & + "REPRESENTATION OF DERIVED_TYPE DID NOT " & + "REDUCE THE SIZE OF DERIVED_TYPE"); + END IF; + + CHECK_1 (DERIVED_TYPE'(GREEN), 18, "DERIVED_TYPE"); + + RESULT; + +END CD1C04D; Index: cd2a22e.ada =================================================================== --- cd2a22e.ada (nonexistent) +++ cd2a22e.ada (revision 338) @@ -0,0 +1,216 @@ +-- CD2A22E.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 IF A SIZE CLAUSE SPECIFYING THE SMALLEST SIZE +-- APPROPRIATE FOR AN UNSIGNED REPRESENTATION IS GIVEN FOR AN +-- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A22E IS + + BASIC_SIZE : CONSTANT := 2; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF CIO1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CIO1'SIZE"); + END IF; + + IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND + (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR + CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR + CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1"); + END IF; + + IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR + CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + +BEGIN + TEST ("CD2A22E", "CHECK THAT IF A SIZE CLAUSE " & + "SPECIFYING THE SMALLEST SIZE APPROPRIATE " & + "FOR AN UNSIGNED REPRESENTATION IS GIVEN " & + "FOR AN ENUMERATION TYPE, THEN OPERATIONS " & + "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " & + "BY THE REPRESENTATION CLAUSE"); + + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (TWO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3"); + END IF; + + IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4"); + END IF; + + IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4"); + END IF; + + IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4"); + END IF; + + RESULT; +END CD2A22E; Index: cd2b15c.ada =================================================================== --- cd2b15c.ada (nonexistent) +++ cd2b15c.ada (revision 338) @@ -0,0 +1,103 @@ +-- CD2B15C.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: +-- IF THE COLLECTION SIZE IS LARGE ENOUGH TO HOLD SOME +-- VALUES OF THE DESIGNATED TYPE, CHECK THAT "STORAGE_ERROR" +-- IS RAISED BY AN ALLOCATOR WHEN INSUFFICIENT STORAGE IS +-- AVAILABLE. + +-- HISTORY: +-- DHH 09/23/87 CREATED ORIGINAL TEST. +-- PMW 09/19/88 MODIFIED WITHDRAWN TEST. +-- THS 03/21/90 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND +-- COMPLETELY REVISED THE TEST TO PREVENT OPTIMIZATION. +-- LDC 09/20/90 REMOVED UNUSED VARIABLE, CHANGED FAIL CALLS TO +-- COMMENT FOR 'STORAGE_SIZE /= TO SPECIFIED SIZE, +-- MOVED LOOP FOR CHECK VALUES TO EXCEPTION HANDLER. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD2B15C IS + + SPECIFIED_SIZE : CONSTANT := 1000; + + TYPE CHECK_TYPE IS ACCESS INTEGER; + FOR CHECK_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / SYSTEM.STORAGE_UNIT; + + TYPE ACC_ARRAY_TYPE IS ARRAY + (INTEGER RANGE 1 .. (CHECK_TYPE'STORAGE_SIZE / + UNITS_PER_INTEGER) + 1) OF CHECK_TYPE; + ACC_ARRAY : ACC_ARRAY_TYPE; + + PLACE_I_STOPPED : INTEGER := 0; + +BEGIN + + TEST ("CD2B15C", "IF THE COLLECTION SIZE IS LARGE " & + "ENOUGH TO HOLD SOME VALUES OF " & + "THE DESIGNATED TYPE, CHECK THAT " & + "STORAGE_ERROR IS RAISED BY AN " & + "ALLOCATOR WHEN INSUFFICIENT STORAGE " & + "IS AVAILABLE"); + + IF CHECK_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("CHECK_TYPE'STORAGE_SIZE IS LESS THEN THE VALUE " & + "SPECIFIED IN THE REPRESENTATION CLAUSE"); + + ELSIF CHECK_TYPE'STORAGE_SIZE > 2 * IDENT_INT (SPECIFIED_SIZE) THEN + COMMENT ("VALUE FOR CHECK_TYPE'STORAGE_SIZE IS MORE THEN " & + "TWICE THE SPECIFIED VALUE IN THE REPRESENTATION " & + "CLAUSE"); + END IF; + + BEGIN + + FOR I IN ACC_ARRAY'RANGE LOOP + ACC_ARRAY (I) := NEW INTEGER'(IDENT_INT (I)); + PLACE_I_STOPPED := I; + END LOOP; + + FAILED ("NO EXCEPTION RAISED WHEN RESERVED SPACE " & + "EXCEEDED"); + + EXCEPTION + WHEN STORAGE_ERROR => + FOR I IN 1 .. PLACE_I_STOPPED LOOP + IF ACC_ARRAY (I).ALL /= IDENT_INT (I) THEN + FAILED ("INCORRECT VALUE FOR ACC_ARRAY (" & + INTEGER'IMAGE (I) & ")"); + END IF; + END LOOP; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN RESERVED SPACE " & + "EXCEEDED"); + END; + + RESULT; + +END CD2B15C; Index: cd5014t.ada =================================================================== --- cd5014t.ada (nonexistent) +++ cd5014t.ada (revision 338) @@ -0,0 +1,86 @@ +-- CD5014T.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART +-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL +-- DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART +-- OF THE SPECIFICATION. + + +-- HISTORY: +-- BCB 10/08/87 CREATED ORIGINAL TEST. + +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +WITH SYSTEM; USE SYSTEM; +WITH SPPRT13; USE SPPRT13; +WITH REPORT; USE REPORT; + +PROCEDURE CD5014T IS + +BEGIN + + TEST ("CD5014T", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + TYPE FORM_DISCRETE_TYPE IS (<>); + PACKAGE PKG IS + FORM_DISCRETE_OBJ1 : FORM_DISCRETE_TYPE := + FORM_DISCRETE_TYPE'FIRST; + PRIVATE + FOR FORM_DISCRETE_OBJ1 USE + AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + + IF EQUAL(3,3) THEN + FORM_DISCRETE_OBJ1 := FORM_DISCRETE_TYPE'LAST; + END IF; + + IF FORM_DISCRETE_OBJ1 /= FORM_DISCRETE_TYPE'LAST THEN + FAILED ("INCORRECT VALUE FOR FORMAL DISCRETE VARIABLE"); + END IF; + + IF FORM_DISCRETE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL DISCRETE " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_DISCRETE_TYPE => INTEGER); + + BEGIN + NULL; + END; + + RESULT; +END CD5014T; Index: cd2a22i.ada =================================================================== --- cd2a22i.ada (nonexistent) +++ cd2a22i.ada (revision 338) @@ -0,0 +1,120 @@ +-- CD2A22I.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 IF A SIZE CLAUSE SPECIFIES THE SMALLEST APPROPRIATE +-- SIZE FOR A SIGNED REPRESENTATION FOR AN ENUMERATION TYPE, +-- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN +-- INSTANTIATION. + +-- HISTORY: +-- JET 08/13/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +PROCEDURE CD2A22I IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 3; + + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + +BEGIN + TEST ("CD2A22I", "CHECK THAT IF A SIZE CLAUSE SPECIFIES THE " & + "SMALLEST APPROPRIATE SIZE FOR A SIGNED " & + "REPRESENTATION FOR AN ENUMERATION TYPE, THEN " & + "THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN " & + "AN INSTANTIATION"); + + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (C1) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + +END CD2A22I; Index: cd5014v.ada =================================================================== --- cd5014v.ada (nonexistent) +++ cd5014v.ada (revision 338) @@ -0,0 +1,83 @@ +-- CD5014V.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 ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART +-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL +-- FIXED TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART +-- OF THE SPECIFICATION. + + +-- HISTORY: +-- BCB 10/08/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH SPPRT13; USE SPPRT13; +WITH REPORT; USE REPORT; + +PROCEDURE CD5014V IS + +BEGIN + + TEST ("CD5014V", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "FIXED TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + TYPE FIX IS DELTA 0.5 RANGE -30.00 .. 30.00; + + GENERIC + TYPE FORM_FIXED_TYPE IS DELTA <>; + PACKAGE PKG IS + FORM_FIXED_OBJ1 : FORM_FIXED_TYPE := 5.0; + FOR FORM_FIXED_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + FORM_FIXED_OBJ1 := 20.0; + END IF; + + IF FORM_FIXED_OBJ1 /= 20.0 THEN + FAILED ("INCORRECT VALUE FOR FORMAL FIXED VARIABLE"); + END IF; + + IF FORM_FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL FIXED " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_FIXED_TYPE => FIX); + + BEGIN + NULL; + END; + + RESULT; +END CD5014V; Index: cd5014x.ada =================================================================== --- cd5014x.ada (nonexistent) +++ cd5014x.ada (revision 338) @@ -0,0 +1,89 @@ +-- CD5014X.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART +-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL +-- ARRAY TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART +-- OF THE SPECIFICATION. + +-- HISTORY: +-- BCB 10/08/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH SPPRT13; USE SPPRT13; +WITH REPORT; USE REPORT; +WITH TEXT_IO; USE TEXT_IO; + +PROCEDURE CD5014X IS + +BEGIN + + TEST ("CD5014X", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "ARRAY TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + TYPE COLOR IS (RED,BLUE,GREEN); + TYPE COLOR_TABLE IS ARRAY (COLOR) OF INTEGER; + + GENERIC + TYPE INDEX IS (<>); + TYPE FORM_ARRAY_TYPE IS ARRAY (INDEX) OF INTEGER; + PACKAGE PKG IS + FORM_ARRAY_OBJ1 : FORM_ARRAY_TYPE := (1,2,3); + PRIVATE + FOR FORM_ARRAY_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + + IF EQUAL(3,3) THEN + FORM_ARRAY_OBJ1 := (10,20,30); + END IF; + + IF FORM_ARRAY_OBJ1 /= (10,20,30) THEN + FAILED ("INCORRECT VALUE FOR FORMAL ARRAY VARIABLE"); + END IF; + + IF FORM_ARRAY_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL ARRAY " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(INDEX => COLOR, + FORM_ARRAY_TYPE => COLOR_TABLE); + + BEGIN + NULL; + END; + + RESULT; +END CD5014X; Index: cd5014z.ada =================================================================== --- cd5014z.ada (nonexistent) +++ cd5014z.ada (revision 338) @@ -0,0 +1,76 @@ +-- CD5014Z.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 ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART +-- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL +-- LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE +-- VISIBLE PART OF THE SPECIFICATION. + +-- HISTORY: +-- BCB 10/08/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; USE SYSTEM; +WITH SPPRT13; USE SPPRT13; +WITH REPORT; USE REPORT; + +PROCEDURE CD5014Z IS + +BEGIN + + TEST ("CD5014Z", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS " & + "DECLARED IN THE VISIBLE PART OF THE " & + "SPECIFICATION"); + + DECLARE + + GENERIC + TYPE FORM_LIM_PRIVATE_TYPE IS LIMITED PRIVATE; + PACKAGE PKG IS + FORM_LIM_PRIVATE_OBJ1 : FORM_LIM_PRIVATE_TYPE; + PRIVATE + FOR FORM_LIM_PRIVATE_OBJ1 USE + AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF FORM_LIM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL LIMITED PRIVATE " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_LIM_PRIVATE_TYPE => INTEGER); + + BEGIN + NULL; + END; + + RESULT; +END CD5014Z; Index: cd5003a.ada =================================================================== --- cd5003a.ada (nonexistent) +++ cd5003a.ada (revision 338) @@ -0,0 +1,79 @@ +-- CD5003A.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 NAMING 'SYSTEM' NEED NOT BE GIVEN FOR +-- A PACKAGE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH' +-- CLAUSE IS GIVEN FOR THE SPECIFICATION. + +-- HISTORY: +-- RJW 10/13/88 CREATED ORIGINAL TEST. +-- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY +-- CRITERIA AND N/A ERROR MESSAGES. +-- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +WITH SYSTEM; +PACKAGE CD5003A_PKG2 IS + PROCEDURE REQUIRE_BODY; +END CD5003A_PKG2; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CD5003A_PKG2 IS + TEST_VAR : INTEGER; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN + TEST ("CD5003A", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " & + "NEED NOT BE GIVEN FOR A PACKAGE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE SPECIFICATION"); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + +END CD5003A_PKG2; + +WITH REPORT; USE REPORT; +WITH CD5003A_PKG2; USE CD5003A_PKG2; +WITH SPPRT13; +PROCEDURE CD5003A IS +BEGIN + + RESULT; +END CD5003A; Index: cd4031a.ada =================================================================== --- cd4031a.ada (nonexistent) +++ cd4031a.ada (revision 338) @@ -0,0 +1,95 @@ +-- CD4031A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A RECORD REPRESENTATION CLAUSE IS GIVEN FOR A +-- VARIANT RECORD TYPE, THEN COMPONENTS BELONGING TO DIFFERENT +-- VARIANTS CAN BE GIVEN OVERLAPPING STORAGE. + +-- HISTORY: +-- PWB 07/22/87 CREATED ORIGINAL TEST. +-- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND +-- ADDED CHECK FOR REPRESENTATION CLAUSE. +-- RJW 06/12/90 REMOVED REFERENCES TO LENGTH_CHECK. REVISED +-- COMMENTS. +-- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's +-- complement machines to represent all values in +-- the specified number of bits. + +WITH REPORT; USE REPORT; +PROCEDURE CD4031A IS + + TYPE DISCRIMINAN IS RANGE -1 .. 1; + TYPE INT IS RANGE -3 .. 3; + TYPE LARGE_INT IS RANGE -7 .. 7; + + TYPE TEST_CLAUSE (DISC : DISCRIMINAN := 0) IS + RECORD + CASE DISC IS + WHEN 0 => + INTEGER_COMP : LARGE_INT; + WHEN OTHERS => + CH_COMP_1 : INT; + CH_COMP_2 : INT; + END CASE; + END RECORD; + + FOR TEST_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0 .. 1; + INTEGER_COMP AT 0 + RANGE 2 .. 5; + CH_COMP_1 AT 0 + RANGE 2 .. 4; + CH_COMP_2 AT 0 + RANGE 5 .. 7; + END RECORD; + + TYPE TEST_CL1 IS NEW TEST_CLAUSE(DISC => 0); + TYPE TEST_CL2 IS NEW TEST_CLAUSE(DISC => 1); + TEST_RECORD : TEST_CL1; + TEST_RECORD1 : TEST_CL2; + + INTEGER_COMP_FIRST, + CH_COMP_1_FIRST : INTEGER; + +BEGIN + TEST ("CD4031A", "IN RECORD REPRESENTATION CLAUSES " & + "FOR VARIANT RECORD TYPES, " & + "COMPONENTS OF DIFFERENT VARIANTS " & + "CAN BE GIVEN OVERLAPPING STORAGE"); + + TEST_RECORD := (0, -7); + INTEGER_COMP_FIRST := TEST_RECORD.INTEGER_COMP'FIRST_BIT; + + TEST_RECORD1 := (1, -3, -3); + CH_COMP_1_FIRST := TEST_RECORD1.CH_COMP_1'FIRST_BIT; + + IF INTEGER_COMP_FIRST /= CH_COMP_1_FIRST THEN + FAILED ("COMPONENTS DO NOT BEGIN AT SAME POINT"); + END IF; + + RESULT; +END CD4031A; Index: cd3015a.ada =================================================================== --- cd3015a.ada (nonexistent) +++ cd3015a.ada (revision 338) @@ -0,0 +1,133 @@ +-- CD3015A.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 DERIVED ENUMERATION TYPE CAN BE USED CORRECTLY IN +-- ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC +-- INSTANTIATIONS, WHEN THERE IS NO ENUMERATION CLAUSE FOR THE +-- PARENT. + +-- HISTORY +-- DHH 09/30/87 CREATED ORIGINAL TEST. +-- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO +-- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. +-- REVISED CHECK FOR ARRAY INDEXING. +-- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE +-- ERROR MESSAGE. + +WITH REPORT; USE REPORT; +PROCEDURE CD3015A IS + +BEGIN + + TEST ("CD3015A", "CHECK THAT A DERIVED ENUMERATION TYPE CAN BE " & + "USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC " & + "INSTANTIATIONS, WHEN THERE IS NO ENUMERATION " & + "CLAUSE FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END PACK; + + PACKAGE BODY PACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES IN PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015A; Index: cd5003c.ada =================================================================== --- cd5003c.ada (nonexistent) +++ cd5003c.ada (revision 338) @@ -0,0 +1,86 @@ +-- CD5003C.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS +-- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE +-- PACKAGE SPECIFICATION. + +-- HISTORY: +-- VCL 09/04/87 CREATED ORIGINAL TEST. +-- PWB 05/12/89 CHANGED TO ".ADA" TEST. + + +WITH SYSTEM; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CD5003C IS + PACKAGE CD5003C_PACK2 IS END CD5003C_PACK2; + + PACKAGE BODY CD5003C_PACK2 IS SEPARATE; + + USE CD5003C_PACK2; +BEGIN + RESULT; +END CD5003C; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +SEPARATE (CD5003C) +PACKAGE BODY CD5003C_PACK2 IS + TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER; + + TEST_VAR : ATYPE := (OTHERS => 0); + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN (OTHERS => 0); + END IF; + END IDENT; +BEGIN + TEST ("CD5003C", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A PACKAGE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE PACKAGE SPECIFICATION"); + + + TEST_VAR := IDENT (ATYPE'(OTHERS => 3)); + + IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; +END CD5003C_PACK2; Index: cd4051b.ada =================================================================== --- cd4051b.ada (nonexistent) +++ cd4051b.ada (revision 338) @@ -0,0 +1,94 @@ +-- CD4051B.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 RECORD REPRESENTATION CLAUSE WHICH CHANGES THE +-- ORDER OF THE COMPONENT STORAGE CAN BE GIVEN FOR A DERIVED TYPE +-- WHOSE PARENT TYPE IS A RECORD WITHOUT A DISCRIMINANT. + +-- HISTORY: +-- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. +-- RJW 08/25/87 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD4051B IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + INT_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 0 + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + +BEGIN + TEST ("CD4051B", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE WHICH CHANGES THE ORDER OF COMPONENT " & + "STORAGE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITHOUT DISCRIMINANTS"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; +END CD4051B; Index: cd3015c.ada =================================================================== --- cd3015c.ada (nonexistent) +++ cd3015c.ada (revision 338) @@ -0,0 +1,82 @@ +-- CD3015C.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 ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED +-- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE +-- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE NO +-- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + +-- HISTORY +-- DHH 10/01/87 CREATED ORIGINAL TEST +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3015C IS + +BEGIN + + TEST ("CD3015C", "CHECK THAT AN ENUMERATION " & + "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " & + "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " & + "VISIBLE PART, WHERE NO ENUMERATION CLAUSE HAS " & + "BEEN GIVEN FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 1, BLUE => 16, YELLOW => 32); + PRIVATE + FOR NEWHUE USE (RED => 16, BLUE => 17, YELLOW => 18); + + TYPE INT1 IS RANGE 1 .. 32; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 16 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + END PACK; + + PACKAGE BODY PACK IS + + BEGIN + CHECK_1 (RED, 1, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END PACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015C; Index: cd5003e.ada =================================================================== --- cd5003e.ada (nonexistent) +++ cd5003e.ada (revision 338) @@ -0,0 +1,76 @@ +-- CD5003E.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A TASK BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS LONG +-- AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE TASK +-- SPECIFICATION. + +-- HISTORY: +-- VCL 09/08/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH SYSTEM; +PROCEDURE CD5003E IS + TASK TASK2 IS + ENTRY TST; + END TASK2; + TASK BODY TASK2 IS SEPARATE; +BEGIN + TASK2.TST; +END CD5003E; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +SEPARATE (CD5003E) +TASK BODY TASK2 IS + TEST_VAR : INTEGER := 0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + +BEGIN + ACCEPT TST DO + TEST ("CD5003E", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A TASK BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG " & + "AS A 'WITH' CLAUSE IS GIVEN FOR THE " & + "UNIT CONTAINING THE TASK SPECIFICATION"); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END TST; +END TASK2; Index: cd4051d.ada =================================================================== --- cd4051d.ada (nonexistent) +++ cd4051d.ada (revision 338) @@ -0,0 +1,134 @@ +-- CD4051D.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 RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR +-- A DERIVED SUBTYPE WHOSE PARENT TYPE IS A RECORD TYPE WITH +-- VARIANTS AND THE REPRESENTATION CLAUSE MENTIONS COMPONENTS THAT +-- DO NOT EXIST IN THE DERIVED SUBTYPE. + +-- HISTORY: +-- RJW 08/25/87 CREATED ORIGINAL TEST. +-- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND +-- ADDED CHECK FOR REPRESENTATION CLAUSE. +-- RJW 10/26/89 REMOVED REFERENCES TO LENGTH_CHECK. +-- THS 09/18/90 MADE CALLS TO IDENT_INT TO DEFEAT OPTIMIZATION. +-- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's +-- complement machines to represent all values in +-- the specified number of bits. + +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE CD4051D IS + + TYPE INT IS RANGE -3 .. 3; + TYPE LARGE_INT IS RANGE -7 .. 7; + + TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD + BOOL_COMP : BOOLEAN; + CASE DISC IS + WHEN FALSE => + INT_COMP : LARGE_INT; + WHEN TRUE => + CH_COMP_1 : INT; + CH_COMP_2 : INT; + END CASE; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE (TRUE); + + FOR CHECK_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0 .. 0; + BOOL_COMP AT 0 + RANGE 1 .. 1; + INT_COMP AT 0 + RANGE 2 .. 5; + CH_COMP_1 AT 0 + RANGE 2 .. 4; + CH_COMP_2 AT 0 + RANGE 5 .. 7; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (TRUE, TRUE, -2, -2); + +BEGIN + TEST ("CD4051D", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS A RECORD TYPE " & + "WITH VARIANTS AND WHERE THE RECORD " & + "REPRESENTATION CLAUSE MENTIONS COMPONENTS " & + "THAT DO NOT EXIST IN THE DERIVED SUBTYPE"); + + IF CHECK_RECORD.DISC'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'LAST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF DISC"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'FIRST_BIT /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'LAST_BIT /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'FIRST_BIT /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'LAST_BIT /= IDENT_INT (4) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'FIRST_BIT /= IDENT_INT (5) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_2"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'LAST_BIT /= IDENT_INT (7) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_2"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_2"); + END IF; + + RESULT; +END CD4051D; Index: cd3015e.ada =================================================================== --- cd3015e.ada (nonexistent) +++ cd3015e.ada (revision 338) @@ -0,0 +1,130 @@ +-- CD3015E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN THERE IS NO ENUMERATION CLAUSE FOR THE PARENT +-- TYPE IN A GENERIC UNIT, THE DERIVED TYPE CAN BE USED CORRECTLY +-- IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC +-- INSTANTIATIONS. + +-- HISTORY +-- DHH 10/05/87 CREATED ORIGINAL TEST +-- DHH 03/30/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED +-- CHECK FOR REPRESENTATION CLAUSE. +-- RJW 03/20/90 MODIFIED CHECK FOR ARRAY INDEXING. +-- THS 09/18/90 REVISED WORDING ON FAILURE ERROR MESSAGE. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3015E IS + +BEGIN + + TEST ("CD3015E", "CHECK THAT WHEN THERE " & + "IS NO ENUMERATION CLAUSE FOR THE PARENT " & + "TYPE IN A GENERIC UNIT, THE " & + "DERIVED TYPE CAN BE USED CORRECTLY IN " & + "ORDERING RELATIONS, INDEXING ARRAYS, AND IN " & + "GENERIC INSTANTIATIONS"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + FOR HUE USE + (RED => 1, BLUE => 6, + YELLOW => 11, 'R' => 16, + 'B' => 22, 'Y' => 30); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + T : INTEGER := 1; + + TYPE INT1 IS RANGE 1 .. 30; + FOR INT1'SIZE USE HUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + IF (COLOR < BASIC OR + BASIC >= 'R' OR + 'Y' <= COLOR OR + COLOR > 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + + IF COLOR /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + FOR I IN HUE LOOP + BARRAY(I) := IDENT_INT(T); + T := T + 1; + END LOOP; + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + CHECK_1 (YELLOW, 11, "HUE"); + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015E; Index: cd5003g.ada =================================================================== --- cd5003g.ada (nonexistent) +++ cd5003g.ada (revision 338) @@ -0,0 +1,89 @@ +-- CD5003G.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A GENERIC PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE +-- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING +-- THE GENERIC PROCEDURE SPECIFICATION. + +-- HISTORY: +-- VCL 09/09/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH SYSTEM; +PACKAGE CD5003G_PACK2 IS + GENERIC + PROCEDURE CD5003G_PROC2; +END CD5003G_PACK2; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +PACKAGE BODY CD5003G_PACK2 IS + PROCEDURE CD5003G_PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD := 0.0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIXD; + BEGIN + TEST ("CD5003G", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A GENERIC PROCEDURE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS " & + "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PROCEDURE " & + "SPECIFICATION"); + + TEST_VAR := IDENT_FIXD (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END CD5003G_PROC2; +END CD5003G_PACK2; + + +WITH CD5003G_PACK2; USE CD5003G_PACK2; +PROCEDURE CD5003G IS + PROCEDURE PROC3 IS NEW CD5003G_PROC2; +BEGIN + PROC3; +END CD5003G; Index: cd3015g.ada =================================================================== --- cd3015g.ada (nonexistent) +++ cd3015g.ada (revision 338) @@ -0,0 +1,136 @@ +-- CD3015G.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 DERIVED ENUMERATION TYPE WITH A REPRESENTATION +-- CLAUSE CAN BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING +-- ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN THERE IS AN +-- ENUMERATION CLAUSE FOR THE PARENT. + +-- HISTORY +-- DHH 09/30/87 CREATED ORIGINAL TEST. +-- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO +-- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. +-- REVISED CHECK FOR ARRAY INDEXING. +-- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE +-- ERROR MESSAGE. + +WITH REPORT; USE REPORT; +PROCEDURE CD3015G IS + +BEGIN + + TEST ("CD3015G", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE CAN BE USED CORRECTLY " & + "IN ORDERING RELATIONS, INDEXING ARRAYS, AND " & + "IN GENERIC INSTANTIATIONS WHEN THERE IS AN " & + "ENUMERATION CLAUSE FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3, 'R' => 4, + 'B' => 5, 'Y' => 6); + + TYPE HUE IS NEW MAIN; + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END PACK; + + PACKAGE BODY PACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015G; Index: cd7007b.ada =================================================================== --- cd7007b.ada (nonexistent) +++ cd7007b.ada (revision 338) @@ -0,0 +1,52 @@ +-- CD7007B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE SUBTYPE 'PRIORITY' IS DECLARED WITHIN THE PACKAGE +-- SYSTEM AND IT IS A SUBTYPE OF 'INTEGER'. + +-- HISTORY: +-- VCL 09/16/87 CREATED ORIGINAL TEST. + +WITH SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CD7007B IS +BEGIN + TEST ("CD7007B", "THE SUBTYPE 'PRIORITY' IS DECLARED WITHIN " & + "THE PACKAGE SYSTEM AND IT IS A SUBTYPE OF " & + "'INTEGER'"); + + DECLARE + CHECK_VAR : SYSTEM.PRIORITY; + BEGIN + IF SYSTEM.PRIORITY'FIRST NOT IN + INTEGER'FIRST .. INTEGER'LAST AND + SYSTEM.PRIORITY'LAST NOT IN + INTEGER'FIRST .. INTEGER'LAST THEN + FAILED ("'SYSTEM.PRIORITY' IS NOT AN INTEGER SUBTYPE"); + END IF; + END; + + RESULT; +END CD7007B; Index: cd5003i.ada =================================================================== --- cd5003i.ada (nonexistent) +++ cd5003i.ada (revision 338) @@ -0,0 +1,94 @@ +-- CD5003I.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 NAMING 'SYSTEM' NEED NOT BE GIVEN +-- FOR A GENERIC PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS +-- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT +-- CONTAINING THE GENERIC PROCEDURE SPECIFICATION. + +-- HISTORY: +-- VCL 09/09/87 CREATED ORIGINAL TEST. +-- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +PACKAGE CD5003I_PACK3 IS + GENERIC + PROCEDURE PROC2; +END CD5003I_PACK3; + +WITH SYSTEM; +PACKAGE BODY CD5003I_PACK3 IS + PROCEDURE PROC2 IS SEPARATE; +END CD5003I_PACK3; + +WITH SPPRT13; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (SPPRT13); +PRAGMA ELABORATE (REPORT); +SEPARATE (CD5003I_PACK3) +PROCEDURE PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD; + FOR TEST_VAR + USE AT SPPRT13.VARIABLE_ADDRESS; + + USE SYSTEM; + + FUNCTION IDENT (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT; +BEGIN + TEST ("CD5003I", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A GENERIC PROCEDURE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PROCEDURE SPECIFICATION"); + + TEST_VAR := IDENT (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; +END PROC2; + +WITH CD5003I_PACK3; USE CD5003I_PACK3; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PROCEDURE CD5003I IS + PROCEDURE PROC3 IS NEW PROC2; +BEGIN + PROC3; +END CD5003I; Index: cd33001.a =================================================================== --- cd33001.a (nonexistent) +++ cd33001.a (revision 338) @@ -0,0 +1,139 @@ +-- CD33001.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 Component_Sizes that are a factor of the word +-- size are supported. +-- +-- Check that for such Component_Sizes arrays contain no gaps between +-- components. +-- +-- TEST DESCRIPTION: +-- This test defines three array types and specifies their layouts +-- using representation specifications for the 'Component_Size and +-- pragma Packs for each. It then checks that the implied assumptions +-- about the resulting layout actually can be made. +-- +-- APPLICABILITY CRITERIA: +-- All implementations must attempt to compile this test. +-- +-- For implementations validating against Systems Programming Annex (C): +-- this test must execute and report PASSED. +-- +-- For implementations not validating against Annex C: +-- this test may report compile time errors at one or more points +-- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. +-- Otherwise, the test must execute and report PASSED. +-- +-- +-- CHANGE HISTORY: +-- 22 JUL 95 SAIC Initial version +-- 07 MAY 96 SAIC Revised for 2.1 +-- 24 AUG 96 SAIC Additional 2.1 revisions +-- 17 FEB 97 PWB.CTA Corrected prefix of 'Component_Size to name +-- array object instead of array subtype +-- 16 FEB 98 EDS Modified documentation. +--! + +----------------------------------------------------------------- CD33001_0 + +with System; +package CD33001_0 is + + S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit; + + type Nibble is mod 2**4; + + type Byte is mod 2**8; + + type Half_Stuff is array(Natural range <>) of Nibble; + for Half_Stuff'Component_Size + use System.Word_Size / 2; -- factor -- ANX-C RQMT. + pragma Pack(Half_Stuff); -- ANX-C RQMT. + + type Word_Stuff is array(Natural range <>) of Byte; + for Word_Stuff'Component_Size + use System.Word_Size; -- ANX-C RQMT. + + type Address_Calculator is record + Item_1 : Nibble; + Item_2 : Nibble; + end record; + + for Address_Calculator use record + Item_1 at 0 range 0..3; + Item_2 at 1 range 0..3; + end record; + + -- given that Item_1 is specified to be at 'Position = 0 and + -- Item_2 is specified to be at 'Position = 1 + -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1 + +end CD33001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +-- there is no package body CD33001_0 + +------------------------------------------------------------------- CD33001 + +with Report; +with System.Storage_Elements; +with CD33001_0; +procedure CD33001 is + + use type System.Storage_Elements.Storage_Offset; + + A_Half : CD33001_0.Half_Stuff(0..15); + + A_Word : CD33001_0.Word_Stuff(0..15); + + procedure Unexpected( Message : String; Wanted, Got: Integer ) is + begin + Report.Failed( Message & " Wanted:" + & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) ); + end Unexpected; + +begin -- Main test procedure. + + Report.Test ("CD33001", "Check that Component_Sizes that are factor of " & + "the word size are supported. Check that for " & + "such Component_Sizes arrays contain no gaps " & + "between components" ); + + if A_Half'Size /= A_Half'Component_Size * 16 then + Unexpected("Half word Size", + CD33001_0.Half_Stuff'Component_Size * 16, + A_Half'Size ); + end if; + + if A_Word(1)'Size /= System.Word_Size then + Unexpected("Word Size", System.Word_Size, A_Word(1)'Size ); + end if; + + + Report.Result; + +end CD33001; Index: cd3015i.ada =================================================================== --- cd3015i.ada (nonexistent) +++ cd3015i.ada (revision 338) @@ -0,0 +1,144 @@ +-- CD3015I.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 DERIVED ENUMERATION TYPE WITH A REPRESENTATION +-- CLAUSE IN A GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING +-- RELATIONS, INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN +-- THERE IS AN ENUMERATION CLAUSE FOR THE PARENT. + +-- HISTORY +-- DHH 09/30/87 CREATED ORIGINAL TEST. +-- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. +-- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO +-- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. +-- REVISED CHECK FOR ARRAY INDEXING. +-- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE +-- ERROR MESSAGE. + +WITH REPORT; USE REPORT; +PROCEDURE CD3015I IS + +BEGIN + + TEST ("CD3015I", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " & + "BE USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC " & + "INSTANTIATIONS WHEN THERE IS AN ENUMERATION " & + "CLAUSE FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + FOR MAIN USE + (RED => 1, BLUE => 2, + YELLOW => 3, 'R' => 4, + 'B' => 5, 'Y' => 6); + + TYPE HUE IS NEW MAIN; + FOR HUE USE + (RED => 8, BLUE => 9, + YELLOW => 10, 'R' => 11, + 'B' => 12, 'Y' => 13); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; +END CD3015I; Index: cdd2a01.a =================================================================== --- cdd2a01.a (nonexistent) +++ cdd2a01.a (revision 338) @@ -0,0 +1,379 @@ +-- CDD2A01.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the Read and Write attributes for a type extension are created +-- from the parent type's attribute (which may be user-defined) and those +-- for the extension components. Also check that the default Input and +-- Output attributes are used for a type extension, even if the parent +-- type's attribute is user-defined. (Defect Report 8652/0040, +-- as reflected in Technical Corrigendum 1, penultimate sentence of +-- 13.13.2(9/1) and 13.13.2(25/1)). +-- +-- CHANGE HISTORY: +-- 30 JUL 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Streams; +use Ada.Streams; +with FDD2A00; +use FDD2A00; +with Report; +use Report; +procedure CDD2A01 is + + Input_Output_Error : exception; + + type Int is range 1 .. 1000; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is tagged + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + X : Parent (1, 1, True); + begin + raise Input_Output_Error; + return X; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + raise Input_Output_Error; + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + + type Derived1 is new Parent with + record + C3 : Int; + end record; + + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False) with + record + C3 : Int; + end record; + +begin + Test ("CDD2A01", + "Check that the Read and Write attributes for a type " & + "extension are created from the parent type's " & + "attribute (which may be user-defined) and those for the " & + "extension components; also check that the default input " & + "and output attributes are used for a type extension, even " & + "if the parent type's attribute is user-defined"); + + Test1: + declare + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + Y1 : Derived1 := (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (100), + C3 => Int (Ident_Int (88))); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + X1.C3 := Int (Ident_Int (99)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call parent type's Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + + if X2 /= (D1 => 2, + D2 => 5, + B => True, + S => Str (Ident_Str ("bcde")), + C2 => Float (Ident_Int (4)), + C3 => Int (Ident_Int (99))) then + Failed + ("Inherited Read and Write are not inverses of each other - 1"); + end if; + + begin + Derived1'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 4, Input => 0, Output => 0) then + Failed ("Error writing extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 2"); + end if; + exception + when Input_Output_Error => + Failed ("Did call inherited Output - 2"); + end; + + begin + declare + Y2 : Derived1 := Derived1'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Error reading extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 2"); + end if; + if Y2 /= (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (88))) then + Failed + ("Input and Output are not inverses of each other - 2"); + end if; + end; + exception + when Input_Output_Error => + Failed ("Did call inherited Input - 2"); + end; + + end Test1; + + Test2: + declare + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + Y1 : Derived2 := (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (200), + C3 => Int (Ident_Int (77))); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + X1.C3 := Int (Ident_Int (666)); + + Derived2'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 4, Write => 5, Input => 0, Output => 0) then + Failed ("Error writing extension components - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 3, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 3"); + end if; + + Derived2'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 5, Write => 5, Input => 0, Output => 0) then + Failed ("Error reading extension components - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 3, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 3"); + end if; + + if X2 /= (D => 7, + S => Str (Ident_Str ("g")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (666))) then + Failed ("Read and Write are not inverses of each other - 3"); + end if; + + begin + Derived2'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 5, Write => 7, Input => 0, Output => 0) then + Failed ("Error writing extension components - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 4, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 4"); + end if; + exception + when Input_Output_Error => + Failed ("Did call inherited Output - 4"); + end; + + begin + declare + Y2 : Derived2 := Derived2'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 7, Write => 7, Input => 0, Output => 0) then + Failed ("Error reading extension components - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 4"); + end if; + if Y2 /= (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (77))) then + Failed + ("Input and Output are not inverses of each other - 4"); + end if; + end; + exception + when Input_Output_Error => + Failed ("Did call inherited Input - 4"); + end; + + end Test2; + + Result; +end CDD2A01; Index: cd3015k.ada =================================================================== --- cd3015k.ada (nonexistent) +++ cd3015k.ada (revision 338) @@ -0,0 +1,92 @@ +-- CD3015K.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 ENUMERATION +-- REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN THE +-- VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A DERIVED TYPE +-- DECLARED IN THE VISIBLE PART, WHERE AN ENUMERATION CLAUSE +-- HAS BEEN GIVEN FOR THE PARENT. + +-- HISTORY +-- DHH 10/01/87 CREATED ORIGINAL TEST +-- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' +-- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + +WITH REPORT; USE REPORT; +WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD3015K IS + +BEGIN + + TEST ("CD3015K", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN " & + "THE VISIBLE OR PRIVATE PART OF A GENERIC " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN " & + "THE VISIBLE PART, WHERE AN ENUMERATION " & + "CLAUSE HAS BEEN GIVEN FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 8, BLUE => 11, YELLOW => 12); + + PRIVATE + + FOR NEWHUE USE (RED => 6, BLUE => 12, YELLOW => 18); + + TYPE INT1 IS RANGE 8 .. 12; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 6 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + BEGIN + CHECK_1 (RED, 8, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; +END CD3015K; Index: cd2a31a.ada =================================================================== --- cd2a31a.ada (nonexistent) +++ cd2a31a.ada (revision 338) @@ -0,0 +1,266 @@ +-- CD2A31A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN +-- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE +-- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + +-- HISTORY: +-- JET 08/06/87 CREATED ORIGINAL TEST. +-- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION +-- CLAUSE CHECK. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD2A31A IS + + BASIC_SIZE : CONSTANT := 9; + + TYPE INT IS RANGE -100 .. 100; + + FOR INT'SIZE USE BASIC_SIZE; + + I1 : INT := -100; + I2 : INT := 0; + I3 : INT := 100; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT; + INTARRAY : ARRAY_TYPE := (-100, 0, 100); + + TYPE REC_TYPE IS RECORD + COMPN : INT := -100; + COMPZ : INT := 0; + COMPP : INT := 100; + END RECORD; + + IREC : REC_TYPE; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT); + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE PROC (PIN, PIP : INT; + PIOZ, PIOP : IN OUT INT; + POP : OUT INT) IS + + BEGIN + IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PIN'SIZE"); + END IF; + + IF NOT ((PIN < IDENT (0)) AND + (IDENT (PIP) > IDENT (PIOZ)) AND + (PIOZ <= IDENT (1)) AND + (IDENT (100) = PIP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF NOT (((PIN + PIP) = PIOZ) AND + ((PIP - PIOZ) = PIOP) AND + ((PIOP * PIOZ) = PIOZ) AND + ((PIOZ / PIN) = PIOZ) AND + ((PIN ** 1) = PIN) AND + ((PIN REM 9) = IDENT (-1)) AND + ((PIP MOD 9) = IDENT (1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'VAL (-100) /= IDENT (PIN) OR + INT'VAL (0) /= IDENT (PIOZ) OR + INT'VAL (100) /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 1"); + END IF; + + IF INT'PRED (PIOZ) /= IDENT (-1) OR + INT'PRED (PIP) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 1"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (PIN) OR + INT'VALUE ("0") /= IDENT (PIOZ) OR + INT'VALUE ("100") /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 1"); + END IF; + + POP := 100; + + END PROC; + +BEGIN + TEST ("CD2A31A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (I1, 9, "INT"); + PROC (-100, 100, I2, I3, I3); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I1) .. IDENT (I3) LOOP + IF NOT (I IN I1 .. I3) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + END LOOP; + + IF NOT ((+I1 = I1) AND + (-I3 = I1) AND + (ABS I1 = I3)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'FIRST /= IDENT (-100) THEN + FAILED ("INCORRECT VALUE FOR INT'FIRST - 2"); + END IF; + + IF INT'POS (I1) /= IDENT_INT (-100) OR + INT'POS (I2) /= IDENT_INT ( 0) OR + INT'POS (I3) /= IDENT_INT ( 100) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 2"); + END IF; + + IF INT'SUCC (I1) /= IDENT (-99) OR + INT'SUCC (I2) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 2"); + END IF; + + IF INT'IMAGE (I1) /= IDENT_STR ("-100") OR + INT'IMAGE (I2) /= IDENT_STR (" 0") OR + INT'IMAGE (I3) /= IDENT_STR (" 100") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2"); + END IF; + + IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE"); + END IF; + + IF NOT ((INTARRAY(-1) < IDENT (0)) AND + (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND + (INTARRAY(0) <= IDENT (0)) AND + (IDENT (100) = INTARRAY (1))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP + IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT (((INTARRAY(-1) + INTARRAY( 1)) = INTARRAY( 0)) AND + ((INTARRAY( 0) - INTARRAY( 1)) = INTARRAY(-1)) AND + ((INTARRAY( 1) * INTARRAY( 0)) = INTARRAY( 0)) AND + ((INTARRAY( 0) / INTARRAY(-1)) = INTARRAY( 0)) AND + ((INTARRAY(-1) ** 1) = INTARRAY(-1)) AND + ((INTARRAY(-1) REM 9) = IDENT (-1)) AND + ((INTARRAY( 1) MOD 9) = IDENT ( 1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'POS (INTARRAY (-1)) /= IDENT_INT (-100) OR + INT'POS (INTARRAY ( 0)) /= IDENT_INT ( 0) OR + INT'POS (INTARRAY ( 1)) /= IDENT_INT ( 100) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 3"); + END IF; + + IF INT'SUCC (INTARRAY (-1)) /= IDENT (-99) OR + INT'SUCC (INTARRAY ( 0)) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 3"); + END IF; + + IF INT'IMAGE (INTARRAY (-1)) /= IDENT_STR ("-100") OR + INT'IMAGE (INTARRAY ( 0)) /= IDENT_STR (" 0") OR + INT'IMAGE (INTARRAY ( 1)) /= IDENT_STR (" 100") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3"); + END IF; + + IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE"); + END IF; + + IF NOT ((IREC.COMPN < IDENT (0)) AND + (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND + (IREC.COMPZ <= IDENT (0)) AND + (IDENT (100) = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP + IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT ((+IREC.COMPN = IREC.COMPN) AND + (-IREC.COMPP = IREC.COMPN) AND + (ABS IREC.COMPN = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'VAL (-100) /= IDENT (IREC.COMPN) OR + INT'VAL ( 0) /= IDENT (IREC.COMPZ) OR + INT'VAL ( 100) /= IDENT (IREC.COMPP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 4"); + END IF; + + IF INT'PRED (IREC.COMPZ) /= IDENT (-1) OR + INT'PRED (IREC.COMPP) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 4"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (IREC.COMPN) OR + INT'VALUE ( "0") /= IDENT (IREC.COMPZ) OR + INT'VALUE ( "100") /= IDENT (IREC.COMPP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 4"); + END IF; + + RESULT; +END CD2A31A; Index: cd2a31c.ada =================================================================== --- cd2a31c.ada (nonexistent) +++ cd2a31c.ada (revision 338) @@ -0,0 +1,127 @@ +-- CD2A31C.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 INTEGER 'SIZE SPECIFICATIONS CAN BE GIVEN: +-- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE +-- DECLARED IN THE VISIBLE PART; +-- FOR A DERIVED INTEGER TYPE; +-- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS +-- AN INTEGER TYPE; +-- FOR AN INTEGER TYPE IN A GENERIC UNIT. + +-- HISTORY: +-- PWB 06/17/87 CREATED ORIGINAL TEST. +-- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION +-- CLAUSE CHECK AND INCLUDED TEST FOR INTEGER IN A +-- GENERIC UNIT. +-- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. +-- DTN 06/17/92 REMOVED THE LENGTH CLAUSE FOR TYPE PRIVATE_INT. + +WITH REPORT; USE REPORT; +WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. +PROCEDURE CD2A31C IS + + TYPE BASIC_INT IS RANGE -60 .. 80; + SPECIFIED_SIZE : CONSTANT := 9; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE -125 .. 125; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE -125 .. 125; + PRIVATE + TYPE PRIVATE_INT IS RANGE -125 .. 125; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + +-- SIZE SPECIFICATION GIVEN IN A GENERIC PROCEDURE. + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + TYPE CHECK_INT IS RANGE -125 .. 125; + FOR CHECK_INT'SIZE USE SPECIFIED_SIZE; + + PROCEDURE CHECK_4 IS NEW LENGTH_CHECK (CHECK_INT); + + BEGIN + + IF CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GENERIC CHECK_INT'SIZE IS INCORRECT"); + END IF; + CHECK_4 (-60, 9, "GENERIC CHECK_INT"); + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_INT); + PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (INT_IN_P); + PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_INT_IN_P); + +BEGIN + + TEST("CD2A31C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN IN " & + "VISIBLE OR PRIVATE PART OF PACKAGE FOR INTEGER " & + "TYPE DECLARED IN VISIBLE PART, AND FOR " & + "DERIVED INTEGER TYPES " & + "AND DERIVED PRIVATE TYPES WHOSE FULL DECLARATIONS " & + "ARE AS INTEGER TYPES"); + + CHECK_1 (-60, 9, "DERIVED_INT"); + CHECK_2 (-60, 9, "INT_IN_P"); + CHECK_3 (-60, 9, "ALT_INT_IN_P"); + + NEWPROC; + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE INCORRECT"); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE INCORRECT"); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE INCORRECT"); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE INCORRECT"); + END IF; + + RESULT; + +END CD2A31C; Index: cd2a31e.ada =================================================================== --- cd2a31e.ada (nonexistent) +++ cd2a31e.ada (revision 338) @@ -0,0 +1,139 @@ +-- CD2A31E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN +-- INTEGER TYPE, THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL +-- PARAMETER TO GENERIC PROCEDURES. + +-- HISTORY: +-- JET 08/12/87 CREATED ORIGINAL TEST. +-- BCB 10/18/88 MODIFIED HEADER AND ENTERED IN ACVC. +-- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED +-- SIZE CLAUSE VALUE TO 9, AND CHANGED 'SIZE CLAUSE +-- CHECKS. +-- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + +WITH REPORT; USE REPORT; + +PROCEDURE CD2A31E IS + + TYPE BASIC_INT IS RANGE -100 .. 100; + BASIC_SIZE : CONSTANT := 9; + + FOR BASIC_INT'SIZE USE BASIC_SIZE; + +BEGIN + + TEST ("CD2A31E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN SUCH A TYPE " & + "CAN BE PASSED AS AN ACTUAL PARAMETER TO " & + "GENERIC PACKAGES AND PROCEDURES"); + + DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS RANGE <>; + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + SUBTYPE INT IS GPARM; + + I1 : INT := -100; + I2 : INT := 0; + I3 : INT := 100; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + IF NOT ((I1 < IDENT (0)) AND + (IDENT (I3) > IDENT (I2)) AND + (I2 <= IDENT (0)) AND + (IDENT (100) = I3)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF NOT (((I1 + I3) = I2) AND + ((I2 - I3) = I1) AND + ((I3 * I2) = I2) AND + ((I2 / I1) = I2) AND + ((I1 ** 1) = I1) AND + ((I1 REM 9) = IDENT (-1)) AND + ((I3 MOD 9) = IDENT (1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS"); + END IF; + + IF INT'LAST /= IDENT (100) THEN + FAILED ("INCORRECT VALUE FOR INT'LAST"); + END IF; + + IF INT'VAL (-100) /= IDENT (I1) OR + INT'VAL (0) /= IDENT (I2) OR + INT'VAL (100) /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL"); + END IF; + + IF INT'PRED (I2) /= IDENT (-1) OR + INT'PRED (I3) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (I1) OR + INT'VALUE (" 0") /= IDENT (I2) OR + INT'VALUE (" 100") /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT); + + BEGIN + + NEWPROC; + + END; + + RESULT; + +END CD2A31E; Index: cd7101f.dep =================================================================== --- cd7101f.dep (nonexistent) +++ cd7101f.dep (revision 338) @@ -0,0 +1,62 @@ +-- CD7101F.DEP + +-- 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 MIN_INT AND MAX_INT IN PACKAGE SYSTEM, +-- LONG_INTEGER'FIRST >= MIN_INT AND LONG_INTEGER'LAST <= MAX_INT. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE LONG_INTEGER DATA TYPE. + +-- IF THE LONG_INTEGER TYPE IS NOT SUPPORTED, THEN THE +-- DECLARATION OF "TEST_VAR" MUST BE REJECTED. + +-- HISTORY: +-- JET 09/10/87 CREATED ORIGINAL TEST. + +WITH SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE CD7101F IS + + TEST_VAR : LONG_INTEGER := 0; -- N/A => ERROR. + +BEGIN + + TEST ("CD7101F", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " & + "SYSTEM, LONG_INTEGER'FIRST >= MIN_INT AND " & + "LONG_INTEGER'LAST <= MAX_INT"); + + IF LONG_INTEGER'POS (LONG_INTEGER'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF LONG_INTEGER'POS (LONG_INTEGER'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + +END CD7101F;

powered by: WebSVN 2.1.0

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