diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/cd | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cd')
179 files changed, 22707 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10001.a b/gcc/testsuite/ada/acats/tests/cd/cd10001.a new file mode 100644 index 000000000..6b44067c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd10001.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd10002.a b/gcc/testsuite/ada/acats/tests/cd/cd10002.a new file mode 100644 index 000000000..fc56d4299 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd10002.a @@ -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; + + diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada new file mode 100644 index 000000000..905675a7f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada new file mode 100644 index 000000000..2cbc9e77f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada new file mode 100644 index 000000000..738235f65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada new file mode 100644 index 000000000..4524358fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada new file mode 100644 index 000000000..8bcde28c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada new file mode 100644 index 000000000..1a1426b5c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada new file mode 100644 index 000000000..35cccb522 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada new file mode 100644 index 000000000..ba35fed3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada new file mode 100644 index 000000000..dcae459af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst new file mode 100644 index 000000000..02a824abf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada new file mode 100644 index 000000000..61bca0d49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada new file mode 100644 index 000000000..7e1932a43 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada new file mode 100644 index 000000000..9ebcaa106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada new file mode 100644 index 000000000..4317a0d05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada new file mode 100644 index 000000000..3dcc29a6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada new file mode 100644 index 000000000..e6c88d837 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada new file mode 100644 index 000000000..fe2bd21f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada new file mode 100644 index 000000000..ef67765a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst new file mode 100644 index 000000000..1ed4b53e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst b/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst new file mode 100644 index 000000000..de803d480 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada new file mode 100644 index 000000000..945e236c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada new file mode 100644 index 000000000..ef06e43f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada new file mode 100644 index 000000000..045be9455 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada new file mode 100644 index 000000000..1300c17f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada b/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada new file mode 100644 index 000000000..61e6b1314 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada new file mode 100644 index 000000000..1b4bf239c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada new file mode 100644 index 000000000..5536ead82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada new file mode 100644 index 000000000..9e37bb4b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst b/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst new file mode 100644 index 000000000..8b706c553 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada new file mode 100644 index 000000000..3686710c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada new file mode 100644 index 000000000..898b68a1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada new file mode 100644 index 000000000..ad84e9196 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada new file mode 100644 index 000000000..25ad2e082 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada new file mode 100644 index 000000000..2c04b1e7b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada new file mode 100644 index 000000000..9e95b546d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada b/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada new file mode 100644 index 000000000..21c7a7eef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst b/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst new file mode 100644 index 000000000..fff91a357 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd20001.a b/gcc/testsuite/ada/acats/tests/cd/cd20001.a new file mode 100644 index 000000000..21f973873 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada new file mode 100644 index 000000000..6f42d393c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada new file mode 100644 index 000000000..0fc6fb127 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada new file mode 100644 index 000000000..c241ea39d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada new file mode 100644 index 000000000..37564d807 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada new file mode 100644 index 000000000..2ed878c5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada new file mode 100644 index 000000000..2dbe50341 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada new file mode 100644 index 000000000..89737c746 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada new file mode 100644 index 000000000..2526f7106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada new file mode 100644 index 000000000..234c7119a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada new file mode 100644 index 000000000..2ec575715 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada new file mode 100644 index 000000000..fcb0087b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada new file mode 100644 index 000000000..494516bf0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada new file mode 100644 index 000000000..2a9fd8175 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada new file mode 100644 index 000000000..be8efa615 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada new file mode 100644 index 000000000..2b01ed6e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada new file mode 100644 index 000000000..b4ed17caa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada new file mode 100644 index 000000000..228b445d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada new file mode 100644 index 000000000..a8edaa6ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada new file mode 100644 index 000000000..621ea6749 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada new file mode 100644 index 000000000..c9d84665c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada new file mode 100644 index 000000000..d3439a71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada new file mode 100644 index 000000000..e8969b3cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada new file mode 100644 index 000000000..f1ce2886b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada new file mode 100644 index 000000000..15613b5d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada new file mode 100644 index 000000000..a023967de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst b/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst new file mode 100644 index 000000000..26413daac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst b/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst new file mode 100644 index 000000000..09acce9f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada new file mode 100644 index 000000000..580bb8d11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada new file mode 100644 index 000000000..770d8d83f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada new file mode 100644 index 000000000..e620bad74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada new file mode 100644 index 000000000..b71f03261 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada new file mode 100644 index 000000000..ad1564502 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada new file mode 100644 index 000000000..8e58d81a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada new file mode 100644 index 000000000..6dc514186 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst b/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst new file mode 100644 index 000000000..d4f326b99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst b/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst new file mode 100644 index 000000000..2e5a5fe9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada new file mode 100644 index 000000000..f44e8ef7d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada b/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada new file mode 100644 index 000000000..abb3f6bcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30001.a b/gcc/testsuite/ada/acats/tests/cd/cd30001.a new file mode 100644 index 000000000..d65e14508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30002.a b/gcc/testsuite/ada/acats/tests/cd/cd30002.a new file mode 100644 index 000000000..7b6fff713 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30003.a b/gcc/testsuite/ada/acats/tests/cd/cd30003.a new file mode 100644 index 000000000..af414490f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30003.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd30004.a b/gcc/testsuite/ada/acats/tests/cd/cd30004.a new file mode 100644 index 000000000..1a1bcff1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30004.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd300050.am b/gcc/testsuite/ada/acats/tests/cd/cd300050.am new file mode 100644 index 000000000..81b6e3354 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd300051.c b/gcc/testsuite/ada/acats/tests/cd/cd300051.c new file mode 100644 index 000000000..5771fc81b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; + } + diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada new file mode 100644 index 000000000..ee37df82a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada new file mode 100644 index 000000000..9e8af8980 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada new file mode 100644 index 000000000..6ce3f4ce8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada new file mode 100644 index 000000000..430cc4b2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada new file mode 100644 index 000000000..34b930db0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada new file mode 100644 index 000000000..c4ed23801 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada new file mode 100644 index 000000000..f0de7be60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada new file mode 100644 index 000000000..61e93ec49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada new file mode 100644 index 000000000..9158dc64b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada new file mode 100644 index 000000000..ad557091d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada new file mode 100644 index 000000000..c1cf45b0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada b/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada new file mode 100644 index 000000000..a075f887c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada new file mode 100644 index 000000000..4bad83b61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33001.a b/gcc/testsuite/ada/acats/tests/cd/cd33001.a new file mode 100644 index 000000000..82555054a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd33001.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd33002.a b/gcc/testsuite/ada/acats/tests/cd/cd33002.a new file mode 100644 index 000000000..5b3cdbd5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd40001.a b/gcc/testsuite/ada/acats/tests/cd/cd40001.a new file mode 100644 index 000000000..273271fdb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd40001.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada b/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada new file mode 100644 index 000000000..936088d65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst b/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst new file mode 100644 index 000000000..d0e2fd65d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada new file mode 100644 index 000000000..746f82bcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada new file mode 100644 index 000000000..1cd440f44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada new file mode 100644 index 000000000..ea97f1caf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada b/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada new file mode 100644 index 000000000..5b83c336c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada new file mode 100644 index 000000000..04a7c1a3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada new file mode 100644 index 000000000..789edd570 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada new file mode 100644 index 000000000..9ea5ae59d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada new file mode 100644 index 000000000..a5a83785c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada new file mode 100644 index 000000000..8c157f832 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada new file mode 100644 index 000000000..1e54c6d24 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada new file mode 100644 index 000000000..5789fec5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada new file mode 100644 index 000000000..c0418568d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada new file mode 100644 index 000000000..7ea6dc715 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada new file mode 100644 index 000000000..b586f0d9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada new file mode 100644 index 000000000..45b2490c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada new file mode 100644 index 000000000..2806fb229 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada new file mode 100644 index 000000000..1b63ba50c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada new file mode 100644 index 000000000..a0a841879 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada new file mode 100644 index 000000000..6c4a16a3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada new file mode 100644 index 000000000..25d6f856e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada new file mode 100644 index 000000000..4b9bf5c36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada b/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada new file mode 100644 index 000000000..2943892da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada new file mode 100644 index 000000000..05cb7babd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada new file mode 100644 index 000000000..455fe8564 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada new file mode 100644 index 000000000..bfcd2f545 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada new file mode 100644 index 000000000..69fb2e80b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada new file mode 100644 index 000000000..1be46d425 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada new file mode 100644 index 000000000..1cd3c218e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada new file mode 100644 index 000000000..ad7650e45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada new file mode 100644 index 000000000..f00dfecb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada new file mode 100644 index 000000000..cb04cfd62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada new file mode 100644 index 000000000..355c682c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada new file mode 100644 index 000000000..7a405b28a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada new file mode 100644 index 000000000..469abf4a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada new file mode 100644 index 000000000..2e4838606 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada b/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada new file mode 100644 index 000000000..c063fcef3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada new file mode 100644 index 000000000..094017798 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada new file mode 100644 index 000000000..d09969f05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada new file mode 100644 index 000000000..145e3aaf1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada new file mode 100644 index 000000000..28ab3997d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada new file mode 100644 index 000000000..23c235783 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada new file mode 100644 index 000000000..1cee824e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada new file mode 100644 index 000000000..8b0ec5743 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada new file mode 100644 index 000000000..e8018ca98 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada new file mode 100644 index 000000000..9eee00c71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada new file mode 100644 index 000000000..237a37a88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada new file mode 100644 index 000000000..fe6e2cb3b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada new file mode 100644 index 000000000..75c8ba64a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada b/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada new file mode 100644 index 000000000..dee329120 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd70001.a b/gcc/testsuite/ada/acats/tests/cd/cd70001.a new file mode 100644 index 000000000..484009588 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada new file mode 100644 index 000000000..f278c0bdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada b/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada new file mode 100644 index 000000000..c5edf4b22 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada b/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada new file mode 100644 index 000000000..9b56f2c3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep b/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep new file mode 100644 index 000000000..d2d430a07 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep b/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep new file mode 100644 index 000000000..4f1169eac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst b/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst new file mode 100644 index 000000000..b91a34d48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada b/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada new file mode 100644 index 000000000..f6da8a0bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada new file mode 100644 index 000000000..8e4f89aef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada b/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada new file mode 100644 index 000000000..64114ad22 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada b/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada new file mode 100644 index 000000000..77ca9bdb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a01.a b/gcc/testsuite/ada/acats/tests/cd/cd72a01.a new file mode 100644 index 000000000..9c98cb0c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd72a02.a b/gcc/testsuite/ada/acats/tests/cd/cd72a02.a new file mode 100644 index 000000000..f396edc19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada b/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada new file mode 100644 index 000000000..3241fca8f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd90001.a b/gcc/testsuite/ada/acats/tests/cd/cd90001.a new file mode 100644 index 000000000..bd5c070a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd90001.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cd92001.a b/gcc/testsuite/ada/acats/tests/cd/cd92001.a new file mode 100644 index 000000000..d07ff4881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd92001.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201a.ada b/gcc/testsuite/ada/acats/tests/cd/cda201a.ada new file mode 100644 index 000000000..b433f0cac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201a.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201b.ada b/gcc/testsuite/ada/acats/tests/cd/cda201b.ada new file mode 100644 index 000000000..742cd92c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201c.ada b/gcc/testsuite/ada/acats/tests/cd/cda201c.ada new file mode 100644 index 000000000..db742ace7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201c.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cda201e.ada b/gcc/testsuite/ada/acats/tests/cd/cda201e.ada new file mode 100644 index 000000000..c82e48c53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201e.ada @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a new file mode 100644 index 000000000..566fad138 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a new file mode 100644 index 000000000..6a7fca54a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd1001.a b/gcc/testsuite/ada/acats/tests/cd/cdd1001.a new file mode 100644 index 000000000..3e16f5d4f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd1001.a @@ -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; + diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2001.a b/gcc/testsuite/ada/acats/tests/cd/cdd2001.a new file mode 100644 index 000000000..3184dded8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; + diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a new file mode 100644 index 000000000..7c8000ce0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a new file mode 100644 index 000000000..854431c34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a new file mode 100644 index 000000000..b4c291772 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a @@ -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; diff --git a/gcc/testsuite/ada/acats/tests/cd/cde0001.a b/gcc/testsuite/ada/acats/tests/cd/cde0001.a new file mode 100644 index 000000000..59db2256f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cde0001.a @@ -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; |