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/c7 | |
| 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/c7')
53 files changed, 12605 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c72001b.ada b/gcc/testsuite/ada/acats/tests/c7/c72001b.ada new file mode 100644 index 000000000..41a1a2c6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c72001b.ada @@ -0,0 +1,96 @@ +-- C72001B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A PACKAGE BODY CAN BE PROVIDED FOR A PACKAGE SPECIFICATION +-- THAT DOES NOT CONTAIN ANY SUBPROGRAM OR TASK DECLARATIONS AND THAT +-- STATEMENTS WITHIN THE PACKAGE BODIES CAN BE USED TO INITIALIZE +-- VARIABLES VISIBLE WITHIN THE PACKAGE BODY. + +-- RM 04/30/81 +-- RM 05/07/81 (TO INCORPORATE OLD TEST OBJECTIVE 7.1/T1 ) +-- ABW 6/10/82 +-- SPS 11/4/82 +-- JBG 9/15/83 + +WITH REPORT; +PROCEDURE C72001B IS + + USE REPORT; + +BEGIN + + TEST( "C72001B" , "CHECK: PACKAGE BODIES CAN INITIALIZE VISIBLE" & + " VARIABLES" ); + + DECLARE + + + PACKAGE P5 IS + + A : CHARACTER := 'B'; + B : BOOLEAN := FALSE; + + PACKAGE P6 IS + I : INTEGER := IDENT_INT(6); + END P6; + + END P5; + + + PACKAGE BODY P5 IS + PACKAGE BODY P6 IS + BEGIN + A := 'C'; + I := 17; + B := IDENT_BOOL(TRUE); + END P6; + BEGIN + A := 'A'; + END P5; + + + USE P5; + USE P6; + + BEGIN + + IF A /= 'A' THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 1"); + END IF; + + IF B /= TRUE THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 2"); + END IF; + + IF I /= 17 THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 3"); + END IF; + + END; + + + RESULT; + + +END C72001B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c72002a.ada b/gcc/testsuite/ada/acats/tests/c7/c72002a.ada new file mode 100644 index 000000000..491f074f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c72002a.ada @@ -0,0 +1,229 @@ +-- C72002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE SPECIFICATION ARE +-- ELABORATED IN THE ORDER DECLARED. + +-- HISTORY: +-- DHH 03/09/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C72002A IS + + A : INTEGER := 0; + TYPE ORDER_ARRAY IS ARRAY(1 .. 14) OF INTEGER; + OBJECT_ARRAY : ORDER_ARRAY; + TYPE REAL IS DIGITS 4; + TYPE ENUM IS (RED,YELLOW,BLUE); + + TYPE ARR IS ARRAY(1 ..2) OF BOOLEAN; + D : ARR := (TRUE, TRUE); + E : ARR := (FALSE, FALSE); + + TYPE REC IS + RECORD + I : INTEGER; + END RECORD; + B : REC := (I => IDENT_INT(1)); + C : REC := (I => IDENT_INT(2)); + + FUNCTION GIVEN_ORDER(X : INTEGER) RETURN INTEGER IS + Y : INTEGER; + BEGIN + Y := X + 1; + RETURN Y; + END GIVEN_ORDER; + + FUNCTION BOOL(X : INTEGER) RETURN BOOLEAN IS + BEGIN + IF X = IDENT_INT(1) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN TRUE; + ELSIF X = IDENT_INT(8) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN FALSE; + END IF; + END BOOL; + + FUNCTION INT(X : INTEGER) RETURN INTEGER IS + BEGIN + IF X = IDENT_INT(2) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN IDENT_INT(1); + ELSIF X = IDENT_INT(9) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN IDENT_INT(2); + END IF; + END INT; + + FUNCTION FLOAT(X : INTEGER) RETURN REAL IS + BEGIN + IF X = IDENT_INT(3) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 1.0; + ELSIF X = IDENT_INT(10) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 2.0; + END IF; + END FLOAT; + + FUNCTION CHAR(X : INTEGER) RETURN CHARACTER IS + BEGIN + IF X = IDENT_INT(4) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 'A'; + ELSIF X = IDENT_INT(11) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 'Z'; + END IF; + END CHAR; + + FUNCTION ENUMR(X : INTEGER) RETURN ENUM IS + BEGIN + IF X = IDENT_INT(5) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN RED; + ELSIF X = IDENT_INT(12) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN YELLOW; + END IF; + END ENUMR; + + FUNCTION ARRY(X : INTEGER) RETURN ARR IS + BEGIN + IF X = IDENT_INT(6) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN D; + ELSIF X = IDENT_INT(13) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN E; + END IF; + END ARRY; + + FUNCTION RECOR(X : INTEGER) RETURN REC IS + BEGIN + IF X = IDENT_INT(7) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN B; + ELSIF X = IDENT_INT(14) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN C; + END IF; + END RECOR; + + PACKAGE PACK IS + A : BOOLEAN := BOOL(1); + B : INTEGER := INT(2); + C : REAL := FLOAT(3); + D : CHARACTER := CHAR(4); + E : ENUM := ENUMR(5); + F : ARR := ARRY(6); + G : REC := RECOR(7); + H : BOOLEAN := BOOL(8); + I : INTEGER := INT(9); + J : REAL := FLOAT(10); + K : CHARACTER := CHAR(11); + L : ENUM := ENUMR(12); + M : ARR := ARRY(13); + N : REC := RECOR(14); + END PACK; + +BEGIN + TEST("C72002A", "CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE " & + "SPECIFICATION ARE ELABORATED IN THE ORDER " & + "DECLARED"); + + IF OBJECT_ARRAY(1) /= IDENT_INT(1) THEN + FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(2) /= IDENT_INT(2) THEN + FAILED("INTEGER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(3) /= IDENT_INT(3) THEN + FAILED("REAL 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(4) /= IDENT_INT(4) THEN + FAILED("CHARACTER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(5) /= IDENT_INT(5) THEN + FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(6) /= IDENT_INT(6) THEN + FAILED("ARRAY 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(7) /= IDENT_INT(7) THEN + FAILED("RECORD 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(8) /= IDENT_INT(8) THEN + FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(9) /= IDENT_INT(9) THEN + FAILED("INTEGER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(10) /= IDENT_INT(10) THEN + FAILED("REAL 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(11) /= IDENT_INT(11) THEN + FAILED("CHARACTER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(12) /= IDENT_INT(12) THEN + FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(13) /= IDENT_INT(13) THEN + FAILED("ARRAY 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(14) /= IDENT_INT(14) THEN + FAILED("RECORD 2 ELABORATED OUT OF ORDER"); + END IF; + + RESULT; +END C72002A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730001.a b/gcc/testsuite/ada/acats/tests/c7/c730001.a new file mode 100644 index 000000000..24cf8e0fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730001.a @@ -0,0 +1,437 @@ +-- C730001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the full view of a private extension may be derived +-- indirectly from the ancestor type (i.e., the parent type of the full +-- type may be any descendant of the ancestor type). Check that, for +-- a primitive subprogram of the private extension that is inherited from +-- the ancestor type and not overridden, the formal parameter names and +-- default expressions come from the corresponding primitive subprogram +-- of the ancestor type, while the body comes from that of the parent +-- type. Check both dispatching and non-dispatching cases. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Ancestor is tagged ... +-- procedure Op (P1: Ancestor; P2: Boolean := True); +-- end P; +-- +-- with P; +-- package Q is +-- type Derived is new P.Ancestor with ... +-- procedure Op (X: Ancestor; Y: Boolean := False); +-- end Q; +-- +-- with P, Q; +-- package R is +-- type Priv_Ext is new P.Ancestor with private; -- (A) +-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True); +-- -- But body executed is that of Q.Op. +-- private +-- type Priv_Ext is new Q.Derived with record ... -- (B) +-- end R; +-- +-- The ancestor type in (A) differs from the parent type in (B); the +-- parent of the full type is descended from the ancestor type of the +-- private extension. For a call to Op (from outside the scope of the +-- full view) with an operand of type Priv_Ext, the formal parameter +-- names and default expression come from that of P.Op (the ancestor +-- type's version), but the body executed will be that of +-- Q.Op (the parent type's version) +-- +-- One half of the test mirrors the above template, where an inherited +-- subprogram (Set_Display) is called using the formal parameter +-- name (C) and default parameter expression of the ancestor type's +-- version (type Clock), but the version of the body executed is from +-- the parent type. +-- +-- The test also includes an examination of the dynamic evaluation +-- case, where correct body associations are required through dispatching +-- calls. As described for the non-dispatching case above, the formal +-- parameter name and default values of the ancestor type's (Phone) +-- version of the inherited subprogram (Answer) are used in the +-- dispatching call, but the body executed is from the parent type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C730001_0 is + + type Display_Kind is (None, Analog, Digital); + type Illumination_Type is (None, Light, Phosphorescence); + type Capability_Type is (Available, In_Use, Call_Waiting, Conference); + type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem); + + type Clock is abstract tagged record -- ancestor type associated + Display : Display_Kind := None; -- with non-dispatching case. + Illumination : Illumination_Type := None; + end record; + + type Phone is tagged record -- ancestor type associated + Status : Capability_Type := Available; -- with dispatching case. + Indicator : Indicator_Type := None; + end record; + + -- The Set_Display procedure for type Clock implements a basic, no-frills + -- clock display. + procedure Set_Display (C : in out Clock; + Disp: in Display_Kind := Digital); + + -- The Answer procedure for type Phone implements a phone status change + -- operation. + procedure Answer (The_Phone : in out Phone; + Ind : in Indicator_Type := Light); + -- ...Other general clock and/or phone operations (not specified in this + -- test scenario). + +end C730001_0; + + + --==================================================================-- + + +package body C730001_0 is + + procedure Set_Display (C : in out Clock; + Disp: in Display_Kind := Digital) is + begin + C.Display := Disp; + C.Illumination := Light; + end Set_Display; + + procedure Answer (The_Phone : in out Phone; + Ind : in Indicator_Type := Light) is + begin + The_Phone.Status := In_Use; + The_Phone.Indicator := Ind; + end Answer; + +end C730001_0; + + + --==================================================================-- + + +with C730001_0; use C730001_0; +package C730001_1 is + + type Power_Supply_Type is (Spring, Battery, AC_Current); + type Speaker_Type is (None, Present, Adjustable, Stereo); + + type Wall_Clock is new Clock with record + Power_Source : Power_Supply_Type := Spring; + end record; + + type Office_Phone is new Phone with record + Speaker : Speaker_Type := Present; + end record; + + -- Note: Both procedures below, parameter names and defaults differ from + -- parent's version. + + -- The Set_Display procedure for type Wall_Clock improves upon the + -- basic Set_Display procedure of type Clock. + + procedure Set_Display (WC: in out Wall_Clock; + D : in Display_Kind := Analog); + + procedure Answer (OP : in out Office_Phone; + OI : in Indicator_Type := Buzzer); + + -- ...Other wall clock and/or Office_Phone operations (not specified in + -- this test scenario). + +end C730001_1; + + + --==================================================================-- + + +package body C730001_1 is + + -- Note: This body is the one that should be executed in the test block + -- below, not the version of the body corresponding to type Clock. + + procedure Set_Display (WC: in out Wall_Clock; + D : in Display_Kind := Analog) is + begin + WC.Display := D; + WC.Illumination := Phosphorescence; + end Set_Display; + + + procedure Answer (OP : in out Office_Phone; + OI : in Indicator_Type := Buzzer) is + begin + OP.Status := Call_Waiting; + OP.Indicator := OI; + end Answer; + +end C730001_1; + + + --==================================================================-- + + +with C730001_0; use C730001_0; +with C730001_1; use C730001_1; +package C730001_2 is + + type Alarm_Type is (Buzzer, Radio, Both); + type Video_Type is (None, TV_Monitor, Wall_Projection); + + type Alarm_Clock is new Clock with private; + -- Inherits proc Set_Display (C : in out Clock; + -- Disp: in Display_Kind := Digital); -- (A) + -- + -- Would also inherit other general clock operations (if present). + + + type Conference_Room_Phone is new Office_Phone with record + Display : Video_Type := TV_Monitor; + end record; + + procedure Answer (CP : in out Conference_Room_Phone; + CI : in Indicator_Type := Modem); + + + function TC_Get_Display (C: Alarm_Clock) return Display_Kind; + function TC_Get_Display_Illumination (C: Alarm_Clock) + return Illumination_Type; + +private + + -- ...however, certain of the wall clock's operations (Set_Display, in + -- this example) improve on the implementations provided for the general + -- clock. We want to call the improved implementations, so we + -- derive from Wall_Clock in the private part. + + type Alarm_Clock is new Wall_Clock with record + Alarm : Alarm_Type := Buzzer; + end record; + + -- Inherits proc Set_Display (WC: in out Wall_Clock; + -- D : in Display_Kind := Analog); -- (B) + + -- The implicit Set_Display at (B) overrides the implicit Set_Display at + -- (A), but only within the scope of the full view. + -- + -- Outside the scope of the full view, only (A) is visible, so calls + -- from outside the scope will get the formal parameter names and default + -- from (A). Both inside and outside the scope, however, the body executed + -- will be that corresponding to Set_Display of the parent type. + +end C730001_2; + + + --==================================================================-- + + +package body C730001_2 is + + procedure Answer (CP : in out Conference_Room_Phone; + CI : in Indicator_Type := Modem)is + begin + CP.Status := Conference; + CP.Indicator := CI; + end Answer; + + + function TC_Get_Display (C: Alarm_Clock) return Display_Kind is + begin + return C.Display; + end TC_Get_Display; + + + function TC_Get_Display_Illumination (C: Alarm_Clock) + return Illumination_Type is + begin + return C.Illumination; + end TC_Get_Display_Illumination; + +end C730001_2; + + + --==================================================================-- + + +with C730001_0; use C730001_0; +with C730001_1; use C730001_1; +with C730001_2; use C730001_2; + +package C730001_3 is + + -- Types extended from the ancestor (Phone) type in the specification. + + type Secure_Phone_Type is new Phone with private; + type Auditorium_Phone_Type is new Phone with private; + -- Inherit versions of Answer from ancestor (Phone). + + function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type; + function TC_Get_Indicator (P : Phone'Class) return Indicator_Type; + +private + + -- Types extended from descendents of Phone_Type in the private part. + + type Secure_Phone_Type is new Office_Phone with record + Scrambled_Communication : Boolean := True; + end record; + + type Auditorium_Phone_Type is new Conference_Room_Phone with record + Volume_Control : Boolean := True; + end record; + +end C730001_3; + + --==================================================================-- + +package body C730001_3 is + + function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is + begin + return P.Status; + end TC_Get_Phone_Status; + + function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is + begin + return P.Indicator; + end TC_Get_Indicator; + +end C730001_3; + + --==================================================================-- + +with C730001_0; use C730001_0; +with C730001_1; use C730001_1; +with C730001_2; use C730001_2; +with C730001_3; use C730001_3; + +with Report; + +procedure C730001 is +begin + + Report.Test ("C730001","Check that the full view of a private extension " & + "may be derived indirectly from the ancestor " & + "type. Check that, for a primitive subprogram " & + "of the private extension that is inherited from " & + "the ancestor type and not overridden, the " & + "formal parameter names and default expressions " & + "come from the corresponding primitive " & + "subprogram of the ancestor type, while the body " & + "comes from that of the parent type"); + + Test_Block: + declare + + Alarm : Alarm_Clock; + Hot_Line : Secure_Phone_Type; + TeleConference_Phone : Auditorium_Phone_Type; + + begin + + -- Evaluate non-dispatching case: + + -- Call Set_Display using formal parameter name from + -- C730001_0.Set_Display. + -- Give no 2nd parameter so that default expression must be used. + + Set_Display (C => Alarm); + + -- The value of the Display component should equal Digital, which is + -- the default value from the ancestor's version of Set_Display, + -- and not the default value from the parent's version of Set_Display. + + if TC_Get_Display (Alarm) /= Digital then + Report.Failed ("Default expression for ancestor op not used " & + "in non-dispatching case"); + end if; + + -- However, the value of the Illumination component should equal + -- Phosphorescence, which is assigned in the parent type's version of + -- the body of Set_Display. + + if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then + Report.Failed ("Wrong body was executed in non-dispatching case"); + end if; + + + -- Evaluate dispatching case: + declare + + Hot_Line : Secure_Phone_Type; + TeleConference_Phone : Auditorium_Phone_Type; + + procedure Answer_The_Phone (P : in out Phone'Class) is + begin + -- Give no 2nd parameter so that default expression must be used. + Answer (P); + end Answer_The_Phone; + + begin + + Answer_The_Phone (Hot_Line); + Answer_The_Phone (TeleConference_Phone); + + -- The value of the Indicator field shold equal "Light", the default + -- value from the ancestor's version of Answer, and not the default + -- from either of the parent versions of Answer. + + if TC_Get_Indicator(Hot_Line) /= Light or + TC_Get_Indicator(TeleConference_Phone) /= Light + then + Report.Failed("Default expression from ancestor operation " & + "not used in dispatching case"); + end if; + + -- However, the value of the Status component should equal + -- Call_Waiting or Conference respectively, based on the assignment + -- in the parent type's version of the body of Answer. + + if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then + Report.Failed("Wrong body executed in dispatching case - 1"); + end if; + + if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then + Report.Failed("Wrong body executed in dispatching case - 2"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + +end C730001; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730002.a b/gcc/testsuite/ada/acats/tests/c7/c730002.a new file mode 100644 index 000000000..9213a7d92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730002.a @@ -0,0 +1,383 @@ +-- C730002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the full view of a private extension may be derived +-- indirectly from the ancestor type (i.e., the parent type of the full +-- type may be any descendant of the ancestor type). Check that, for +-- a primitive subprogram of the private extension that is inherited from +-- the ancestor type and not overridden, the formal parameter names and +-- default expressions come from the corresponding primitive subprogram +-- of the ancestor type, while the body comes from that of the parent +-- type. +-- Check for a case where the parent type is derived from the ancestor +-- type through a series of types produced by generic instantiations. +-- Examine both the static and dynamic binding cases. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Ancestor is tagged ... +-- procedure Op (P1: Ancestor; P2: Boolean := True); +-- end P; +-- +-- with P; +-- generic +-- type T is new P.Ancestor with private; +-- package Gen1 is +-- type Enhanced is new T with private; +-- procedure Op (A: Enhanced; B: Boolean := True); +-- -- other specific procedures... +-- private +-- type Enhanced is new T with ... +-- end Gen1; +-- +-- with P, Gen1; +-- package N is new Gen1 (P.Ancestor); +-- +-- with N; +-- generic +-- type T is new N.Enhanced with private; +-- package Gen2 is +-- type Enhanced_Again is new T with private; +-- procedure Op (X: Enhanced_Again; Y: Boolean := False); +-- -- other specific procedures... +-- private +-- type Enhanced_Again is new T with ... +-- end Gen2; +-- +-- with N, Gen2; +-- package Q is new Gen2 (N.Enhanced); +-- +-- with P, Q; +-- package R is +-- type Priv_Ext is new P.Ancestor with private; -- (A) +-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True); +-- -- But body executed is that of Q.Op. +-- private +-- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B) +-- end R; +-- +-- The ancestor type in (A) differs from the parent type in (B); the +-- parent of the full type is descended from the ancestor type of the +-- private extension, in this case through a series of types produced +-- by generic instantiations. Gen1 redefines the implementation of Op +-- for any type that has one. N is an instance of Gen1 for the ancestor +-- type. Gen2 again redefines the implementation of Op for any type that +-- has one. Q is an instance of Gen2 for the extension of the P.Ancestor +-- declared in N. Both N and Q could define other operations which we +-- don't want to be available in R. For a call to Op (from outside the +-- scope of the full view) with an operand of type R.Priv_Ext, the body +-- executed will be that of Q.Op (the parent type's version), but the +-- formal parameter names and default expression come from that of P.Op +-- (the ancestor type's version). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 27 Feb 97 CTA.PWB Added elaboration pragmas. +--! + +package C730002_0 is + + type Hours_Type is range 0..1000; + type Personnel_Type is range 0..10; + type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry); + + type Engine_Type is tagged record + Ave_Repair_Time : Hours_Type := 0; -- Default init. for + Personnel_Required : Personnel_Type := 0; -- component fields. + Specialist : Specialist_ID := Manny; + end record; + + procedure Routine_Maintenance (Engine : in out Engine_Type ; + Specialist : in Specialist_ID := Moe); + + -- The Routine_Maintenance procedure implements the processing required + -- for an engine. + +end C730002_0; + + --==================================================================-- + +package body C730002_0 is + + procedure Routine_Maintenance (Engine : in out Engine_Type ; + Specialist : in Specialist_ID := Moe) is + begin + Engine.Ave_Repair_Time := 3; + Engine.Personnel_Required := 1; + Engine.Specialist := Specialist; + end Routine_Maintenance; + +end C730002_0; + + --==================================================================-- + +with C730002_0; use C730002_0; +generic + type T is new C730002_0.Engine_Type with private; +package C730002_1 is + + -- This generic package contains types/procedures specific to engines + -- of the diesel variety. + + type Repair_Facility_Type is (On_Site, Repair_Shop, Factory); + + type Diesel_Series is new T with private; + + procedure Routine_Maintenance (Eng : in out Diesel_Series; + Spec_Req : in Specialist_ID := Jack); + + -- Other diesel specific operations... (not required in this test). + +private + + type Diesel_Series is new T with record + Repair_Facility_Required : Repair_Facility_Type := On_Site; + end record; + +end C730002_1; + + --==================================================================-- + +package body C730002_1 is + + procedure Routine_Maintenance (Eng : in out Diesel_Series; + Spec_Req : in Specialist_ID := Jack) is + begin + Eng.Ave_Repair_Time := 6; + Eng.Personnel_Required := 2; + Eng.Specialist := Spec_Req; + Eng.Repair_Facility_Required := On_Site; + end Routine_Maintenance; + +end C730002_1; + + --==================================================================-- + +with C730002_0; +with C730002_1; +pragma Elaborate (C730002_1); +package C730002_2 is new C730002_1 (C730002_0.Engine_Type); + + --==================================================================-- + +with C730002_0; use C730002_0; +with C730002_2; use C730002_2; +generic + type T is new C730002_2.Diesel_Series with private; +package C730002_3 is + + type Time_Of_Operation_Type is range 0..100_000; + + type Electric_Series is new T with private; + + procedure Routine_Maintenance (E : in out Electric_Series; + SR : in Specialist_ID := Curly); + + -- Other electric specific operations... (not required in this test). + +private + + type Electric_Series is new T with record + Mean_Time_Between_Repair : Time_Of_Operation_Type := 0; + end record; + +end C730002_3; + + --==================================================================-- + +package body C730002_3 is + + procedure Routine_Maintenance (E : in out Electric_Series; + SR : in Specialist_ID := Curly) is + begin + E.Ave_Repair_Time := 9; + E.Personnel_Required := 3; + E.Specialist := SR; + E.Mean_Time_Between_Repair := 1000; + end Routine_Maintenance; + +end C730002_3; + + --==================================================================-- + +with C730002_2; +with C730002_3; +pragma Elaborate (C730002_3); +package C730002_4 is new C730002_3 (C730002_2.Diesel_Series); + + --==================================================================-- + +with C730002_0; use C730002_0; +with C730002_4; use C730002_4; + +package C730002_5 is + + type Inspection_Type is (AAA, MIL_STD, NRC); + + type Nuclear_Series is new Engine_Type with private; -- (A) + + -- Inherits procedure Routine_Maintenance from ancestor; does not override. + -- (Engine : in out Nuclear_Series; + -- Specialist : in Specialist_ID := Moe); + -- But body executed will be that of C730002_4.Routine_Maintenance, + -- the parent type. + + function TC_Specialist (E : Nuclear_Series) return Specialist_ID; + function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type; + function TC_Time_Required (E : Nuclear_Series) return Hours_Type; + + -- Dispatching subprogram. + procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class); + +private + + type Nuclear_Series is new Electric_Series with record -- (B) + Inspector_Rep : Inspection_Type := NRC; + end record; + + -- The ancestor type is used in the type extension (A), while the parent + -- of the full type (B) is a descendent of the ancestor type, through a + -- series of types produced by generic instantiation. + +end C730002_5; + + --==================================================================-- + +package body C730002_5 is + + function TC_Specialist (E : Nuclear_Series) return Specialist_ID is + begin + return E.Specialist; + end TC_Specialist; + + function TC_Personnel_Required (E : Nuclear_Series) + return Personnel_Type is + begin + return E.Personnel_Required; + end TC_Personnel_Required; + + function TC_Time_Required (E : Nuclear_Series) return Hours_Type is + begin + return E.Ave_Repair_Time; + end TC_Time_Required; + + -- Dispatching subprogram. + procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is + begin + Routine_Maintenance (The_Engine); + end Maintain_The_Engine; + + +end C730002_5; + + --==================================================================-- + +with Report; +with C730002_0; use C730002_0; +with C730002_2; use C730002_2; +with C730002_4; use C730002_4; +with C730002_5; use C730002_5; + +procedure C730002 is +begin + + Report.Test ("C730002", "Check that the full view of a private " & + "extension may be derived indirectly from " & + "the ancestor type. Check for a case where " & + "the parent type is derived from the ancestor " & + "type through a series of types produced by " & + "generic instantiations"); + + Test_Block: + declare + Nuclear_Drive : Nuclear_Series; + Warp_Drive : Nuclear_Series; + begin + + -- Non-Dispatching Case: + -- Call Routine_Maintenance using formal parameter name from + -- C730002_0.Routine_Maintenance (ancestor version). + -- Give no second parameter so that the default expression must be + -- used. + + Routine_Maintenance (Engine => Nuclear_Drive); + + -- The value of the Specialist component should equal "Moe", + -- which is the default value from the ancestor's version of + -- Routine_Maintenance, and not the default value from the parent's + -- version of Routine_Maintenance. + + if TC_Specialist (Nuclear_Drive) /= Moe then + Report.Failed + ("Default expression for ancestor op not used " & + " - non-dispatching case"); + end if; + + -- However the value of the Ave_Repair_Time and Personnel_Required + -- components should be those assigned in the parent type's version + -- of the body of Routine_Maintenance. + -- Note: Only components associated with the ancestor type are + -- evaluated for the purposes of this test. + + if TC_Personnel_Required (Nuclear_Drive) /= 3 or + TC_Time_Required (Nuclear_Drive) /= 9 + then + Report.Failed("Wrong body was executed - non-dispatching case"); + end if; + + -- Dispatching Case: + -- Use a dispatching subprogram to ensure that the correct body is + -- used at runtime. + + Maintain_The_Engine (Warp_Drive); + + -- The resulting assignments to the fields of the Warp_Drive variable + -- should be the same as those of the Nuclear_Drive above, indicating + -- that the body of the parent version of the inherited subprogram + -- was used. + + if TC_Specialist (Warp_Drive) /= Moe then + Report.Failed + ("Default expression for ancestor op not used - dispatching case"); + end if; + + if TC_Personnel_Required (Nuclear_Drive) /= 3 or + TC_Time_Required (Nuclear_Drive) /= 9 + then + Report.Failed("Wrong body was executed - dispatching case"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end C730002; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730003.a b/gcc/testsuite/ada/acats/tests/c7/c730003.a new file mode 100644 index 000000000..47002f3aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730003.a @@ -0,0 +1,283 @@ +-- C730003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the characteristics of a type derived from a private +-- extension (outside the scope of the full view) are those defined by +-- the partial view of the private extension. +-- In particular, check that a component of the derived type may be +-- explicitly declared with the same name as a component declared for +-- the full view of the private extension. +-- Check that a component defined in the private extension of a type +-- may be updated through a view conversion of a type derived from +-- the type. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package Parent is +-- type T is tagged record +-- ... +-- end record; +-- +-- type DT is new T with private; +-- procedure Op1 (P: in out DT); +-- +-- private +-- type DT is new T with record +-- Y: ...; -- (A) +-- end record; +-- end Parent; +-- +-- package body Parent is +-- function Op1 (P: in DT) return ... is +-- begin +-- return P.Y; +-- end Op1; +-- end Parent; +-- +-- package Unrelated is +-- type Intermediate is new DT with record +-- Y: ...; -- Note: same name as component of -- (B) +-- -- parent's full view. +-- end record; +-- end Unrelated; +-- +-- package Parent.Child is +-- type DDT is new Intermediate with null record; +-- -- Implicit declared Op1 (P.DDT); -- (C) +-- +-- procedure Op2 (P: in out DDT); +-- end Parent.Child; +-- +-- package body Parent.Child is +-- procedure Op2 (P: in out DDT) is +-- Obj : DT renames DT(P); +-- begin +-- ... +-- P.Y := ...; -- Updates DDT's Y. -- (D) +-- DT(P).Y := ...; -- Updates DT's Y. -- (E) +-- Obj.Y := ...; -- Updates DT's Y. -- (F) +-- end Op2; +-- end Parent.Child; +-- +-- Types DT and DDT both declare a component Y at (A) and (B), +-- respectively. The component Y of the full view of DT is not visible +-- at the place where DDT is declared. Therefore, it is invisible for +-- all views of DDT (although it still exists for objects of DDT), and +-- it is legal to declare another component for DDT with the same name. +-- +-- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns +-- the component Y; for calls with an operand of type DDT, Op1 returns +-- the Y inherited from DT, not the new Y explicitly declared for DDT, +-- even though the inherited Y is not visible for any view of DDT. +-- +-- Within the body of Op2, the assignment statement at (D) updates the +-- Y explicitly declared for DDT. At (E) and (F), however, a view +-- conversion denotes a new view of P as an object of type DT, which +-- enables access to the Y from the full view of DT. Thus, the +-- assignment statements at (E) and (F) update the (invisible) Y from DT. +-- +-- Note that the above analysis would be wrong if the new component Y +-- were declared directly in Child. In that case, the two same-named +-- components would be illegal -- see AI-150. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 1994 SAIC ACVC 2.0 +-- 29 JUN 1999 RAD Declare same-named component in an +-- unrelated package -- see AI-150. +-- +--! + +package C730003_0 is + + type Suit_Kind is (Clubs, Diamonds, Hearts, Spades); + type Face_Kind is (Up, Down); + + type Playing_Card is tagged record + Face: Face_Kind; + Suit: Suit_Kind; + end record; + + procedure Turn_Over_Card (Card : in out Playing_Card); + + type Disp_Card is new Playing_Card with private; + + subtype ASCII_Representation is Natural range 1..14; + + function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation; + +private + + type Disp_Card is new Playing_Card with record + View: ASCII_Representation; -- (A) + end record; + +end C730003_0; + +--==================================================================-- + +package body C730003_0 is + + procedure Turn_Over_Card (Card: in out Playing_Card) is + begin + Card.Face := Up; + end Turn_Over_Card; + + function Get_Private_View (A_Card : Disp_Card) + return ASCII_Representation is + begin + return A_Card.View; + end Get_Private_View; + +end C730003_0; + +--==================================================================-- + +with C730003_0; use C730003_0; +package C730003_1 is + + subtype Graphic_Representation is String (1 .. 2); + + type Graphic_Card is new Disp_Card with record + View : Graphic_Representation; -- (B) + -- "Duplicate" component field name. + end record; + +end C730003_1; + +--==================================================================-- + +with C730003_1; use C730003_1; +package C730003_0.C730003_2 is + + Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12; + Ace_Of_Hearts : constant String := "AH"; + Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14; + Read_Em_And_Weep : constant String := "AA"; + + type Graphic_Card is new C730003_1.Graphic_Card with null record; + + -- Implicit function Get_Private_View -- (C) + -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation; + + function Get_View (Card : Graphic_Card) return String; + procedure Update_View (Card : in out Graphic_Card); + procedure Hide_From_View (Card : in out Graphic_Card); + +end C730003_0.C730003_2; + +--==================================================================-- + +package body C730003_0.C730003_2 is + + function Get_View (Card : Graphic_Card) return String is + begin + return Card.View; + end Get_View; + + procedure Update_View (Card : in out Graphic_Card) is + ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion. + begin + ASCII_View.View := Queen_Of_Spades; -- (F) + -- Assignment to "hidden" field. + Card.View := Ace_Of_Hearts; -- (D) + -- Assignment to Graphic_Card declared field. + end Update_View; + + procedure Hide_From_View (Card : in out Graphic_Card) is + begin + -- Update both of Card's View components. + Disp_Card(Card).View := Close_To_The_Vest; -- (E) + -- Assignment to "hidden" field. + Card.View := Read_Em_And_Weep; -- (D) + -- Assignment to Graphic_Card declared field. + end Hide_From_View; + +end C730003_0.C730003_2; + +--==================================================================-- + +with C730003_0; +with C730003_0.C730003_2; +with Report; + +procedure C730003 is +begin + + Report.Test ("C730003", "Check that the characteristics of a type " & + "derived from a private extension (outside " & + "the scope of the full view) are those " & + "defined by the partial view of the private " & + "extension"); + + Check_Your_Cards: + declare + use C730003_0; + use C730003_0.C730003_2; + + Top_Card_On_The_Deck : Graphic_Card; + + begin + + -- Update value in the components of the card. There are two + -- component fields named View, although one is not visible for + -- any view of a Graphic_Card. + + Update_View(Top_Card_On_The_Deck); + + -- Verify that both "View" components of the card have been updated. + + if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then + Report.Failed ("Incorrect value in visible component - 1"); + end if; + + if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades + then + Report.Failed ("Incorrect value in non-visible component - 1"); + end if; + + -- Again, update the components of the card (to blank values). + + Hide_From_View(Top_Card_On_The_Deck); + + -- Verify that both components have been updated. + + if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then + Report.Failed ("Incorrect value in visible component - 2"); + end if; + + if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest + then + Report.Failed ("Incorrect value in non-visible component - 2"); + end if; + + exception + when others => Report.Failed("Exception raised in test block"); + end Check_Your_Cards; + + Report.Result; + +end C730003; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730004.a b/gcc/testsuite/ada/acats/tests/c7/c730004.a new file mode 100644 index 000000000..c2a23230a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730004.a @@ -0,0 +1,327 @@ +-- C730004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that for a type declared in a package, descendants of the package +-- use the full view of type. Specifically check that full view of the +-- limited type is visible only in private descendants (children) and in +-- the private parts and bodies of public descendants (children). +-- Check that a limited type may be used as an out parameter outside +-- the package that defines the type. +-- +-- TEST DESCRIPTION: +-- This test defines a parent package containing limited private type +-- definitions. Children packages are defined (one public, one private) +-- that use the nonlimited full view of the types defined in the private +-- part of the parent specification. +-- The main declares a procedure with an out parameter that was defined +-- as limited in the specification of the parent package. +-- +-- +-- CHANGE HISTORY: +-- 15 Sep 95 SAIC Initial prerelease version. +-- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File. +-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report. +-- +--! + +package C730004_0 is + + -- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are + -- are nonlimited. + + type File_Descriptor is limited private; + + type File_Mode is limited private; + + Active_Mode : constant File_Mode; + + type File_Name is limited private; + + type File_Type is limited private; + + function Next_Available_File return File_Descriptor; + +private + + type File_Descriptor is new Integer; + + Null_File : constant File_Descriptor := 0; + First_File : constant File_Descriptor := 1; + + type File_Mode is + (Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost); + + Default_Mode : constant File_Mode := Read_Only; + Active_Mode : constant File_Mode := Read_Write; + + type File_Name is array (1 .. 6) of Character; + + Null_String : File_Name := " "; + String1 : File_Name := "ACVC "; + String2 : File_Name := " 1995"; + + type File_Type is + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + Name : File_Name := Null_String; + end record; + +end C730004_0; + + --=================================================================-- + +package body C730004_0 is + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); -- Type conversion. + end Next_Available_File; + +end C730004_0; + + --=================================================================-- + +private +package C730004_0.C730004_1 is -- private child + + -- Since full view of the nontagged File_Name is nonlimited in the parent + -- package, it is not limited in the private child, so concatenation is + -- available. + + System_File_Name : constant File_Name + := String1(1..4) & String2(5..6); + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private child, so a default expression + -- is available. + + function New_File_Validated (File : File_Type + := (Descriptor => First_File, + Mode => Active_Mode, + Name => System_File_Name)) + return Boolean; + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private child, so initialization + -- expression in an object declaration is available. + + System_File : File_Type + := (Null_File, Read_Only, System_File_Name); + + +end C730004_0.C730004_1; + + --=================================================================-- + +package body C730004_0.C730004_1 is + + function New_File_Validated (File : File_Type + := (Descriptor => First_File, + Mode => Active_Mode, + Name => System_File_Name)) + return Boolean is + Result : Boolean := False; + begin + if (File.Descriptor > System_File.Descriptor) and + (File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95") + then + Result := True; + end if; + + return (Result); + + end New_File_Validated; + +end C730004_0.C730004_1; + + --=================================================================-- + +package C730004_0.C730004_2 is -- public child + + -- File_Type is limited here. + + procedure Create_File (File : out File_Type); + + procedure Modify_File (File : out File_Type); + + type File_Dir is limited private; + + -- The following three validation functions provide the capability to + -- check the limited private types defined in the parent and the + -- private child package from within the client program. + + function Validate_Create (File : in File_Type) return Boolean; + + function Validate_Modification (File : in File_Type) + return Boolean; + + function Validate_Dir (Dir : in File_Dir) return Boolean; + +private + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private part of the public child, so + -- aggregates are available. + + Child_File : File_Type + := File_Type'(Descriptor => Null_File, + Mode => Write_Only, + Name => String2); + + -- Since full view of the nontagged component File_Type is nonlimited in + -- the parent package, it is not limited in the private part of the public + -- child, so default expressions are available. + + type File_Dir is + record + Comp : File_Type := Child_File; + end record; + +end C730004_0.C730004_2; + + --=================================================================-- + +with C730004_0.C730004_1; + +package body C730004_0.C730004_2 is + + procedure Create_File (File : out File_Type) is + New_File : File_Type; + + begin + New_File.Descriptor := Next_Available_File; + New_File.Mode := Default_Mode; + New_File.Name := C730004_0.C730004_1.System_File_Name; + + if C730004_0.C730004_1.New_File_Validated (New_File) then + File := New_File; + else + File := (Null_File, Lost, "MISSED"); + end if; + + end Create_File; + + -------------------------------------------------------------- + procedure Modify_File (File : out File_Type) is + begin + File.Descriptor := Next_Available_File; + File.Mode := Active_Mode; + File.Name := String1; + end Modify_File; + + -------------------------------------------------------------- + function Validate_Create (File : in File_Type) return Boolean is + begin + if ((File.Descriptor /= Child_File.Descriptor) and + (File.Mode = Read_Only) and (File.Name = "ACVC95")) + then + return True; + else + return False; + end if; + end Validate_Create; + + ------------------------------------------------------------------------ + function Validate_Modification (File : in File_Type) + return Boolean is + begin + if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and + (File.Mode = Read_Write) and (File.Name = "ACVC ")) + then + return True; + else + return False; + end if; + end Validate_Modification; + + ------------------------------------------------------------------------ + function Validate_Dir (Dir : in File_Dir) return Boolean is + begin + if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor) + and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2)) + then + return True; + else + return False; + end if; + end Validate_Dir; + +end C730004_0.C730004_2; + + --=================================================================-- + +with C730004_0.C730004_2; +with Report; + +procedure C730004 is + + package File renames C730004_0; + package File_Ops renames C730004_0.C730004_2; + + Validation_File : File.File_Type; + + Validation_Dir : File_Ops.File_Dir; + + ------------------------------------------------------------------------ + -- Limited File_Type is allowed as an out parameter outside package File. + + procedure Call_Modify_File (Modified_File : out File.File_Type) is + begin + File_Ops.Modify_File (Modified_File); + end Call_Modify_File; + +begin + + Report.Test ("C730004", "Check that for a type declared in a package, " & + "descendants of the package use the full view " & + "of the type. Specifically check that full " & + "view of the limited type is visible only in " & + "private children and in the private parts and " & + "bodies of public children"); + + File_Ops.Create_File (Validation_File); + + if not File_Ops.Validate_Create (Validation_File) then + Report.Failed ("Incorrect creation of file"); + end if; + + Call_Modify_File (Validation_File); + + if not File_Ops.Validate_Modification (Validation_File) then + Report.Failed ("Incorrect modification of file"); + end if; + + if not File_Ops.Validate_Dir (Validation_Dir) then + Report.Failed ("Incorrect creation of directory"); + end if; + + Report.Result; + +end C730004; diff --git a/gcc/testsuite/ada/acats/tests/c7/c73002a.ada b/gcc/testsuite/ada/acats/tests/c7/c73002a.ada new file mode 100644 index 000000000..8bbc4afb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c73002a.ada @@ -0,0 +1,110 @@ +-- C73002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE STATEMENTS IN A PACKAGE BODY ARE EXECUTED AFTER THE +-- ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY). + + +-- RM 05/15/81 +-- JBG 9/21/83 + +WITH REPORT; +PROCEDURE C73002A IS + + USE REPORT; + +BEGIN + + TEST( "C73002A" , "CHECK: EXECUTION OF STATEMENTS IN A PACKAGE " & + "BODY FOLLOWS ELABORATION OF THE DECLARATIONS"); + + DECLARE + + PACKAGE P1 IS + + A : INTEGER := IDENT_INT(7); + + PACKAGE P2 IS + B : INTEGER := IDENT_INT(11); + END P2; + + END P1; + + + PACKAGE BODY P1 IS -- A AA B BB + + AA : INTEGER := IDENT_INT(7); -- 7 7 11 (11) + + PACKAGE BODY P2 IS + BB : INTEGER := IDENT_INT(11);-- 7 11 11 + BEGIN + + B := 2*B ; -- 7 7 22 11 + BB := 2*BB; -- 7 7 22 22 + A := 5*A ; -- 35 7 22 22 + AA := 2*AA; -- 35 14 22 22 + + IF BB /= 22 OR + AA /= 14 OR + A /= 35 OR + B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 1" ); + END IF; + + END P2; + + BEGIN + + A := A + 20; -- 55 14 22 22 + AA := AA + 20; -- 55 34 22 22 + + IF AA /= 34 OR + A /= 55 OR + P2.B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 2" ); + END IF; + + END P1; + + + USE P1; + USE P2; + + BEGIN + + IF A /= 55 OR + B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 3" ); + END IF; + + END; + + + RESULT; + + +END C73002A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a01.a b/gcc/testsuite/ada/acats/tests/c7/c730a01.a new file mode 100644 index 000000000..43f16f928 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730a01.a @@ -0,0 +1,176 @@ +-- C730A01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a tagged type declared in a package specification +-- may be passed as a generic formal (tagged) private type to a generic +-- package declaration. Check that the formal type may be extended with +-- a private extension in the generic package. +-- +-- Check that, in the instance, the private extension inherits the +-- user-defined primitive subprograms of the tagged actual. +-- +-- TEST DESCRIPTION: +-- Declare a tagged type and an associated primitive subprogram in a +-- package specification (foundation code). Declare a generic package +-- which takes a tagged type as a formal parameter, and then extends +-- it with a private extension (foundation code). +-- +-- Instantiate the generic package with the tagged type from the first +-- package (the "generic" extension should now have inherited +-- the primitive subprogram of the tagged type from the first +-- package). +-- +-- In the main program, call the primitive subprogram inherited by the +-- "generic" extension, and verify the correctness of the components. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F730A000.A +-- F730A001.A +-- => C730A01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with F730A001; -- Book definitions. +package C730A01_0 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + +end C730A01_0; + + + --==================================================================-- + + + + + --==================================================================-- + + +-- Library-level instantiation. Actual parameter is tagged record. + +with F730A001; -- Book definitions. +with F730A000; -- Singly-linked list abstraction. +package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type); + + + --==================================================================-- + + +with Report; + +with F730A001; -- Book definitions. +with C730A01_0; -- Raw book data. +with C730A01_1; -- Instance. + +use F730A001; -- Primitive operations of Book_Type directly visible. +use C730A01_1; -- Operations inherited by Node_Type directly visible. + +procedure C730A01 is + + + List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C730A01_0.Data_List; + Head : in out Priv_Node_Ptr) is + + Book : Priv_Node_Type; -- Object of extended type. + Book_Ptr : Priv_Node_Ptr; + + begin + for I in C730A01_0.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call inherited + -- operation. + Book_Ptr := new Priv_Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + Book1_Ptr : Priv_Node_Ptr; + Book2_Ptr : Priv_Node_Ptr; + Book3_Ptr : Priv_Node_Ptr; + begin + Remove (List_Of_Books, Book1_Ptr); + Remove (List_Of_Books, Book2_Ptr); + Remove (List_Of_Books, Book3_Ptr); + return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited + Book1_Ptr.Author.all /= "Joyce, James" or -- components + Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still + Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in + Book3_Ptr.Title.all /= "Wuthering Heights" or -- private + Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension. + + end Bad_List_Contents; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C730A01", "Inheritance of primitive operations: private " & + "extension of formal tagged private type; actual is " & + "an ultimate ancestor type"); + + -- Create linked list using inherited operation: + Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operation"); + end if; + + Report.Result; + +end C730A01; diff --git a/gcc/testsuite/ada/acats/tests/c7/c730a02.a b/gcc/testsuite/ada/acats/tests/c7/c730a02.a new file mode 100644 index 000000000..97d04b6db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730a02.a @@ -0,0 +1,252 @@ +-- C730A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a private extension (declared in a package specification) of +-- a tagged type (declared in a different package specification) may be +-- passed as a generic formal (tagged) private type to a generic package +-- declaration. Check that the formal type may be further extended with a +-- private extension in the generic package. +-- +-- Check that the (visible) components inherited by the "generic" +-- extension are visible outside the generic package. +-- +-- Check that, in the instance, the private extension inherits the +-- user-defined primitive subprograms of the tagged actual, including +-- those inherited by the actual from its parent. +-- +-- TEST DESCRIPTION: +-- Declare a tagged type and an associated primitive subprogram in a +-- package specification (foundation code). Declare a private extension +-- of the tagged type and an associated primitive subprogram in a second +-- package specification. Declare a generic package which takes a tagged +-- type as a formal parameter, and then extends it with a private +-- extension (foundation code). +-- +-- Instantiate the generic package with the private extension from the +-- second package (the "generic" extension should now have inherited +-- the primitive subprograms of the private extension from the second +-- package). +-- +-- In the main program, call the primitive subprograms inherited by the +-- "generic" extension. There are two: (1) Create_Book, declared for +-- the root tagged type in the first package (inherited by the private +-- extension of the second package, and then in turn by the "generic" +-- extension), and (2) Update_Pages, declared for the private extension +-- in the second package. Verify the correctness of the components. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F730A000.A +-- F730A001.A +-- => C730A02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F730A001; -- Book definitions. +package C730A02_0 is -- Extended book abstraction. + + + type Detailed_Book_Type is new F730A001.Book_Type -- Private ext. + with private; -- of root tagged + -- type. + + -- Inherits Create_Book from Book_Type. + + procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op. + Pages : in Natural); -- of extension. + + + -- The following function is needed to verify the value of the + -- extension's private component. It will be inherited by extensions + -- of Detailed_Book_Type. + + function Get_Pages (Book : in Detailed_Book_Type) return Natural; + +private + + type Detailed_Book_Type is new F730A001.Book_Type with record + Pages : Natural; + end record; + +end C730A02_0; + + + --==================================================================-- + + +package body C730A02_0 is + + + procedure Update_Pages (Book : in out Detailed_Book_Type; + Pages : in Natural) is + begin + Book.Pages := Pages; + end Update_Pages; + + + function Get_Pages (Book : in Detailed_Book_Type) return Natural is + begin + return (Book.Pages); + end Get_Pages; + + +end C730A02_0; + + + --==================================================================-- + + +with F730A001; -- Book definitions. +package C730A02_1 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr; + type Page_Counts is array (Number_Of_Books) of Natural; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + Page_List : Page_Counts := (237, 215, 456); + +end C730A02_1; + + +-- No body for C730A02_1. + + + --==================================================================-- + + +-- Library-level instantiation. Actual parameter is private extension. + +with C730A02_0; -- Extended book abstraction. +with F730A000; -- Singly-linked list abstraction. +package C730A02_2 is new F730A000 + (Parent_Type => C730A02_0.Detailed_Book_Type); + + + --==================================================================-- + + +with Report; + +with C730A02_0; -- Extended book abstraction. +with C730A02_1; -- Raw book data. +with C730A02_2; -- Instance. + +use C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible. +use C730A02_2; -- Operations inherited by Priv_Node_Type directly visible. + +procedure C730A02 is + + + List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C730A02_1.Data_List; + Pages : in C730A02_1.Page_Counts; + Head : in out Priv_Node_Ptr) is + + Book : Priv_Node_Type; -- Object of extended type. + Book_Ptr : Priv_Node_Ptr; + + begin + for I in C730A02_1.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call twice-inherited + -- operation. + Update_Pages (Book, Pages (I)); -- Call inherited op. + Book_Ptr := new Priv_Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + Book1_Ptr : Priv_Node_Ptr; + Book2_Ptr : Priv_Node_Ptr; + Book3_Ptr : Priv_Node_Ptr; + begin + + Remove (List_Of_Books, Book1_Ptr); + Remove (List_Of_Books, Book2_Ptr); + Remove (List_Of_Books, Book3_Ptr); + + return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited + Book1_Ptr.Author.all /= "Joyce, James" or -- components + Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still + Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible + Book3_Ptr.Title.all /= "Wuthering Heights" or -- in private + Book3_Ptr.Author.all /= "Bronte, Emily" or -- "generic" + -- extension. + -- Call inherited operations using dereferenced pointers. + Get_Pages (Book1_Ptr.all) /= 456 or + Get_Pages (Book2_Ptr.all) /= 215 or + Get_Pages (Book3_Ptr.all) /= 237); + + end Bad_List_Contents; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C730A02", "Inheritance of primitive operations: private " & + "extension of formal tagged private type; actual is " & + "a private extension"); + + -- Create linked list using inherited operation: + Create_List (C730A02_1.Title_List, C730A02_1.Author_List, + C730A02_1.Page_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operations"); + end if; + + Report.Result; + +end C730A02; diff --git a/gcc/testsuite/ada/acats/tests/c7/c731001.a b/gcc/testsuite/ada/acats/tests/c7/c731001.a new file mode 100644 index 000000000..0cfce32bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c731001.a @@ -0,0 +1,407 @@ +-- C731001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE +-- Check that inherited operations can be overridden, even when they are +-- inherited in a body. +-- The test cases here are inspired by the AARM examples given in +-- the discussion of AARM-7.3.1(7.a-7.v). +-- This discussion was confirmed by AI95-00035. +-- +-- TEST DESCRIPTION +-- See AARM-7.3.1. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 23 SEP 1999 RLB Improved comments, renamed, issued. +-- 20 AUG 2001 RLB Corrected 'verbose' flag. +-- +--! + +with Report; use Report; pragma Elaborate_All(Report); +package C731001_1 is + pragma Elaborate_Body; +private + procedure Check_String(X, Y: String); + function Check_String(X, Y: String) return String; + -- This one is a function, so we can call it in package specs. +end C731001_1; + +package body C731001_1 is + + Verbose: Boolean := False; + + procedure Check_String(X, Y: String) is + begin + if Verbose then + Comment("""" & X & """ = """ & Y & """?"); + end if; + if X /= Y then + Failed("""" & X & """ should be """ & Y & """"); + end if; + end Check_String; + + function Check_String(X, Y: String) return String is + begin + Check_String(X, Y); + return X; + end Check_String; + +end C731001_1; + +private package C731001_1.Parent is + + procedure Call_Main; + + type Root is tagged null record; + subtype Renames_Root is Root; + subtype Root_Class is Renames_Root'Class; + function Make return Root; + function Op1(X: Root) return String; + function Call_Op2(X: Root'Class) return String; +private + function Op2(X: Root) return String; +end C731001_1.Parent; + +procedure C731001_1.Parent.Main; + +with C731001_1.Parent.Main; +package body C731001_1.Parent is + + procedure Call_Main is + begin + Main; + end Call_Main; + + function Make return Root is + Result: Root; + begin + return Result; + end Make; + + function Op1(X: Root) return String is + begin + return "Parent.Op1 body"; + end Op1; + + function Op2(X: Root) return String is + begin + return "Parent.Op2 body"; + end Op2; + + function Call_Op2(X: Root'Class) return String is + begin + return Op2(X); + end Call_Op2; + +begin + + Check_String(Op1(Root'(Make)), "Parent.Op1 body"); + Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body"); + + Check_String(Op2(Root'(Make)), "Parent.Op2 body"); + Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body"); + +end C731001_1.Parent; + +with C731001_1.Parent; use C731001_1.Parent; +private package C731001_1.Unrelated is + + type T2 is new Root with null record; + subtype T2_Class is T2'Class; + function Make return T2; + function Op2(X: T2) return String; +end C731001_1.Unrelated; + +with C731001_1.Parent; use C731001_1.Parent; + pragma Elaborate(C731001_1.Parent); +package body C731001_1.Unrelated is + + function Make return T2 is + Result: T2; + begin + return Result; + end Make; + + function Op2(X: T2) return String is + begin + return "Unrelated.Op2 body"; + end Op2; +begin + + Check_String(Op1(T2'(Make)), "Parent.Op1 body"); + Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body"); + Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body"); + + Check_String(Op2(T2'(Make)), "Unrelated.Op2 body"); + Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body"); + Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body"); + Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body"); + +end C731001_1.Unrelated; + +package C731001_1.Parent.Child is + pragma Elaborate_Body; + + type T3 is new Root with null record; + subtype T3_Class is T3'Class; + function Make return T3; + + T3_Obj: T3; + T3_Class_Obj: T3_Class := T3_Obj; + T3_Root_Class_Obj: Root_Class := T3_Obj; + + X3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + package Nested is + type T4 is new Root with null record; + subtype T4_Class is T4'Class; + function Make return T4; + + T4_Obj: T4; + T4_Class_Obj: T4_Class := T4_Obj; + T4_Root_Class_Obj: Root_Class := T4_Obj; + + X4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + private + + XX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end Nested; + + use Nested; + + XXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + +private + + XX3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + XXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + +end C731001_1.Parent.Child; + +with C731001_1.Unrelated; use C731001_1.Unrelated; + pragma Elaborate(C731001_1.Unrelated); +package body C731001_1.Parent.Child is + + XXX3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + XXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + function Make return T3 is + Result: T3; + begin + return Result; + end Make; + + package body Nested is + function Make return T4 is + Result: T4; + begin + return Result; + end Make; + + XXXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end Nested; + + type T5 is new T2 with null record; + subtype T5_Class is T5'Class; + function Make return T5; + + function Make return T5 is + Result: T5; + begin + return Result; + end Make; + + XXXXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + +end C731001_1.Parent.Child; + +procedure C731001_1.Main; + +with C731001_1.Parent; +procedure C731001_1.Main is +begin + C731001_1.Parent.Call_Main; +end C731001_1.Main; + +with C731001_1.Parent.Child; + use C731001_1.Parent; + use C731001_1.Parent.Child; + use C731001_1.Parent.Child.Nested; +with C731001_1.Unrelated; use C731001_1.Unrelated; +procedure C731001_1.Parent.Main is + + Root_Obj: Root := Make; + Root_Class_Obj: Root_Class := Root'(Make); + + T2_Obj: T2 := Make; + T2_Class_Obj: T2_Class := T2_Obj; + T2_Root_Class_Obj: Root_Class := T2_Class_Obj; + + T3_Obj: T3 := Make; + T3_Class_Obj: T3_Class := T3_Obj; + T3_Root_Class_Obj: Root_Class := T3_Obj; + + T4_Obj: T4 := Make; + T4_Class_Obj: T4_Class := T4_Obj; + T4_Root_Class_Obj: Root_Class := T4_Obj; + +begin + Test("C731001_1", "Check that inherited operations can be overridden, even" + & " when they are inherited in a body"); + + Check_String(Op1(Root_Obj), "Parent.Op1 body"); + Check_String(Op1(Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(Root_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T2_Obj), "Parent.Op1 body"); + Check_String(Op1(T2_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Op2(T2_Obj), "Unrelated.Op2 body"); + Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body"); + Check_String(Call_Op2(T2_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T3_Obj), "Parent.Op1 body"); + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T4_Obj), "Parent.Op1 body"); + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + Result; +end C731001_1.Parent.Main; + +with C731001_1.Main; +procedure C731001 is +begin + C731001_1.Main; +end C731001; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74004a.ada b/gcc/testsuite/ada/acats/tests/c7/c74004a.ada new file mode 100644 index 000000000..f2a016b09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74004a.ada @@ -0,0 +1,375 @@ +-- C74004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT OPERATIONS DEPENDING ON THE FULL DECLARATION OF A +-- PRIVATE TYPE ARE AVAILABLE WITHIN THE PACKAGE BODY. + +-- HISTORY: +-- BCB 04/05/88 CREATED ORIGINAL TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C74004A IS + + PACKAGE P IS + TYPE PR IS PRIVATE; + TYPE ARR1 IS LIMITED PRIVATE; + TYPE ARR2 IS PRIVATE; + TYPE REC (D : INTEGER) IS PRIVATE; + TYPE ACC IS PRIVATE; + TYPE TSK IS LIMITED PRIVATE; + TYPE FLT IS LIMITED PRIVATE; + TYPE FIX IS LIMITED PRIVATE; + + TASK TYPE T IS + ENTRY ONE(V : IN OUT INTEGER); + END T; + + PROCEDURE CHECK (V : ARR2); + PRIVATE + TYPE PR IS NEW INTEGER; + + TYPE ARR1 IS ARRAY(1..5) OF INTEGER; + + TYPE ARR2 IS ARRAY(1..5) OF BOOLEAN; + + TYPE REC (D : INTEGER) IS RECORD + COMP1 : INTEGER; + COMP2 : BOOLEAN; + END RECORD; + + TYPE ACC IS ACCESS INTEGER; + + TYPE TSK IS NEW T; + + TYPE FLT IS DIGITS 5; + + TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0; + END P; + + PACKAGE BODY P IS + X1, X2, X3 : PR; + BOOL : BOOLEAN := IDENT_BOOL(FALSE); + VAL : INTEGER := IDENT_INT(0); + FVAL : FLOAT := 0.0; + ST : STRING(1..2); + O1 : ARR1 := (1,2,3,4,5); + Y1 : ARR2 := (FALSE,TRUE,FALSE,TRUE,FALSE); + Y2 : ARR2 := (OTHERS => TRUE); + Y3 : ARR2 := (OTHERS => FALSE); + Z1 : REC(0) := (0,1,FALSE); + W1, W2 : ACC := NEW INTEGER'(0); + V1 : TSK; + + TASK BODY T IS + BEGIN + ACCEPT ONE(V : IN OUT INTEGER) DO + V := IDENT_INT(10); + END ONE; + END T; + + PROCEDURE CHECK (V : ARR2) IS + BEGIN + IF V /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER VALUE PASSED AS AGGREGATE"); + END IF; + END CHECK; + BEGIN + TEST ("C74004A", "CHECK THAT OPERATIONS DEPENDING ON THE " & + "FULL DECLARATION OF A PRIVATE TYPE ARE " & + "AVAILABLE WITHIN THE PACKAGE BODY"); + + X1 := 10; + X2 := 5; + + X3 := X1 + X2; + + IF X3 /= 15 THEN + FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR"); + END IF; + + X3 := X1 - X2; + + IF X3 /= 5 THEN + FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR"); + END IF; + + X3 := X1 * X2; + + IF X3 /= 50 THEN + FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR"); + END IF; + + X3 := X1 / X2; + + IF X3 /= 2 THEN + FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR"); + END IF; + + X3 := X1 ** 2; + + IF X3 /= 100 THEN + FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR"); + END IF; + + BOOL := X1 < X2; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR"); + END IF; + + BOOL := X1 > X2; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR"); + END IF; + + BOOL := X1 <= X2; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " & + "OPERATOR"); + END IF; + + BOOL := X1 >= X2; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " & + "TO OPERATOR"); + END IF; + + X3 := X1 MOD X2; + + IF X3 /= 0 THEN + FAILED ("IMPROPER RESULT FROM MOD OPERATOR"); + END IF; + + X3 := X1 REM X2; + + IF X3 /= 0 THEN + FAILED ("IMPROPER RESULT FROM REM OPERATOR"); + END IF; + + X3 := ABS(X1); + + IF X3 /= 10 THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 1"); + END IF; + + X1 := -10; + + X3 := ABS(X1); + + IF X3 /= 10 THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 2"); + END IF; + + X3 := PR'BASE'FIRST; + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'BASE'FIRST"); + END IF; + + X3 := PR'FIRST; + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'FIRST"); + END IF; + + VAL := PR'WIDTH; + + IF NOT EQUAL(VAL,INTEGER'WIDTH) THEN + FAILED ("IMPROPER RESULT FROM 'WIDTH"); + END IF; + + VAL := PR'POS(X3); + + IF NOT EQUAL(VAL,INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'POS"); + END IF; + + X3 := PR'VAL(VAL); + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'VAL"); + END IF; + + X3 := PR'SUCC(X2); + + IF X3 /= 6 THEN + FAILED ("IMPROPER RESULT FROM 'SUCC"); + END IF; + + X3 := PR'PRED(X2); + + IF X3 /= 4 THEN + FAILED ("IMPROPER RESULT FROM 'PRED"); + END IF; + + ST := PR'IMAGE(X3); + + IF ST /= INTEGER'IMAGE(INTEGER(X3)) THEN + FAILED ("IMPROPER RESULT FROM 'IMAGE"); + END IF; + + X3 := PR'VALUE(ST); + + IF X3 /= PR(INTEGER'VALUE(ST)) THEN + FAILED ("IMPROPER RESULT FROM 'VALUE"); + END IF; + + CHECK ((TRUE,FALSE,TRUE,FALSE,TRUE)); + + IF O1(2) /= IDENT_INT(2) THEN + FAILED ("IMPROPER VALUE FROM INDEXING"); + END IF; + + IF O1(2..4) /= (2,3,4) THEN + FAILED ("IMPROPER VALUES FROM SLICING"); + END IF; + + IF VAL IN O1'RANGE THEN + FAILED ("IMPROPER RESULT FROM 'RANGE"); + END IF; + + VAL := O1'LENGTH; + + IF NOT EQUAL(VAL,5) THEN + FAILED ("IMPROPER RESULT FROM 'LENGTH"); + END IF; + + Y3 := Y1(1..2) & Y2(3..5); + + IF Y3 /= (FALSE,TRUE,TRUE,TRUE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM CATENATION"); + END IF; + + Y3 := NOT Y1; + + IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM NOT OPERATOR"); + END IF; + + Y3 := Y1 AND Y2; + + IF Y3 /= (FALSE,TRUE,FALSE,TRUE,FALSE) THEN + FAILED ("IMPROPER RESULT FROM AND OPERATOR"); + END IF; + + Y3 := Y1 OR Y2; + + IF Y3 /= (TRUE,TRUE,TRUE,TRUE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM OR OPERATOR"); + END IF; + + Y3 := Y1 XOR Y2; + + IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM XOR OPERATOR"); + END IF; + + VAL := Z1.COMP1; + + IF NOT EQUAL(VAL,1) THEN + FAILED ("IMPROPER RESULT FROM SELECTION OF RECORD " & + "COMPONENTS"); + END IF; + + W1 := NEW INTEGER'(0); + + IF NOT EQUAL(W1.ALL,0) THEN + FAILED ("IMPROPER RESULT FROM ALLOCATION"); + END IF; + + W1 := NULL; + + IF W1 /= NULL THEN + FAILED ("IMPROPER RESULT FROM NULL LITERAL"); + END IF; + + VAL := W2.ALL; + + IF NOT EQUAL(VAL,0) THEN + FAILED ("IMPROPER RESULT FROM SELECTED COMPONENT"); + END IF; + + BOOL := V1'CALLABLE; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM 'CALLABLE"); + END IF; + + BOOL := V1'TERMINATED; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM 'TERMINATED"); + END IF; + + V1.ONE(VAL); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("IMPROPER RESULT RETURNED FROM ENTRY SELECTION"); + END IF; + + IF NOT (FLT(1.0) IN FLT) THEN + FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION"); + END IF; + + VAL := FLT'DIGITS; + + IF NOT EQUAL(VAL,5) THEN + FAILED ("IMPROPER RESULT FROM 'DIGITS"); + END IF; + + BOOL := FLT'MACHINE_ROUNDS; + + BOOL := FLT'MACHINE_OVERFLOWS; + + VAL := FLT'MACHINE_RADIX; + + VAL := FLT'MACHINE_MANTISSA; + + VAL := FLT'MACHINE_EMAX; + + VAL := FLT'MACHINE_EMIN; + + FVAL := FIX'DELTA; + + IF FVAL /= 2.0**(-1) THEN + FAILED ("IMPROPER RESULT FROM 'DELTA"); + END IF; + + VAL := FIX'FORE; + + VAL := FIX'AFT; + + END P; + + USE P; + +BEGIN + RESULT; +END C74004A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74203a.ada b/gcc/testsuite/ada/acats/tests/c7/c74203a.ada new file mode 100644 index 000000000..82cfe9269 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74203a.ada @@ -0,0 +1,263 @@ +-- C74203A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, AND EXPLICIT +-- CONVERSION ARE AVAILABLE FOR LIMITED AND NON-LIMITED PRIVATE +-- TYPES. INCLUDE TYPES WITH DISCRIMINANTS AND TYPES +-- WITH LIMITED COMPONENTS. + +-- HISTORY: +-- BCB 03/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74203A IS + + PACKAGE PP IS + TYPE LIM IS LIMITED PRIVATE; + PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER); + + TYPE A IS PRIVATE; + SUBTYPE SUBA IS A; + A1 : CONSTANT A; + + TYPE B IS LIMITED PRIVATE; + B1 : CONSTANT B; + + TYPE C IS PRIVATE; + C1 : CONSTANT C; + + TYPE D IS LIMITED PRIVATE; + D1 : CONSTANT D; + + TYPE E (DISC1 : INTEGER := 5) IS PRIVATE; + SUBTYPE SUBE IS E; + E1 : CONSTANT E; + + TYPE F (DISC2 : INTEGER := 15) IS LIMITED PRIVATE; + F1 : CONSTANT F; + + TYPE G (DISC3 : INTEGER) IS PRIVATE; + G1 : CONSTANT G; + + TYPE H (DISC4 : INTEGER) IS LIMITED PRIVATE; + H1 : CONSTANT H; + + TYPE I IS RECORD + COMPI : LIM; + END RECORD; + SUBTYPE SUBI IS I; + + TYPE J IS ARRAY(1..5) OF LIM; + SUBTYPE SUBJ IS J; + + TYPE S1 IS (VINCE, TOM, PHIL, JODIE, ROSA, TERESA); + TYPE S2 IS (THIS, THAT, THESE, THOSE, THEM); + TYPE S3 IS RANGE 1 .. 100; + TYPE S4 IS RANGE 1 .. 100; + PRIVATE + TYPE LIM IS RANGE 1 .. 100; + + TYPE A IS (RED, BLUE, GREEN, YELLOW, BLACK, WHITE); + A1 : CONSTANT A := BLUE; + + TYPE B IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + B1 : CONSTANT B := THREE; + + TYPE C IS RANGE 1 .. 100; + C1 : CONSTANT C := 50; + + TYPE D IS RANGE 1 .. 100; + D1 : CONSTANT D := 50; + + TYPE E (DISC1 : INTEGER := 5) IS RECORD + COMPE : S1; + END RECORD; + E1 : CONSTANT E := (DISC1 => 5, COMPE => TOM); + + TYPE F (DISC2 : INTEGER := 15) IS RECORD + COMPF : S2; + END RECORD; + F1 : CONSTANT F := (DISC2 => 15, COMPF => THAT); + + TYPE G (DISC3 : INTEGER) IS RECORD + COMPG : S3; + END RECORD; + G1 : CONSTANT G := (DISC3 => 25, COMPG => 50); + + TYPE H (DISC4 : INTEGER) IS RECORD + COMPH : S4; + END RECORD; + H1 : CONSTANT H := (DISC4 => 30, COMPH => 50); + END PP; + + USE PP; + + AVAR : SUBA := A1; + EVAR : SUBE := E1; + + IVAR : SUBI; + JVAR : SUBJ; + + PACKAGE BODY PP IS + PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER) IS + BEGIN + Z1 := LIM (Z2); + END INIT; + BEGIN + NULL; + END PP; + + PROCEDURE QUAL_PRIV (W : A) IS + BEGIN + NULL; + END QUAL_PRIV; + + PROCEDURE QUAL_LIM_PRIV (X : B) IS + BEGIN + NULL; + END QUAL_LIM_PRIV; + + PROCEDURE EXPL_CONV_PRIV_1 (Y : C) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_1; + + PROCEDURE EXPL_CONV_LIM_PRIV_1 (Z : D) IS + BEGIN + NULL; + END EXPL_CONV_LIM_PRIV_1; + + PROCEDURE EXPL_CONV_PRIV_2 (Y2 : G) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_2; + + PROCEDURE EXPL_CONV_LIM_PRIV_2 (Z2 : H) IS + BEGIN + NULL; + END EXPL_CONV_LIM_PRIV_2; + + PROCEDURE EXPL_CONV_PRIV_3 (Y3 : I) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_3; + + PROCEDURE EXPL_CONV_PRIV_4 (Y4 : J) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_4; + +BEGIN + TEST ("C74203A", "CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, " & + "AND EXPLICIT CONVERSION ARE AVAILABLE FOR " & + "LIMITED AND NON-LIMITED PRIVATE TYPES. " & + "INCLUDE TYPES WITH DISCRIMINANTS AND " & + "TYPES WITH LIMITED COMPONENTS"); + + INIT (IVAR.COMPI, 50); + + FOR K IN IDENT_INT (1) .. IDENT_INT (5) LOOP + INIT (JVAR(K), 25); + END LOOP; + + IF NOT (AVAR IN A) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 1"); + END IF; + + IF (AVAR NOT IN A) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 1"); + END IF; + + IF NOT (B1 IN B) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "LIMITED PRIVATE TYPE - 1"); + END IF; + + IF (B1 NOT IN B) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "LIMITED PRIVATE TYPE - 1"); + END IF; + + QUAL_PRIV (A'(AVAR)); + + QUAL_LIM_PRIV (B'(B1)); + + EXPL_CONV_PRIV_1 (C(C1)); + + EXPL_CONV_LIM_PRIV_1 (D(D1)); + + IF NOT (EVAR IN E) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 2"); + END IF; + + IF (EVAR NOT IN E) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 2"); + END IF; + + IF NOT (F1 IN F) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "LIMITED PRIVATE TYPE - 2"); + END IF; + + IF (F1 NOT IN F) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "LIMITED PRIVATE TYPE - 2"); + END IF; + + EXPL_CONV_PRIV_2 (G(G1)); + + EXPL_CONV_LIM_PRIV_2 (H(H1)); + + IF NOT (IVAR IN I) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 3"); + END IF; + + IF (IVAR NOT IN I) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 3"); + END IF; + + EXPL_CONV_PRIV_3 (I(IVAR)); + + IF NOT (JVAR IN J) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 4"); + END IF; + + IF (JVAR NOT IN J) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 4"); + END IF; + + EXPL_CONV_PRIV_4 (J(JVAR)); + + RESULT; +END C74203A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74206a.ada b/gcc/testsuite/ada/acats/tests/c7/c74206a.ada new file mode 100644 index 000000000..6a0dfbfc6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74206a.ada @@ -0,0 +1,144 @@ +-- C74206A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE PACKAGE AS A +-- PRIVATE TYPE AND CONTAINS A COMPONENT OF THE PRIVATE TYPE, OPERATIONS +-- OF THE COMPOSITE TYPE WHICH DO NOT DEPEND ON CHARACTERISTICS OF THE +-- PRIVATE TYPE ARE AVAILABLE AFTER THE FULL DECLARATION OF THE PRIVATE +-- TYPE, BUT BEFORE THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE +-- DECLARATION OF THE COMPOSITE TYPE THAT IS AFTER THE FULL DECLARATION +-- OF THE PRIVATE TYPE. IN PARTICULAR, CHECK FOR THE FOLLOWING : + +-- 'FIRST, 'LAST, 'RANGE, AND 'LENGTH FOR ARRAY TYPES +-- SELECTED COMPONENTS FOR DISCRIMINANTS AND COMPONENTS OF RECORDS +-- INDEXED COMPONENTS AND SLICES FOR ARRAYS + +-- DSJ 5/5/83 +-- JBG 3/8/84 + +WITH REPORT; +PROCEDURE C74206A IS + + USE REPORT; + +BEGIN + + TEST("C74206A", "CHECK THAT ADDITIONAL OPERATIONS FOR " + & "COMPOSITE TYPES OF PRIVATE TYPES ARE " + & "AVAILABLE AT THE EARLIEST PLACE AFTER THE " + & "FULL DECLARATION OF THE PRIVATE TYPE EVEN " + & "IF BEFORE THE EARLIEST PLACE WITHIN THE " + & "IMMEDIATE SCOPE OF THE COMPOSITE TYPE"); + + DECLARE + + PACKAGE PACK1 IS + TYPE P1 IS PRIVATE; + TYPE LP1 IS LIMITED PRIVATE; + + PACKAGE PACK_LP IS + TYPE LP_ARR IS ARRAY (1 .. 2) OF LP1; + TYPE LP_REC (D : INTEGER) IS + RECORD + C1, C2 : LP1; + END RECORD; + END PACK_LP; + + PACKAGE PACK2 IS + TYPE ARR IS ARRAY ( 1 .. 2 ) OF P1; + TYPE REC (D : INTEGER) IS + RECORD + C1, C2 : P1; + END RECORD; + END PACK2; + PRIVATE + TYPE P1 IS NEW BOOLEAN; + TYPE LP1 IS NEW BOOLEAN; + END PACK1; + + PACKAGE BODY PACK1 IS + + USE PACK_LP; + USE PACK2; + + A1 : ARR; + L1 : LP_ARR; + + N1 : INTEGER := ARR'FIRST; -- LEGAL + N2 : INTEGER := ARR'LAST; -- LEGAL + N3 : INTEGER := A1'LENGTH; -- LEGAL + N4 : INTEGER := LP_ARR'FIRST; -- LEGAL + N5 : INTEGER := LP_ARR'LAST; -- LEGAL + N6 : INTEGER := L1'LENGTH; -- LEGAL + B1 : BOOLEAN := 1 IN ARR'RANGE; -- LEGAL + B2 : BOOLEAN := 5 IN LP_ARR'RANGE; -- LEGAL + + N7 : INTEGER := A1(1)'SIZE; -- LEGAL: A1(1) + N8 : INTEGER := L1(2)'SIZE; -- LEGAL: L1(2) + + R1 : REC(1); + Q1 : LP_REC(1); + + K1 : INTEGER := R1.D'SIZE; -- LEGAL: R1.D + K2 : INTEGER := R1.C1'SIZE; -- LEGAL: R1.C1 + K3 : INTEGER := Q1.D'SIZE; -- LEGAL: Q1.D + K4 : INTEGER := Q1.C2'SIZE; -- LEGAL: Q1.C2 + + BEGIN + + IF N1 /= 1 OR N4 /= 1 THEN + FAILED ("WRONG VALUE FOR 'FIRST"); + END IF; + + IF N2 /= 2 OR N5 /= 2 THEN + FAILED ("WRONG VALUE FOR 'LAST"); + END IF; + + IF N3 /= 2 OR N6 /= 2 THEN + FAILED ("WRONG VALUE FOR 'LENGTH"); + END IF; + + IF B1 /= TRUE OR B2 /= FALSE THEN + FAILED ("INCORRECT RANGE TEST"); + END IF; + + IF N7 /= N8 THEN + FAILED ("INCORRECT INDEXED COMPONENTS"); + END IF; + + IF K1 /= K3 OR K2 /= K4 THEN + FAILED ("INCORRECT COMPONENT SELECTION"); + END IF; + + END PACK1; + + BEGIN + + NULL; + + END; + + RESULT; + +END C74206A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74207b.ada b/gcc/testsuite/ada/acats/tests/c7/c74207b.ada new file mode 100644 index 000000000..a5284a6de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74207b.ada @@ -0,0 +1,75 @@ +-- C74207B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT 'CONSTRAINED CAN BE APPLIED AFTER THE FULL DECLARATION OF +-- A PRIVATE TYPE THAT IS DERIVED FROM A PRIVATE TYPE. + +-- BHS 6/18/84 + +WITH REPORT; +USE REPORT; +PROCEDURE C74207B IS +BEGIN + TEST ("C74207B", "AFTER THE FULL DECLARATION OF A PRIVATE " & + "TYPE DERIVED FROM A PRIVATE TYPE, " & + "'CONSTRAINED MAY BE APPLIED"); + + DECLARE + PACKAGE P1 IS + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE P IS PRIVATE; + PRIVATE + TYPE PREC (D : INTEGER) IS RECORD + NULL; + END RECORD; + TYPE P IS NEW INTEGER; + END P1; + + PACKAGE P2 IS + TYPE LP1 IS LIMITED PRIVATE; + TYPE LP2 IS LIMITED PRIVATE; + PRIVATE + TYPE LP1 IS NEW P1.PREC(3); + TYPE LP2 IS NEW P1.P; + B1 : BOOLEAN := LP1'CONSTRAINED; + B2 : BOOLEAN := LP2'CONSTRAINED; + END P2; + + PACKAGE BODY P2 IS + BEGIN + IF NOT IDENT_BOOL(B1) THEN + FAILED ("WRONG VALUE FOR LP1'CONSTRAINED"); + END IF; + IF NOT IDENT_BOOL(B2) THEN + FAILED ("WRONG VALUE FOR LP2'CONSTRAINED"); + END IF; + END P2; + + BEGIN + NULL; + END; + + RESULT; + +END C74207B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74208a.ada b/gcc/testsuite/ada/acats/tests/c7/c74208a.ada new file mode 100644 index 000000000..36607d285 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74208a.ada @@ -0,0 +1,116 @@ +-- C74208A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT 'SIZE AND 'ADDRESS FOR OBJECTS OF LIMITED AND +-- NON-LIMITED TYPES ARE AVAILABLE BOTH INSIDE AND OUTSIDE THE +-- PACKAGE DECLARING THE TYPES. + +-- HISTORY: +-- BCB 03/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; + +PROCEDURE C74208A IS + + PACKAGE P IS + TYPE T IS PRIVATE; + TYPE U IS LIMITED PRIVATE; + PRIVATE + TYPE T IS RANGE 1 .. 100; + TYPE U IS RANGE 1 .. 100; + END P; + + A : P.T; + B : P.U; + ASIZE, BSIZE : INTEGER; + AADDRESS, BADDRESS : ADDRESS; + + FUNCTION IDENT_ADR(X : ADDRESS) RETURN ADDRESS IS + Y : P.T; + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Y'ADDRESS; + END IDENT_ADR; + + PACKAGE BODY P IS + X : T; + Y : U; + XSIZE, YSIZE : INTEGER; + XADDRESS, YADDRESS : ADDRESS; + BEGIN + TEST ("C74208A", "CHECK THAT 'SIZE AND 'ADDRESS FOR " & + "OBJECTS OF LIMITED AND NON-LIMITED TYPES " & + "ARE AVAILABLE BOTH INSIDE AND OUTSIDE " & + "THE PACKAGE DECLARING THE TYPES"); + + XSIZE := X'SIZE; + YSIZE := Y'SIZE; + XADDRESS := X'ADDRESS; + YADDRESS := Y'ADDRESS; + + IF NOT EQUAL(XSIZE,X'SIZE) THEN + FAILED ("IMPROPER VALUE FOR X'SIZE"); + END IF; + + IF XADDRESS /= IDENT_ADR(X'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR X'ADDRESS"); + END IF; + + IF NOT EQUAL(YSIZE,Y'SIZE) THEN + FAILED ("IMPROPER VALUE FOR Y'SIZE"); + END IF; + + IF YADDRESS /= IDENT_ADR(Y'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR Y'ADDRESS"); + END IF; + END P; + +BEGIN + ASIZE := A'SIZE; + BSIZE := B'SIZE; + AADDRESS := A'ADDRESS; + BADDRESS := B'ADDRESS; + + IF NOT EQUAL(ASIZE,A'SIZE) THEN + FAILED ("IMPROPER VALUE FOR A'SIZE"); + END IF; + + IF AADDRESS /= IDENT_ADR(A'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR A'ADDRESS"); + END IF; + + IF NOT EQUAL(BSIZE,B'SIZE) THEN + FAILED ("IMPROPER VALUE FOR B'SIZE"); + END IF; + + IF BADDRESS /= IDENT_ADR(B'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR B'ADDRESS"); + END IF; + + RESULT; +END C74208A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74208b.ada b/gcc/testsuite/ada/acats/tests/c7/c74208b.ada new file mode 100644 index 000000000..c4c00bfc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74208b.ada @@ -0,0 +1,106 @@ +-- C74208B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT 'CONSTRAINED FOR OBJECTS OF A PRIVATE TYPE WITH +-- VISIBLE DISCRIMINANTS IS AVAILABLE OUTSIDE THE PACKAGE DECLARING +-- THE TYPE AND IS AVAILABLE BEFORE AND AFTER THE FULL DECLARATION. + +-- HISTORY: +-- BCB 07/14/88 CREATED ORIGINAL TEST. +-- GJD 11/15/95 MOVED REC2_VAR OUT OF P DUE TO ADA 95 FREEZING RULES. + +WITH REPORT; USE REPORT; + +PROCEDURE C74208B IS + + PACKAGE P IS + TYPE REC (D : INTEGER := 0) IS PRIVATE; + R1 : CONSTANT REC; + TYPE REC2 IS RECORD + COMP : BOOLEAN := R1'CONSTRAINED; + END RECORD; + PRIVATE + TYPE REC (D : INTEGER := 0) IS RECORD + NULL; + END RECORD; + R1 : CONSTANT REC := (D => 5); + R2 : REC := (D => 0); + R2A : REC(3); + R2CON : CONSTANT REC := (D => 3); + C : BOOLEAN := R2'CONSTRAINED; + D : BOOLEAN := R2A'CONSTRAINED; + E : BOOLEAN := R2CON'CONSTRAINED; + END P; + + REC2_VAR : P.REC2; + + R3 : P.REC(0); + R3A : P.REC; + + A : BOOLEAN := R3'CONSTRAINED; + B : BOOLEAN := R3A'CONSTRAINED; + + PACKAGE BODY P IS + BEGIN + TEST ("C74208B", "CHECK THAT 'CONSTRAINED FOR OBJECTS OF A " & + "PRIVATE TYPE WITH VISIBLE DISCRIMINANTS " & + "IS AVAILABLE OUTSIDE THE PACKAGE " & + "DECLARING THE TYPE AND IS AVAILABLE " & + "BEFORE AND AFTER THE FULL DECLARATION"); + + IF NOT REC2_VAR.COMP THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED BEFORE THE " & + "FULL DECLARATION OF THE PRIVATE TYPE"); + END IF; + + IF C THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 1"); + END IF; + + IF NOT D THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 2"); + END IF; + + IF NOT E THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 3"); + END IF; + END P; + +BEGIN + IF NOT A THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " & + "PACKAGE DECLARING THE PRIVATE TYPE - 1"); + END IF; + + IF B THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " & + "PACKAGE DECLARING THE PRIVATE TYPE - 2"); + END IF; + + RESULT; +END C74208B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74209a.ada b/gcc/testsuite/ada/acats/tests/c7/c74209a.ada new file mode 100644 index 000000000..eef77fde9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74209a.ada @@ -0,0 +1,224 @@ +-- C74209A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED +-- PRIVATE TYPES IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE +-- THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A +-- LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION +-- SUBPROGRAMS). + +-- RM 07/14/81 + + +WITH REPORT; +PROCEDURE C74209A IS + + USE REPORT; + +BEGIN + + TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " & + "PRIVATE TYPES" ); + + DECLARE + + PACKAGE PACK IS + + TYPE LIM_PRIV IS LIMITED PRIVATE; + TYPE PRIV IS PRIVATE; + PRIV_CONST_IN : CONSTANT PRIV; + PRIV_CONST_OUT : CONSTANT PRIV; + FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV; + FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ; + PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV ); + + PRIVATE + + TYPE LIM_PRIV IS NEW INTEGER; + TYPE PRIV IS NEW STRING( 1..5 ); + PRIV_CONST_IN : CONSTANT PRIV := "ABCDE"; + PRIV_CONST_OUT : CONSTANT PRIV := "FGHIJ"; + + END PACK; + + + PRIV_VAR_1 , PRIV_VAR_2 : PACK.PRIV; + LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2 : PACK.LIM_PRIV; + + + USE PACK; + + + PACKAGE BODY PACK IS + + FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV IS + BEGIN + RETURN LIM_PRIV(X); + END PACKAGED; + + FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN IS + BEGIN + RETURN X = Y ; + END EQUALS; + + PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV) IS + BEGIN + Y := X; + END ASSIGN; + + END PACK; + + + PROCEDURE PROC1( X : IN OUT PACK.PRIV; + Y : IN PACK.PRIV := PACK.PRIV_CONST_IN; + Z : OUT PACK.PRIV; + U : PACK.PRIV ) IS + BEGIN + + IF X /= PACK.PRIV_CONST_IN OR + Y /= PACK.PRIV_CONST_IN OR + U /= PACK.PRIV_CONST_IN + THEN + FAILED( "WRONG INPUT VALUES - PROC1" ); + END IF; + + X := PACK.PRIV_CONST_OUT; + Z := PACK.PRIV_CONST_OUT; + + END PROC1; + + + PROCEDURE PROC2( X : IN OUT LIM_PRIV; + Y : IN LIM_PRIV; + Z : IN OUT LIM_PRIV; + U : LIM_PRIV ) IS + BEGIN + + IF NOT(EQUALS( X , PACKAGED(17) )) OR + NOT(EQUALS( Y , PACKAGED(17) )) OR + NOT(EQUALS( U , PACKAGED(17) )) + THEN + FAILED( "WRONG INPUT VALUES - PROC2" ); + END IF; + + ASSIGN( PACKAGED(13) , X ); + ASSIGN( PACKAGED(13) , Z ); + + END PROC2; + + + FUNCTION FUNC1( Y : IN PRIV := PRIV_CONST_IN; + U : PRIV ) RETURN PRIV IS + BEGIN + + IF Y /= PRIV_CONST_IN OR + U /= PRIV_CONST_IN + THEN + FAILED( "WRONG INPUT VALUES - FUNC1" ); + END IF; + + RETURN PRIV_CONST_OUT; + + END FUNC1; + + + FUNCTION FUNC2( Y : IN LIM_PRIV; + U : LIM_PRIV ) RETURN LIM_PRIV IS + BEGIN + + IF NOT(EQUALS( Y , PACKAGED(17) )) OR + NOT(EQUALS( U , PACKAGED(17) )) + THEN + FAILED( "WRONG INPUT VALUES - FUNC2" ); + END IF; + + RETURN PACKAGED(13); + + END FUNC2; + + + BEGIN + + -------------------------------------------------------------- + + PRIV_VAR_1 := PRIV_CONST_IN; + PRIV_VAR_2 := PRIV_CONST_IN; + + PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN ); + + IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT OR + PRIV_VAR_2 /= PACK.PRIV_CONST_OUT + THEN + FAILED( "WRONG OUTPUT VALUES - PROC1" ); + END IF; + + -------------------------------------------------------------- + + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 ); + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 ); + + PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) , + LIM_PRIV_VAR_2 , PACKAGED(17) ); + + IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) OR + NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) )) + THEN + FAILED( "WRONG OUTPUT VALUES - PROC2" ); + END IF; + + -------------------------------------------------------------- + + PRIV_VAR_1 := PRIV_CONST_IN; + PRIV_VAR_2 := PRIV_CONST_IN; + + PRIV_VAR_1 := + FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN ); + + IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT + THEN + FAILED( "WRONG OUTPUT VALUES - FUNC1" ); + END IF; + + -------------------------------------------------------------- + + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 ); + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 ); + + ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) , + LIM_PRIV_VAR_1 ); + + IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) + THEN + FAILED( "WRONG OUTPUT VALUES - FUNC2" ); + END IF; + + -------------------------------------------------------------- + + END; + + + RESULT; + + +END C74209A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74210a.ada b/gcc/testsuite/ada/acats/tests/c7/c74210a.ada new file mode 100644 index 000000000..f3496b31c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74210a.ada @@ -0,0 +1,117 @@ +-- C74210A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OPERATOR SYMBOLS OVERLOADED IN A PACKAGE ARE +-- USED AND DERIVED IN PREFERENCE TO THOSE OF THE PARENT OF A DERIVED +-- PRIVATE TYPE. + +-- CHECK THAT OPERATOR DEFINITIONS FOR A PRIVATE TYPE MAY BE +-- OVERLOADED OUTSIDE THE PACKAGE. + +-- CHECK THAT EQUALITY CAN BE DEFINED FOR LIMITED TYPES AND COMPOSITE +-- TYPES WITH LIMITED COMPONENTS. + +-- DAT 5/11/81 + +WITH REPORT; USE REPORT; + +PROCEDURE C74210A IS +BEGIN + TEST ("C74210A", "OVERLOADED OPERATORS FOR PRIVATE TYPES"); + + DECLARE + PACKAGE P IS + TYPE T IS PRIVATE; + FUNCTION "+" (X, Y : T) RETURN T; + ONE, TWO : CONSTANT T; + + TYPE L IS LIMITED PRIVATE; + TYPE A IS ARRAY (0 .. 0) OF L; + TYPE R IS RECORD + C : L; + END RECORD; + FUNCTION "=" (X, Y : L) RETURN BOOLEAN; + PRIVATE + TYPE T IS NEW INTEGER; + ONE : CONSTANT T := T(IDENT_INT(1)); + TWO : CONSTANT T := T(IDENT_INT(2)); + TYPE L IS (ENUM); + END P; + USE P; + + VR : R; + VA : A; + + PACKAGE BODY P IS + FUNCTION "+" (X, Y : T) RETURN T IS + BEGIN + RETURN 1; + END "+"; + + FUNCTION "=" (X, Y : L) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END "="; + BEGIN + VR := (C => ENUM); + VA := (0 => VR.C); + END P; + BEGIN + IF ONE + TWO /= ONE THEN + FAILED ("WRONG ""+"" OPERATOR"); + END IF; + + DECLARE + TYPE NEW_T IS NEW T; + + FUNCTION "=" (X, Y : A) RETURN BOOLEAN; + FUNCTION "=" (X, Y : R) RETURN BOOLEAN; + + FUNCTION "+" (X, Y : T) RETURN T IS + BEGIN + RETURN TWO; + END "+"; + + FUNCTION "=" (X, Y : A) RETURN BOOLEAN IS + BEGIN + RETURN X(0) = Y(0); + END "="; + + FUNCTION "=" (X, Y : R) RETURN BOOLEAN IS + BEGIN + RETURN X.C = Y.C; + END "="; + BEGIN + IF ONE + TWO /= TWO THEN + FAILED ("WRONG DERIVED ""+"" OPERATOR"); + END IF; + + IF VR = VR OR VA = VA THEN + FAILED ("CANNOT OVERLOAD ""="" CORRECTLY"); + END IF; + END; + END; + + RESULT; +END C74210A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74211a.ada b/gcc/testsuite/ada/acats/tests/c7/c74211a.ada new file mode 100644 index 000000000..d4a1caf05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74211a.ada @@ -0,0 +1,195 @@ +-- C74211A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WITHIN THE PACKAGE SPECIFICATION AND BODY, ANY EXPLICIT +-- DECLARATIONS OF OPERATORS AND SUBPROGRAMS HIDE ANY OPERATIONS WHICH +-- ARE IMPLICITLY DECLARED AT THE POINT OF THE FULL DECLARATION, +-- REGARDLESS OF THE ORDER OF OCCURENCE OF THE DECLARATIONS. + +-- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS HIDE IMPLICITLY +-- DECLARED PREDEFINED OPERATORS, REGARDLESS OF THE ORDER OF OCCURENCE +-- OF THE DECLARATIONS. + +-- DSJ 4/28/83 +-- JBG 9/23/83 + +-- A) EXPLICIT DECLARATION HIDES LATER IMPLICIT DECL OF PREDEFINED OP. +-- B) " " " LATER " " " DERIVED OP. +-- C) " " " EARLIER " " " PREDEFINED OP. +-- D) " " " EARLIER " " " DERIVED OP. + +WITH REPORT; +PROCEDURE C74211A IS + + USE REPORT; + +BEGIN + + TEST ("C74211A", "CHECK THAT HIDING OF IMPLICITLY DECLARED " & + "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " & + "CORRECTLY REGARDLESS OF ORDER OF DECL'S"); + + DECLARE + + PACKAGE P1 IS + TYPE T1 IS RANGE 1 .. 50; + C1 : CONSTANT T1 := T1(IDENT_INT(2)); + D1 : CONSTANT T1 := C1 + C1; -- PREDEFINED "+" + FUNCTION "+" (L, R : T1) RETURN T1; -- C) FOR "+". + FUNCTION "-" (L, R : T1) RETURN T1; -- C) FOR "-". + FUNCTION "/" (L, R : T1) RETURN T1; + END P1; + + USE P1; + + PACKAGE BODY P1 IS + A,B : T1 := 3; + + FUNCTION "+" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN 1; + ELSE RETURN 2; + END IF; + END "+"; + + FUNCTION "-" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN 3; + ELSE RETURN 4; + END IF; + END "-"; + + FUNCTION "/" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN T1(IDENT_INT(INTEGER(L))); + ELSE + RETURN T1(IDENT_INT(50)); + END IF; + END "/"; + + BEGIN + IF D1 /= 4 THEN + FAILED ("WRONG PREDEFINED OPERATION - '+' "); + END IF; + + IF D1 + C1 /= 2 THEN + FAILED ("IMPLICIT '+' NOT HIDDEN BY EXPLICIT '+'"); + END IF; + + IF A + B /= 1 THEN + FAILED ("IMPLICIT DECLARATION NOT HIDDEN " & + "BY EXPLICIT DECLARATION - '+' "); + END IF; + + IF A - B /= 3 THEN + FAILED ("IMPLICIT DECLARATION NOT HIDDEN " & + "BY EXPLICIT DECLARATION - '-' "); + END IF; + + IF A * B /= 9 THEN + FAILED ("WRONG PREDEFINED OPERATION - '*' "); + END IF; + + IF B / A /= T1(IDENT_INT(3)) THEN + FAILED ("NOT REDEFINED '/' "); + END IF; + END P1; + + PACKAGE P2 IS + TYPE T2 IS PRIVATE; + X , Y : CONSTANT T2; + FUNCTION "+" (L, R : T2) RETURN T2; -- B) + FUNCTION "*" (L, R : T2) RETURN T2; -- A) + PRIVATE + TYPE T2 IS NEW T1; -- B) +; A) * + Z : T2 := T2(IDENT_INT(3))/4; -- Z = 50 USING + -- DERIVED / + FUNCTION "/" (L, R : T2) RETURN T2; -- D) FOR / + X , Y : CONSTANT T2 := 3; + END P2; + + PACKAGE BODY P2 IS + FUNCTION "+" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(5)); + ELSE RETURN T2(IDENT_INT(6)); + END IF; + END "+"; + + FUNCTION "*" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(7)); + ELSE RETURN T2(IDENT_INT(8)); + END IF; + END "*"; + + FUNCTION "/" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(9)); + ELSE RETURN T2(IDENT_INT(10)); + END IF; + END "/"; + BEGIN + IF X + Y /= 5 THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '+' "); + END IF; + + IF Y - X /= 3 THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '-' "); + END IF; + + IF X * Y /= 7 THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '*' "); + END IF; + + IF Y / X /= T2(IDENT_INT(9)) THEN + FAILED ("DERIVED OPERATOR NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '/' "); + END IF; + + IF Z /= 50 THEN + FAILED ("DERIVED OPERATOR HIDDEN PREMATURELY " & + " BY REDECLARED OPERATOR"); + END IF; + + END P2; + + BEGIN + + NULL; + + END; + + RESULT; + +END C74211A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74211b.ada b/gcc/testsuite/ada/acats/tests/c7/c74211b.ada new file mode 100644 index 000000000..d4b9ef73f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74211b.ada @@ -0,0 +1,156 @@ +-- C74211B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED INEQUALITY WHICH ACCOMPANIES AN +-- EXPLICIT DECLARATION OF EQUALITY HIDES OTHER IMPLICITLY DECLARED +-- HOMOGRAPHS, AND THAT DERIVED INEQUALITY HIDES PREDEFINED INEQUALITY. + +-- DSJ 4/29/83 +-- JBG 9/23/83 + +WITH REPORT; +PROCEDURE C74211B IS + + USE REPORT; + +BEGIN + + TEST( "C74211B", "CHECK THAT HIDING OF IMPLICITLY DECLARED " & + "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " & + "CORRECTLY REGARDLESS OF ORDER OF DECL'S"); + + DECLARE + + PACKAGE P1 IS + TYPE LT1 IS LIMITED PRIVATE; + FUNCTION "="(L, R : LT1) RETURN BOOLEAN; + FUNCTION LT1_VALUE_2 RETURN LT1; + FUNCTION LT1_VALUE_4 RETURN LT1; + TYPE LT2 IS LIMITED PRIVATE; + PRIVATE + TYPE LT1 IS RANGE 1 .. 10; + TYPE LT2 IS RANGE 1 .. 10; + END P1; + + USE P1; + + PACKAGE P2 IS + TYPE LT3 IS LIMITED PRIVATE; + TYPE LT4 IS NEW LT1; + PRIVATE + FUNCTION "=" (L, R : LT3) RETURN BOOLEAN; + TYPE LT3 IS NEW LT1; + END P2; + + USE P2; + + PACKAGE BODY P1 IS + A , B : CONSTANT LT1 := 4; + C , D : CONSTANT LT2 := 6; + + FUNCTION "=" (L, R : LT1) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER(L) /= INTEGER(R); + END "="; + + FUNCTION LT1_VALUE_2 RETURN LT1 IS + BEGIN + RETURN 2; + END LT1_VALUE_2; + + FUNCTION LT1_VALUE_4 RETURN LT1 IS + BEGIN + RETURN 4; + END LT1_VALUE_4; + + BEGIN + IF A = B THEN + FAILED ("PREDEFINED EQUALITY NOT HIDDEN BY " & + "EXPLICIT DECLARATION - LT1"); + END IF; + + IF C /= D THEN + FAILED ("WRONG PREDEFINED OPERATION - T2"); + END IF; + END P1; + + PACKAGE BODY P2 IS + FUNCTION U RETURN LT3 IS + BEGIN + RETURN LT1_VALUE_2; + END U; + + FUNCTION V RETURN LT3 IS + BEGIN + RETURN LT1_VALUE_4; + END V; + + FUNCTION W RETURN LT4 IS + BEGIN + RETURN LT1_VALUE_2; + END W; + + FUNCTION X RETURN LT4 IS + BEGIN + RETURN LT1_VALUE_4; + END X; + + FUNCTION "=" (L, R : LT3) RETURN BOOLEAN IS + BEGIN + RETURN NOT (LT1(L) = LT1(R)); + END "="; + + BEGIN + IF NOT (U /= V) THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "IMPLICITLY DECLARED INEQUALITY " & + "FROM EXPLICITLY DECLARED EQUALITY"); + END IF; + + IF NOT (LT3(W) = U) THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '=' "); + END IF; + + IF W /= X THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '/=' "); + END IF; + + IF NOT ( X = W ) THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '=' "); + END IF; + + END P2; + + BEGIN + + NULL; + + END; + + RESULT; + +END C74211B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74302a.ada b/gcc/testsuite/ada/acats/tests/c7/c74302a.ada new file mode 100644 index 000000000..a772e5087 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74302a.ada @@ -0,0 +1,81 @@ +-- C74302A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR DEFERRED CONSTANT +-- DECLARATIONS, EVEN IF THE FULL DECLARATIONS ARE GIVEN INDIVIDUALLY. + +-- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR THE FULL +-- DECLARATIONS, EVEN IF THE DEFERRED CONSTANT DECLARATIONS ARE GIVEN +-- INDIVIDUALLY. + + +-- DSJ 5/09/83 +-- SPS 10/24/83 +-- EG 12/19/83 +-- JRK 12/20/83 + +-- DTN 11/19/91 DELETED SUBPART (C). + +WITH REPORT; +PROCEDURE C74302A IS + + USE REPORT; + +BEGIN + + TEST("C74302A", "CHECK THAT MULTIPLE DECLARATIONS MAY BE USED " & + "FOR DEFERRED CONSTANT DECLARATIONS"); + + DECLARE + + PACKAGE PACK1 IS + + TYPE T IS PRIVATE; + + B, E : CONSTANT T; + + F : CONSTANT T; + PRIVATE + + TYPE T IS NEW INTEGER; + + E : CONSTANT T := T(IDENT_INT(4)); + + B, F : CONSTANT T := T(IDENT_INT(2)); + + END PACK1; + + USE PACK1; + + BEGIN + + IF B/=F THEN + FAILED("VALUES OF DEFERRED CONSTANTS B AND F NOT EQUAL"); + END IF; + + END; + + RESULT; + +END C74302A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74302b.ada b/gcc/testsuite/ada/acats/tests/c7/c74302b.ada new file mode 100644 index 000000000..16b0803cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74302b.ada @@ -0,0 +1,308 @@ +-- C74302B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WHEN THE FULL DECLARATION OF A DEFERRED CONSTANT IS +-- GIVEN AS A MULTIPLE DECLARATION, THE INITIALIZATION EXPRESSION +-- IS EVALUATED ONCE FOR EACH DEFERRED CONSTANT. (USE ENUMERATION, +-- INTEGER, FIXED POINT, FLOATING POINT, ARRAY, RECORD (INCLUDING +-- USE OF DEFAULT EXPRESSIONS FOR COMPONENTS), ACCESS, AND PRIVATE +-- TYPES AS FULL DECLARATION OF PRIVATE TYPE) + +-- HISTORY: +-- BCB 07/25/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74302B IS + + TYPE ARR_RAN IS RANGE 1..2; + + BUMP : INTEGER := IDENT_INT(0); + + GENERIC + TYPE DT IS (<>); + FUNCTION F1 RETURN DT; + + GENERIC + TYPE FE IS DELTA <>; + FUNCTION F2 RETURN FE; + + GENERIC + TYPE FLE IS DIGITS <>; + FUNCTION F3 RETURN FLE; + + GENERIC + TYPE CA IS ARRAY(ARR_RAN) OF INTEGER; + FUNCTION F4 RETURN CA; + + GENERIC + TYPE GP IS LIMITED PRIVATE; + FUNCTION F5 (V : GP) RETURN GP; + + GENERIC + TYPE GP1 IS LIMITED PRIVATE; + FUNCTION F6 (V1 : GP1) RETURN GP1; + + GENERIC + TYPE AC IS ACCESS INTEGER; + FUNCTION F7 RETURN AC; + + GENERIC + TYPE PP IS PRIVATE; + FUNCTION F8 (P1 : PP) RETURN PP; + + FUNCTION F1 RETURN DT IS + BEGIN + BUMP := BUMP + 1; + RETURN DT'VAL(BUMP); + END F1; + + FUNCTION F2 RETURN FE IS + BEGIN + BUMP := BUMP + 1; + RETURN FE(BUMP); + END F2; + + FUNCTION F3 RETURN FLE IS + BEGIN + BUMP := BUMP + 1; + RETURN FLE(BUMP); + END F3; + + FUNCTION F4 RETURN CA IS + BEGIN + BUMP := BUMP + 1; + RETURN ((BUMP,BUMP-1)); + END F4; + + FUNCTION F5 (V : GP) RETURN GP IS + BEGIN + BUMP := BUMP + 1; + RETURN V; + END F5; + + FUNCTION F6 (V1 : GP1) RETURN GP1 IS + BEGIN + BUMP := BUMP + 1; + RETURN V1; + END F6; + + FUNCTION F7 RETURN AC IS + VAR : AC; + BEGIN + BUMP := BUMP + 1; + VAR := NEW INTEGER'(BUMP); + RETURN VAR; + END F7; + + FUNCTION F8 (P1 : PP) RETURN PP IS + BEGIN + BUMP := BUMP + 1; + RETURN P1; + END F8; + + PACKAGE PACK IS + TYPE SP IS PRIVATE; + CONS : CONSTANT SP; + PRIVATE + TYPE SP IS RANGE 1 .. 100; + CONS : CONSTANT SP := 50; + END PACK; + + USE PACK; + + PACKAGE P IS + TYPE INT IS PRIVATE; + TYPE ENUM IS PRIVATE; + TYPE FIX IS PRIVATE; + TYPE FLT IS PRIVATE; + TYPE CON_ARR IS PRIVATE; + TYPE REC IS PRIVATE; + TYPE REC1 IS PRIVATE; + TYPE ACC IS PRIVATE; + TYPE PRIV IS PRIVATE; + + GENERIC + TYPE LP IS PRIVATE; + FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN; + + I1, I2, I3, I4 : CONSTANT INT; + E1, E2, E3, E4 : CONSTANT ENUM; + FI1, FI2, FI3, FI4 : CONSTANT FIX; + FL1, FL2, FL3, FL4 : CONSTANT FLT; + CA1, CA2, CA3, CA4 : CONSTANT CON_ARR; + R1, R2, R3, R4 : CONSTANT REC; + R1A, R2A, R3A, R4A : CONSTANT REC1; + A1, A2, A3, A4 : CONSTANT ACC; + PR1, PR2, PR3, PR4 : CONSTANT PRIV; + PRIVATE + TYPE INT IS RANGE 1 .. 100; + + TYPE ENUM IS (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE); + + TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0; + + TYPE FLT IS DIGITS 5 RANGE -100.0 .. 100.0; + + TYPE CON_ARR IS ARRAY(ARR_RAN) OF INTEGER; + + TYPE REC IS RECORD + COMP1 : INTEGER; + COMP2 : INTEGER; + COMP3 : BOOLEAN; + END RECORD; + + TYPE REC1 IS RECORD + COMP1 : INTEGER := 10; + COMP2 : INTEGER := 20; + COMP3 : BOOLEAN := FALSE; + END RECORD; + + TYPE ACC IS ACCESS INTEGER; + + TYPE PRIV IS NEW SP; + + FUNCTION DDT IS NEW F1 (INT); + FUNCTION EDT IS NEW F1 (ENUM); + FUNCTION FDT IS NEW F2 (FIX); + FUNCTION FLDT IS NEW F3 (FLT); + FUNCTION CADT IS NEW F4 (CON_ARR); + FUNCTION RDT IS NEW F5 (REC); + FUNCTION R1DT IS NEW F6 (REC1); + FUNCTION ADT IS NEW F7 (ACC); + FUNCTION PDT IS NEW F8 (PRIV); + + REC_OBJ : REC := (1,2,TRUE); + REC1_OBJ : REC1 := (3,4,FALSE); + + I1, I2, I3, I4 : CONSTANT INT := DDT; + E1, E2, E3, E4 : CONSTANT ENUM := EDT; + FI1, FI2, FI3, FI4 : CONSTANT FIX := FDT; + FL1, FL2, FL3, FL4 : CONSTANT FLT := FLDT; + CA1, CA2, CA3, CA4 : CONSTANT CON_ARR := CADT; + R1, R2, R3, R4 : CONSTANT REC := RDT(REC_OBJ); + R1A, R2A, R3A, R4A : CONSTANT REC1 := R1DT(REC1_OBJ); + A1, A2, A3, A4 : CONSTANT ACC := ADT; + PR1, PR2, PR3, PR4 : CONSTANT PRIV := PDT(PRIV(CONS)); + END P; + + PACKAGE BODY P IS + AVAR1 : ACC := NEW INTEGER'(29); + AVAR2 : ACC := NEW INTEGER'(30); + AVAR3 : ACC := NEW INTEGER'(31); + AVAR4 : ACC := NEW INTEGER'(32); + + FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN IS + BEGIN + RETURN Z1 = Z2; + END GEN_EQUAL; + + FUNCTION INT_EQUAL IS NEW GEN_EQUAL (INT); + FUNCTION ENUM_EQUAL IS NEW GEN_EQUAL (ENUM); + FUNCTION FIX_EQUAL IS NEW GEN_EQUAL (FIX); + FUNCTION FLT_EQUAL IS NEW GEN_EQUAL (FLT); + FUNCTION ARR_EQUAL IS NEW GEN_EQUAL (CON_ARR); + FUNCTION REC_EQUAL IS NEW GEN_EQUAL (REC); + FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1); + FUNCTION ACC_EQUAL IS NEW GEN_EQUAL (INTEGER); + FUNCTION PRIV_EQUAL IS NEW GEN_EQUAL (PRIV); + BEGIN + TEST ("C74302B", "CHECK THAT WHEN THE FULL DECLARATION OF " & + "A DEFERRED CONSTANT IS GIVEN AS A " & + "MULTIPLE DECLARATION, THE INITIALIZATION " & + "EXPRESSION IS EVALUATED ONCE FOR EACH " & + "DEFERRED CONSTANT"); + + IF NOT EQUAL(BUMP,36) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED CONSTANTS IN A MULIPLE DECLARATION"); + END IF; + + IF NOT INT_EQUAL(I1,1) OR NOT INT_EQUAL(I2,2) OR + NOT INT_EQUAL(I3,3) OR NOT INT_EQUAL(I4,4) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED INTEGER CONSTANTS"); + END IF; + + IF NOT ENUM_EQUAL(E1,SIX) OR NOT ENUM_EQUAL(E2,SEVEN) OR + NOT ENUM_EQUAL(E3,EIGHT) OR NOT ENUM_EQUAL(E4,NINE) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ENUMERATION CONSTANTS"); + END IF; + + IF NOT FIX_EQUAL(FI1,9.0) OR NOT FIX_EQUAL(FI2,10.0) OR + NOT FIX_EQUAL(FI3,11.0) OR NOT FIX_EQUAL(FI4,12.0) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED FIXED POINT CONSTANTS"); + END IF; + + IF NOT FLT_EQUAL(FL1,13.0) OR NOT FLT_EQUAL(FL2,14.0) OR + NOT FLT_EQUAL(FL3,15.0) OR NOT FLT_EQUAL(FL4,16.0) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED FLOATING POINT CONSTANTS"); + END IF; + + IF NOT ARR_EQUAL(CA1,(17,16)) OR NOT ARR_EQUAL(CA2,(18,17)) + OR NOT ARR_EQUAL(CA3,(19,18)) OR NOT ARR_EQUAL(CA4,(20,19)) + THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ARRAY CONSTANTS"); + END IF; + + IF NOT REC_EQUAL(R1,REC_OBJ) OR NOT REC_EQUAL(R2,REC_OBJ) + OR NOT REC_EQUAL(R3,REC_OBJ) OR NOT REC_EQUAL(R4,REC_OBJ) + THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED RECORD CONSTANTS"); + END IF; + + IF NOT REC1_EQUAL(R1A,REC1_OBJ) OR NOT REC1_EQUAL(R2A, + REC1_OBJ) OR NOT REC1_EQUAL(R3A,REC1_OBJ) OR NOT + REC1_EQUAL(R4A,REC1_OBJ) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED RECORD CONSTANTS WITH DEFAULT " & + "EXPRESSIONS"); + END IF; + + IF NOT ACC_EQUAL(A1.ALL,AVAR1.ALL) OR NOT ACC_EQUAL(A2.ALL, + AVAR2.ALL) OR NOT ACC_EQUAL(A3.ALL,AVAR3.ALL) OR NOT + ACC_EQUAL(A4.ALL,AVAR4.ALL) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ACCESS CONSTANTS"); + END IF; + + IF NOT PRIV_EQUAL(PR1,PRIV(CONS)) OR NOT PRIV_EQUAL(PR2, + PRIV(CONS)) OR NOT PRIV_EQUAL(PR3,PRIV(CONS)) OR NOT + PRIV_EQUAL(PR4,PRIV(CONS)) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED PRIVATE CONSTANTS"); + END IF; + + RESULT; + END P; + + USE P; + +BEGIN + NULL; +END C74302B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74305a.ada b/gcc/testsuite/ada/acats/tests/c7/c74305a.ada new file mode 100644 index 000000000..b1233cbd1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74305a.ada @@ -0,0 +1,160 @@ +-- C74305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT +-- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA- +-- LIZATION FOR A COMPONENT (NON GENERIC CASE). + +-- DAT 4/06/81 +-- RM 5/21/81 +-- SPS 8/23/82 +-- SPS 2/10/83 +-- SPS 10/20/83 +-- EG 12/20/83 +-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY. + +WITH REPORT; + +PROCEDURE C74305A IS + + USE REPORT; + + PACKAGE PK IS + TYPE T1 IS PRIVATE; + TYPE T2 IS PRIVATE; + C1 : CONSTANT T1; -- OK. + + PROCEDURE P1 (P : T1 := C1); -- OK. + + TYPE R1 IS RECORD + C : T1 := C1; -- OK. + END RECORD; + PRIVATE + PROCEDURE PROC2 (P : T1 := C1); -- OK. + + TYPE R2 IS RECORD + C : T1 := C1; -- OK. + D : INTEGER := C1'SIZE; -- OK. + END RECORD; + + FUNCTION F1 (P : T1) RETURN T1; + + TYPE T1 IS NEW INTEGER; + TYPE T2 IS ARRAY (1..2) OF INTEGER; -- OK. + + FUNCTION F2 (P : T1) RETURN T1; + + PROCEDURE P3 (P : T1 := C1+1); -- OK. + + PROCEDURE P4 (P : T1 := F1(C1)); + + TYPE R5 IS RECORD + C : T1 := F2(C1); + END RECORD; + + PROCEDURE P5 (P : T1 := C1+2) RENAMES P3; + + TYPE R3 IS RECORD + C : T1 := C1; -- OK. + END RECORD; + + C1 : CONSTANT T1 := 1; -- OK. + C2 : CONSTANT T2 := (1,1); -- OK. + END PK; + + USE PK; + + PACKAGE BODY PK IS + + R11 : R1; + + PROCEDURE P1 (P : T1 := C1) IS + BEGIN + IF ( P /= 1 ) THEN + FAILED ("PARAMETER DEFAULT OF P1 NOT PROPERLY " & + "INITIALIZED"); + END IF; + END P1; + + PROCEDURE PROC2 (P : T1 := C1) IS + BEGIN NULL; END PROC2; + + PROCEDURE P3 (P : T1 := C1+1) IS + BEGIN + IF ( P /= 3 ) THEN + FAILED ("PARAMETER DEFAULT OF P5 NOT PROPERLY " & + "INITIALIZED"); + END IF; + END P3; + + FUNCTION F1 (P : T1) RETURN T1 IS + BEGIN + RETURN P+10; + END F1; + + PROCEDURE P4 (P : T1 := F1(C1)) IS + BEGIN + IF ( P /= 11 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED"); + END IF; + END P4; + + FUNCTION F2 (P : T1) RETURN T1 IS + BEGIN + RETURN P+20; + END F2; + + BEGIN -- PK BODY. + + DECLARE + + R55 : R5; + + BEGIN + TEST ("C74305A","CHECK THAT A DEFERRED CONSTANT CAN " & + "BE USED AS A DEFAULT INITIALIZATION " & + "FOR A PARAMETER OR AS A DEFAULT " & + "INITIALIZATION FOR A COMPONENT (NON " & + "GENERIC CASE)"); + + IF ( R11.C /= 1 ) THEN + FAILED ("RECORD R11 NOT PROPERLY INITIALIZED"); + END IF; + + P4; + + IF ( R55.C /= 21 ) THEN + FAILED ("RECORD R55 NOT PROPERLY INITIALIZED"); + END IF; + + P5; + END; + END PK; + +BEGIN + + P1; + + RESULT; +END C74305A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74305b.ada b/gcc/testsuite/ada/acats/tests/c7/c74305b.ada new file mode 100644 index 000000000..fa9ae1ea4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74305b.ada @@ -0,0 +1,101 @@ +-- C74305B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT +-- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA- +-- LIZATION FOR A COMPONENT (GENERIC CASE). + +-- EG 12/20/83 + +WITH REPORT; + +PROCEDURE C74305B IS + + USE REPORT; + + PACKAGE PK IS + TYPE TD IS PRIVATE; + CD : CONSTANT TD; + DD : CONSTANT TD; + + GENERIC + TYPE T1 IS PRIVATE; + C1 : T1; + WITH PROCEDURE P2 (A1 : T1 := C1; A2 : TD := CD); + PROCEDURE P1 (A1 : TD := CD); + + PRIVATE + TYPE TD IS NEW INTEGER; + CD : CONSTANT TD := 2; + DD : CONSTANT TD := 3; + END PK; + + USE PK; + + PACKAGE BODY PK IS + + PROCEDURE P1 (A1 : TD := CD) IS + BEGIN + IF ( A1 /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (1)"); + END IF; + P2; + END P1; + + PROCEDURE P3 (X : TD := DD; Y : TD := DD) IS + BEGIN + IF ( X /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (2)"); + END IF; + IF ( Y /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (3)"); + END IF; + END P3; + + PROCEDURE P4 IS NEW P1 (TD,CD,P3); + + BEGIN + TEST ("C74305B","CHECK THAT A DEFERRED CONSTANT CAN BE " & + "USED AS A DEFAULT INITIALIZATION FOR A " & + "PARAMETER OR AS A DEFAULT INITIALIZATION " & + "FOR A COMPONENT (GENERIC CASE)"); + P4; + END PK; + + PROCEDURE P5 (X : TD := DD; Y : TD := DD) IS + BEGIN + IF ( X /= CD ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (4)"); + END IF; + IF ( Y /= CD ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (5)"); + END IF; + END P5; + + PROCEDURE P6 IS NEW P1 (TD,CD,P5); + +BEGIN + P6; + RESULT; +END C74305B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74306a.ada b/gcc/testsuite/ada/acats/tests/c7/c74306a.ada new file mode 100644 index 000000000..c6ebad3c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74306a.ada @@ -0,0 +1,279 @@ +-- C74306A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- AFTER THE FULL DECLARATION OF A DEFERRED CONSTANT, THE VALUE OF +-- THE CONSTANT MAY BE USED IN ANY EXPRESSION, PARTICULARLY +-- EXPRESSIONS IN WHICH THE USE WOULD BE ILLEGAL BEFORE THE FULL +-- DECLARATION. + +-- HISTORY: +-- BCB 03/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74306A IS + + GENERIC + TYPE GENERAL_PURPOSE IS LIMITED PRIVATE; + Y : IN OUT GENERAL_PURPOSE; + FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; + + FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Y; + END IDENT; + + PACKAGE P IS + TYPE T IS PRIVATE; + C : CONSTANT T; + PRIVATE + TYPE T IS RANGE 1 .. 100; + + TYPE A IS ARRAY(1..2) OF T; + + TYPE B IS ARRAY(INTEGER RANGE <>) OF T; + + TYPE D (DISC : T) IS RECORD + NULL; + END RECORD; + + C : CONSTANT T := 50; + + PARAM : T := 99; + + FUNCTION IDENT_T IS NEW IDENT (T, PARAM); + + FUNCTION F (X : T := C) RETURN T; + + SUBTYPE RAN IS T RANGE 1 .. C; + + SUBTYPE IND IS B(1..INTEGER(C)); + + SUBTYPE DIS IS D (DISC => C); + + OBJ : T := C; + + CON : CONSTANT T := C; + + ARR : A := (5, C); + + PAR : T := IDENT_T (C); + + RANOBJ : T RANGE 1 .. C := C; + + INDOBJ : B(1..INTEGER(C)); + + DIS_VAL : DIS; + + REN : T RENAMES C; + + GENERIC + FOR_PAR : T := C; + PACKAGE GENPACK IS + VAL : T; + END GENPACK; + + GENERIC + IN_PAR : IN T; + PACKAGE NEWPACK IS + IN_VAL : T; + END NEWPACK; + END P; + + USE P; + + PACKAGE BODY P IS + TYPE A1 IS ARRAY(1..2) OF T; + + TYPE B1 IS ARRAY(INTEGER RANGE <>) OF T; + + TYPE D1 (DISC1 : T) IS RECORD + NULL; + END RECORD; + + SUBTYPE RAN1 IS T RANGE 1 .. C; + + SUBTYPE IND1 IS B1(1..INTEGER(C)); + + SUBTYPE DIS1 IS D1 (DISC1 => C); + + OBJ1 : T := C; + + FUNCVAR : T; + + CON1 : CONSTANT T := C; + + ARR1 : A1 := (5, C); + + PAR1 : T := IDENT_T (C); + + RANOBJ1 : T RANGE 1 .. C := C; + + INDOBJ1 : B1(1..INTEGER(C)); + + DIS_VAL1 : DIS1; + + REN1 : T RENAMES C; + + FUNCTION F (X : T := C) RETURN T IS + BEGIN + RETURN C; + END F; + + PACKAGE BODY GENPACK IS + BEGIN + VAL := FOR_PAR; + END GENPACK; + + PACKAGE BODY NEWPACK IS + BEGIN + IN_VAL := IN_PAR; + END NEWPACK; + + PACKAGE PACK IS NEW GENPACK (FOR_PAR => C); + + PACKAGE NPACK IS NEW NEWPACK (IN_PAR => C); + BEGIN + TEST ("C74306A", "AFTER THE FULL DECLARATION OF A DEFERRED " & + "CONSTANT, THE VALUE OF THE CONSTANT MAY " & + "BE USED IN ANY EXPRESSION, PARTICULARLY " & + "EXPRESSIONS IN WHICH THE USE WOULD BE " & + "ILLEGAL BEFORE THE FULL DECLARATION"); + + IF OBJ /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR OBJ"); + END IF; + + IF CON /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR CON"); + END IF; + + IF ARR /= (IDENT_T(5), IDENT_T(50)) THEN + FAILED ("IMPROPER VALUES FOR ARR"); + END IF; + + IF PAR /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PAR"); + END IF; + + IF OBJ1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR OBJ1"); + END IF; + + IF CON1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR CON1"); + END IF; + + IF ARR1 /= (IDENT_T(5), IDENT_T(50)) THEN + FAILED ("IMPROPER VALUES FOR ARR1"); + END IF; + + IF PAR1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PAR1"); + END IF; + + IF PACK.VAL /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PACK.VAL"); + END IF; + + IF NPACK.IN_VAL /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR NPACK.IN_VAL"); + END IF; + + IF RAN'LAST /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RAN'LAST"); + END IF; + + IF RANOBJ /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RANOBJ"); + END IF; + + IF IND'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR IND'LAST"); + END IF; + + IF INDOBJ'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR INDOBJ'LAST"); + END IF; + + IF DIS_VAL.DISC /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR DIS_VAL.DISC"); + END IF; + + IF REN /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR REN"); + END IF; + + IF RAN1'LAST /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RAN1'LAST"); + END IF; + + IF RANOBJ1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RANOBJ1"); + END IF; + + IF IND1'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR IND1'LAST"); + END IF; + + IF INDOBJ1'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR INDOBJ1'LAST"); + END IF; + + IF DIS_VAL1.DISC1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR DIS_VAL1.DISC1"); + END IF; + + IF REN1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR REN1"); + END IF; + + FUNCVAR := F(C); + + IF FUNCVAR /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR FUNCVAR"); + END IF; + + RESULT; + END P; + +BEGIN + DECLARE + TYPE ARR IS ARRAY(1..2) OF T; + + VAL1 : T := C; + + VAL2 : ARR := (C, C); + + VAL3 : T RENAMES C; + BEGIN + NULL; + END; + + NULL; +END C74306A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74307a.ada b/gcc/testsuite/ada/acats/tests/c7/c74307a.ada new file mode 100644 index 000000000..aaddc0505 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74307a.ada @@ -0,0 +1,58 @@ +-- C74307A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN EXPLICIT CONSTRAINT MAY BE GIVEN IN THE SUBTYPE +-- INDICATION OF THE FULL DECLARATION OF A DEFERRED CONSTANT. + +-- HISTORY: +-- BCB 03/14/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74307A IS + + PACKAGE P IS + TYPE T (D : INTEGER) IS PRIVATE; + C : CONSTANT T; + PRIVATE + TYPE T (D : INTEGER) IS RECORD + NULL; + END RECORD; + C : CONSTANT T(2) := (D => 2); + END P; + + USE P; + +BEGIN + TEST ("C74307A", "CHECK THAT AN EXPLICIT CONSTRAINT MAY BE " & + "GIVEN IN THE SUBTYPE INDICATION OF THE FULL " & + "DECLARATION OF A DEFERRED CONSTANT"); + + IF C.D /= 2 THEN + FAILED ("IMPROPER RESULTS FOR C.D"); + END IF; + + RESULT; +END C74307A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401d.ada b/gcc/testsuite/ada/acats/tests/c7/c74401d.ada new file mode 100644 index 000000000..024e677ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401d.ada @@ -0,0 +1,111 @@ +-- C74401D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN OUT PARAMETER HAVING A LIMITED TYPE IS ALLOWED FOR +-- FORMAL SUBPROGRAM PARAMETERS. (ONLY THE CASE OF PRACTICAL INTEREST, +-- NAMELY, LIMITED PRIVATE TYPES, IS CHECKED HERE.) + +-- CHECK THAT AN OUT PARAMETER IN A RENAMING DECLARATION CAN HAVE A +-- LIMITED PRIVATE TYPE WHEN IT RENAMES A GENERIC FORMAL SUBPROGRAM. + +-- JBG 5/1/85 + +WITH REPORT; USE REPORT; +PROCEDURE C74401D IS + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE P1 (X : OUT LP); + PROCEDURE P2 (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + VAL2 : CONSTANT LP; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + VAL2 : CONSTANT LP := LP(IDENT_INT(-3)); + END P; + + PACKAGE BODY P IS + PROCEDURE P1 (X : OUT LP) IS + BEGIN + X := 3; + END P1; + + PROCEDURE P2 (X : OUT LP) IS + BEGIN + X := -3; + END P2; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + END P; + + GENERIC + WITH PROCEDURE P3 (Y : OUT P.LP); + TYPE GLP IS LIMITED PRIVATE; + WITH PROCEDURE P4 (Y : OUT GLP); + VAL_P3 : IN OUT P.LP; + VAL_P4 : IN OUT GLP; + PACKAGE GPACK IS + PROCEDURE RENAMED (X : OUT GLP) RENAMES P4; -- OK. RENAMING. + END GPACK; + + PACKAGE BODY GPACK IS + BEGIN + P3 (VAL_P3); + P4 (VAL_P4); + END GPACK; + +BEGIN + + TEST ("C74401D", "CHECK THAT GENERIC FORMAL SUBPROGRAMS CAN HAVE "& + "LIMITED PRIVATE OUT PARAMETERS"); + + DECLARE + VAR1 : P.LP; + VAR2 : P.LP; + PACKAGE PACK IS NEW GPACK (P.P1, P.LP, P.P2, VAR1, VAR2); + BEGIN + IF NOT P.EQ (VAR1, P.VAL1) THEN + FAILED ("P1 INVOCATION INCORRECT"); + END IF; + + IF NOT P.EQ (VAR2, P.VAL2) THEN + FAILED ("P2 INVOCATION INCORRECT"); + END IF; + + P.P1 (VAR2); -- RESET VALUE OF VAR2. + PACK.RENAMED (VAR2); + + IF NOT P.EQ (VAR2, P.VAL2) THEN + FAILED ("RENAMED INVOCATION INCORRECT"); + END IF; + END; + + RESULT; + +END C74401D; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401e.ada b/gcc/testsuite/ada/acats/tests/c7/c74401e.ada new file mode 100644 index 000000000..df0c99007 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401e.ada @@ -0,0 +1,120 @@ +-- C74401E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE +-- DECLARED IN A PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES +-- NESTED IN A VISIBLE PART. + +-- CHECK THAT A RENAMING DECLARATION CAN RENAME A PROCEDURE DECLARED +-- WITH AN OUT PARAMETER. + +-- JBG 5/1/85 + +WITH REPORT; USE REPORT; +PROCEDURE C74401E IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE P20 (X : OUT LP); -- OK. + PROCEDURE RESET (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + PROCEDURE NEST1 (X : OUT LP); + PRIVATE + PROCEDURE NEST2 (X : OUT LP); + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + PROCEDURE P20 (X : OUT LP) IS + BEGIN + X := 3; + END P20; + + PROCEDURE RESET (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(0)); + END RESET; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + PROCEDURE NEST1 (X : OUT LP) IS + BEGIN + X := 3; + END NEST1; + + PROCEDURE NEST2 (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(3)); + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20; -- OK: + -- RENAMING. + END PKG1; + +BEGIN + + TEST ("C74401E", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.RESET (VAR); + PKG.P20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG.NESTED.NEST1 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("NESTED CALL NOT CORRECT"); + END IF; + + RESULT; + +END C74401E; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401k.ada b/gcc/testsuite/ada/acats/tests/c7/c74401k.ada new file mode 100644 index 000000000..55f153e0d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401k.ada @@ -0,0 +1,136 @@ +-- C74401K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OUT PARAMETERS OF AN ENTRY DECLARATION CAN HAVE A LIMITED +-- PRIVATE TYPE IF THE ENTRY DECLARATION OCCURS IN THE VISIBLE PART OF A +-- PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE +-- PART. + +-- CHECK THAT A RENAMING DECLARATION CAN RENAME AN ENTRY DECLARED +-- WITH AN OUT PARAMETER. + +-- JBG 5/1/85 + +WITH REPORT; USE REPORT; +PROCEDURE C74401K IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + TASK P20 IS + ENTRY TP20 (X : OUT LP); -- OK. + ENTRY RESET (X : OUT LP); + END P20; + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + TASK NEST1 IS + ENTRY TNEST1 (X : OUT LP); + END NEST1; + PRIVATE + TASK NEST2 IS + ENTRY TNEST2 (X : OUT LP); + END NEST2; + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + TASK BODY P20 IS + BEGIN + LOOP + SELECT + ACCEPT TP20 (X : OUT LP) DO + X := 3; + END TP20; + OR + ACCEPT RESET (X : OUT LP) DO + X := 0; + END RESET; + OR + TERMINATE; + END SELECT; + END LOOP; + END P20; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + TASK BODY NEST1 IS + BEGIN + ACCEPT TNEST1 (X : OUT LP) DO + X := 3; + END TNEST1; + END NEST1; + + TASK BODY NEST2 IS + BEGIN + NULL; + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20.TP20; -- OK: + -- RENAMING. + END PKG1; + +BEGIN + + TEST ("C74401K", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.P20.RESET (VAR); + PKG.P20.TP20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.P20.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + PKG.P20.RESET (VAR); + PKG.NESTED.NEST1.TNEST1 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("NESTED CALL NOT CORRECT"); + END IF; + + RESULT; + +END C74401K; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74401q.ada b/gcc/testsuite/ada/acats/tests/c7/c74401q.ada new file mode 100644 index 000000000..7576721a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401q.ada @@ -0,0 +1,119 @@ +-- C74401Q.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE +-- DECLARED FOR A GENERIC SUBPROGRAM IN A PACKAGE SPECIFICATION, +-- INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE PART. + +-- JBG 5/1/85 + +WITH REPORT; USE REPORT; +PROCEDURE C74401Q IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + + GENERIC + PROCEDURE P20 (X : OUT LP); -- OK. + PROCEDURE RESET (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + GENERIC + PROCEDURE NEST1 (X : OUT LP); + PRIVATE + GENERIC + PROCEDURE NEST2 (X : OUT LP); + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + PROCEDURE P20 (X : OUT LP) IS + BEGIN + X := 3; + END P20; + + PROCEDURE RESET (X : OUT LP) IS + BEGIN + X := 0; + END RESET; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + PROCEDURE NEST1 (X : OUT LP) IS + BEGIN + X := 3; + END NEST1; + + PROCEDURE NEST2 (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(3)); + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE INSTANCES IS + PROCEDURE NP20 IS NEW PKG.P20; + PROCEDURE NNEST1 IS NEW PKG.NESTED.NEST1; + END INSTANCES; + USE INSTANCES; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES INSTANCES.NP20; + END PKG1; + +BEGIN + + TEST ("C74401Q", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.RESET (VAR); + NP20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + RESULT; + +END C74401Q; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74402a.ada b/gcc/testsuite/ada/acats/tests/c7/c74402a.ada new file mode 100644 index 000000000..3dac5c75a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74402a.ada @@ -0,0 +1,154 @@ +-- C74402A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED TYPE MAY HAVE A +-- DEFAULT EXPRESSION, EVEN IF THE SUBPROGRAM IS DECLARED OUTSIDE +-- THE PACKAGE THAT DECLARES THE LIMITED TYPE. +-- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.) + +-- DSJ 5/6/83 +-- SPS 10/24/83 + +WITH REPORT; +PROCEDURE C74402A IS + + USE REPORT; + +BEGIN + + TEST("C74402A", "CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED " & + "TYPE MAY HAVE A DEFAULT EXPRESSION, EVEN IF " & + "THE SUBPROGRAM IS DECLARED OUTSIDE THE PACKAGE " & + "THAT DECLARES THE LIMITED TYPE"); + + DECLARE + + PACKAGE PACK1 IS + + TYPE LP1 IS LIMITED PRIVATE; + TYPE LP2 IS ARRAY (1 .. 2) OF LP1; + TYPE LP3 IS + RECORD + C1, C2 : LP2; + END RECORD; + + FUNCTION F1 RETURN LP1; + FUNCTION F2 RETURN LP2; + FUNCTION F3 RETURN LP3; + + PROCEDURE G1 (X : LP1 := F1); -- LEGAL + PROCEDURE G2 (X : LP2 := F2); -- LEGAL + PROCEDURE G3 (X : LP3 := F3); -- LEGAL + + PRIVATE + + TYPE LP1 IS NEW INTEGER; + + END PACK1; + + PACKAGE BODY PACK1 IS + + FUNCTION F1 RETURN LP1 IS + BEGIN + RETURN LP1'(1); + END F1; + + FUNCTION F2 RETURN LP2 IS + BEGIN + RETURN LP2'(2,3); + END F2; + + FUNCTION F3 RETURN LP3 IS + BEGIN + RETURN LP3'((4,5),(6,7)); + END F3; + + PROCEDURE G1 (X : LP1 := F1) IS + BEGIN + IF X /= LP1'(1) THEN + FAILED("WRONG DEFAULT VALUE - LP1"); + END IF; + END G1; + + PROCEDURE G2 (X : LP2 := F2) IS + BEGIN + IF X /= LP2'(2,3) THEN + FAILED("WRONG DEFAULT VALUE - LP2"); + END IF; + END G2; + + PROCEDURE G3 (X : LP3 := F3) IS + BEGIN + IF X /= LP3'((4,5),(6,7)) THEN + FAILED("WRONG DEFAULT VALUE - LP3"); + END IF; + END G3; + + BEGIN + + G1; -- LEGAL, DEFAULT USED + G2; -- LEGAL, DEFAULT USED + G3; -- LEGAL, DEFAULT USED + + G1(F1); -- LEGAL + G2(F2); -- LEGAL + G3(F3); -- LEGAL + + END PACK1; + + USE PACK1; + + PROCEDURE G4 (X : LP1 := F1) IS + BEGIN + G1; -- LEGAL, DEFAULT USED + G1(X); + END G4; + + PROCEDURE G5 (X : LP2 := F2) IS + BEGIN + G2; -- LEGAL, DEFAULT USED + G2(X); + END G5; + + PROCEDURE G6 (X : LP3 := F3) IS + BEGIN + G3; -- DEFAULT USED + G3(X); + END G6; + + BEGIN + + G4; -- LEGAL, DEFAULT USED + G5; -- LEGAL, DEFAULT USED + G6; -- LEGAL, DEFAULT USED + + G4(F1); -- LEGAL + G5(F2); -- LEGAL + G6(F3); -- LEGAL + + END; + + RESULT; + +END C74402A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74402b.ada b/gcc/testsuite/ada/acats/tests/c7/c74402b.ada new file mode 100644 index 000000000..45597a908 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74402b.ada @@ -0,0 +1,103 @@ +-- C74402B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT INITIALIZATION OF IN PARAMETERS THAT ARE OF +-- LIMITED PRIVATE TYPE IS PERMITTED. +-- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.) + +-- DAS 1/21/81 +-- ABW 6/30/82 +-- BHS 7/10/84 + +WITH REPORT; +PROCEDURE C74402B IS + + USE REPORT; + +BEGIN + + TEST( "C74402B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " & + "OF LIMITED PRIVATE TYPE IS PERMITTED" ); + + DECLARE + + PACKAGE PKG IS + + TYPE LPTYPE IS LIMITED PRIVATE; + CLP : CONSTANT LPTYPE; + XLP : CONSTANT LPTYPE; + FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN; + FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN; + + PRIVATE + + TYPE LPTYPE IS NEW INTEGER RANGE 0..127; + CLP : CONSTANT LPTYPE := 127; + XLP : CONSTANT LPTYPE := 0; + + END; + + PACKAGE BODY PKG IS + + FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN IS + BEGIN + RETURN (L = CLP); + END EQCLP; + + FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN IS + BEGIN + RETURN (L = XLP); + END EQXLP; + + END PKG; + + USE PKG; + + PROCEDURE PROC1 (Y : IN LPTYPE := CLP) IS + BEGIN + IF (EQCLP (Y)) THEN + FAILED( "LIMITED PRIVATE NOT PASSED, " & + "DEFAULT CLP EMPLOYED" ); + ELSIF (NOT EQXLP (Y)) THEN + FAILED( "NO LIMITED PRIVATE FOUND" ); + END IF; + END PROC1; + + PROCEDURE PROC2 (Y : IN LPTYPE := CLP) IS + BEGIN + IF (NOT EQCLP(Y)) THEN + FAILED( "DEFAULT NOT EMPLOYED" ); + END IF; + END PROC2; + + BEGIN + + PROC1(XLP); + PROC2; + + END; + + RESULT; + +END C74402B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74406a.ada b/gcc/testsuite/ada/acats/tests/c7/c74406a.ada new file mode 100644 index 000000000..69ddd41b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74406a.ada @@ -0,0 +1,130 @@ +-- C74406A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE FULL DECLARATION OF A LIMITED PRIVATE TYPE CAN +-- DECLARE A TASK TYPE, A TYPE DERIVED FROM A LIMITED PRIVATE TYPE, +-- AND A COMPOSITE TYPE WITH A COMPONENT OF A LIMITED TYPE. + +-- HISTORY: +-- BCB 03/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74406A IS + + PACKAGE TP IS + TYPE T IS LIMITED PRIVATE; + PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER); + FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN; + PRIVATE + TYPE T IS RANGE 1 .. 100; + END TP; + + PACKAGE BODY TP IS + PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER) IS + BEGIN + Z1 := T (Z2); + END INIT; + + FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END EQUAL_T; + BEGIN + NULL; + END TP; + + USE TP; + + PACKAGE P IS + TYPE T1 IS LIMITED PRIVATE; + TYPE T2 IS LIMITED PRIVATE; + TYPE T3 IS LIMITED PRIVATE; + TYPE T4 IS LIMITED PRIVATE; + PRIVATE + TASK TYPE T1 IS + ENTRY HERE(VAL1 : IN OUT INTEGER); + END T1; + + TYPE T2 IS NEW T; + + TYPE T3 IS RECORD + INT : T; + END RECORD; + + TYPE T4 IS ARRAY(1..5) OF T; + END P; + + PACKAGE BODY P IS + X1 : T1; + X3 : T3; + X4 : T4; + VAR : INTEGER := 25; + + TASK BODY T1 IS + BEGIN + ACCEPT HERE(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 2; + END HERE; + END T1; + + BEGIN + TEST ("C74406A", "CHECK THAT THE FULL DECLARATION OF A " & + "LIMITED PRIVATE TYPE CAN DECLARE A TASK " & + "TYPE, A TYPE DERIVED FROM A LIMITED " & + "PRIVATE TYPE, AND A COMPOSITE TYPE WITH " & + "A COMPONENT OF A LIMITED TYPE"); + + X1.HERE(VAR); + + IF NOT EQUAL(VAR,IDENT_INT(50)) THEN + FAILED ("IMPROPER VALUE FOR VAL"); + END IF; + + INIT (X3.INT, 50); + + IF X3.INT NOT IN T THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + INIT (X4(3), 17); + + IF NOT EQUAL_T(T'(X4(3)),T(X4(3))) THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION AND " & + "EXPLICIT CONVERSION"); + END IF; + + RESULT; + END P; + + USE P; + +BEGIN + NULL; +END C74406A; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74407b.ada b/gcc/testsuite/ada/acats/tests/c7/c74407b.ada new file mode 100644 index 000000000..d8f65084c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74407b.ada @@ -0,0 +1,195 @@ +-- C74407B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK, FOR A LIMITED PRIVATE TYPE, THAT PRE-DEFINED EQUALITY AND +-- ASSIGNMENT ARE DEFINED AND AVAILABLE WITHIN THE PRIVATE PART AND +-- THE BODY OF A PACKAGE, AFTER THE FULL DECLARATION, IF THE FULL +-- DECLARATION IS NOT LIMITED. + +-- HISTORY: +-- BCB 07/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C74407B IS + + PACKAGE PP IS + TYPE PRIV IS PRIVATE; + C1 : CONSTANT PRIV; + C2 : CONSTANT PRIV; + PRIVATE + TYPE PRIV IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + C1 : CONSTANT PRIV := ONE; + C2 : CONSTANT PRIV := TWO; + END PP; + + USE PP; + + PACKAGE P IS + TYPE INT IS LIMITED PRIVATE; + TYPE COMP IS LIMITED PRIVATE; + TYPE DER IS LIMITED PRIVATE; + PRIVATE + TYPE INT IS RANGE 1 .. 100; + TYPE COMP IS ARRAY(1..5) OF INTEGER; + TYPE DER IS NEW PRIV; + D, E : INT := 10; + F : INT := 20; + CONS_INT1 : CONSTANT INT := 30; + G : BOOLEAN := D = E; + H : BOOLEAN := D /= F; + CONS_BOOL1 : CONSTANT BOOLEAN := D = E; + CONS_BOOL2 : CONSTANT BOOLEAN := D /= F; + I : COMP := (1,2,3,4,5); + CONS_COMP1 : CONSTANT COMP := (6,7,8,9,10); + J : DER := DER(C1); + CONS_DER1 : CONSTANT DER := DER(C2); + END P; + + PACKAGE BODY P IS + A, B, C : INT; + X, Y, Z : COMP; + L, M, N : DER; + CONS_INT2 : CONSTANT INT := 10; + CONS_COMP2 : CONSTANT COMP := (1,2,3,4,5); + CONS_DER2 : CONSTANT DER := DER(C1); + BEGIN + TEST ("C74407B", "CHECK, FOR A LIMITED PRIVATE TYPE, THAT " & + "PRE-DEFINED EQUALITY AND ASSIGNMENT ARE " & + "DEFINED AND AVAILABLE WITHIN THE PRIVATE " & + "PART AND THE BODY OF A PACKAGE, AFTER " & + "THE FULL DECLARATION, IF THE FULL " & + "DECLARATION IS NOT LIMITED"); + + A := 10; + + B := 10; + + C := 20; + + IF A = C THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 1"); + END IF; + + IF A /= B THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 1"); + END IF; + + IF CONS_INT2 = C THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 2"); + END IF; + + IF CONS_INT2 /= B THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 2"); + END IF; + + IF NOT G THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 1"); + END IF; + + IF NOT H THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 1"); + END IF; + + IF NOT CONS_BOOL1 THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 2"); + END IF; + + IF NOT CONS_BOOL2 THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 2"); + END IF; + + X := (1,2,3,4,5); + + Y := (1,2,3,4,5); + + Z := (5,4,3,2,1); + + IF X = Z THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 3"); + END IF; + + IF X /= Y THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 3"); + END IF; + + IF CONS_COMP2 = Z THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 4"); + END IF; + + IF CONS_COMP2 /= Y THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 4"); + END IF; + + L := DER(C1); + + M := DER(C1); + + N := DER(C2); + + IF L = N THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 5"); + END IF; + + IF L /= M THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 5"); + END IF; + + IF CONS_DER2 = N THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 6"); + END IF; + + IF CONS_DER2 /= M THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 6"); + END IF; + + RESULT; + END P; + + USE P; + +BEGIN + NULL; +END C74407B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c74409b.ada b/gcc/testsuite/ada/acats/tests/c7/c74409b.ada new file mode 100644 index 000000000..0bd2a065b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74409b.ada @@ -0,0 +1,93 @@ +-- C74409B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE SAME PACKAGE +-- AS A LIMITED PRIVATE TYPE AND HAS A COMPONENT OF THAT TYPE, +-- THE COMPOSITE TYPE IS TREATED AS A LIMITED TYPE UNTIL THE +-- EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION +-- OF THE COMPOSITE TYPE AND AFTER THE FULL DECLARATION OF THE +-- LIMITED PRIVATE TYPE + +-- DSJ 5/5/83 +-- JBG 9/23/83 + +WITH REPORT; +PROCEDURE C74409B IS + + USE REPORT; + +BEGIN + + TEST("C74409B", "CHECK THAT A COMPOSITE TYPE WITH A LIMITED " & + "PRIVATE COMPONENT IS TREATED AS A LIMITED " & + "TYPE UNTIL ASSIGNMENT AND EQUALITY ARE BOTH " & + "AVAILABLE FOR THE COMPOSITE TYPE"); + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PACKAGE Q IS + TYPE LP_ARRAY IS ARRAY (1 .. 2) OF LP; + END Q; + PRIVATE + TYPE LP IS NEW INTEGER; + END P; + + PACKAGE BODY P IS + USE Q; + FUNCTION "=" (L,R : LP_ARRAY) RETURN BOOLEAN IS -- LEGAL + BEGIN + RETURN TRUE; + END; + + GENERIC + TYPE T IS PRIVATE; -- NOTE: NOT LIMITED PRIVATE + C, D : T; + PACKAGE A IS + -- IRRELEVANT DETAILS + END A; + + PACKAGE BODY A IS + BEGIN + IF C = D THEN + FAILED ("USED WRONG EQUALITY OPERATOR"); + END IF; + END A; + + PACKAGE BODY Q IS + PACKAGE ANOTHER_NEW_A IS + NEW A (LP_ARRAY, (2,3), (4,5)); -- LEGAL + END Q; + END P; + + BEGIN + + NULL; + + END; + + RESULT; + +END C74409B; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760001.a b/gcc/testsuite/ada/acats/tests/c7/c760001.a new file mode 100644 index 000000000..be9ff8194 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760001.a @@ -0,0 +1,390 @@ +-- C760001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Initialize is called for objects and components of +-- a controlled type when the objects and components are not +-- assigned explicit initial values. Check this for "simple" controlled +-- objects, controlled record components and arrays with controlled +-- components. +-- +-- Check that if an explicit initial value is assigned to an object +-- or component of a controlled type then Initialize is not called. +-- +-- TEST DESCRIPTION: +-- This test derives a type for Ada.Finalization.Controlled, and +-- overrides the Initialize and Adjust operations for the type. The +-- intent of the type is that it should carry incremental values +-- indicating the ordering of events with respect to these (and default +-- initialization) operations. The body of the test uses these values +-- to determine that the implicit calls to these subprograms happen +-- (or don't) at the appropriate times. +-- +-- The test further derives types from this "root" type, which are the +-- actual types used in the test. One of the types is "simply" derived +-- from the "root" type, the other contains a component of the first +-- type, thus nesting a controlled object as a record component in +-- controlled objects. +-- +-- The main program declares objects of these types and checks the +-- values of the components to ascertain that they have been touched +-- as expected. +-- +-- Note that Finalization procedures are provided. This test does not +-- test that the calls to Finalization are made correctly. The +-- Finalization procedures are provided to catch an implementation that +-- calls Finalization at an incorrect time. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1 +-- +--! + +---------------------------------------------------------------- C760001_0 + +with Ada.Finalization; +package C760001_0 is + subtype Unique_ID is Natural; + function Unique_Value return Unique_ID; + -- increments each time it's called + + function Most_Recent_Unique_Value return Unique_ID; + -- returns the same value as the most recent call to Unique_Value + + type Root_Controlled is new Ada.Finalization.Controlled with record + My_ID : Unique_ID := Unique_Value; + My_Init_ID : Unique_ID := Unique_ID'First; + My_Adj_ID : Unique_ID := Unique_ID'First; + end record; + + procedure Initialize( R: in out Root_Controlled ); + procedure Adjust ( R: in out Root_Controlled ); + + TC_Initialize_Calls_Is_Failing : Boolean := False; + +end C760001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760001_0 is + + Global_Unique_Counter : Unique_ID := 0; + + function Unique_Value return Unique_ID is + begin + Global_Unique_Counter := Global_Unique_Counter +1; + return Global_Unique_Counter; + end Unique_Value; + + function Most_Recent_Unique_Value return Unique_ID is + begin + return Global_Unique_Counter; + end Most_Recent_Unique_Value; + + procedure Initialize( R: in out Root_Controlled ) is + begin + if TC_Initialize_Calls_Is_Failing then + Report.Failed("Initialized incorrectly called"); + end if; + R.My_Init_ID := Unique_Value; + end Initialize; + + procedure Adjust( R: in out Root_Controlled ) is + begin + R.My_Adj_ID := Unique_Value; + end Adjust; + +end C760001_0; + +---------------------------------------------------------------- C760001_1 + +with Ada.Finalization; +with C760001_0; +package C760001_1 is + + type Proc_ID is (None, Init, Adj, Fin); + + type Test_Controlled is new C760001_0.Root_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Controlled ); + procedure Adjust ( TC: in out Test_Controlled ); + procedure Finalize ( TC: in out Test_Controlled ); + + type Nested_Controlled is new C760001_0.Root_Controlled with record + Nested : C760001_0.Root_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Controlled ); + procedure Adjust ( TC: in out Nested_Controlled ); + procedure Finalize ( TC: in out Nested_Controlled ); + +end C760001_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760001_1 is + + procedure Initialize( TC: in out Test_Controlled ) is + begin + if TC.Last_Proc_Called /= None then + Report.Failed("Initialize for Test_Controlled"); + end if; + TC.Last_Proc_Called := Init; + C760001_0.Initialize(C760001_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760001_0.Adjust(C760001_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Controlled ) is + begin + if TC.Last_Proc_Called /= None then + Report.Failed("Initialize for Nested_Controlled"); + end if; + TC.Last_Proc_Called := Init; + C760001_0.Initialize(C760001_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760001_0.Adjust(C760001_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + +end C760001_1; + +---------------------------------------------------------------- C760001 + +with Report; +with TCTouch; +with C760001_0; +with C760001_1; +with Ada.Finalization; +procedure C760001 is + + use type C760001_1.Proc_ID; + + -- in the first test, test the simple case. Check that a controlled object + -- causes a call to the procedure Initialize. + -- Also check that assignment causes a call to Adjust. + + procedure Check_Simple_Objects is + S,T : C760001_1.Test_Controlled; + begin + TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch"); + TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and + (T.Last_Proc_Called = C760001_1.Init), + "Initialize for simple object"); + S := T; + TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj), + "Adjust for simple object"); + TCTouch.Assert((S.My_ID = T.My_ID), + "Simple object My_ID's don't match"); + TCTouch.Assert((S.My_Init_ID = T.My_Init_ID), + "Simple object My_Init_ID's don't match"); + TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID), + "Simple object My_Adj_ID's in wrong order"); + end Check_Simple_Objects; + + -- in the second test, test a more complex case, check that a controlled + -- component of a controlled object gets processed correctly + + procedure Check_Nested_Objects is + NO1 : C760001_1.Nested_Controlled; + begin + TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id), + "Default value order incorrect"); + TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID), + "Initialization call order incorrect"); + end Check_Nested_Objects; + + -- check that objects assigned an initial value at declaration are Adjusted + -- and NOT Initialized + + procedure Check_Objects_With_Initial_Values is + + TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; + + A: C760001_1.Test_Controlled := + ( Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_1.None); + + B: C760001_1.Nested_Controlled := + ( Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_0.Root_Controlled(A), + C760001_1.None); + + begin + -- the implementation may or may not call Adjust for the values + -- assigned into A and B, + -- but should NOT call Initialize. + -- if the value used in the aggregate is overwritten by Initialize, + -- this indicates failure + TCTouch.Assert(A.My_Init_Id = TC_Now, + "Initialize was called for A with initial value"); + TCTouch.Assert(B.My_Init_Id = TC_Now, + "Initialize was called for B with initial value"); + TCTouch.Assert(B.Nested.My_Init_ID = TC_Now, + "Initialize was called for B.Nested initial value"); + end Check_Objects_With_Initial_Values; + + procedure Check_Array_Case is + type Array_Simple is array(1..4) of C760001_1.Test_Controlled; + type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; + + Simple_Array_Default : Array_Simple; + + Nested_Array_Default : Array_Nested; + + TC_A_Bit_Later : C760001_0.Unique_ID; + + begin + TC_A_Bit_Later := C760001_0.Unique_Value; + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called + = C760001_1.Init, + "Initialize for array initial value"); + + TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID + > C760001_0.Unique_ID'First) + and (Simple_Array_Default(N).My_Init_ID + < TC_A_Bit_Later), + "Initialize timing for simple array"); + + TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID + > C760001_0.Unique_ID'First) + and (Nested_Array_Default(N).My_Init_ID + < TC_A_Bit_Later), + "Initialize timing for container array"); + + TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called + = C760001_1.Init, + "Initialize for nested array (outer) initial value"); + + TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID + > C760001_0.Unique_ID'First) + and (Nested_Array_Default(N).Nested.My_Init_ID + < Nested_Array_Default(N).My_Init_ID), + "Initialize timing for array content"); + end loop; + end Check_Array_Case; + + procedure Check_Array_Case_With_Initial_Values is + + TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; + + type Array_Simple is array(1..4) of C760001_1.Test_Controlled; + type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; + + Simple_Array_Explicit : Array_Simple := ( 1..4 => ( + Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_1.None ) ); + + A : constant C760001_0.Root_Controlled := + ( Ada.Finalization.Controlled + with others => TC_Now); + + Nested_Array_Explicit : Array_Nested := ( 1..4 => ( + Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + A, + C760001_1.None ) ); + + begin + -- the implementation may or may not call Adjust for the values + -- assigned into Simple_Array_Explicit and Nested_Array_Explicit, + -- but should NOT call Initialize. + -- if the value used in the aggregate is overwritten by Initialize, + -- this indicates failure + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID + = TC_Now, + "Initialize was called for array with initial value"); + TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID + = TC_Now, + "Initialize was called for nested array (outer) with initial value"); + TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now, + "Initialize was called for nested array (inner) with initial value"); + end loop; + end Check_Array_Case_With_Initial_Values; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("C760001", "Check that Initialize is called for objects " & + "and components of a controlled type when the " & + "objects and components are not assigned " & + "explicit initial values. Check that if an " & + "explicit initial value is assigned to an " & + "object or component of a controlled type " & + "then Initialize is not called" ); + + Check_Simple_Objects; + + Check_Nested_Objects; + + Check_Array_Case; + + C760001_0.TC_Initialize_Calls_Is_Failing := True; + + Check_Objects_With_Initial_Values; + + Check_Array_Case_With_Initial_Values; + + Report.Result; + +end C760001; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760002.a b/gcc/testsuite/ada/acats/tests/c7/c760002.a new file mode 100644 index 000000000..4601873be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760002.a @@ -0,0 +1,489 @@ +-- C760002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that assignment to an object of a (non-limited) controlled +-- type causes the Adjust operation of the type to be called. +-- Check that Adjust is called after copying the value of the +-- source expression to the target object. +-- +-- Check that Adjust is called for all controlled components when +-- the containing object is assigned. (Test this for the cases +-- where the type of the containing object is controlled and +-- noncontrolled; test this for initialization as well as +-- assignment statements.) +-- +-- Check that for an object of a controlled type with controlled +-- components, Adjust for each of the components is called before +-- the containing object is adjusted. +-- +-- Check that an Adjust procedure for a Limited_Controlled type is +-- not called by the implementation. +-- +-- TEST DESCRIPTION: +-- This test is loosely "derived" from C760001. +-- +-- Visit Tags: +-- D - Default value at declaration +-- d - Default value at declaration, limited root +-- I - initialize at root controlled +-- i - initialize at root limited controlled +-- A - adjust at root controlled +-- X,Y,Z,x,y,z - used in test body +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Correct test assertion logic for Sinister case +-- +--! + +---------------------------------------------------------------- C760002_0 + +with Ada.Finalization; +package C760002_0 is + subtype Unique_ID is Natural; + function Unique_Value return Unique_ID; + -- increments each time it's called + + function Most_Recent_Unique_Value return Unique_ID; + -- returns the same value as the most recent call to Unique_Value + + type Root is tagged record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; -- Default + end record; + + procedure Initialize( R: in out Root ); + procedure Adjust ( R: in out Root ); + + type Root_Controlled is new Ada.Finalization.Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; ---------------------------------------- D + end record; + + procedure Initialize( R: in out Root_Controlled ); + procedure Adjust ( R: in out Root_Controlled ); + + type Root_Limited_Controlled is + new Ada.Finalization.Limited_Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'd'; ---------------------------------------- d + end record; + + procedure Initialize( R: in out Root_Limited_Controlled ); + procedure Adjust ( R: in out Root_Limited_Controlled ); + +end C760002_0; + +with Report; +package body C760002_0 is + + Global_Unique_Counter : Unique_ID := 0; + + function Unique_Value return Unique_ID is + begin + Global_Unique_Counter := Global_Unique_Counter +1; + return Global_Unique_Counter; + end Unique_Value; + + function Most_Recent_Unique_Value return Unique_ID is + begin + return Global_Unique_Counter; + end Most_Recent_Unique_Value; + + procedure Initialize( R: in out Root ) is + begin + Report.Failed("Initialize called for Non_Controlled type"); + end Initialize; + + procedure Adjust ( R: in out Root ) is + begin + Report.Failed("Adjust called for Non_Controlled type"); + end Adjust; + + procedure Initialize( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'I'; --------------------------------------------------- I + end Initialize; + + procedure Adjust( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'A'; --------------------------------------------------- A + end Adjust; + + procedure Initialize( R: in out Root_Limited_Controlled ) is + begin + R.Visit_Tag := 'i'; --------------------------------------------------- i + end Initialize; + + procedure Adjust( R: in out Root_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Limited_Controlled type"); + end Adjust; + +end C760002_0; + +---------------------------------------------------------------- C760002_1 + +with Ada.Finalization; +with C760002_0; +package C760002_1 is + + type Proc_ID is (None, Init, Adj, Fin); + + type Test_Controlled is new C760002_0.Root_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Controlled ); + procedure Adjust ( TC: in out Test_Controlled ); + procedure Finalize ( TC: in out Test_Controlled ); + + type Nested_Controlled is new C760002_0.Root_Controlled with record + Nested : C760002_0.Root_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Controlled ); + procedure Adjust ( TC: in out Nested_Controlled ); + procedure Finalize ( TC: in out Nested_Controlled ); + + type Test_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Limited_Controlled ); + procedure Adjust ( TC: in out Test_Limited_Controlled ); + procedure Finalize ( TC: in out Test_Limited_Controlled ); + + type Nested_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Nested : C760002_0.Root_Limited_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Limited_Controlled ); + procedure Adjust ( TC: in out Nested_Limited_Controlled ); + procedure Finalize ( TC: in out Nested_Limited_Controlled ); + +end C760002_1; + +with Report; +package body C760002_1 is + + procedure Initialize( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Test_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Nested_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + +end C760002_1; + +---------------------------------------------------------------- C760002 + +with Report; +with TCTouch; +with C760002_0; +with C760002_1; +with Ada.Finalization; +procedure C760002 is + + use type C760002_1.Proc_ID; + + -- in the first test, test the simple cases. + -- Also check that assignment causes a call to Adjust for a controlled + -- object. Check that assignment of a non-controlled object does not call + -- an Adjust procedure. + + procedure Check_Simple_Objects is + + A,B : C760002_0.Root; + S,T : C760002_1.Test_Controlled; + Q : C760002_1.Test_Limited_Controlled; -- Adjust call shouldn't happen + begin + + S := T; + + TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj), + "Adjust for simple object"); + TCTouch.Assert((S.My_ID = T.My_ID), + "Assignment failed for simple object"); + + -- Check that adjust was called + TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect"); + + -- Check that Adjust has not been called + TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called"); + + -- Check that Adjust does not get called + A.My_ID := A.My_ID +1; + B := A; -- see: Adjust: Report.Failed + + end Check_Simple_Objects; + + -- in the second test, test a more complex case, check that a controlled + -- component of a controlled object gets processed correctly + + procedure Check_Nested_Objects is + NO1 : C760002_1.Nested_Controlled; + NO2 : C760002_1.Nested_Controlled := NO1; + + begin + + -- NO2 should be flagged with adjust markers + TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj), + "Adjust not called for NO2 enclosure declaration"); + TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'), + "Adjust not called for NO2 enclosed declaration"); + + NO2.Visit_Tag := 'x'; + NO2.Nested.Visit_Tag := 'y'; + + NO1 := NO2; + + -- NO1 should be flagged with adjust markers + TCTouch.Assert((NO1.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosure declaration"); + TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosed declaration"); + + end Check_Nested_Objects; + + procedure Check_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Controlled; + type Array_Nested is array(1..4) of C760002_1.Nested_Controlled; + + Left,Right : Array_Simple; + Overlap : Array_Simple := Left; + + Sinister,Dexter : Array_Nested; + Underlap : Array_Nested := Sinister; + + Now : Natural; + + begin + + -- get a current unique value since initializations + Now := C760002_0.Unique_Value; + + -- check results of declarations + for N in 1..4 loop + TCTouch.Assert(Left(N).My_Id < Now, + "Initialize for array initial value"); + TCTouch.Assert(Overlap(N).My_Id < Now, + "Adjust for nested array (outer) initial value"); + TCTouch.Assert(Sinister(N).Nested.My_Id < Now, + "Initialize for nested array (inner) initial value"); + TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id, + "Initialize for enclosure should be after enclosed"); + TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration"); + TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A', + "Adjust at declaration, nested object"); + end loop; + + -- set visit tags + for O in 1..4 loop + Overlap(O).Visit_Tag := 'X'; + Underlap(O).Visit_Tag := 'Y'; + Underlap(O).Nested.Visit_Tag := 'y'; + end loop; + + -- check that overlapping assignments don't cause odd grief + Overlap(1..3) := Overlap(2..4); + Underlap(2..4) := Underlap(1..3); + + for M in 2..3 loop + TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for overlap"); + TCTouch.Assert(Overlap(M).Visit_Tag = 'A', + "Adjust for overlap ID"); + TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for Underlap"); + TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A', + "Adjust for Underlaps nested ID"); + end loop; + + end Check_Array_Case; + + procedure Check_Access_Case is + type TC_Ref is access C760002_1.Test_Controlled; + type NC_Ref is access C760002_1.Nested_Controlled; + type TL_Ref is access C760002_1.Test_Limited_Controlled; + type NL_Ref is access C760002_1.Nested_Limited_Controlled; + + A,B : TC_Ref; + C,D : NC_Ref; + E : TL_Ref; + F : NL_Ref; + + begin + + A := new C760002_1.Test_Controlled; + B := new C760002_1.Test_Controlled'( A.all ); + + C := new C760002_1.Nested_Controlled; + D := new C760002_1.Nested_Controlled'( C.all ); + + E := new C760002_1.Test_Limited_Controlled; + F := new C760002_1.Nested_Limited_Controlled; + + TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation"); + TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value"); + + TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation"); + TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested"); + TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value"); + TCTouch.Assert(D.Nested.Visit_Tag = 'A', + "NC Allocation, Nested, with value"); + + TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation"); + TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation"); + + A.all := B.all; + C.all := D.all; + + TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment"); + TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment"); + TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested"); + + end Check_Access_Case; + + procedure Check_Access_Limited_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled; + type AS_Ref is access Array_Simple; + type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled; + type AN_Ref is access Array_Nested; + + Simple_Array_Limited : AS_Ref; + + Nested_Array_Limited : AN_Ref; + + begin + + Simple_Array_Limited := new Array_Simple; + + Nested_Array_Limited := new Array_Nested; + + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for array initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for nested array (outer) initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i', + "Initialize for nested array (inner) initial value"); + end loop; + end Check_Access_Limited_Array_Case; + +begin -- Main test procedure. + + Report.Test ("C760002", "Check that assignment causes the Adjust " & + "operation of the type to be called. Check " & + "that Adjust is called after copying the " & + "value of the source expression to the target " & + "object. Check that Adjust is called for all " & + "controlled components when the containing " & + "object is assigned. Check that Adjust is " & + "called for components before the containing " & + "object is adjusted. Check that Adjust is not " & + "called for a Limited_Controlled type by the " & + "implementation" ); + + Check_Simple_Objects; + + Check_Nested_Objects; + + Check_Array_Case; + + Check_Access_Case; + + Check_Access_Limited_Array_Case; + + Report.Result; + +end C760002; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760007.a b/gcc/testsuite/ada/acats/tests/c7/c760007.a new file mode 100644 index 000000000..c1ddfcb93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760007.a @@ -0,0 +1,247 @@ +-- C760007.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Adjust is called for the execution of a return +-- statement for a function returning a result of a (non-limited) +-- controlled type. +-- +-- Check that Adjust is called when evaluating an aggregate +-- component association for a controlled component. +-- +-- Check that Adjust is called for the assignment of the ancestor +-- expression of an extension aggregate when the type of the +-- aggregate is controlled. +-- +-- TEST DESCRIPTION: +-- A type is derived from Ada.Finalization.Controlled; the dispatching +-- procedure Adjust is defined for the new type. Structures and +-- subprograms to model the test objectives are used to check that +-- Adjust is called at the right time. For the sake of simplicity, +-- globally accessible data is used to check that the calls are made. +-- +-- +-- CHANGE HISTORY: +-- 06 DEC 94 SAIC ACVC 2.0 +-- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1 +-- 05 APR 96 SAIC Add RM reference +-- 06 NOV 96 SAIC Reduce adjust requirement +-- 25 NOV 97 EDS Allowed zero calls to adjust at line 144 +--! + +---------------------------------------------------------------- C760007_0 + +with Ada.Finalization; +package C760007_0 is + + type Controlled is new Ada.Finalization.Controlled with record + TC_ID : Natural := Natural'Last; + end record; + procedure Adjust( Object: in out Controlled ); + + type Structure is record + Controlled_Component : Controlled; + end record; + + type Child is new Controlled with record + TC_XX : Natural := Natural'Last; + end record; + procedure Adjust( Object: in out Child ); + + Adjust_Count : Natural := 0; + Child_Adjust_Count : Natural := 0; + +end C760007_0; + +package body C760007_0 is + + procedure Adjust( Object: in out Controlled ) is + begin + Adjust_Count := Adjust_Count +1; + end Adjust; + + procedure Adjust( Object: in out Child ) is + begin + Child_Adjust_Count := Child_Adjust_Count +1; + end Adjust; + +end C760007_0; + +------------------------------------------------------------------ C760007 + +with Report; +with C760007_0; +procedure C760007 is + + procedure Check_Adjust_Count(Message: String; + Min: Natural := 1; + Max: Natural := 2) is + begin + + -- in order to allow for the anonymous objects referred to in + -- the reference manual, the check for calls to Adjust must be + -- in a range. This number must then be further adjusted + -- to allow for the optimization that does not call for an adjust + -- of an aggregate initial value built directly in the object + + if C760007_0.Adjust_Count not in Min..Max then + Report.Failed(Message + & " = " & Natural'Image(C760007_0.Adjust_Count)); + end if; + C760007_0.Adjust_Count := 0; + end Check_Adjust_Count; + + procedure Check_Child_Adjust_Count(Message: String; + Min: Natural := 1; + Max: Natural := 2) is + begin + -- ditto above + + if C760007_0.Child_Adjust_Count not in Min..Max then + Report.Failed(Message + & " = " & Natural'Image(C760007_0.Child_Adjust_Count)); + end if; + C760007_0.Child_Adjust_Count := 0; + end Check_Child_Adjust_Count; + + Object : C760007_0.Controlled; + +-- Check that Adjust is called for the execution of a return +-- statement for a function returning a result of a (non-limited) +-- controlled type or a result of a noncontrolled type with +-- controlled components. + + procedure Subtest_1 is + function Create return C760007_0.Controlled is + New_Object : C760007_0.Controlled; + begin + return New_Object; + end Create; + + procedure Examine( Thing : in C760007_0.Controlled ) is + begin + Check_Adjust_Count("Function call passed as parameter",0); + end Examine; + + begin + -- this assignment must call Adjust: + -- 1: on the value resulting from the function + -- ** unless this is optimized out by building the result directly + -- in the target object. + -- 2: on Object once it's been assigned + -- may call adjust + -- 1: for a anonymous object created in the evaluation of the function + -- 2: for a anonymous object created in the assignment operation + + Object := Create; + + Check_Adjust_Count("Function call",1,4); + + Examine( Create ); + + end Subtest_1; + +-- Check that Adjust is called when evaluating an aggregate +-- component association for a controlled component. + + procedure Subtest_2 is + S : C760007_0.Structure; + + procedure Examine( Thing : in C760007_0.Structure ) is + begin + Check_Adjust_Count("Aggregate passed as parameter"); + end Examine; + + begin + -- this assignment must call Adjust: + -- 1: on the value resulting from the aggregate + -- ** unless this is optimized out by building the result directly + -- in the target object. + -- 2: on Object once it's been assigned + -- may call adjust + -- 1: for a anonymous object created in the evaluation of the aggregate + -- 2: for a anonymous object created in the assignment operation + S := ( Controlled_Component => Object ); + Check_Adjust_Count("Aggregate and Assignment", 1, 4); + + Examine( C760007_0.Structure'(Controlled_Component => Object) ); + end Subtest_2; + +-- Check that Adjust is called for the assignment of the ancestor +-- expression of an extension aggregate when the type of the +-- aggregate is controlled. + + procedure Subtest_3 is + Bambino : C760007_0.Child; + + procedure Examine( Thing : in C760007_0.Child ) is + begin + Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2); + Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4); + end Examine; + + begin + -- implementation permissions make all of the following calls to adjust + -- optional: + -- these assignments may call Adjust: + -- 1: on the value resulting from the aggregate + -- 2: on Object once it's been assigned + -- 3: for a anonymous object created in the evaluation of the aggregate + -- 4: for a anonymous object created in the assignment operation + Bambino := ( Object with TC_XX => 10 ); + Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2); + Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 ); + + Bambino := ( C760007_0.Controlled with TC_XX => 11 ); + Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2); + Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 ); + + Examine( ( Object with TC_XX => 21 ) ); + + Examine( ( C760007_0.Controlled with TC_XX => 37 ) ); + + end Subtest_3; + +begin -- Main test procedure. + + Report.Test ("C760007", "Check that Adjust is called for the " & + "execution of a return statement for a " & + "function returning a result containing a " & + "controlled type. Check that Adjust is " & + "called when evaluating an aggregate " & + "component association for a controlled " & + "component. " & + "Check that Adjust is called for the " & + "assignment of the ancestor expression of an " & + "extension aggregate when the type of the " & + "aggregate is controlled" ); + + Subtest_1; + Subtest_2; + Subtest_3; + + Report.Result; + +end C760007; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760009.a b/gcc/testsuite/ada/acats/tests/c7/c760009.a new file mode 100644 index 000000000..8c3b80b36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760009.a @@ -0,0 +1,533 @@ +-- C760009.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that for an extension_aggregate whose ancestor_part is a +-- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) ) +-- Initialize is called on all controlled subcomponents of the +-- ancestor part; if the type of the ancestor part is itself controlled, +-- the Initialize procedure of the ancestor type is called, unless that +-- Initialize procedure is abstract. +-- +-- Check that the utilization of a controlled type for a generic actual +-- parameter supports the correct behavior in the instantiated package. +-- +-- TEST DESCRIPTION: +-- Declares a generic package instantiated to check that controlled +-- types are not impacted by the "generic boundary." +-- This instance is then used to perform the tests of various +-- aggregate formations of the controlled type. After each operation +-- in the main program that should cause implicit calls, the "state" of +-- the software is checked. The "state" of the software is maintained in +-- several variables which count the calls to the Initialize, Adjust and +-- Finalize procedures in each context. Given the nature of the +-- language rules, the test specifies a minimum number of times that +-- these subprograms should have been called. The test also checks cases +-- where the subprograms should not have been called. +-- +-- As per the example in AARM 7.6(11a..d);6.0, the distinctions between +-- the presence/absence of default values is tested. +-- +-- DATA STRUCTURES +-- +-- C760009_3.Master_Control is derived from +-- C760009_2.Control is derived from +-- Ada.Finalization.Controlled +-- +-- C760009_1.Simple_Control is derived from +-- Ada.Finalization.Controlled +-- +-- C760009_3.Master_Control contains +-- Standard.Integer +-- +-- C760009_2.Control contains +-- C760009_1.Simple_Control (default value) +-- C760009_1.Simple_Control (default initialized) +-- +-- +-- CHANGE HISTORY: +-- 01 MAY 95 SAIC Initial version +-- 19 FEB 96 SAIC Fixed elaboration Initialize count +-- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations +-- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129 +-- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0 +-- to avoid possible instantiation error +--! + +---------------------------------------------------------------- C760009_0 + +with Ada.Finalization; +generic + + type Private_Formal is private; + + with procedure TC_Validate( APF: in out Private_Formal ); + +package C760009_0 is -- Check_1 + + pragma Elaborate_Body; + procedure TC_Check_1( APF: in Private_Formal ); + procedure TC_Check_2( APF: out Private_Formal ); + procedure TC_Check_3( APF: in out Private_Formal ); + +end C760009_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760009_0 is -- Check_1 + + procedure TC_Check_1( APF: in Private_Formal ) is + Local : Private_Formal; + begin + Local := APF; + TC_Validate( Local ); + end TC_Check_1; + + procedure TC_Check_2( APF: out Private_Formal ) is + Local : Private_Formal; -- initialized by virtue of actual being + -- Controlled + begin + APF := Local; + TC_Validate( APF ); + end TC_Check_2; + + procedure TC_Check_3( APF: in out Private_Formal ) is + Local : Private_Formal; + begin + Local := APF; + TC_Validate( Local ); + end TC_Check_3; + +end C760009_0; + +---------------------------------------------------------------- C760009_1 + +with Ada.Finalization; +package C760009_1 is + + Initialize_Called : Natural := 0; + Adjust_Called : Natural := 0; + Finalize_Called : Natural := 0; + + procedure Reset_Counters; + + type Simple_Control is new Ada.Finalization.Controlled with private; + + procedure Initialize( AV: in out Simple_Control ); + procedure Adjust ( AV: in out Simple_Control ); + procedure Finalize ( AV: in out Simple_Control ); + procedure Validate ( AV: in out Simple_Control ); + + function Item( AV: Simple_Control'Class ) return String; + + Empty : constant Simple_Control; + + procedure TC_Trace( Message: String ); + +private + type Simple_Control is new Ada.Finalization.Controlled with record + Item: Natural; + end record; + + Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 ); + +end C760009_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760009_1 is + + -- Maintenance_Mode and TC_Trace are for the test writers and compiler + -- developers to get more information from this test as it executes. + -- Maintenance_Mode is always False for validation purposes. + + Maintenance_Mode : constant Boolean := False; + + procedure TC_Trace( Message: String ) is + begin + if Maintenance_Mode then + Report.Comment( Message ); + end if; + end TC_Trace; + + procedure Reset_Counters is + begin + Initialize_Called := 0; + Adjust_Called := 0; + Finalize_Called := 0; + end Reset_Counters; + + Master_Count : Natural := 100; -- Help distinguish values + + procedure Initialize( AV: in out Simple_Control ) is + begin + Initialize_Called := Initialize_Called +1; + AV.Item := Master_Count; + Master_Count := Master_Count +100; + TC_Trace( "Initialize _1.Simple_Control" ); + end Initialize; + + procedure Adjust ( AV: in out Simple_Control ) is + begin + Adjust_Called := Adjust_Called +1; + AV.Item := AV.Item +1; + TC_Trace( "Adjust _1.Simple_Control" ); + end Adjust; + + procedure Finalize ( AV: in out Simple_Control ) is + begin + Finalize_Called := Finalize_Called +1; + AV.Item := AV.Item +1; + TC_Trace( "Finalize _1.Simple_Control" ); + end Finalize; + + procedure Validate ( AV: in out Simple_Control ) is + begin + Report.Failed("Attempt to Validate at Simple_Control level"); + end Validate; + + function Item( AV: Simple_Control'Class ) return String is + begin + return Natural'Image(AV.Item); + end Item; + +end C760009_1; + +---------------------------------------------------------------- C760009_2 + +with C760009_1; +with Ada.Finalization; +package C760009_2 is + + type Control is new Ada.Finalization.Controlled with record + Element_1 : C760009_1.Simple_Control; + Element_2 : C760009_1.Simple_Control := C760009_1.Empty; + end record; + + procedure Initialize( AV: in out Control ); + procedure Finalize ( AV: in out Control ); + + Initialized : Natural := 0; + Finalized : Natural := 0; + +end C760009_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C760009_2 is + + procedure Initialize( AV: in out Control ) is + begin + Initialized := Initialized +1; + C760009_1.TC_Trace( "Initialize _2.Control" ); + end Initialize; + + procedure Finalize ( AV: in out Control ) is + begin + Finalized := Finalized +1; + C760009_1.TC_Trace( "Finalize _2.Control" ); + end Finalize; + +end C760009_2; + +---------------------------------------------------------------- C760009_3 + +with C760009_0; +with C760009_2; +package C760009_3 is + + type Master_Control is new C760009_2.Control with record + Data: Integer; + end record; + + procedure Initialize( AC: in out Master_Control ); + -- calls C760009_2.Initialize + -- embedded data causes 1 call to C760009_1.Initialize + + -- Adjusting operation will + -- make 1 call to C760009_2.Adjust + -- make 2 call to C760009_1.Adjust + + -- Finalize operation will + -- make 1 call to C760009_2.Finalize + -- make 2 call to C760009_1.Finalize + + procedure Validate( AC: in out Master_Control ); + + package Check_1 is + new C760009_0(Master_Control, Validate); + +end C760009_3; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with C760009_1; +package body C760009_3 is + + procedure Initialize( AC: in out Master_Control ) is + begin + AC.Data := 42; + C760009_2.Initialize(C760009_2.Control(AC)); + C760009_1.TC_Trace( "Initialize Master_Control" ); + end Initialize; + + procedure Validate( AC: in out Master_Control ) is + begin + if AC.Data not in 0..1000 then + Report.Failed("C760009_3.Control did not Initialize" ); + end if; + end Validate; + +end C760009_3; + +--------------------------------------------------------------------- C760009 + +with Report; +with C760009_1; +with C760009_2; +with C760009_3; +procedure C760009 is + + -- Comment following declaration indicates expected calls in the order: + -- Initialize of a C760009_2 value + -- Finalize of a C760009_2 value + -- Initialize of a C760009_1 value + -- Adjust of a C760009_1 value + -- Finalize of a C760009_1 value + + Global_Control : C760009_3.Master_Control; + -- 1, 0, 1, 1, 0 + + Parent_Control : C760009_2.Control; + -- 1, 0, 1, 1, 0 + + -- Global_Control is a derived tagged type, the parent type + -- of Master_Control, Control, is derived from Controlled, and contains + -- two components of a Controlled type, Simple_Control. One of these + -- components has a default value, the other does not. + + procedure Fail( Which: String; Expect, Got: Natural ) is + begin + Report.Failed(Which & " Expected" & Natural'Image(Expect) + & " got" & Natural'Image(Got) ); + end Fail; + + procedure Master_Assertion( Layer_2_Inits : Natural; + Layer_2_Finals : Natural; + Layer_1_Inits : Natural; + Layer_1_Adjs : Natural; + Layer_1_Finals : Natural; + Failing_Message : String ) is + + begin + + + + if C760009_2.Initialized /= Layer_2_Inits then + Fail("C760009_2.Initialize " & Failing_Message, + Layer_2_Inits, C760009_2.Initialized ); + end if; + + if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then + Fail("C760009_2.Finalize " & Failing_Message, + Layer_2_Finals, C760009_2.Finalized ); + end if; + + if C760009_1.Initialize_Called /= Layer_1_Inits then + Fail("C760009_1.Initialize " & Failing_Message, + Layer_1_Inits, + C760009_1.Initialize_Called ); + end if; + + if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then + Fail("C760009_1.Adjust " & Failing_Message, + Layer_1_Adjs, C760009_1.Adjust_Called ); + end if; + + if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then + Fail("C760009_1.Finalize " & Failing_Message, + Layer_1_Finals, C760009_1.Finalize_Called ); + end if; + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + end Master_Assertion; + + procedure Lesser_Assertion( Layer_2_Inits : Natural; + Layer_2_Finals : Natural; + Layer_1_Inits : Natural; + Layer_1_Adjs : Natural; + Layer_1_Finals : Natural; + Failing_Message : String ) is + begin + + + if C760009_2.Initialized > Layer_2_Inits then + Fail("C760009_2.Initialize " & Failing_Message, + Layer_2_Inits, C760009_2.Initialized ); + end if; + + if C760009_2.Finalized < Layer_2_Inits + or C760009_2.Finalized > Layer_2_Finals*2 then + Fail("C760009_2.Finalize " & Failing_Message, + Layer_2_Finals, C760009_2.Finalized ); + end if; + + if C760009_1.Initialize_Called > Layer_1_Inits then + Fail("C760009_1.Initialize " & Failing_Message, + Layer_1_Inits, + C760009_1.Initialize_Called ); + end if; + + if C760009_1.Adjust_Called > Layer_1_Adjs*2 then + Fail("C760009_1.Adjust " & Failing_Message, + Layer_1_Adjs, C760009_1.Adjust_Called ); + end if; + + if C760009_1.Finalize_Called < Layer_1_Inits + or C760009_1.Finalize_Called > Layer_1_Finals*2 then + Fail("C760009_1.Finalize " & Failing_Message, + Layer_1_Finals, C760009_1.Finalize_Called ); + end if; + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + end Lesser_Assertion; + +begin -- Main test procedure. + + Report.Test ("C760009", "Check that for an extension_aggregate whose " & + "ancestor_part is a subtype_mark, Initialize " & + "is called on all controlled subcomponents of " & + "the ancestor part. Also check that the " & + "utilization of a controlled type for a generic " & + "actual parameter supports the correct behavior " & + "in the instantiated software" ); + + C760009_1.TC_Trace( "=====> Case 0 <=====" ); + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + C760009_3.Validate( Global_Control ); -- check that it Initialized correctly + + C760009_1.TC_Trace( "=====> Case 1 <=====" ); + + C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) ); + Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" ); + -- | | | | + Finalize 2 embedded in aggregate + -- | | | | + Finalize 2 at assignment in TC_Check_1 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 caused by assignment in TC_Check_1 + -- | | | + Adjust at declaration in TC_Check_1 + -- | | + Initialize at declaration in TC_Check_1 + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- | + Finalize of aggregate object + -- + Initialize of aggregate object + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 2 <=====" ); + + C760009_3.Check_1.TC_Check_2( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" ); + -- | | | | + Finalize 2 at assignment in TC_Check_2 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 caused by assignment in TC_Check_2 + -- | | | + Adjust at declaration in TC_Check_2 + -- | | + Initialize at declaration in TC_Check_2 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 3 <=====" ); + + Global_Control := ( C760009_2.Control with Data => 2 ); + Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" ); + -- | | | | + Finalize 2 by assignment + -- | | | + Adjust 2 caused by assignment + -- | | | + Adjust in aggregate creation + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- + Initialize of aggregate object + + + C760009_1.TC_Trace( "=====> Case 4 <=====" ); + + C760009_3.Check_1.TC_Check_3( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" ); + -- | | | | + Finalize 2 at assignment in TC_Check_3 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 at assignment in TC_Check_3 + -- | | | + Adjust in local variable creation + -- | | + Initialize of local variable in TC_Check_3 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 5 <=====" ); + + Global_Control := ( Parent_Control with Data => 3 ); + Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" ); + -- | | | | + Finalize 2 by assignment + -- | | | + Adjust 2 caused by assignment + -- | | | + Adjust in aggregate creation + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- + Initialize of aggregate object + + + + C760009_1.TC_Trace( "=====> Case 6 <=====" ); + + -- perform this check a second time to make sure nothing is "remembered" + + C760009_3.Check_1.TC_Check_3( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" ); + -- | | | | + Finalize 2 at assignment in TC_Check_3 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 at assignment in TC_Check_3 + -- | | | + Adjust in local variable creation + -- | | + Initialize of local variable in TC_Check_3 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + Report.Result; + +end C760009; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760010.a b/gcc/testsuite/ada/acats/tests/c7/c760010.a new file mode 100644 index 000000000..08fe62b9f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760010.a @@ -0,0 +1,418 @@ +-- C760010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that explicit calls to Initialize, Adjust and Finalize +-- procedures that raise exceptions propagate the exception raised, +-- not Program_Error. Check this for both a user defined exception +-- and a language defined exception. Check that implicit calls to +-- initialize procedures that raise an exception propagate the +-- exception raised, not Program_Error; +-- +-- Check that the utilization of a controlled type as the actual for +-- a generic formal tagged private parameter supports the correct +-- behavior in the instantiated software. +-- +-- TEST DESCRIPTION: +-- Declares a generic package instantiated to check that controlled +-- types are not impacted by the "generic boundary." +-- This instance is then used to perform the tests of various calls to +-- the procedures. After each operation in the main program that should +-- cause implicit calls where an exception is raised, the program handles +-- Program_Error. After each explicit call, the program handles the +-- Expected_Error. Handlers for the opposite exception are provided to +-- catch the obvious failure modes. The predefined exception +-- Tasking_Error is used to be certain that some other reason has not +-- raised a predefined exception. +-- +-- +-- DATA STRUCTURES +-- +-- C760010_1.Simple_Control is derived from +-- Ada.Finalization.Controlled +-- +-- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control +-- by way of generic instantiation +-- +-- +-- CHANGE HISTORY: +-- 01 MAY 95 SAIC Initial version +-- 23 APR 96 SAIC Fix visibility problem for 2.1 +-- 14 NOV 96 SAIC Revisit for 2.1 release +-- 26 JUN 98 EDS Added pragma Elaborate_Body to +-- package C760010_0.Check_Formal_Tagged +-- to avoid possible instantiation error +--! + +---------------------------------------------------------------- C760010_0 + +package C760010_0 is + + User_Defined_Exception : exception; + + type Actions is ( No_Action, + Init_Raise_User_Defined, Init_Raise_Standard, + Adj_Raise_User_Defined, Adj_Raise_Standard, + Fin_Raise_User_Defined, Fin_Raise_Standard ); + + Action : Actions := No_Action; + + function Unique return Natural; + +end C760010_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C760010_0 is + + Value : Natural := 101; + + function Unique return Natural is + begin + Value := Value +1; + return Value; + end Unique; + +end C760010_0; + +---------------------------------------------------------------- C760010_0 +------------------------------------------------------ Check_Formal_Tagged + +generic + + type Formal_Tagged is tagged private; + +package C760010_0.Check_Formal_Tagged is + + pragma Elaborate_Body; + + type Embedded_Derived is new Formal_Tagged with record + TC_Meaningless_Value : Natural := Unique; + end record; + + procedure Initialize( ED: in out Embedded_Derived ); + procedure Adjust ( ED: in out Embedded_Derived ); + procedure Finalize ( ED: in out Embedded_Derived ); + +end C760010_0.Check_Formal_Tagged; + + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760010_0.Check_Formal_Tagged is + + + procedure Initialize( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Init_Raise_User_Defined => raise User_Defined_Exception; + when Init_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Initialize; + + procedure Adjust ( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Adj_Raise_User_Defined => raise User_Defined_Exception; + when Adj_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Adjust; + + procedure Finalize ( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Fin_Raise_User_Defined => raise User_Defined_Exception; + when Fin_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Finalize; + +end C760010_0.Check_Formal_Tagged; + +---------------------------------------------------------------- C760010_1 + +with Ada.Finalization; +package C760010_1 is + + procedure Check_Counters(Init,Adj,Fin : Natural; Message: String); + procedure Reset_Counters; + + type Simple_Control is new Ada.Finalization.Controlled with record + Item: Integer; + end record; + procedure Initialize( AV: in out Simple_Control ); + procedure Adjust ( AV: in out Simple_Control ); + procedure Finalize ( AV: in out Simple_Control ); + +end C760010_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760010_1 is + + Initialize_Called : Natural; + Adjust_Called : Natural; + Finalize_Called : Natural; + + procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is + begin + if Init /= Initialize_Called then + Report.Failed("Initialize mismatch " & Message); + end if; + if Adj /= Adjust_Called then + Report.Failed("Adjust mismatch " & Message); + end if; + if Fin /= Finalize_Called then + Report.Failed("Finalize mismatch " & Message); + end if; + end Check_Counters; + + procedure Reset_Counters is + begin + Initialize_Called := 0; + Adjust_Called := 0; + Finalize_Called := 0; + end Reset_Counters; + + procedure Initialize( AV: in out Simple_Control ) is + begin + Initialize_Called := Initialize_Called +1; + AV.Item := 0; + end Initialize; + + procedure Adjust ( AV: in out Simple_Control ) is + begin + Adjust_Called := Adjust_Called +1; + AV.Item := AV.Item +1; + end Adjust; + + procedure Finalize ( AV: in out Simple_Control ) is + begin + Finalize_Called := Finalize_Called +1; + AV.Item := AV.Item +1; + end Finalize; + +end C760010_1; + +---------------------------------------------------------------- C760010_2 + +with C760010_0.Check_Formal_Tagged; +with C760010_1; +package C760010_2 is + new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control); + +--------------------------------------------------------------------------- + +with Report; +with C760010_0; +with C760010_1; +with C760010_2; +procedure C760010 is + + use type C760010_0.Actions; + + procedure Case_Failure(Message: String) is + begin + Report.Failed(Message & " for case " + & C760010_0.Actions'Image(C760010_0.Action) ); + end Case_Failure; + + procedure Check_Implicit_Initialize is + Item : C760010_2.Embedded_Derived; -- exception here propagates to + Gadget : C760010_2.Embedded_Derived; -- caller + begin + if C760010_0.Action + in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard + then + Case_Failure("Anticipated exception at implicit init"); + end if; + begin + Item := Gadget; -- exception here handled locally + if C760010_0.Action in C760010_0.Adj_Raise_User_Defined + .. C760010_0.Fin_Raise_Standard then + Case_Failure ("Anticipated exception at assignment"); + end if; + exception + when Program_Error => + if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined + .. C760010_0.Fin_Raise_Standard then + Report.Failed("Program_Error in Check_Implicit_Initialize"); + end if; + when Tasking_Error => + Report.Failed("Tasking_Error in Check_Implicit_Initialize"); + when C760010_0.User_Defined_Exception => + Report.Failed("User_Error in Check_Implicit_Initialize"); + when others => + Report.Failed("Wrong exception Check_Implicit_Initialize"); + end; + end Check_Implicit_Initialize; + +--------------------------------------------------------------------------- + + Global_Item : C760010_2.Embedded_Derived; + +--------------------------------------------------------------------------- + + procedure Check_Explicit_Initialize is + begin + begin + C760010_2.Initialize( Global_Item ); + if C760010_0.Action + in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard + then + Case_Failure("Anticipated exception at explicit init"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Initialize"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Init_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Initialize"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Initialize"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Initialize"); + end; + end Check_Explicit_Initialize; + +--------------------------------------------------------------------------- + + procedure Check_Explicit_Adjust is + begin + begin + C760010_2.Adjust( Global_Item ); + if C760010_0.Action + in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard + then + Case_Failure("Anticipated exception at explicit Adjust"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Adjust"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Adj_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Adjust"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Adjust"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Adjust"); + end; + end Check_Explicit_Adjust; + +--------------------------------------------------------------------------- + + procedure Check_Explicit_Finalize is + begin + begin + C760010_2.Finalize( Global_Item ); + if C760010_0.Action + in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard + then + Case_Failure("Anticipated exception at explicit Finalize"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Finalize"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Fin_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Finalize"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Finalize"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Finalize"); + end; + end Check_Explicit_Finalize; + +--------------------------------------------------------------------------- + +begin -- Main test procedure. + + Report.Test ("C760010", "Check that explicit calls to finalization " & + "procedures that raise exceptions propagate " & + "the exception raised. Check the utilization " & + "of a controlled type as the actual for a " & + "generic formal tagged private parameter" ); + + for Act in C760010_0.Actions loop + C760010_1.Reset_Counters; + C760010_0.Action := Act; + + begin + Check_Implicit_Initialize; + if Act in + C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then + Case_Failure("No exception at Check_Implicit_Initialize"); + end if; + exception + when Tasking_Error => + if Act /= C760010_0.Init_Raise_Standard then + Case_Failure("Tasking_Error at Check_Implicit_Initialize"); + end if; + when C760010_0.User_Defined_Exception => + if Act /= C760010_0.Init_Raise_User_Defined then + Case_Failure("User_Error at Check_Implicit_Initialize"); + end if; + when Program_Error => + -- If finalize raises an exception, all other object are finalized + -- first and Program_Error is raised upon leaving the master scope. + -- 7.6.1:14 + if Act not in C760010_0.Fin_Raise_User_Defined.. + C760010_0.Fin_Raise_Standard then + Case_Failure("Program_Error at Check_Implicit_Initialize"); + end if; + when others => + Case_Failure("Wrong exception at Check_Implicit_Initialize"); + end; + + Check_Explicit_Initialize; + Check_Explicit_Adjust; + Check_Explicit_Finalize; + + C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act)); + + end loop; + + -- Set to No_Action to avoid exception in finalizing Global_Item + C760010_0.Action := C760010_0.No_Action; + + Report.Result; + +end C760010; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760011.a b/gcc/testsuite/ada/acats/tests/c7/c760011.a new file mode 100644 index 000000000..8df37fa3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760011.a @@ -0,0 +1,291 @@ +-- C760011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the anonymous objects of a controlled type associated with +-- function results and aggregates are finalized no later than the +-- end of the innermost enclosing declarative_item or statement. Also +-- check this for function calls and aggregates of a noncontrolled type +-- with controlled components. +-- +-- TEST DESCRIPTION: +-- This test defines a controlled type with a discriminant, the +-- discriminant is use as an index into a global table to indicate that +-- the object has been finalized. The controlled type is used as the +-- component of a non-controlled type, and the non-controlled type is +-- used for the same set of tests. Following is a table of the tests +-- performed and their associated tag character. +-- +-- 7.6(21) allows for the optimizations that remove these temporary +-- objects from ever existing. As such this test checks that in the +-- case the object was initialized (the only access we have to +-- determining if it ever existed) it must subsequently be finalized. +-- +-- CASE TABLE: +-- A - aggregate test, controlled +-- B - aggregate test, controlled +-- C - aggregate test, non_controlled +-- D - function test, controlled +-- E - function test, non_controlled +-- F - formal parameter function test, controlled +-- G - formal parameter aggregate test, controlled +-- H - formal parameter function test, non_controlled +-- I - formal parameter aggregate test, non_controlled +-- +-- X - scratch object, not consequential to the objective +-- Y - scratch object, not consequential to the objective +-- Z - scratch object, not consequential to the objective +-- +-- +-- CHANGE HISTORY: +-- 22 MAY 95 SAIC Initial version +-- 24 APR 96 SAIC Minor doc fixes, visibility patch +-- 14 NOV 96 SAIC Revised for release 2.1 +-- +--! + +------------------------------------------------------------------- C760011_0 + +with Ada.Finalization; +package C760011_0 is + type Tracking_Array is array(Character range 'A'..'Z') of Boolean; + + Initialized : Tracking_Array := (others => False); + Finalized : Tracking_Array := (others => False); + + type Controlled_Type(Tag : Character) is + new Ada.Finalization.Controlled with record + TC_Component : String(1..4) := "ACVC"; + end record; + procedure Initialize( It: in out Controlled_Type ); + procedure Finalize ( It: in out Controlled_Type ); + function Create(With_Tag: Character) return Controlled_Type; + + type Non_Controlled(Tag : Character := 'Y') is record + Controlled_Component : Controlled_Type(Tag); + end record; + procedure Initialize( It: in out Non_Controlled ); + procedure Finalize ( It: in out Non_Controlled ); + function Create(With_Tag: Character) return Non_Controlled; + + Under_Debug : constant Boolean := False; -- construction lines + +end C760011_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C760011_0 is + + procedure Initialize( It: in out Controlled_Type ) is + begin + It.TC_Component := (others => It.Tag); + if It.Tag in Tracking_Array'Range then + Initialized(It.Tag) := True; + end if; + if Under_Debug then + Report.Comment("Initializing Tag: " & It.Tag ); + end if; + end Initialize; + + procedure Finalize( It: in out Controlled_Type ) is + begin + if Under_Debug then + Report.Comment("Finalizing for Tag: " & It.Tag ); + end if; + if It.Tag in Finalized'Range then + Finalized(It.Tag) := True; + end if; + end Finalize; + + function Create(With_Tag: Character) return Controlled_Type is + begin + return Controlled_Type'(Ada.Finalization.Controlled + with Tag => With_Tag, + TC_Component => "*CON" ); + end Create; + + procedure Initialize( It: in out Non_Controlled ) is + begin + Report.Failed("Called Initialize for Non_Controlled"); + end Initialize; + + procedure Finalize( It: in out Non_Controlled ) is + begin + Report.Failed("Called Finalize for Non_Controlled"); + end Finalize; + + function Create(With_Tag: Character) return Non_Controlled is + begin + return Non_Controlled'(Tag => With_Tag, Controlled_Component => ( + Ada.Finalization.Controlled + with Tag => With_Tag, + TC_Component => "#NON" ) ); + end Create; + +end C760011_0; + +--------------------------------------------------------------------- C760011 + +with Report; +with TCTouch; +with C760011_0; +with Ada.Finalization; -- needed to be able to create extension aggregates +procedure C760011 is + + use type C760011_0.Controlled_Type; + use type C760011_0.Controlled_Type'Class; + use type C760011_0.Non_Controlled; + + subtype AFC is Ada.Finalization.Controlled; + + procedure Check_Result( Tag : Character; Message : String ) is + -- make allowance for 7.6(21) optimizations + begin + if C760011_0.Initialized(Tag) then + TCTouch.Assert(C760011_0.Finalized(Tag),Message); + elsif C760011_0.Under_Debug then + Report.Comment("Optimized away: " & Tag ); + end if; + end Check_Result; + + procedure Subtest_1 is + + + procedure Subtest_1_Local_1 is + An_Object : C760011_0.Controlled_Type'Class + := C760011_0.Controlled_Type'(AFC with 'X', "ONE*"); + -- initialize An_Object + begin + if C760011_0.Controlled_Type(An_Object) + = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then + Report.Failed("Comparison bad"); -- A = X !!! + end if; + end Subtest_1_Local_1; + -- An_Object must be Finalized by this point. + + procedure Subtest_1_Local_2 is + An_Object : C760011_0.Controlled_Type('B'); + begin + An_Object := (AFC with 'B', "TWO!" ); + if Report.Ident_Char(An_Object.Tag) /= 'B' then + Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!"); + end if; + exception + when others => Report.Failed("Bad controlled assignment"); + end Subtest_1_Local_2; + -- An_Object must be Finalized by this point. + + procedure Subtest_1_Local_3 is + An_Object : C760011_0.Non_Controlled('C'); + begin + TCTouch.Assert_Not(C760011_0.Finalized('C'), + "Non_Controlled declaration C"); + An_Object := C760011_0.Non_Controlled'('C', Controlled_Component + => (AFC with 'C', "TEE!")); + if Report.Ident_Char(An_Object.Tag) /= 'C' then + Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!"); + end if; + end Subtest_1_Local_3; + -- Only controlled components of An_Object must be finalized; it is an + -- error to call Finalize for An_Object + + begin + Subtest_1_Local_1; + Check_Result( 'A', "Aggregate in subprogram 1" ); + + Subtest_1_Local_2; + Check_Result( 'B', "Aggregate in subprogram 2" ); + + Subtest_1_Local_3; + Check_Result( 'C', "Embedded aggregate in subprogram 3" ); + end Subtest_1; + + + procedure Subtest_2 is + -- using 'Z' for both evades order issues + Con_Object : C760011_0.Controlled_Type('Z'); + Non_Object : C760011_0.Non_Controlled('Z'); + begin + if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then + Report.Failed("Con_Object catastrophe"); + end if; + -- Controlled function result should be finalized by now + Check_Result( 'D', "Function Result" ); + + if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then + Report.Failed("Non_Object catastrophe"); + end if; + -- Controlled component of function result should be finalized by now + Check_Result( 'E', "Function Result" ); + end Subtest_2; + + + procedure Subtest_3(Con : in C760011_0.Controlled_Type) is + begin + if Con.Tag not in 'F'..'G' then + Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' ' + & Report.Ident_Str(Con.TC_Component)); + end if; + end Subtest_3; + + + procedure Subtest_4(Non : in C760011_0.Non_Controlled) is + begin + if Non.Tag not in 'H'..'I' then + Report.Failed("Bad value passed to subtest 4 " + & Non.Tag & ' ' + & Report.Ident_Str(Non.Controlled_Component.TC_Component)); + end if; + end Subtest_4; + + +begin -- Main test procedure. + + Report.Test ("C760011", "Check that anonymous objects of controlled " & + "types or types containing controlled types " & + "are finalized no later than the end of the " & + "innermost enclosing declarative_item or " & + "statement" ); + + Subtest_1; + + Subtest_2; + + Subtest_3(C760011_0.Create('F')); + Check_Result( 'F', "Function as formal F" ); + + Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI")); + Check_Result( 'G', "Aggregate as formal G" ); + + Subtest_4(C760011_0.Create('H')); + Check_Result( 'H', "Function as formal H" ); + + Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO"))); + Check_Result( 'I', "Aggregate as formal I" ); + + Report.Result; + +end C760011; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760012.a b/gcc/testsuite/ada/acats/tests/c7/c760012.a new file mode 100644 index 000000000..08986a838 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760012.a @@ -0,0 +1,256 @@ +-- C760012.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that record components that have per-object access discriminant +-- constraints are initialized in the order of their component +-- declarations, and after any components that are not so constrained. +-- +-- Check that record components that have per-object access discriminant +-- constraints are finalized in the reverse order of their component +-- declarations, and before any components that are not so constrained. +-- +-- TEST DESCRIPTION: +-- The type List_Item is the "container" type. It holds two fields that +-- have per-object access discriminant constraints, and two fields that +-- are not discriminated. These four fields are all controlled types. +-- A fifth field is a pointer used to maintain a linked list of these +-- data objects. Each component is of a unique type which allows for +-- the test to simply track the order of initialization and finalization. +-- +-- The types and their purpose are: +-- Constrained_First - a controlled discriminated type +-- Constrained_Second - a controlled discriminated type +-- Simple_First - a controlled type with no discriminant +-- Simple_Second - a controlled type with no discriminant +-- +-- The required order of operations: +-- Initialize +-- ( Simple_First | Simple_Second ) -- no "internal order" required +-- Constrained_First +-- Constrained_Second +-- Finalize +-- Constrained_Second +-- Constrained_First +-- ( Simple_First | Simple_Second ) -- must be inverse of init. +-- +-- +-- CHANGE HISTORY: +-- 23 MAY 95 SAIC Initial version +-- 02 MAY 96 SAIC Reorganized for 2.1 +-- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check +-- 31 DEC 97 EDS Remove references to and uses of +-- Initialization_Sequence +--! + +---------------------------------------------------------------- C760012_0 + +with Ada.Finalization; +with Ada.Unchecked_Deallocation; +package C760012_0 is + + type List_Item; + + type List is access all List_Item; + + package Firsts is -- distinguish first from second + type Constrained_First(Container : access List_Item) is + new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize( T : in out Constrained_First ); + procedure Finalize ( T : in out Constrained_First ); + + type Simple_First is new Ada.Finalization.Controlled with + record + My_Init_Seq_Number : Natural; + end record; + procedure Initialize( T : in out Simple_First ); + procedure Finalize ( T : in out Simple_First ); + + end Firsts; + + type Constrained_Second(Container : access List_Item) is + new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize( T : in out Constrained_Second ); + procedure Finalize ( T : in out Constrained_Second ); + + type Simple_Second is new Ada.Finalization.Controlled with + record + My_Init_Seq_Number : Natural; + end record; + procedure Initialize( T : in out Simple_Second ); + procedure Finalize ( T : in out Simple_Second ); + + -- by 3.8(18);6.0 the following type contains components constrained + -- by per-object expressions + + + type List_Item is new Ada.Finalization.Limited_Controlled + with record + ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S + SimpleA : Firsts.Simple_First; -- A T + SimpleB : Simple_Second; -- A T + ContentB : Constrained_Second( List_Item'Access ); -- D R + Next : List; -- | | + end record; -- | | + procedure Initialize( L : in out List_Item ); ------------------+ | + procedure Finalize ( L : in out List_Item ); --------------------+ + + -- the tags are the same for SimpleA and SimpleB due to the fact that + -- the language does not specify an ordering with respect to this + -- component pair. 7.6(12) does specify the rest of the ordering. + + procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List); + +end C760012_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C760012_0 is + + package body Firsts is + + procedure Initialize( T : in out Constrained_First ) is + begin + TCTouch.Touch('C'); ----------------------------------------------- C + end Initialize; + + procedure Finalize ( T : in out Constrained_First ) is + begin + TCTouch.Touch('S'); ----------------------------------------------- S + end Finalize; + + procedure Initialize( T : in out Simple_First ) is + begin + T.My_Init_Seq_Number := 0; + TCTouch.Touch('A'); ----------------------------------------------- A + end Initialize; + + procedure Finalize ( T : in out Simple_First ) is + begin + TCTouch.Touch('T'); ----------------------------------------------- T + end Finalize; + + end Firsts; + + procedure Initialize( T : in out Constrained_Second ) is + begin + TCTouch.Touch('D'); ------------------------------------------------- D + end Initialize; + + procedure Finalize ( T : in out Constrained_Second ) is + begin + TCTouch.Touch('R'); ------------------------------------------------- R + end Finalize; + + + procedure Initialize( T : in out Simple_Second ) is + begin + T.My_Init_Seq_Number := 0; + TCTouch.Touch('A'); ------------------------------------------------- A + end Initialize; + + procedure Finalize ( T : in out Simple_Second ) is + begin + TCTouch.Touch('T'); ------------------------------------------------- T + end Finalize; + + procedure Initialize( L : in out List_Item ) is + begin + TCTouch.Touch('F'); ------------------------------------------------- F + end Initialize; + + procedure Finalize ( L : in out List_Item ) is + begin + TCTouch.Touch('Q'); ------------------------------------------------- Q + end Finalize; + +end C760012_0; + +--------------------------------------------------------------------- C760012 + +with Report; +with TCTouch; +with C760012_0; +procedure C760012 is + + use type C760012_0.List; + + procedure Subtest_1 is + -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints + -- 7.6.1(9);6.0 dictates the order of finalization of the components + + One_Of_Them : C760012_0.List_Item; + begin + if One_Of_Them.Next /= null then -- just to hold the subtest in place + Report.Failed("No default value for Next"); + end if; + end Subtest_1; + + List : C760012_0.List; + + procedure Subtest_2 is + begin + + List := new C760012_0.List_Item; + + List.Next := new C760012_0.List_Item; + + end Subtest_2; + + procedure Subtest_3 is + begin + + C760012_0.Deallocate( List.Next ); + + C760012_0.Deallocate( List ); + + end Subtest_3; + +begin -- Main test procedure. + + Report.Test ("C760012", "Check that record components that have " & + "per-object access discriminant constraints " & + "are initialized in the order of their " & + "component declarations, and after any " & + "components that are not so constrained. " & + "Check that record components that have " & + "per-object access discriminant constraints " & + "are finalized in the reverse order of their " & + "component declarations, and before any " & + "components that are not so constrained" ); + + Subtest_1; + TCTouch.Validate("AACDFQRSTT", "One object"); + + Subtest_2; + TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated"); + + Subtest_3; + TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated"); + + Report.Result; + +end C760012; diff --git a/gcc/testsuite/ada/acats/tests/c7/c760013.a b/gcc/testsuite/ada/acats/tests/c7/c760013.a new file mode 100644 index 000000000..6921bf027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760013.a @@ -0,0 +1,108 @@ +-- C760013.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Initialize is not called for default-initialized subcomponents +-- of the ancestor type of an extension aggregate. (Defect Report +-- 8652/0021, Technical Corrigendum 7.6(11/1)). +-- +-- CHANGE HISTORY: +-- 25 JAN 2001 PHL Initial version. +-- 29 JUN 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Finalization; +use Ada.Finalization; +package C760013_0 is + + type Ctrl1 is new Controlled with + record + C : Integer := 0; + end record; + type Ctrl2 is new Controlled with + record + C : Integer := 0; + end record; + + procedure Initialize (Obj1 : in out Ctrl1); + procedure Initialize (Obj2 : in out Ctrl2); + +end C760013_0; + +with Report; +use Report; +package body C760013_0 is + + procedure Initialize (Obj1 : in out Ctrl1) is + begin + Obj1.C := Ident_Int (47); + end Initialize; + + procedure Initialize (Obj2 : in out Ctrl2) is + begin + Failed ("Initialize called for type Ctrl2"); + end Initialize; + +end C760013_0; + +with Ada.Finalization; +with C760013_0; +use C760013_0; +with Report; +use Report; +procedure C760013 is + + type T is tagged + record + C1 : Ctrl1; + C2 : Ctrl2 := (Ada.Finalization.Controlled with + C => Ident_Int (23)); + end record; + + type Nt is new T with + record + C3 : Float; + end record; + + X : Nt; + +begin + Test ("C760013", + "Check that Initialize is not called for " & + "default-initialized subcomponents of the ancestor type of an " & + "extension aggregate"); + + X := (T with C3 => 5.0); + + if X.C1.C /= Ident_Int (47) then + Failed ("Initialize not called for type Ctrl1"); + end if; + if X.C2.C /= Ident_Int (23) then + Failed ("Initial value not assigned for type Ctrl2"); + end if; + + Result; +end C760013; + diff --git a/gcc/testsuite/ada/acats/tests/c7/c761001.a b/gcc/testsuite/ada/acats/tests/c7/c761001.a new file mode 100644 index 000000000..7be1ee07a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761001.a @@ -0,0 +1,117 @@ +-- C761001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that controlled objects declared immediately within a library +-- package are finalized following the completion of the environment +-- task (and prior to termination of the program). +-- +-- TEST DESCRIPTION: +-- This test derives a type from Ada.Finalization.Controlled, and +-- declares an object of that type in the body of a library package. +-- The dispatching procedure Finalize is redefined for the derived +-- type to perform a check that it has been called only once, and in +-- turn calls Report.Result. This test may fail by not calling +-- Report.Result. This test may also fail by calling Report.Result +-- twice, the first call will report a false pass. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Updated for ACVC 2.0.1 +-- +--! + +with Ada.Finalization; +package C761001_0 is + + type Global is new Ada.Finalization.Controlled with null record; + procedure Finalize( It: in out Global ); + +end C761001_0; + +package C761001_1 is + + task Library_Task is + entry Never_Called; + end Library_Task; + +end C761001_1; + +with Report; +with C761001_1; +package body C761001_0 is + + My_Object : Global; + + Done : Boolean := False; + + procedure Finalize( It: in out Global ) is + begin + if not C761001_1.Library_Task'Terminated then + Report.Failed("Library task not terminated before finalize"); + end if; + if Done then -- checking included "just in case" + Report.Comment("Test FAILED, even if previously reporting passed"); + Report.Failed("Unwarranted multiple call to finalize"); + end if; + Report.Result; + Done := True; + end Finalize; + +end C761001_0; + +with Report; +package body C761001_1 is + + task body Library_Task is + begin + if Report.Ident_Int( 1 ) /= 1 then + Report.Failed( "Baseline failure in Library_Task"); + end if; + end Library_Task; + +end C761001_1; + +with Report; +with C761001_0; + +procedure C761001 is + +begin -- Main test procedure. + + Report.Test ("C761001", "Check that controlled objects declared " + & "immediately within a library package are " + & "finalized following the completion of the " + & "environment task (and prior to termination " + & "of the program)"); + + -- note that if the test DOES call report twice, the first will report a + -- false pass, the second call will correctly fail the test. + + -- not calling Report.Result; + -- Result is called as part of the finalization of C761001_0.My_Object. + +end C761001; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761002.a b/gcc/testsuite/ada/acats/tests/c7/c761002.a new file mode 100644 index 000000000..5b807bba7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761002.a @@ -0,0 +1,245 @@ +-- C761002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that objects of a controlled type that are created +-- by an allocator are finalized at the appropriate time. In +-- particular, check that such objects are not finalized due to +-- completion of the master in which they were allocated if the +-- corresponding access type is declared outside of that master. +-- +-- Check that Unchecked_Deallocation of a controlled +-- object causes finalization of that object. +-- +-- TEST DESCRIPTION: +-- This test derives a type from Ada.Finalization.Controlled, and +-- declares access types to that type in various scope scenarios. +-- The dispatching procedure Finalize is redefined for the derived +-- type to perform a check that it has been called at the +-- correct time. This is accomplished using a global variable +-- which indicates what state the software is currently +-- executing. The test utilizes the TCTouch facilities to +-- verify that Finalize is called the correct number of times, at +-- the correct times. Several calls are made to validate passing +-- the null string to check that Finalize has NOT been called at +-- that point. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Ada.Finalization; +package C761002_0 is + type Global is new Ada.Finalization.Controlled with null record; + procedure Finalize( It: in out Global ); + + type Second is new Ada.Finalization.Limited_Controlled with null record; + procedure Finalize( It: in out Second ); +end C761002_0; + +with Report; +with TCTouch; +package body C761002_0 is + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch('F'); ------------------------------------------------- F + end Finalize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch('S'); ------------------------------------------------- S + end Finalize; +end C761002_0; + +with Report; +with TCTouch; +with C761002_0; +with Unchecked_Deallocation; +procedure C761002 is + + -- check the straightforward case + procedure Subtest_1 is + type Access_1 is access C761002_0.Global; + V1 : Access_1; + procedure Allocate is + V2 : Access_1; + begin + V2 := new C761002_0.Global; + V1 := V2; -- "dead" assignment must not be optimized away due to + -- finalization "side effects", many more of these follow + end Allocate; + begin + Allocate; + -- no calls to Finalize should have occurred at this point + TCTouch.Validate("","Allocated nested, retained"); + end Subtest_1; + + -- check Unchecked_Deallocation + procedure Subtest_2 is + type Access_2 is access C761002_0.Global; + procedure Free is + new Unchecked_Deallocation(C761002_0.Global, Access_2); + V1 : Access_2; + V2 : Access_2; + + procedure Allocate is + begin + V1 := new C761002_0.Global; + V2 := new C761002_0.Global; + end Allocate; + + begin + Allocate; + -- no calls to Finalize should have occurred at this point. + TCTouch.Validate("","Allocated nested, non-local"); + + Free(V1); -- instance of Unchecked_Deallocation + -- should cause the finalization of V1.all + TCTouch.Validate("F","Unchecked Deallocation"); + end Subtest_2; -- leaving this scope should cause the finalization of V2.all + + -- check various master-exit scenarios + -- the "Fake" parameters are used to avoid unwanted optimizations + procedure Subtest_3 is + procedure With_Local_Block is + type Access_3 is access C761002_0.Global; + V1 : Access_3; + begin + declare + V2 : Access_3 := new C761002_0.Global; + begin + V1 := V2; + end; + TCTouch.Validate("","Local Block, normal exit"); + -- the allocated object should be finalized on leaving this scope + end With_Local_Block; + + procedure With_Local_Block_Return(Fake: Integer) is + type Access_4 is access C761002_0.Global; + V1 : Access_4 := new C761002_0.Global; + begin + if Fake = 0 then + declare + V2 : Access_4; + begin + V2 := new C761002_0.Global; + return; -- the two allocated objects should be finalized + end; -- upon leaving this scope + else + V1 := null; + end if; + end With_Local_Block_Return; + + procedure With_Goto(Fake: Integer) is + type Access_5 is access C761002_0.Global; + V1 : Access_5 := new C761002_0.Global; + V2 : Access_5; + V3 : Access_5; + begin + if Fake = 0 then + declare + type Access_6 is access C761002_0.Second; + V6 : Access_6; + begin + V6 := new C761002_0.Second; + goto check; + end; + else + V2 := V1; + end if; + V3 := V2; +<<check>> + TCTouch.Validate("S","goto past master end"); + end With_Goto; + + begin + With_Local_Block; + TCTouch.Validate("F","Local Block, normal exit, after master"); + + With_Local_Block_Return( Report.Ident_Int(0) ); + TCTouch.Validate("FF","Local Block, return from block"); + + With_Goto( Report.Ident_Int(0) ); + TCTouch.Validate("F","With Goto"); + + end Subtest_3; + + procedure Subtest_4 is + + Oops : exception; + + procedure Alley( Fake: Integer ) is + type Access_1 is access C761002_0.Global; + V1 : Access_1; + begin + V1 := new C761002_0.Global; + if Fake = 1 then + raise Oops; + end if; + V1 := null; + end Alley; + + begin + Catch: begin + Alley( Report.Ident_Int(1) ); + exception + when Oops => TCTouch.Validate("F","leaving via exception"); + when others => Report.Failed("Wrong exception"); + end Catch; + end Subtest_4; + +begin -- Main test procedure. + + Report.Test ("C761002", "Check that objects of a controlled type created " + & "by an allocator are finalized appropriately. " + & "Check that Unchecked_Deallocation of a " + & "controlled object causes finalization " + & "of that object" ); + + Subtest_1; + -- leaving the scope of the access type should finalize the + -- collection + TCTouch.Validate("F","Allocated nested, Subtest 1"); + + Subtest_2; + -- Unchecked_Deallocation already finalized one of the two + -- objects allocated, the other should be the only one finalized + -- at leaving the scope of the access type. + TCTouch.Validate("F","Allocated non-local"); + + Subtest_3; + -- there should be no remaining finalizations from this subtest + TCTouch.Validate("","Localized objects"); + + Subtest_4; + -- there should be no remaining finalizations from this subtest + TCTouch.Validate("","Exception testing"); + + Report.Result; + +end C761002; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761003.a b/gcc/testsuite/ada/acats/tests/c7/c761003.a new file mode 100644 index 000000000..77051ee4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761003.a @@ -0,0 +1,447 @@ +-- C761003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an object of a controlled type is finalized when the +-- enclosing master is complete. +-- Check this for controlled types where the derived type has a +-- discriminant. +-- Check this for subprograms of abstract types derived from the +-- types in Ada.Finalization. +-- +-- Check that finalization of controlled objects is +-- performed in the correct order. In particular, check that if +-- multiple objects of controlled types are declared immediately +-- within the same declarative part then type are finalized in the +-- reverse order of their creation. +-- +-- TEST DESCRIPTION: +-- This test checks these conditions for subprograms and +-- block statements; both variables and constants of controlled +-- types; cases of a controlled component of a record type, as +-- well as an array with controlled components. +-- +-- The base controlled types used for the test are defined +-- with a character discriminant. The initialize procedure for +-- the types will record the order of creation in a globally +-- accessible array, the finalize procedure for the types will call +-- TCTouch with that tag character. The test can then check that +-- the order of finalization is indeed the reverse of the order of +-- creation (assuming that the implementation calls Initialize in +-- the order that the objects are created). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 02 Nov 95 SAIC ACVC 2.0.1 +-- +--! + +------------------------------------------------------------ C761003_Support + +package C761003_Support is + + function Pick_Char return Character; + -- successive calls to Pick_Char return distinct characters which may + -- be assigned to objects to track an order sequence. These characters + -- are then used in calls to TCTouch.Touch. + + procedure Validate(Initcount : Natural; + Testnumber : Natural; + Check_Order : Boolean := True); + -- does a little extra processing prior to calling TCTouch.Validate, + -- specifically, it reverses the stored string of characters, and checks + -- for a correct count. + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + +end C761003_Support; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body C761003_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + begin + for SI in reverse S'Range loop + T(S'Last - SI + 1) := S(SI); + end loop; + return T; + end Invert; + + procedure Validate(Initcount : Natural; + Testnumber : Natural; + Check_Order : Boolean := True) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected" + & Natural'Image(Initcount) & ", Subtest " & Number); + TCTouch.Flush; + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, Order_Meaningful => Check_Order ); + end if; + Inits_Called := 0; -- reset for the next batch + end Validate; + +end C761003_Support; + +------------------------------------------------------------------ C761003_0 + +with Ada.Finalization; +package C761003_0 is + + type Global(Tag: Character) is new Ada.Finalization.Controlled + with null record; + + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1'); + + type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled + with null record; + + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + +end C761003_0; + +------------------------------------------------------------------ C761003_1 + +with Ada.Finalization; +package C761003_1 is + + type Global is abstract new Ada.Finalization.Controlled with record + Tag: Character; + end record; + + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + type Second is abstract new Ada.Finalization.Limited_Controlled with record + Tag: Character; + end record; + + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + +end C761003_1; + +------------------------------------------------------------------ C761003_2 + +with C761003_1; +package C761003_2 is + + type Global is new C761003_1.Global with null record; + -- inherits Initialize and Finalize + + type Second is new C761003_1.Second with null record; + -- inherits Initialize and Finalize + +end C761003_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0 + +with TCTouch; +with C761003_Support; +package body C761003_0 is + + package Sup renames C761003_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + +end C761003_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1 + +with TCTouch; +with C761003_Support; +package body C761003_1 is + + package Sup renames C761003_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + +end C761003_1; + +-------------------------------------------------------------------- C761003 + +with Report; +with TCTouch; +with C761003_0; +with C761003_2; +with C761003_Support; +procedure C761003 is + + package Sup renames C761003_Support; + +---------------------------------------------------------------- Subtest_1 + + Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous + + procedure Subtest_1 is + + -- the constant will take its constraint from the value. + -- must be declared first to be finalized last (and take the + -- initialize from before calling subtest_1) + Item_1 : constant C761003_0.Global := C761003_0.Null_Global; + + -- Item_2, declared second, should be finalized second to last. + Item_2 : C761003_0.Global(Sup.Pick_Char); + + -- Item_3 and Item_4 will be created in the order of the + -- list. + Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char); + + -- Item_5 will be finalized first. + Item_5 : C761003_0.Second(Sup.Pick_Char); + + begin + if Item_3.Tag >= Item_4.Tag then + Report.Failed("Controlled objects created by list in wrong order"); + end if; + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 1 body"); + end Subtest_1; + +---------------------------------------------------------------- Subtest_2 + + -- These declarations should cause calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. Note that for these objects, the + -- Initialize and Finalize are visible only by inheritance. + + Subtest_2_Inits_Expected : constant := 4; + + procedure Subtest_2 is + + Item_1 : C761003_2.Global; + Item_2, Item_3 : C761003_2.Global; + Item_4 : C761003_2.Second; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 2 body"); + end Subtest_2; + +---------------------------------------------------------------- Subtest_3 + + -- Test for controlled objects embedded in arrays. Using structures + -- that will cause a checkable order. + + Subtest_3_Inits_Expected : constant := 8; + + procedure Subtest_3 is + + type Global_List is array(Natural range <>) + of C761003_0.Global(Sup.Pick_Char); + + Items : Global_List(1..4); -- components have the same tag + + type Second_List is array(Natural range <>) + of C761003_0.Second(Sup.Pick_Char); + + Second_Items : Second_List(1..4); -- components have the same tag, + -- distinct from the tag used in Items + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 3 body"); + end Subtest_3; + +---------------------------------------------------------------- Subtest_4 + + -- These declarations should cause dispatching calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + + Subtest_4_Inits_Expected : constant := 2; + + procedure Subtest_4 is + + type Global_Rec is record + Item1: C761003_0.Global(Sup.Pick_Char); + end record; + + type Second_Rec is record + Item2: C761003_2.Second; + end record; + + G : Global_Rec; + S : Second_Rec; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 4 body"); + end Subtest_4; + +---------------------------------------------------------------- Subtest_5 + + -- Test for controlled objects embedded in arrays. In these cases, the + -- order of the finalization of the components is not defined by the + -- language. + + Subtest_5_Inits_Expected : constant := 8; + + procedure Subtest_5 is + + + type Another_Global_List is array(Natural range <>) + of C761003_2.Global; + + More_Items : Another_Global_List(1..4); + + type Another_Second_List is array(Natural range <>) + of C761003_2.Second; + + Second_More_Items : Another_Second_List(1..4); + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 5 body"); + end Subtest_5; + +---------------------------------------------------------------- Subtest_6 + + -- These declarations should cause dispatching calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + + Subtest_6_Inits_Expected : constant := 2; + + procedure Subtest_6 is + + type Global_Rec is record + Item2: C761003_2.Global; + end record; + + type Second_Rec is record + Item1: C761003_0.Second(Sup.Pick_Char); + end record; + + G : Global_Rec; + S : Second_Rec; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 6 body"); + end Subtest_6; + +begin -- Main test procedure. + + Report.Test ("C761003", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + -- adjust for optional adjusts and initializes for C761003_0.Null_Global + TCTouch.Flush; -- clear the optional adjust + if Sup.Inits_Called /= 1 then + -- C761003_0.Null_Global did not get "initialized" + C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump + end if; + + Subtest_1; + Sup.Validate(Subtest_1_Inits_Expected, 1); + + Subtest_2; + Sup.Validate(Subtest_2_Inits_Expected, 2); + + Subtest_3; + Sup.Validate(Subtest_3_Inits_Expected, 3); + + Subtest_4; + Sup.Validate(Subtest_4_Inits_Expected, 4); + + Subtest_5; + Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False); + + Subtest_6; + Sup.Validate(Subtest_6_Inits_Expected, 6); + + Report.Result; + +end C761003; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761004.a b/gcc/testsuite/ada/acats/tests/c7/c761004.a new file mode 100644 index 000000000..9b88382b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761004.a @@ -0,0 +1,305 @@ +-- C761004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an object of a controlled type is finalized with the +-- enclosing master is complete. +-- Check that finalization occurs in the case where the master is +-- left by a transfer of control. +-- Specifically check for types where the derived types do not have +-- discriminants. +-- +-- Check that finalization of controlled objects is +-- performed in the correct order. In particular, check that if +-- multiple objects of controlled types are declared immediately +-- within the same declarative part then they are finalized in the +-- reverse order of their creation. +-- +-- TEST DESCRIPTION: +-- This test checks these conditions for subprograms and +-- block statements; both variables and constants of controlled +-- types; cases of a controlled component of a record type, as +-- well as an array with controlled components. +-- +-- The base controlled types used for the test are defined +-- with a character discriminant. The initialize procedure for +-- the types will record the order of creation in a globally +-- accessible array, the finalize procedure for the types will call +-- TCTouch with that tag character. The test can then check that +-- the order of finalization is indeed the reverse of the order of +-- creation (assuming that the implementation calls Initialize in +-- the order that the objects are created). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +package C761004_Support is + + function Pick_Char return Character; + -- successive calls to Pick_Char return distinct characters which may + -- be assigned to objects to track an order sequence. These characters + -- are then used in calls to TCTouch.Touch. + + procedure Validate(Initcount: Natural; Testnumber:Natural); + -- does a little extra processing prior to calling TCTouch.Validate, + -- specifically, it reverses the stored string of characters, and checks + -- for a correct count. + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + +end C761004_Support; + +with Report; +with TCTouch; +package body C761004_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + TI: Positive := 1; + begin + for SI in reverse S'Range loop + T(TI) := S(SI); + TI := TI +1; + end loop; + return T; + end Invert; + + procedure Validate(Initcount: Natural; Testnumber:Natural) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Wrong number of inits, Subtest " & Number); + TCTouch.Flush; + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, True); + end if; + end Validate; + +end C761004_Support; + +----------------------------------------------------------------- C761004_0 + +with Ada.Finalization; +package C761004_0 is + type Global is new Ada.Finalization.Controlled with record + Tag : Character; + end record; + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + type Second is new Ada.Finalization.Limited_Controlled with record + Tag : Character; + end record; + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + +end C761004_0; + +with TCTouch; +with C761004_Support; +package body C761004_0 is + + package Sup renames C761004_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; +end C761004_0; + +------------------------------------------------------------------- C761004 + +with Report; +with TCTouch; +with C761004_0; +with C761004_Support; +with Ada.Finalization; -- needed to be able to create extension aggregates +procedure C761004 is + + Verbose : constant Boolean := False; + + package Sup renames C761004_Support; + + -- Subtest 1, general case. Check that several objects declared in a + -- subprogram are created, and finalized in opposite order. + + Subtest_1_Expected_Inits : constant := 3; + + procedure Subtest_1 is + Item_1 : C761004_0.Global; + Item_2, Item_3 : C761004_0.Global; + begin + if Item_2.Tag = Item_3.Tag then -- not germane to the test + Report.Failed("Duplicate tag");-- but helps prevent code elimination + end if; + end Subtest_1; + + -- Subtest 2, extension of the general case. Check that several objects + -- created identically on the stack (via a recursive procedure) are + -- finalized in the opposite order of their creation. + Subtest_2_Expected_Inits : constant := 12; + User_Exception : exception; + + procedure Subtest_2 is + + Item_1 : C761004_0.Global; + + -- combine recursion and exit by exception: + + procedure Nested(Recurs: Natural) is + Item_3 : C761004_0.Global; + begin + if Verbose then + Report.Comment("going in: " & Item_3.Tag); + end if; + if Recurs = 1 then + raise User_Exception; + else + Nested(Recurs -1); + end if; + end Nested; + + Item_2 : C761004_0.Global; + + begin + Nested(10); + end Subtest_2; + + -- subtest 3, check the case of objects embedded in structures: + -- an array + -- a record + Subtest_3_Expected_Inits : constant := 3; + procedure Subtest_3 is + type G_List is array(Positive range <>) of C761004_0.Global; + type Pandoras_Box is record + G : G_List(1..1); + end record; + + procedure Nested(Recursions: Natural) is + Merlin : Pandoras_Box; + begin + if Recursions > 1 then + Nested(Recursions-1); + else + TCTouch.Validate("","Final Nested call"); + end if; + end Nested; + + begin + Nested(3); + end Subtest_3; + + -- subtest 4, check the case of objects embedded in structures: + -- an array + -- a record + Subtest_4_Expected_Inits : constant := 3; + procedure Subtest_4 is + type S_List is array(Positive range <>) of C761004_0.Second; + type Pandoras_Box is record + S : S_List(1..1); + end record; + + procedure Nested(Recursions: Natural) is + Merlin : Pandoras_Box; + begin + if Recursions > 1 then + Nested(Recursions-1); + else + TCTouch.Validate("","Final Nested call"); + end if; + end Nested; + + begin + Nested(3); + end Subtest_4; + +begin -- Main test procedure. + + Report.Test ("C761004", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + Subtest_1; + Sup.Validate(Subtest_1_Expected_Inits,1); + + Subtest_2_Frame: begin + Sup.Inits_Called := 0; + Subtest_2; + exception + when User_Exception => null; + when others => Report.Failed("Wrong Exception, Subtest 2"); + end Subtest_2_Frame; + Sup.Validate(Subtest_2_Expected_Inits,2); + + Sup.Inits_Called := 0; + Subtest_3; + Sup.Validate(Subtest_3_Expected_Inits,3); + + Sup.Inits_Called := 0; + Subtest_4; + Sup.Validate(Subtest_4_Expected_Inits,4); + + Report.Result; + +end C761004; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761005.a b/gcc/testsuite/ada/acats/tests/c7/c761005.a new file mode 100644 index 000000000..acac59b48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761005.a @@ -0,0 +1,288 @@ +-- C761005.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that deriving abstract types from the types in Ada.Finalization +-- does not negatively impact the implicit operations. +-- Check that an object of a controlled type is finalized when the +-- enclosing master is complete. +-- Check that finalization occurs in the case where the master is +-- left by a transfer of control. +-- Check this for controlled types where the derived type has a +-- discriminant. +-- Check this for cases where the type is defined as private, +-- and the full type is derived from the types in Ada.Finalization. +-- +-- Check that finalization of controlled objects is +-- performed in the correct order. In particular, check that if +-- multiple objects of controlled types are declared immediately +-- within the same declarative part then type are finalized in the +-- reverse order of their creation. +-- +-- TEST DESCRIPTION: +-- This test checks these conditions for subprograms and +-- block statements; both variables and constants of controlled +-- types; cases of a controlled component of a record type, as +-- well as an array with controlled components. +-- +-- The base controlled types used for the test are defined +-- with a character discriminant. The initialize procedure for +-- the types will record the order of creation in a globally +-- accessible array, the finalize procedure for the types will call +-- TCTouch with that tag character. The test can then check that +-- the order of finalization is indeed the reverse of the order of +-- creation (assuming that the implementation calls Initialize in +-- the order that the objects are created). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +package C761005_Support is + + function Pick_Char return Character; + procedure Validate(Initcount: Natural; Testnumber:Natural); + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + +end C761005_Support; + +with Report; +with TCTouch; +package body C761005_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + TI: Positive := 1; + begin + for SI in reverse S'Range loop + T(TI) := S(SI); + TI := TI +1; + end loop; + return T; + end Invert; + + procedure Validate(Initcount: Natural; Testnumber:Natural) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Wrong number of inits, Subtest " & Number); + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, True); + end if; + Inits_Called := 0; + end Validate; + +end C761005_Support; + +----------------------------------------------------------------------------- +with Ada.Finalization; +package C761005_0 is + type Final_Root(Tag: Character) is private; + + type Ltd_Final_Root(Tag: Character) is limited private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; +private + type Final_Root(Tag: Character) is new Ada.Finalization.Controlled + with null record; + procedure Initialize( It: in out Final_Root ); + procedure Finalize ( It: in out Final_Root ); + + type Ltd_Final_Root(Tag: Character) is new +Ada.Finalization.Limited_Controlled + with null record; + procedure Initialize( It: in out Ltd_Final_Root ); + procedure Finalize ( It: in out Ltd_Final_Root ); +end C761005_0; + +----------------------------------------------------------------------------- +with Ada.Finalization; +package C761005_1 is + type Final_Abstract is abstract tagged private; + + type Ltd_Final_Abstract_Child is abstract tagged limited private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + +private + type Final_Abstract is abstract new Ada.Finalization.Controlled with record + Tag: Character; + end record; + procedure Initialize( It: in out Final_Abstract ); + procedure Finalize ( It: in out Final_Abstract ); + + type Ltd_Final_Abstract_Child is + abstract new Ada.Finalization.Limited_Controlled with record + Tag: Character; + end record; + procedure Initialize( It: in out Ltd_Final_Abstract_Child ); + procedure Finalize ( It: in out Ltd_Final_Abstract_Child ); + +end C761005_1; + +----------------------------------------------------------------------------- +with C761005_1; +package C761005_2 is + + type Final_Child is new C761005_1.Final_Abstract with null record; + type Ltd_Final_Child is + new C761005_1.Ltd_Final_Abstract_Child with null record; + +end C761005_2; + +----------------------------------------------------------------------------- +with Report; +with TCTouch; +with C761005_Support; +package body C761005_0 is + + package Sup renames C761005_Support; + + procedure Initialize( It: in out Final_Root ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Final_Root ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + + procedure Initialize( It: in out Ltd_Final_Root ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Ltd_Final_Root ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; +end C761005_0; + +----------------------------------------------------------------------------- +with Report; +with TCTouch; +with C761005_Support; +package body C761005_1 is + + package Sup renames C761005_Support; + + procedure Initialize( It: in out Final_Abstract ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Final_Abstract ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + + procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; +end C761005_1; + +----------------------------------------------------------------------------- +with Report; +with TCTouch; +with C761005_0; +with C761005_2; +with C761005_Support; +procedure C761005 is + + package Sup renames C761005_Support; + + Subtest_1_Inits_Expected : constant := 4; + procedure Subtest_1 is + Item_1 : C761005_0.Final_Root(Sup.Pick_Char); + Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char); + Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char); + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 1 body"); + end Subtest_1; + + -- These declarations should cause calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + Subtest_2_Inits_Expected : constant := 4; + procedure Subtest_2 is + Item_1 : C761005_2.Final_Child; + Item_2, Item_3 : C761005_2.Final_Child; + Item_4 : C761005_2.Ltd_Final_Child; + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 2 body"); + end Subtest_2; + +begin -- Main test procedure. + + Report.Test ("C761005", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + Subtest_1; + Sup.Validate(Subtest_1_Inits_Expected,1); + + Subtest_2; + Sup.Validate(Subtest_2_Inits_Expected,2); + + Report.Result; + +end C761005; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761006.a b/gcc/testsuite/ada/acats/tests/c7/c761006.a new file mode 100644 index 000000000..771e625d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761006.a @@ -0,0 +1,425 @@ +-- C761006.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Program_Error is raised when: +-- * an exception is raised if Finalize invoked as part of an +-- assignment operation; or +-- * an exception is raised if Adjust invoked as part of an assignment +-- operation, after any other adjustment due to be performed are +-- performed; or +-- * an exception is raised if Finalize invoked as part of a call on +-- Unchecked_Deallocation, after any other finalizations to be +-- performed are performed. +-- +-- TEST DESCRIPTION: +-- This test defines these four controlled types: +-- Good +-- Bad_Initialize +-- Bad_Adjust +-- Bad_Finalize +-- The type name conveys the associated failure. The operations in type +-- good will "touch" the boolean array indicating correct path +-- utilization for the purposes of checking "other <operations> are +-- performed", where <operations> ::= initialization, adjusting, and +-- finalization +-- +-- +-- +-- CHANGE HISTORY: +-- 12 APR 94 SAIC Initial version +-- 02 MAY 96 SAIC Visibility fixed for 2.1 +-- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286 +-- 01 DEC 97 EDS Made correction wrt RM 7.6(21) +-- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with +-- RM 7.6.1(16/1) from Technical Corrigendum 1. +-- +--! + +------------------------------------------------------------- C761006_Support + +package C761006_Support is + + type Events is ( Good_Initialize, Good_Adjust, Good_Finalize ); + + type Event_Array is array(Events) of Boolean; + + Events_Occurring : Event_Array := (others => False); + + Propagating_Exception : exception; + + procedure Raise_Propagating_Exception(Do_It: Boolean); + + function Unique_Value return Natural; + +end C761006_Support; + +------------------------------------------------------------- C761006_Support + +with Report; +package body C761006_Support is + + procedure Raise_Propagating_Exception(Do_It: Boolean) is + begin + if Report.Ident_Bool(Do_It) then + raise Propagating_Exception; + end if; + end Raise_Propagating_Exception; + + Seed : Natural := 0; + + function Unique_Value return Natural is + begin + Seed := Seed +1; + return Seed; + end Unique_Value; + +end C761006_Support; + +------------------------------------------------------------------- C761006_0 + +with Ada.Finalization; +with C761006_Support; +package C761006_0 is + + type Good is new Ada.Finalization.Controlled + with record + Initialized : Boolean := False; + Adjusted : Boolean := False; + Unique : Natural := C761006_Support.Unique_Value; + end record; + + procedure Initialize( It: in out Good ); + procedure Adjust ( It: in out Good ); + procedure Finalize ( It: in out Good ); + + type Bad_Initialize is private; + + type Bad_Adjust is private; + + type Bad_Finalize is private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; +private + type Bad_Initialize is new Ada.Finalization.Controlled + with null record; + procedure Initialize( It: in out Bad_Initialize ); + + type Bad_Adjust is new Ada.Finalization.Controlled + with null record; + procedure Adjust ( It: in out Bad_Adjust ); + + type Bad_Finalize is + new Ada.Finalization.Controlled with null record; + procedure Finalize ( It: in out Bad_Finalize ); +end C761006_0; + +------------------------------------------------------------------- C761006_1 + +with Ada.Finalization; +with C761006_0; +package C761006_1 is + + type Init_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Init_Fails : C761006_0.Bad_Initialize; + end record; + + type Adj_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Adj_Fails : C761006_0.Bad_Adjust; + end record; + + type Fin_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Fin_Fails : C761006_0.Bad_Finalize; + end record; + +end C761006_1; + +------------------------------------------------------------------- C761006_2 + +with C761006_1; +package C761006_2 is + + type Init_Check is new C761006_1.Init_Check_Root with null record; + type Adj_Check is new C761006_1.Adj_Check_Root with null record; + type Fin_Check is new C761006_1.Fin_Check_Root with null record; + +end C761006_2; + +------------------------------------------------------------------- C761006_0 + +with Report; +with C761006_Support; +package body C761006_0 is + + package Sup renames C761006_Support; + + procedure Initialize( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Initialize ) := True; + It.Initialized := True; + end Initialize; + + procedure Adjust ( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Adjust ) := True; + It.Adjusted := True; + It.Unique := C761006_Support.Unique_Value; + end Adjust; + + procedure Finalize ( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Finalize ) := True; + end Finalize; + + procedure Initialize( It: in out Bad_Initialize ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Initialize; + + procedure Adjust( It: in out Bad_Adjust ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Adjust; + + procedure Finalize( It: in out Bad_Finalize ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Finalize; + +end C761006_0; + +--------------------------------------------------------------------- C761006 + +with Report; +with C761006_0; +with C761006_2; +with C761006_Support; +with Ada.Exceptions; +with Ada.Finalization; +with Unchecked_Deallocation; +procedure C761006 is + + package Sup renames C761006_Support; + use type Sup.Event_Array; + + type Procedure_Handle is access procedure; + + type Test_ID is ( Simple, Initialize, Adjust, Finalize ); + + Sub_Tests : array(Test_ID) of Procedure_Handle; + + procedure Simple_Test is + A_Good_Object : C761006_0.Good; -- should call Initialize + begin + if not A_Good_Object.Initialized then + Report.Failed("Good object not initialized"); + end if; + + -- should call Adjust + A_Good_Object := ( Ada.Finalization.Controlled + with Unique => 0, others => False ); + if not A_Good_Object.Adjusted then + Report.Failed("Good object not adjusted"); + end if; + + -- should call Finalize before end of scope + end Simple_Test; + + procedure Initialize_Test is + begin + declare + This_Object_Fails_In_Initialize : C761006_2.Init_Check; + begin + Report.Failed("Exception in Initialize did not occur"); + exception + when others => + Report.Failed("Initialize caused exception at wrong lex"); + end; + + Report.Failed("Error in execution sequence"); + + exception + when Sup.Propagating_Exception => -- this is correct + if not Sup.Events_Occurring(Sup.Good_Initialize) then + Report.Failed("Initialization of Good Component did not occur"); + end if; + end Initialize_Test; + + procedure Adjust_Test is + This_Object_OK : C761006_2.Adj_Check; + This_Object_Target : C761006_2.Adj_Check; + begin + + Check_Adjust_Due_To_Assignment: begin + This_Object_Target := This_Object_OK; + Report.Failed("Adjust did not propagate any exception"); + exception + when Program_Error => -- expected case + if not This_Object_Target.Good_Component.Adjusted then + Report.Failed("other adjustment not performed"); + end if; + when others => + Report.Failed("Adjust propagated wrong exception"); + end Check_Adjust_Due_To_Assignment; + + C761006_Support.Events_Occurring := (True, False, False); + + Check_Adjust_Due_To_Initial_Assignment: declare + Another_Target : C761006_2.Adj_Check := This_Object_OK; + begin + Report.Failed("Adjust did not propagate any exception"); + exception + when others => Report.Failed("Adjust caused exception at wrong lex"); + end Check_Adjust_Due_To_Initial_Assignment; + + exception + when Program_Error => -- expected case + if Sup.Events_Occurring(Sup.Good_Finalize) /= + Sup.Events_Occurring(Sup.Good_Adjust) then + -- RM 7.6.1(16/1) says that the good Adjust may or may not + -- be performed; but if it is, then the Finalize must be + -- performed; and if it is not, then the Finalize must not + -- performed. + if Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Good adjust not performed with bad adjust, " & + "but good finalize was"); + else + Report.Failed("Good adjust performed with bad adjust, " & + "but good finalize was not"); + end if; + end if; + when others => + Report.Failed("Adjust propagated wrong exception"); + end Adjust_Test; + + procedure Finalize_Test is + + Fin_Not_Perf : constant String := "other finalizations not performed"; + + procedure Finalize_15 is + Item : C761006_2.Fin_Check; + Target : C761006_2.Fin_Check; + begin + + Item := Target; + -- finalization of Item should cause PE + -- ARM7.6:21 allows the implementation to omit the assignment of the + -- value into an anonymous object, which is the point at which Adjust + -- is normally called. However, this would result in Program_Error's + -- being raised before the call to Adjust, with the consequence that + -- Adjust is never called. + + exception + when Program_Error => -- expected case + if not Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Assignment: " & Fin_Not_Perf); + end if; + when others => + Report.Failed("Other exception in Finalize_15"); + + -- finalization of Item/Target should cause PE + end Finalize_15; + + -- check failure in finalize due to Unchecked_Deallocation + + type Shark is access C761006_2.Fin_Check; + + procedure Catch is + new Unchecked_Deallocation( C761006_2.Fin_Check, Shark ); + + procedure Finalize_17 is + White : Shark := new C761006_2.Fin_Check; + begin + Catch( White ); + exception + when Program_Error => + if not Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf); + end if; + end Finalize_17; + + begin + + Exception_In_Finalization: begin + Finalize_15; + exception + when Program_Error => null; -- anticipated + end Exception_In_Finalization; + + Use_Of_Unchecked_Deallocation: begin + Finalize_17; + exception + when others => + Report.Failed("Unchecked_Deallocation check, unwanted exception"); + end Use_Of_Unchecked_Deallocation; + + end Finalize_Test; + +begin -- Main test procedure. + + Report.Test ("C761006", "Check that exceptions raised in Initialize, " & + "Adjust and Finalize are processed correctly" ); + + Sub_Tests := (Simple_Test'Access, Initialize_Test'Access, + Adjust_Test'Access, Finalize_Test'Access); + + for Test in Sub_Tests'Range loop + begin + + Sup.Events_Occurring := (others => False); + + Sub_Tests(Test).all; + + case Test is + when Simple | Adjust => + if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then + Report.Failed ( "Other operation missing in " & + Test_ID'Image ( Test ) ); + end if; + when Initialize => + null; + when Finalize => + -- Note that for Good_Adjust, we may get either True or False + if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or + Sup.Events_Occurring ( Sup.Good_Finalize ) = False + then + Report.Failed ( "Other operation missing in " & + Test_ID'Image ( Test ) ); + end if; + end case; + + exception + when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How ) + & " from " & Test_ID'Image( Test ) ); + end; + end loop; + + Report.Result; + +end C761006; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761007.a b/gcc/testsuite/ada/acats/tests/c7/c761007.a new file mode 100644 index 000000000..7b3dbfb9b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761007.a @@ -0,0 +1,419 @@ +-- C761007.A +-- +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a finalize procedure invoked by a transfer of control +-- due to selection of a terminate alternative attempts to propagate an +-- exception, the exception is ignored, but any other finalizations due +-- to be performed are performed. +-- +-- +-- TEST DESCRIPTION: +-- This test declares a nested controlled data type, and embeds an object +-- of that type within a protected type. Objects of the protected type +-- are created and destroyed, and the actions of the embedded controlled +-- object are checked. The container controlled type causes an exception +-- as the last part of it's finalization operation. +-- +-- This test utilizes several tasks to accomplish the objective. The +-- tasks contain delays to ensure that the expected order of processing +-- is indeed accomplished. +-- +-- Subtest 1: +-- local task object runs to normal completion +-- +-- Subtest 2: +-- local task aborts a nested task to cause finalization +-- +-- Subtest 3: +-- local task sleeps long enough to allow procedure started +-- asynchronously to go into infinite loop. Procedure is then aborted +-- via ATC, causing finalization of objects. +-- +-- Subtest 4: +-- local task object takes terminate alternative, causing finalization +-- +-- +-- CHANGE HISTORY: +-- 06 JUN 95 SAIC Initial version +-- 05 APR 96 SAIC Documentation changes +-- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test +-- 02 DEC 97 EDS Remove duplicate characters from check string. +--! + +---------------------------------------------------------------- C761007_0 + +with Ada.Finalization; +package C761007_0 is + + type Internal is new Ada.Finalization.Controlled + with record + Effect : Character; + end record; + + procedure Finalize( I: in out Internal ); + + Side_Effect : String(1..80); -- way bigger than needed + Side_Effect_Finger : Natural := 0; + +end C761007_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C761007_0 is + + procedure Finalize( I : in out Internal ) is + Previous_Side_Effect : Boolean := False; + begin + -- look to see if this character has been finalized yet + for SEI in 1..Side_Effect_Finger loop + Previous_Side_Effect := Previous_Side_Effect + or Side_Effect(Side_Effect_Finger) = I.Effect; + end loop; + + -- if not, then tack it on to the string, and touch the character + if not Previous_Side_Effect then + Side_Effect_Finger := Side_Effect_Finger +1; + Side_Effect(Side_Effect_Finger) := I.Effect; + TCTouch.Touch(I.Effect); + end if; + + end Finalize; + +end C761007_0; + +---------------------------------------------------------------- C761007_1 + +with C761007_0; +with Ada.Finalization; +package C761007_1 is + + type Container is new Ada.Finalization.Controlled + with record + Effect : Character; + Content : C761007_0.Internal; + end record; + + procedure Finalize( C: in out Container ); + + Side_Effect : String(1..80); -- way bigger than needed + Side_Effect_Finger : Natural := 0; + + This_Exception_Is_Supposed_To_Be_Ignored : exception; + +end C761007_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with TCTouch; +package body C761007_1 is + + procedure Finalize( C: in out Container ) is + Previous_Side_Effect : Boolean := False; + begin + -- look to see if this character has been finalized yet + for SEI in 1..Side_Effect_Finger loop + Previous_Side_Effect := Previous_Side_Effect + or Side_Effect(Side_Effect_Finger) = C.Effect; + end loop; + + -- if not, then tack it on to the string, and touch the character + if not Previous_Side_Effect then + Side_Effect_Finger := Side_Effect_Finger +1; + Side_Effect(Side_Effect_Finger) := C.Effect; + TCTouch.Touch(C.Effect); + end if; + + raise This_Exception_Is_Supposed_To_Be_Ignored; + + end Finalize; + +end C761007_1; + +---------------------------------------------------------------- C761007_2 +with C761007_1; +package C761007_2 is + + protected type Prot_W_Fin_Obj is + procedure Set_Effects( Container, Filling: Character ); + private + The_Data_Under_Test : C761007_1.Container; + -- finalization for this will occur when the Prot_W_Fin_Obj object + -- "goes out of existence" for whatever reason. + end Prot_W_Fin_Obj; + +end C761007_2; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body C761007_2 is + + protected body Prot_W_Fin_Obj is + procedure Set_Effects( Container, Filling: Character ) is + begin + The_Data_Under_Test.Effect := Container; -- A, etc. + The_Data_Under_Test.Content.Effect := Filling; -- B, etc. + end Set_Effects; + end Prot_W_Fin_Obj; + +end C761007_2; + +------------------------------------------------------------------ C761007 + +with Report; +with Impdef; +with TCTouch; +with C761007_0; +with C761007_1; +with C761007_2; +procedure C761007 is + + task type Subtests( Outer, Inner : Character) is + entry Ready; + entry Complete; + end Subtests; + + task body Subtests is + Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj; + begin + Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner ); + + accept Ready; + + select + accept Complete; + or terminate; -- used in Subtest 4 + end select; + exception + -- the exception caused by the finalization of Local_Prot_W_Fin_Obj + -- should never be visible to this scope. + when others => Report.Failed("Exception in a Subtest object " + & Outer & Inner); + end Subtests; + + procedure Subtest_1 is + -- check the case where "nothing special" happens. + + This_Subtest : Subtests( 'A', 'B' ); + begin + + This_Subtest.Ready; + This_Subtest.Complete; + + while not This_Subtest'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + -- in the finalization of This_Subtest, the controlled object embedded in + -- the Prot_W_Fin_Obj will finalize. An exception is raised in the + -- container object, after "touching" it's tag character. + -- The finalization of the contained controlled object must be performed. + + + TCTouch.Validate( "AB", "Item embedded in task" ); + + + exception + when others => Report.Failed("Undesirable exception in Subtest_1"); + + end Subtest_1; + + procedure Subtest_2 is + -- check for explicit abort + + task Subtest_Task is + entry Complete; + end Subtest_Task; + + task body Subtest_Task is + + task Nesting; + task body Nesting is + Deep_Nesting : Subtests( 'E', 'F' ); + begin + if Report.Ident_Bool( True ) then + -- controlled objects have been created in the elaboration of + -- Deep_Nesting. Deep_Nesting must call the Set_Effects operation + -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete + -- entry call. + Deep_Nesting.Ready; + abort Deep_Nesting; + else + Report.Failed("Dead code in Nesting"); + end if; + exception + when others => Report.Failed("Exception in Subtest_Task.Nesting"); + end Nesting; + + Local_2 : C761007_2.Prot_W_Fin_Obj; + + begin + -- Nesting has activated at this point, which implies the activation + -- of Deep_Nesting as well. + + Local_2.Set_Effects( 'C', 'D' ); + + -- wait for Nesting to terminate + + while not Nesting'Terminated loop + delay Impdef.Clear_Ready_Queue; + end loop; + + accept Complete; + + exception + when others => Report.Failed("Exception in Subtest_Task"); + end Subtest_Task; + + begin + + -- wait for everything in Subtest_Task to happen + Subtest_Task.Complete; + + while not Subtest_Task'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + TCTouch.Validate( "EFCD", "Aborted nested task" ); + + exception + when others => Report.Failed("Undesirable exception in Subtest_2"); + end Subtest_2; + + procedure Subtest_3 is + -- check abort caused by asynchronous transfer of control + + task Subtest_3_Task is + entry Complete; + end Subtest_3_Task; + + procedure Check_Atc_Operation is + Check_Atc : C761007_2.Prot_W_Fin_Obj; + begin + + Check_Atc.Set_Effects( 'G', 'H' ); + + + while Report.Ident_Bool( True ) loop -- wait to be aborted + if Report.Ident_Bool( True ) then + Impdef.Exceed_Time_Slice; + delay Impdef.Switch_To_New_Task; + else + Report.Failed("Optimization prevention"); + end if; + end loop; + + Report.Failed("Check_Atc_Operation loop completed"); + + end Check_Atc_Operation; + + task body Subtest_3_Task is + task Nesting is + entry Complete; + end Nesting; + + task body Nesting is + Nesting_3 : C761007_2.Prot_W_Fin_Obj; + begin + Nesting_3.Set_Effects( 'G', 'H' ); + + -- give Check_Atc_Operation sufficient time to perform it's + -- Set_Effects on it's local Prot_W_Fin_Obj object + delay Impdef.Clear_Ready_Queue; + + accept Complete; + exception + when others => Report.Failed("Exception in Subtest_3_Task.Nesting"); + end Nesting; + + Local_3 : C761007_2.Prot_W_Fin_Obj; + + begin -- Subtest_3_Task + + Local_3.Set_Effects( 'I', 'J' ); + + select + Nesting.Complete; + then abort ---------------------------------------------------- cause KL + Check_ATC_Operation; + end select; + + accept Complete; + + exception + when others => Report.Failed("Exception in Subtest_3_Task"); + end Subtest_3_Task; + + begin -- Subtest_3 + Subtest_3_Task.Complete; + + while not Subtest_3_Task'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" ); + + exception + when others => Report.Failed("Undesirable exception in Subtest_3"); + end Subtest_3; + + procedure Subtest_4 is + -- check the case where transfer is caused by terminate alternative + -- highly similar to Subtest_1 + + This_Subtest : Subtests( 'M', 'N' ); + begin + + This_Subtest.Ready; + -- don't call This_Subtest.Complete; + + exception + when others => Report.Failed("Undesirable exception in Subtest_4"); + + end Subtest_4; + +begin -- Main test procedure. + + Report.Test ("C761007", "Check that if a finalize procedure invoked by " & + "a transfer of control or selection of a " & + "terminate alternative attempts to propagate " & + "an exception, the exception is ignored, but " & + "any other finalizations due to be performed " & + "are performed" ); + + Subtest_1; -- checks internal + + Subtest_2; -- checks internal + + Subtest_3; -- checks internal + + Subtest_4; + TCTouch.Validate( "MN", "transfer due to terminate alternative" ); + + Report.Result; + +end C761007; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761010.a b/gcc/testsuite/ada/acats/tests/c7/c761010.a new file mode 100644 index 000000000..7784c6da5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761010.a @@ -0,0 +1,447 @@ +-- C761010.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE +-- Check the requirements of the new 7.6(17.1/1) from Technical +-- Corrigendum 1 (originally discussed as AI95-00083). +-- This new paragraph requires that the initialization of an object with +-- an aggregate does not involve calls to Adjust. +-- +-- TEST DESCRIPTION +-- We include several cases of initialization: +-- - Explicit initialization of an object declared by an +-- object declaration. +-- - Explicit initialization of a heap object. +-- - Default initialization of a record component. +-- - Initialization of a formal parameter during a call. +-- - Initialization of a formal parameter during a call with +-- a defaulted parameter. +-- - Lots of nested records, arrays, and pointers. +-- In this test, Initialize should never be called, because we +-- never declare a default-initialized controlled object (although +-- we do declare default-initialized records containing controlled +-- objects, with default expressions for the components). +-- Adjust should never be called, because every initialization +-- is via an aggregate. Finalize is called, because the objects +-- themselves need to be finalized. +-- Thus, Initialize and Adjust call Failed. +-- In some of the cases, these procedures will not yet be elaborated, +-- anyway. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 23 SEP 1999 RLB Improved comments, renamed, issued. +-- 10 APR 2000 RLB Corrected errors in comments and text, fixed +-- discriminant error. Fixed so that Report.Test +-- is called before any Report.Failed call. Added +-- a marker so that the failed subtest can be +-- determined. +-- 26 APR 2000 RAD Try to defeat optimizations. +-- 04 AUG 2000 RLB Corrected error in Check_Equal. +-- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172). +-- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result. +-- +--! + +with Ada; use Ada; +with Report; use Report; pragma Elaborate_All(Report); +with Ada.Finalization; +package C761010_1 is + pragma Elaborate_Body; + function Square(X: Integer) return Integer; +private + type TC_Control is new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize (Object : in out TC_Control); + procedure Finalize (Object : in out TC_Control); + TC_Finalize_Called : Boolean := False; +end C761010_1; + +package body C761010_1 is + function Square(X: Integer) return Integer is + begin + return X**2; + end Square; + + procedure Initialize (Object : in out TC_Control) is + begin + Test("C761010_1", + "Check that Adjust is not called" + & " when aggregates are used to initialize objects"); + end Initialize; + + procedure Finalize (Object : in out TC_Control) is + begin + if not TC_Finalize_Called then + Failed("Var_Strings Finalize never called"); + end if; + Result; + end Finalize; + + TC_Test : TC_Control; -- Starts test; finalization ends test. +end C761010_1; + +with Ada.Finalization; +package C761010_1.Var_Strings is + type Var_String(<>) is private; + + Some_String: constant Var_String; + + function "=" (X, Y: Var_String) return Boolean; + + procedure Check_Equal(X, Y: Var_String); + -- Calls to this are used to defeat optimizations + -- that might otherwise defeat the purpose of the + -- test. I'm talking about the optimization of removing + -- unused controlled objects. + +private + + type String_Ptr is access constant String; + + type Var_String(Length: Natural) is new Finalization.Controlled with + record + Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x'); + Comp_2: String_Ptr(1..Length) := null; + Comp_3: String(Length..Length) := (others => '.'); + TC_Lab: Character := '1'; + end record; + procedure Initialize(X: in out Var_String); + procedure Adjust(X: in out Var_String); + procedure Finalize(X: in out Var_String); + + Some_String: constant Var_String + := (Finalization.Controlled with Length => 1, + Comp_1 => null, + Comp_2 => null, + Comp_3 => "x", + TC_Lab => 'A'); + + Another_String: constant Var_String + := (Finalization.Controlled with Length => 10, + Comp_1 => Some_String.Comp_2, + Comp_2 => new String'("1234567890"), + Comp_3 => "x", + TC_Lab => 'B'); + +end C761010_1.Var_Strings; + +package C761010_1.Var_Strings.Types is + + type Ptr is access all Var_String; + Ptr_Const: constant Ptr; + + type Ptr_Arr is array(Positive range <>) of Ptr; + Ptr_Arr_Const: constant Ptr_Arr; + + type Ptr_Rec(N_Strings: Natural) is + record + Ptrs: Ptr_Arr(1..N_Strings); + end record; + Ptr_Rec_Const: constant Ptr_Rec; + +private + + Ptr_Const: constant Ptr := new Var_String' + (Finalization.Controlled with + Length => 1, + Comp_1 => null, + Comp_2 => null, + Comp_3 => (others => ' '), + TC_Lab => 'C'); + + Ptr_Arr_Const: constant Ptr_Arr := + (1 => new Var_String' + (Finalization.Controlled with + Length => 1, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'D')); + + Ptr_Rec_Var: Ptr_Rec := + (3, + (1..2 => null, + 3 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'E'))); + + Ptr_Rec_Const: constant Ptr_Rec := + (3, + (1..2 => null, + 3 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'F'))); + + type Arr is array(Positive range <>) of Var_String(Length => 2); + + Arr_Var: Arr := + (1 => (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'G')); + + type Rec(N_Strings: Natural) is + record + Ptrs: Ptr_Rec(N_Strings); + Strings: Arr(1..N_Strings) := + (others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'H')); + end record; + + Default_Init_Rec_Var: Rec(N_Strings => 10); + Empty_Default_Init_Rec_Var: Rec(N_Strings => 0); + + Rec_Var: Rec(N_Strings => 2) := + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'J'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'K'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'L'))); + + procedure Check_Equal(X, Y: Rec); + +end C761010_1.Var_Strings.Types; + +package body C761010_1.Var_Strings.Types is + + -- Check that parameter passing doesn't create new objects, + -- and therefore doesn't need extra Adjusts or Finalizes. + + procedure Check_Equal(X, Y: Rec) is + -- We assume that the arguments should be equal. + -- But we cannot assume that pointer values are the same. + begin + if X.N_Strings /= Y.N_Strings then + Failed("Records should be equal (1)"); + else + for I in 1 .. X.N_Strings loop + if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then + if X.Ptrs.Ptrs(I) = null or else + Y.Ptrs.Ptrs(I) = null or else + X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then + Failed("Records should be equal (2)"); + end if; + end if; + if X.Strings(I) /= Y.Strings(I) then + Failed("Records should be equal (3)"); + end if; + end loop; + end if; + end Check_Equal; + + procedure My_Check_Equal + (X: Rec := Rec_Var; + Y: Rec := + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'M'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'N'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'O')))) + renames Check_Equal; +begin + + My_Check_Equal; + + Check_Equal(Rec_Var, + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'P'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'Q'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'R')))); + + -- Use the objects to avoid optimizations. + + Check_Equal(Ptr_Const.all, Ptr_Const.all); + Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all); + Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all, + Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all); + Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all, + Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all); + + if Report.Equal (3, 2) then + -- Can't get here. + Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1)); + Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1)); + end if; + +end C761010_1.Var_Strings.Types; + +with C761010_1.Var_Strings; +with C761010_1.Var_Strings.Types; +procedure C761010_1.Main is +begin + -- Report.Test is called by the elaboration of C761010_1, and + -- Report.Result is called by the finalization of C761010_1. + -- This will happen before any objects are created, and after any + -- are finalized. + null; +end C761010_1.Main; + +with C761010_1.Main; +procedure C761010 is +begin + C761010_1.Main; +end C761010; + +package body C761010_1.Var_Strings is + + Some_Error: exception; + + procedure Initialize(X: in out Var_String) is + begin + Failed("Initialize should never be called"); + raise Some_Error; + end Initialize; + + procedure Adjust(X: in out Var_String) is + begin + Failed("Adjust should never be called - case " & X.TC_Lab); + raise Some_Error; + end Adjust; + + procedure Finalize(X: in out Var_String) is + begin + Comment("Finalize called - case " & X.TC_Lab); + C761010_1.TC_Finalize_Called := True; + end Finalize; + + function "=" (X, Y: Var_String) return Boolean is + -- Don't check the TC_Lab component, but do check the contents of the + -- access values. + begin + if X.Length /= Y.Length then + return False; + end if; + if X.Comp_3 /= Y.Comp_3 then + return False; + end if; + if X.Comp_1 /= Y.Comp_1 then + -- Still OK if the values are the same. + if X.Comp_1 = null or else + Y.Comp_1 = null or else + X.Comp_1.all /= Y.Comp_1.all then + return False; + --else OK. + end if; + end if; + if X.Comp_2 /= Y.Comp_2 then + -- Still OK if the values are the same. + if X.Comp_2 = null or else + Y.Comp_2 = null or else + X.Comp_2.all /= Y.Comp_2.all then + return False; + end if; + end if; + return True; + end "="; + + procedure Check_Equal(X, Y: Var_String) is + begin + if X /= Y then + Failed("Check_Equal of Var_String"); + end if; + end Check_Equal; + +begin + Check_Equal(Another_String, Another_String); +end C761010_1.Var_Strings; diff --git a/gcc/testsuite/ada/acats/tests/c7/c761011.a b/gcc/testsuite/ada/acats/tests/c7/c761011.a new file mode 100644 index 000000000..1d447c755 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761011.a @@ -0,0 +1,410 @@ +-- C761011.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a Finalize propagates an exception, other Finalizes due +-- to be performed are performed. +-- Case 1: A Finalize invoked due to the end of execution of +-- a master. (Defect Report 8652/0023, as reflected in Technical +-- Corrigendum 1). +-- Case 2: A Finalize invoked due to finalization of an anonymous +-- object. (Defect Report 8652/0023, as reflected in Technical +-- Corrigendum 1). +-- Case 3: A Finalize invoked due to the transfer of control +-- due to an exit statement. +-- Case 4: A Finalize invoked due to the transfer of control +-- due to a goto statement. +-- Case 5: A Finalize invoked due to the transfer of control +-- due to a return statement. +-- Case 6: A Finalize invoked due to the transfer of control +-- due to raises an exception. +-- +-- +-- CHANGE HISTORY: +-- 29 JAN 2001 PHL Initial version +-- 15 MAR 2001 RLB Readied for release; added optimization blockers. +-- Added test cases for paragraphs 18 and 19 of the +-- standard (the previous tests were withdrawn). +-- +--! +with Ada.Finalization; +use Ada.Finalization; +package C761011_0 is + + type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with + record + Finalized : Boolean := False; + case D is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + function Create (Id : Integer) return Ctrl; + procedure Finalize (Obj : in out Ctrl); + function Was_Finalized (Id : Integer) return Boolean; + procedure Use_It (Obj : in Ctrl); + -- Use Obj to prevent optimization. + +end C761011_0; + +with Report; +use Report; +package body C761011_0 is + + User_Error : exception; + + Finalize_Called : array (0 .. 50) of Boolean := (others => False); + + function Create (Id : Integer) return Ctrl is + Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2))); + begin + case Obj.D is + when False => + Obj.C1 := Ident_Int (Id); + when True => + Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id))); + end case; + return Obj; + end Create; + + procedure Finalize (Obj : in out Ctrl) is + begin + if not Obj.Finalized then + Obj.Finalized := True; + if Obj.D then + if Integer (Obj.C2 / 2.0) mod Ident_Int (10) = + Ident_Int (3) then + raise User_Error; + else + Finalize_Called (Integer (Obj.C2) / 2) := True; + end if; + else + if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then + raise Tasking_Error; + else + Finalize_Called (Obj.C1) := True; + end if; + end if; + end if; + end Finalize; + + function Was_Finalized (Id : Integer) return Boolean is + begin + return Finalize_Called (Ident_Int (Id)); + end Was_Finalized; + + procedure Use_It (Obj : in Ctrl) is + -- Use Obj to prevent optimization. + begin + case Obj.D is + when True => + if not Equal (Boolean'Pos(Obj.Finalized), + Boolean'Pos(Obj.Finalized)) then + Failed ("Identity check - 1"); + end if; + when False => + if not Equal (Obj.C1, Obj.C1) then + Failed ("Identity check - 2"); + end if; + end case; + end Use_It; + +end C761011_0; + +with Ada.Exceptions; +use Ada.Exceptions; +with Ada.Finalization; +with C761011_0; +use C761011_0; +with Report; +use Report; +procedure C761011 is +begin + Test + ("C761011", + " Check that if a finalize propagates an exception, other finalizes " & + "due to be performed are performed"); + + Normal: -- Case 1 + begin + declare + Obj1 : Ctrl := Create (Ident_Int (1)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (2)); + Obj3 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int + (3))); -- Finalization: User_Error + Obj4 : Ctrl := Create (Ident_Int (4)); + begin + Comment ("Finalization of normal object"); + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + end; + Failed ("No exception raised by finalization of normal object"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (1)) or + not Was_Finalized (Ident_Int (2)) or + not Was_Finalized (Ident_Int (4)) then + Failed ("Missing finalizations - 1"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 1"); + end Normal; + + Anon: -- Case 2 + begin + declare + Obj1 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (5))); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (6)); + Obj3 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (7))); + Obj4 : Ctrl := Create (Ident_Int (8)); + begin + Comment ("Finalization of anonymous object"); + + -- The finalization of the anonymous object below will raise + -- Tasking_Error. + if Create (Ident_Int (10)).C1 /= Ident_Int (10) then + Failed ("Incorrect construction of an anonymous object"); + end if; + Failed ("Anonymous object not finalized at the end of the " & + "enclosing statement"); + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + end; + Failed ("No exception raised by finalization of an anonymous " & + "object of a function"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (5)) or + not Was_Finalized (Ident_Int (6)) or + not Was_Finalized (Ident_Int (7)) or + not Was_Finalized (Ident_Int (8)) then + Failed ("Missing finalizations - 2"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 2"); + end Anon; + + An_Exit: -- Case 3 + begin + for Counter in 1 .. 4 loop + declare + Obj1 : Ctrl := Create (Ident_Int (11)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (12)); + Obj3 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float ( + Ident_Int(13))); -- Finalization: User_Error + Obj4 : Ctrl := Create (Ident_Int (14)); + begin + Comment ("Finalization because of exit of loop"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + exit when not Ident_Bool (Obj2.D); + + Failed ("Exit not taken"); + end; + end loop; + Failed ("No exception raised by finalization on exit"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (11)) or + not Was_Finalized (Ident_Int (12)) or + not Was_Finalized (Ident_Int (14)) then + Failed ("Missing finalizations - 3"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 3"); + end An_Exit; + + A_Goto: -- Case 4 + begin + declare + Obj1 : Ctrl := Create (Ident_Int (15)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (0)); + -- Finalization: Tasking_Error + Obj3 : Ctrl := Create (Ident_Int (16)); + Obj4 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (17))); + begin + Comment ("Finalization because of goto statement"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + if Ident_Bool (Obj4.D) then + goto Continue; + end if; + + Failed ("Goto not taken"); + end; + <<Continue>> + Failed ("No exception raised by finalization on goto"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (15)) or + not Was_Finalized (Ident_Int (16)) or + not Was_Finalized (Ident_Int (17)) then + Failed ("Missing finalizations - 4"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 4"); + end A_Goto; + + A_Return: -- Case 5 + declare + procedure Do_Something is + Obj1 : Ctrl := Create (Ident_Int (18)); + Obj2 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (19))); + Obj3 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (20)); + -- Finalization: Tasking_Error + begin + Comment ("Finalization because of return statement"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + + if not Ident_Bool (Obj3.D) then + return; + end if; + + Failed ("Return not taken"); + end Do_Something; + begin + Do_Something; + Failed ("No exception raised by finalization on return statement"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (18)) or + not Was_Finalized (Ident_Int (19)) then + Failed ("Missing finalizations - 5"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 5"); + end A_Return; + + Except: -- Case 6 + declare + Funky_Error : exception; + + procedure Do_Something is + Obj1 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float ( + Ident_Int(23))); -- Finalization: User_Error + Obj2 : Ctrl := Create (Ident_Int (24)); + Obj3 : Ctrl := Create (Ident_Int (25)); + Obj4 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (26)); + begin + Comment ("Finalization because of exception propagation"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + if not Ident_Bool (Obj4.D) then + raise Funky_Error; + end if; + + Failed ("Exception not raised"); + end Do_Something; + begin + Do_Something; + Failed ("No exception raised by finalization on exception " & + "propagation"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (24)) or + not Was_Finalized (Ident_Int (25)) or + not Was_Finalized (Ident_Int (26)) then + Failed ("Missing finalizations - 6"); + end if; + when Funky_Error => + Failed ("Wrong exception propagated"); + -- Should be Program_Error (7.6.1(19)). + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 6"); + end Except; + + Result; +end C761011; + diff --git a/gcc/testsuite/ada/acats/tests/c7/c761012.a b/gcc/testsuite/ada/acats/tests/c7/c761012.a new file mode 100644 index 000000000..77b9e2253 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761012.a @@ -0,0 +1,151 @@ +-- C761012.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an anonymous object is finalized with its enclosing master if +-- a transfer of control or exception occurs prior to performing its normal +-- finalization. (Defect Report 8652/0023, as reflected in +-- Technical Corrigendum 1, RM95 7.6.1(13.1/1)). +-- +-- CHANGE HISTORY: +-- 29 JAN 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Finalization; +use Ada.Finalization; +package C761012_0 is + + type Ctrl (D : Boolean) is new Controlled with + record + case D is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + function Create return Ctrl; + procedure Finalize (Obj : in out Ctrl); + function Finalize_Was_Called return Boolean; + +end C761012_0; + +with Report; +use Report; +package body C761012_0 is + + Finalization_Flag : Boolean := False; + + function Create return Ctrl is + Obj : Ctrl (Ident_Bool (True)); + begin + Obj.C2 := 3.0; + return Obj; + end Create; + + procedure Finalize (Obj : in out Ctrl) is + begin + Finalization_Flag := True; + end Finalize; + + function Finalize_Was_Called return Boolean is + begin + if Finalization_Flag then + Finalization_Flag := False; + return True; + else + return False; + end if; + end Finalize_Was_Called; + +end C761012_0; + +with Ada.Exceptions; +use Ada.Exceptions; +with C761012_0; +use C761012_0; +with Report; +use Report; +procedure C761012 is +begin + Test ("C761012", + "Check that an anonymous object is finalized with its enclosing " & + "master if a transfer of control or exception occurs prior to " & + "performing its normal finalization"); + + Excep: + begin + + declare + I : Integer := Create.C1; -- Raises Constraint_Error + begin + Failed + ("Improper component selection did not raise Constraint_Error, I =" & + Integer'Image (I)); + exception + when Constraint_Error => + Failed ("Constraint_Error caught by the wrong handler"); + end; + + Failed ("Transfer of control did not happen correctly"); + + exception + when Constraint_Error => + if not Finalize_Was_Called then + Failed ("Finalize wasn't called when the master was left " & + "- Constraint_Error"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E)); + end Excep; + + Transfer: + declare + Finalize_Was_Called_Before_Leaving_Exit : Boolean; + begin + + begin + loop + exit when Create.C2 = 3.0; + end loop; + Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called; + if Finalize_Was_Called_Before_Leaving_Exit then + Comment ("Finalize called before the transfer of control"); + end if; + end; + + if not Finalize_Was_Called and then + not Finalize_Was_Called_Before_Leaving_Exit then + Failed ("Finalize wasn't called when the master was left " & + "- transfer of control"); + end if; + end Transfer; + + Result; +end C761012; + |