diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4')
27 files changed, 0 insertions, 9415 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc/testsuite/ada/acats/tests/c4/c410001.a deleted file mode 100644 index 26555531b06..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c410001.a +++ /dev/null @@ -1,303 +0,0 @@ --- C410001.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 evaluating an access to subprogram variable containing --- the value null causes the exception Constraint_Error. --- Check that the default value for objects of access to subprogram --- types is null. --- --- TEST DESCRIPTION: --- This test defines a few simple access_to_subprogram types, and --- objects of those types. It checks that the default values for --- these objects is null, and that an attempt to make a subprogram --- call via one of this objects containing a null value causes the --- predefined exception Constraint_Error. The check is performed ---- both with the default null value, and with an explicitly assigned --- null value, after the object has been used to successfully designate --- and call a subprogram. --- --- --- CHANGE HISTORY: --- 05 APR 96 SAIC Initial version --- 04 NOV 96 SAIC Revised for 2.1 release --- 26 FEB 97 PWB.CTA Initialized variable before passing to function ---! - ------------------------------------------------------------------ C410001_0 - -package C410001_0 is - - -- used to "switch state" in the software - Expect_Exception : Boolean; - - -- define a minimal mixture of access_to_subprogram types - - type Proc_Ref is access procedure; - - type Func_Ref is access function(I:Integer) return Integer; - - type Proc_Para_Ref is access procedure(P:Proc_Ref); - - type Func_Para_Ref is access function(F:Func_Ref) return Integer; - - type Prot_Proc_Ref is access protected procedure; - - type Prot_Func_Ref is access protected function return Boolean; - - -- define some subprograms for them to reference - - procedure Proc; - - function Func(I:Integer) return Integer; - - procedure Proc_Para( Param : Proc_Ref ); - - function Func_Para( Param : Func_Ref ) return Integer; - - protected Prot_Obj is - procedure Prot_Proc; - function Prot_Func return Boolean; - end Prot_Obj; - -end C410001_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C410001_0 is - - -- Note that some failing cases will cause duplicate failure messages; - -- rather than have the procedure/function bodies be null, the error - -- checking code makes for a reasonable anti-optimization feature. - - procedure Proc is - begin - if Expect_Exception then - Report.Failed("Expected exception did not occur: Proc"); - end if; - end Proc; - - function Func(I:Integer) return Integer is - begin - if Expect_Exception then - Report.Failed("Expected exception did not occur: Func"); - end if; - return Report.Ident_Int(I); - end Func; - - procedure Proc_Para( Param : Proc_Ref ) is - begin - - Param.all; -- call by explicit dereference - - if Expect_Exception then - Report.Failed("Expected exception did not occur: Proc_Para"); - end if; - - exception - when Constraint_Error => - if not Expect_Exception then - Report.Failed("Unexpected Constraint_Error: Proc_Para"); - end if; -- else null; expected the exception - when others => Report.Failed("Unexpected exception: Proc_Para"); - end Proc_Para; - - function Func_Para( Param : Func_Ref ) return Integer is - begin - - return Param(1); -- call by implicit dereference - - if Expect_Exception then - Report.Failed("Expected exception did not occur: Func_Para"); - end if; - return 1; -- really just to avoid warnings - - exception - when Constraint_Error => - if not Expect_Exception then - Report.Failed("Unexpected Constraint_Error: Func_Para"); - return 0; - else - return 1995; -- any value other than this is unexpected - end if; - when others => Report.Failed("Unexpected exception: Func_Para"); - return -42; - end Func_Para; - - protected body Prot_Obj is - - procedure Prot_Proc is - begin - if Expect_Exception then - Report.Failed("Expected exception did not occur: Prot_Proc"); - end if; - end Prot_Proc; - - function Prot_Func return Boolean is - begin - if Expect_Exception then - Report.Failed("Expected exception did not occur: Prot_Func"); - end if; - return Report.Ident_Bool( True ); - end Prot_Func; - - end Prot_Obj; - -end C410001_0; - -------------------------------------------------------------------- C410001 - -with Report; -with TCTouch; -with C410001_0; -procedure C410001 is - - Proc_Ref_Var : C410001_0.Proc_Ref; - - Func_Ref_Var : C410001_0.Func_Ref; - - Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref; - - Func_Para_Ref_Var : C410001_0.Func_Para_Ref; - - type Enclosure is record - Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref; - Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref; - end record; - - Enclosed : Enclosure; - - Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access; - - Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access; - - procedure Make_Calls( Expecting_Exceptions : Boolean ) is - type Case_Numbers is range 1..6; - Some_Integer : Integer := 0; - begin - for Cases in Case_Numbers loop - Catch_Exception : begin - case Cases is - when 1 => Proc_Ref_Var.all; - when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer ); - when 3 => Proc_Para_Ref_Var( Valid_Proc ); - when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func ); - when 5 => Enclosed.Prot_Proc_Ref_Var.all; - when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all - /= Expecting_Exceptions, - "Case 6"); - end case; - if Expecting_Exceptions then - Report.Failed("Exception expected: Case" - & Case_Numbers'Image(Cases) ); - end if; - exception - when Constraint_Error => - if not Expecting_Exceptions then - Report.Failed("Constraint_Error not expected: Case" - & Case_Numbers'Image(Cases) ); - end if; - when others => - Report.Failed("Wrong/Bad Exception: Case" - & Case_Numbers'Image(Cases) ); - end Catch_Exception; - end loop; - end Make_Calls; - -begin -- Main test procedure. - - Report.Test ("C410001", "Check that evaluating an access to subprogram " & - "variable containing the value null causes the " & - "exception Constraint_Error. Check that the " & - "default value for objects of access to " & - "subprogram types is null" ); - - -- check that the default values are null - declare - use C410001_0; -- make all "="'s visible for all types - begin - TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" ); - - TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" ); - - TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" ); - - TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" ); - - TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null, - "Enclosed.Prot_Proc_Ref_Var = null" ); - - TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null, - "Enclosed.Prot_Func_Ref_Var = null" ); - end; - - -- check that calls via the default values cause Constraint_Error - - C410001_0.Expect_Exception := True; - - Make_Calls( Expecting_Exceptions => True ); - - -- assign non-null values to the objects - - Proc_Ref_Var := C410001_0.Proc'Access; - Func_Ref_Var := C410001_0.Func'Access; - Proc_Para_Ref_Var := C410001_0.Proc_Para'Access; - Func_Para_Ref_Var := C410001_0.Func_Para'Access; - Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access, - C410001_0.Prot_Obj.Prot_Func'Access); - - -- check that the calls perform normally - - C410001_0.Expect_Exception := False; - - Make_Calls( Expecting_Exceptions => False ); - - -- check that a passed null value causes Constraint_Error - - C410001_0.Expect_Exception := True; - - Proc_Para_Ref_Var( null ); - - TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995, - "Func_Para_Ref_Var( null )"); - - -- assign the null value to the objects - - Proc_Ref_Var := null; - Func_Ref_Var := null; - Proc_Para_Ref_Var := null; - Func_Para_Ref_Var := null; - Enclosed := (null,null); - - -- check that calls now again cause Constraint_Error - - C410001_0.Expect_Exception := True; - - Make_Calls( Expecting_Exceptions => True ); - - Report.Result; - -end C410001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c420001.a b/gcc/testsuite/ada/acats/tests/c4/c420001.a deleted file mode 100644 index ae4b4d8fdcd..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c420001.a +++ /dev/null @@ -1,110 +0,0 @@ --- C420001.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 if the index subtype of a string type is a modular subtype --- whose lower bound is zero, then the evaluation of a null string_literal --- raises Constraint_Error. This was confirmed by AI95-00138. --- --- TEST DESCRIPTION --- In this test, we have a generic formal modular type, and we have --- several null string literals of that type. Because the type is --- generic formal, the string literals are not static, and therefore --- the Constraint_Error should be detected at run time. --- --- CHANGE HISTORY: --- 29 JUN 1999 RAD Initial Version --- 23 SEP 1999 RLB Improved comments and messages, renamed, issued. --- ---! -with Report; use Report; pragma Elaborate_All(Report); -with System; -procedure C420001 is - generic - type Modular is mod <>; - package Mod_Test is - type Str is array(Modular range <>) of Character; - procedure Test_String_Literal; - end Mod_Test; - - package body Mod_Test is - procedure Test_String_Literal is - begin - begin - declare - Null_String: Str := ""; -- Should raise C_E. - begin - Comment(String(Null_String)); -- Avoid 11.6 issues. - end; - Failed("Null string didn't raise Constraint_Error"); - exception - when Exc: Constraint_Error => - null; -- Comment("Constraint_Error -- OK"); - when Exc2: others => - Failed("Null string raised wrong exception"); - end; - begin - Failed(String(Str'(""))); -- Should raise C_E, not do Failed. - Failed("Null string didn't raise Constraint_Error"); - exception - when Exc: Constraint_Error => - null; -- Comment("Constraint_Error -- OK"); - when Exc2: others => - Failed("Null string raised wrong exception"); - end; - end Test_String_Literal; - begin - Test_String_Literal; - end Mod_Test; -begin - Test("C420001", "Check that if the index subtype of a string type is a " & - "modular subtype whose lower bound is zero, then the " & - "evaluation of a null string_literal raises " & - "Constraint_Error. "); - declare - type M1 is mod 1; - package Test_M1 is new Mod_Test(M1); - type M2 is mod 2; - package Test_M2 is new Mod_Test(M2); - type M3 is mod 3; - package Test_M3 is new Mod_Test(M3); - type M4 is mod 4; - package Test_M4 is new Mod_Test(M4); - type M5 is mod 5; - package Test_M5 is new Mod_Test(M5); - type M6 is mod 6; - package Test_M6 is new Mod_Test(M6); - type M7 is mod 7; - package Test_M7 is new Mod_Test(M7); - type M8 is mod 8; - package Test_M8 is new Mod_Test(M8); - type M_Max_Binary_Modulus is mod System.Max_Binary_Modulus; - package Test_M_Max_Binary_Modulus is new Mod_Test(M_Max_Binary_Modulus); - type M_Max_Nonbinary_Modulus is mod System.Max_Nonbinary_Modulus; - package Test_M_Max_Nonbinary_Modulus is new Mod_Test(M_Max_Nonbinary_Modulus); - begin - null; - end; - Result; -end C420001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c431001.a b/gcc/testsuite/ada/acats/tests/c4/c431001.a deleted file mode 100644 index 7d417ce69d9..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c431001.a +++ /dev/null @@ -1,464 +0,0 @@ --- C431001.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 record aggregate can be given for a nonprivate, --- nonlimited record extension and that the tag of the aggregate --- values are initialized to the tag of the record extension. --- --- TEST DESCRIPTION: --- From an initial parent tagged type, several type extensions --- are declared. Each type extension adds components onto --- the existing record structure. --- --- In the main procedure, aggregates are declared in two ways. --- In the declarative part, aggregates are used to supply --- initial values for objects of specific types. In the executable --- part, aggregates are used directly as actual parameters to --- a class-wide formal parameter. --- --- The abstraction is for a catalog of recordings. A recording --- can be a CD or a record (vinyl). Additionally, a CD may also --- be a CD-ROM, containing both music and data. This type is declared --- as an extension to a type extension, to test that the inclusion --- of record components is transitive across multiple extensions. --- --- That the aggregate has the correct tag is verify by feeding --- it to a dispatching operation and confirming that the --- expected subprogram is called as a result. To accomplish this, --- an enumeration type is declared with an enumeration literal --- representing each of the declared types in the hierarchy. A value --- of this type is passed as a parameter to the dispatching --- operation which passes it along to the dispatched subprogram. --- Each dispatched subprogram verifies that it received the --- expected enumeration literal. --- --- Not quite fitting the above abstraction are several test cases --- for null records. These tests verify that the new syntax for --- null record aggregates, (null record), is supported. A type is --- declared which extends a null tagged type and adds components. --- Aggregates of this type should include associations for the --- components of the type extension only. Finally, a type is --- declared that adds a null type extension onto a non-null tagged --- type. The aggregate associations should remain the same. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- ---! --- -package C431001_0 is - - -- Values of TC_Type_ID are passed through to dispatched subprogram - -- calls so that it can be verified that the dispatching resulted in - -- the expected call. - type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM); - - type Genre is (Classical, Country, Jazz, Rap, Rock, World); - - type Recording is tagged record - Artist : String (1..20); - Category : Genre; - Length : Duration; - Selections : Positive; - end record; - - function Summary (R : in Recording; - TC_Type : in TC_Type_ID) return String; - - type Recording_Method is (Audio, Digital); - type CD is new Recording with record - Recorded : Recording_Method; - Mastered : Recording_Method; - end record; - - function Summary (Disc : in CD; - TC_Type : in TC_Type_ID) return String; - - type Playing_Speed is (LP_33, Single_45, Old_78); - type Vinyl is new Recording with record - Speed : Playing_Speed; - end record; - - function Summary (Album : in Vinyl; - TC_Type : in TC_Type_ID) return String; - - - type CD_ROM is new CD with record - Storage : Positive; - end record; - - function Summary (Disk : in CD_ROM; - TC_Type : in TC_Type_ID) return String; - - function Catalog_Entry (R : in Recording'Class; - TC_Type : in TC_Type_ID) return String; - - procedure Print (S : in String); -- provides somewhere for the - -- results of Catalog_Entry to - -- "go", so they don't get - -- optimized away. - - -- The types and procedures declared below are not a continuation - -- of the Recording abstraction. These types are intended to test - -- support for null tagged types and type extensions. TC_Check mirrors - -- the operation of function Summary, above. Similarly, TC_Dispatch - -- mirrors the operation of Catalog_Entry. - - type TC_N_Type_ID is - (TC_Null_Tagged, TC_Null_Extension, - TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull); - - type Null_Tagged is tagged null record; - procedure TC_Check (N : in Null_Tagged; - TC_Type : in TC_N_Type_ID); - - type Null_Extension is new Null_Tagged with null record; - procedure TC_Check (N : in Null_Extension; - TC_Type : in TC_N_Type_ID); - - type Extension_Of_Null is new Null_Tagged with record - New_Component1 : Boolean; - New_Component2 : Natural; - end record; - procedure TC_Check (N : in Extension_Of_Null; - TC_Type : in TC_N_Type_ID); - - type Null_Extension_Of_Nonnull is new Extension_Of_Null - with null record; - procedure TC_Check (N : in Null_Extension_Of_Nonnull; - TC_Type : in TC_N_Type_ID); - - procedure TC_Dispatch (N : in Null_Tagged'Class; - TC_Type : in TC_N_Type_ID); - -end C431001_0; - -with Report; -package body C431001_0 is - - function Summary (R : in Recording; - TC_Type : in TC_Type_ID) return String is - begin - - if TC_Type /= TC_Recording then - Report.Failed ("Did not dispatch on tag for tagged parent " & - "type Recording"); - end if; - - return R.Artist (1..10) - & ' ' & Genre'Image (R.Category) (1..2) - & ' ' & Duration'Image (R.Length) - & ' ' & Integer'Image (R.Selections); - - end Summary; - - function Summary (Disc : in CD; - TC_Type : in TC_Type_ID) return String is - begin - - if TC_Type /= TC_CD then - Report.Failed ("Did not dispatch on tag for type extension " & - "CD"); - end if; - - return Summary (Recording (Disc), TC_Type => TC_Recording) - & ' ' & Recording_Method'Image(Disc.Recorded)(1) - & Recording_Method'Image(Disc.Mastered)(1); - - end Summary; - - function Summary (Album : in Vinyl; - TC_Type : in TC_Type_ID) return String is - begin - if TC_Type /= TC_Vinyl then - Report.Failed ("Did not dispatch on tag for type extension " & - "Vinyl"); - end if; - - case Album.Speed is - when LP_33 => - return Summary (Recording (Album), TC_Type => TC_Recording) - & " 33"; - when Single_45 => - return Summary (Recording (Album), TC_Type => TC_Recording) - & " 45"; - when Old_78 => - return Summary (Recording (Album), TC_Type => TC_Recording) - & " 78"; - end case; - - end Summary; - - function Summary (Disk : in CD_ROM; - TC_Type : in TC_Type_ID) return String is - begin - if TC_Type /= TC_CD_ROM then - Report.Failed ("Did not dispatch on tag for type extension " & - "CD_ROM. This is an extension of the type " & - "extension CD"); - end if; - - return Summary (Recording(Disk), TC_Type => TC_Recording) - & ' ' & Integer'Image (Disk.Storage) & 'K'; - - end Summary; - - function Catalog_Entry (R : in Recording'Class; - TC_Type : in TC_Type_ID) return String is - begin - return Summary (R, TC_Type); -- dispatched call - end Catalog_Entry; - - procedure Print (S : in String) is - T : String (1..S'Length) := Report.Ident_Str (S); - begin - -- Ada.Text_IO.Put_Line (S); - null; - end Print; - - -- Bodies for null type checks - procedure TC_Check (N : in Null_Tagged; - TC_Type : in TC_N_Type_ID) is - begin - if TC_Type /= TC_Null_Tagged then - Report.Failed ("Did not dispatch on tag for null tagged " & - "type Null_Tagged"); - end if; - end TC_Check; - - procedure TC_Check (N : in Null_Extension; - TC_Type : in TC_N_Type_ID) is - begin - if TC_Type /= TC_Null_Extension then - Report.Failed ("Did not dispatch on tag for null tagged " & - "type extension Null_Extension"); - end if; - end TC_Check; - - procedure TC_Check (N : in Extension_Of_Null; - TC_Type : in TC_N_Type_ID) is - begin - if TC_Type /= TC_Extension_Of_Null then - Report.Failed - ("Did not dispatch on tag for extension of null parent" & - "type"); - end if; - end TC_Check; - - procedure TC_Check (N : in Null_Extension_Of_Nonnull; - TC_Type : in TC_N_Type_ID) is - begin - if TC_Type /= TC_Null_Extension_Of_Nonnull then - Report.Failed - ("Did not dispatch on tag for null extension of nonnull " & - "parent type"); - end if; - end TC_Check; - - procedure TC_Dispatch (N : in Null_Tagged'Class; - TC_Type : in TC_N_Type_ID) is - begin - TC_Check (N, TC_Type); -- dispatched call - end TC_Dispatch; - -end C431001_0; - - -with C431001_0; -with Report; -procedure C431001 is - - -- Tagged type - -- Named component associations - DAT : C431001_0.Recording := - (Artist => "Aerosmith ", - Category => C431001_0.Rock, - Length => 48.5, - Selections => 10); - - -- Type extensions - -- Named component associations - Disc1 : C431001_0.CD := - (Artist => "London Symphony ", - Category => C431001_0.Classical, - Length => 55.0, - Selections => 4, - Recorded => C431001_0.Digital, - Mastered => C431001_0.Digital); - - -- Named component associations with others - Disc2 : C431001_0.CD := - (Artist => "Pink Floyd ", - Category => C431001_0.Rock, - Length => 51.8, - Selections => 5, - others => C431001_0.Audio); -- Recorded - -- Mastered - - -- Positional component associations - Album1 : C431001_0.Vinyl := - ("Hammer ", -- Artist - C431001_0.Rap, -- Category - 46.2, -- Length - 9, -- Selections - C431001_0.LP_33); -- Speed - - -- Mixed positional and named component associations - -- Named component associations out of order - Album2 : C431001_0.Vinyl := - ("Balinese Gamelan ", -- Artist - C431001_0.World, -- Category - 42.6, -- Length - 14, -- Selections - C431001_0.LP_33); -- Speed - - -- Type extension, parent is also type extension - -- Named notation, components out of order - Data : C431001_0.CD_ROM := - (Storage => 140, - Mastered => C431001_0.Digital, - Category => C431001_0.Rock, - Selections => 10, - Recorded => C431001_0.Digital, - Artist => "Black, Clint ", - Length => 48.5); - - -- Null tagged type - Null_Rec : C431001_0.Null_Tagged := (null record); - - -- Null type extension - Null_Ext : C431001_0.Null_Extension := (null record); - - -- Nonnull extension of null parent - Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0); - - -- Null extension of nonnull parent - Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull - := (False, 1); - -begin - - Report.Test ("C431001", "Aggregate values for type extensions"); - - C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording)); - C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD)); - C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD)); - C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl)); - C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl)); - C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM)); - - C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged); - C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension); - C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null); - C431001_0.TC_Dispatch - (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull); - - -- Tagged type - -- Named component associations - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_Recording, - R => C431001_0.Recording'(Artist => "Zappa, Frank ", - Category => C431001_0.Rock, - Length => 70.0, - Selections => 38))); - - -- Type extensions - -- Named component associations - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_CD, - R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ", - Category => C431001_0.Rap, - Length => 37.3, - Selections => 8, - Recorded => C431001_0.Audio, - Mastered => C431001_0.Digital))); - - -- Named component associations with others - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_CD, - R => C431001_0.CD'(Artist => "Judd, Winona ", - Category => C431001_0.Country, - Length => 51.2, - Selections => 11, - others => C431001_0.Digital))); -- Recorded - -- Mastered - - -- Positional component associations - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_Vinyl, - R => C431001_0.Vinyl'("Davis, Miles ", -- Artist - C431001_0.Jazz, -- Category - 50.4, -- Length - 10, -- Selections - C431001_0.LP_33))); -- Speed - - -- Mixed positional and named component associations - -- Named component associations out of order - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_Vinyl, - R => C431001_0.Vinyl'("Zamfir ", -- Artist - C431001_0.World, -- Category - Speed => C431001_0.LP_33, - Selections => 14, - Length => 56.5))); - - -- Type extension, parent is also type extension - -- Named notation, components out of order - C431001_0.Print (C431001_0.Catalog_Entry - (TC_Type => C431001_0.TC_CD_ROM, - R => C431001_0.CD_ROM'(Storage => 720, - Category => C431001_0.Classical, - Recorded => C431001_0.Digital, - Artist => "Baltimore Symphony ", - Length => 68.9, - Mastered => C431001_0.Digital, - Selections => 5))); - - -- Null tagged type - C431001_0.TC_Dispatch - (TC_Type => C431001_0.TC_Null_Tagged, - N => C431001_0.Null_Tagged'(null record)); - - -- Null type extension - C431001_0.TC_Dispatch - (TC_Type => C431001_0.TC_Null_Extension, - N => C431001_0.Null_Extension'(null record)); - - -- Nonnull extension of null parent - C431001_0.TC_Dispatch - (TC_Type => C431001_0.TC_Extension_Of_Null, - N => C431001_0.Extension_Of_Null'(True, 3)); - - -- Null extension of nonnull parent - C431001_0.TC_Dispatch - (TC_Type => C431001_0.TC_Extension_Of_Null, - N => C431001_0.Extension_Of_Null'(False, 4)); - - Report.Result; - -end C431001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432001.a b/gcc/testsuite/ada/acats/tests/c4/c432001.a deleted file mode 100644 index dab75b388f5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c432001.a +++ /dev/null @@ -1,512 +0,0 @@ --- C432001.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 extension aggregates may be used to specify values --- for types that are record extensions. Check that the --- type of the ancestor expression may be any nonlimited type that --- is a record extension, including private types and private --- extensions. Check that the type for the aggregate is --- derived from the type of the ancestor expression. --- --- TEST DESCRIPTION: --- --- Two progenitor nonlimited record types are declared, one --- nonprivate and one private. Using these as parent types, --- all possible combinations of record extensions are declared --- (Nonprivate record extension of nonprivate type, private --- extension of nonprivate type, nonprivate record extension of --- private type, and private extension of private type). Finally, --- each of these types is extended using nonprivate record --- extensions. --- --- Extension of private types is done in packages other than --- the ones containing the parent declaration. This is done --- to eliminate errors with extension of the partial view of --- a type, which is not an objective of this test. --- --- All components of private types and private extensions are given --- default values. This eliminates the need for separate subprograms --- whose sole purpose is to place a value into a private record type. --- --- Types that have been extended are checked using an object of their --- parent type as the ancestor expression. For those types that --- have been extended twice, using only nonprivate record extensions, --- a check is made using an object of their grandparent type as --- the ancestor expression. --- --- For each type, a subprogram is defined which checks the contents --- of the parameter, which is a value of the record extension. --- Components of nonprivate record extensions are checked against --- passed-in parameters of the component type. Components of private --- extensions are checked to ensure that they maintain their initial --- values. --- --- To check that the aggregate's type is derived from its ancestor, --- each Check subprogram in turn calls the Check subprogram for --- its parent type. Explicit conversion is used to convert the --- record extension to the parent type. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with Report; -package C432001_0 is - - type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); - - type N is tagged record - How_Long_Ago : Natural := Report.Ident_Int(1); - Era : Eras := Cenozoic; - end record; - - function Check (Rec : in N; - N : in Natural; - E : in Eras) return Boolean; - - type P is tagged private; - - function Check (Rec : in P) return Boolean; - -private - - type P is tagged record - How_Long_Ago : Natural := Report.Ident_Int(150); - Era : Eras := Mesozoic; - end record; - -end C432001_0; - -package body C432001_0 is - - function Check (Rec : in P) return Boolean is - begin - return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic; - end Check; - - function Check (Rec : in N; - N : in Natural; - E : in Eras) return Boolean is - begin - return Rec.How_Long_Ago = N and Rec.Era = E; - end Check; - -end C432001_0; - -with C432001_0; -package C432001_1 is - - type Periods is - (Aphebian, Helikian, Hadrynian, - Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, - Triassic, Jurassic, Cretaceous, - Tertiary, Quaternary); - - type N_N is new C432001_0.N with record - Period : Periods := C432001_1.Quaternary; - end record; - - function Check (Rec : in N_N; - N : in Natural; - E : in C432001_0.Eras; - P : in Periods) return Boolean; - - type N_P is new C432001_0.N with private; - - function Check (Rec : in N_P) return Boolean; - - type P_N is new C432001_0.P with record - Period : Periods := C432001_1.Jurassic; - end record; - - function Check (Rec : in P_N; - P : in Periods) return Boolean; - - type P_P is new C432001_0.P with private; - - function Check (Rec : in P_P) return Boolean; - - type P_P_Null is new C432001_0.P with null record; - -private - - type N_P is new C432001_0.N with record - Period : Periods := C432001_1.Quaternary; - end record; - - type P_P is new C432001_0.P with record - Period : Periods := C432001_1.Jurassic; - end record; - -end C432001_1; - -with Report; -package body C432001_1 is - - function Check (Rec : in N_N; - N : in Natural; - E : in C432001_0.Eras; - P : in Periods) return Boolean is - begin - if not C432001_0.Check (C432001_0.N (Rec), N, E) then - Report.Failed ("Conversion to parent type of " & - "nonprivate portion of " & - "nonprivate extension failed"); - end if; - return Rec.Period = P; - end Check; - - - function Check (Rec : in N_P) return Boolean is - begin - if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then - Report.Failed ("Conversion to parent type of " & - "nonprivate portion of " & - "private extension failed"); - end if; - return Rec.Period = C432001_1.Quaternary; - end Check; - - function Check (Rec : in P_N; - P : in Periods) return Boolean is - begin - if not C432001_0.Check (C432001_0.P (Rec)) then - Report.Failed ("Conversion to parent type of " & - "private portion of " & - "nonprivate extension failed"); - end if; - return Rec.Period = P; - end Check; - - function Check (Rec : in P_P) return Boolean is - begin - if not C432001_0.Check (C432001_0.P (Rec)) then - Report.Failed ("Conversion to parent type of " & - "private portion of " & - "private extension failed"); - end if; - return Rec.Period = C432001_1.Jurassic; - end Check; - -end C432001_1; - -with C432001_0; -with C432001_1; -package C432001_2 is - - -- All types herein are nonprivate extensions, since aggregates - -- cannot be given for private extensions - - type N_N_N is new C432001_1.N_N with record - Sample_On_Loan : Boolean; - end record; - - function Check (Rec : in N_N_N; - N : in Natural; - E : in C432001_0.Eras; - P : in C432001_1.Periods; - B : in Boolean) return Boolean; - - type N_P_N is new C432001_1.N_P with record - Sample_On_Loan : Boolean; - end record; - - function Check (Rec : in N_P_N; - B : Boolean) return Boolean; - - type P_N_N is new C432001_1.P_N with record - Sample_On_Loan : Boolean; - end record; - - function Check (Rec : in P_N_N; - P : in C432001_1.Periods; - B : Boolean) return Boolean; - - type P_P_N is new C432001_1.P_P with record - Sample_On_Loan : Boolean; - end record; - - function Check (Rec : in P_P_N; - B : Boolean) return Boolean; - -end C432001_2; - -with Report; -package body C432001_2 is - - -- direct access to operator - use type C432001_1.Periods; - - - function Check (Rec : in N_N_N; - N : in Natural; - E : in C432001_0.Eras; - P : in C432001_1.Periods; - B : in Boolean) return Boolean is - begin - if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then - Report.Failed ("Conversion to parent " & - "nonprivate type extension " & - "failed"); - end if; - return Rec.Sample_On_Loan = B; - end Check; - - - function Check (Rec : in N_P_N; - B : Boolean) return Boolean is - begin - if not C432001_1.Check (C432001_1.N_P (Rec)) then - Report.Failed ("Conversion to parent " & - "private type extension " & - "failed"); - end if; - return Rec.Sample_On_Loan = B; - end Check; - - function Check (Rec : in P_N_N; - P : in C432001_1.Periods; - B : Boolean) return Boolean is - begin - if not C432001_1.Check (C432001_1.P_N (Rec), P) then - Report.Failed ("Conversion to parent " & - "nonprivate type extension " & - "failed"); - end if; - return Rec.Sample_On_Loan = B; - end Check; - - function Check (Rec : in P_P_N; - B : Boolean) return Boolean is - begin - if not C432001_1.Check (C432001_1.P_P (Rec)) then - Report.Failed ("Conversion to parent " & - "private type extension " & - "failed"); - end if; - return Rec.Sample_On_Loan = B; - end Check; - -end C432001_2; - - -with C432001_0; -with C432001_1; -with C432001_2; -with Report; -procedure C432001 is - - N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375), - Era => C432001_0.Paleozoic); - - P_Object : C432001_0.P; -- default value is (150, - -- C432001_0.Mesozoic) - - N_N_Object : C432001_1.N_N := - (N_Object with Period => C432001_1.Devonian); - - P_N_Object : C432001_1.P_N := - (P_Object with Period => C432001_1.Jurassic); - - N_P_Object : C432001_1.N_P; -- default is (1, - -- C432001_0.Cenozoic, - -- C432001_1.Quaternary) - - P_P_Object : C432001_1.P_P; -- default is (150, - -- C432001_0.Mesozoic, - -- C432001_1.Jurassic) - - P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record); - - N_N_N_Object : C432001_2.N_N_N := - (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); - - N_P_N_Object : C432001_2.N_P_N := - (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); - - P_N_N_Object : C432001_2.P_N_N := - (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); - - P_P_N_Object : C432001_2.P_P_N := - (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); - - P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object) - with C432001_1.Carboniferous); - - N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian) - with C432001_1.Carboniferous); - -begin - - Report.Test ("C432001", "Extension aggregates"); - - -- check ultimate ancestor types - - if not C432001_0.Check (N_Object, - 375, - C432001_0.Paleozoic) then - Report.Failed ("Object of " & - "nonprivate type " & - "failed content check"); - end if; - - if not C432001_0.Check (P_Object) then - Report.Failed ("Object of " & - "private type " & - "failed content check"); - end if; - - -- check direct type extensions - - if not C432001_1.Check (N_N_Object, - 375, - C432001_0.Paleozoic, - C432001_1.Devonian) then - Report.Failed ("Object of " & - "nonprivate extension of nonprivate type " & - "failed content check"); - end if; - - if not C432001_1.Check (N_P_Object) then - Report.Failed ("Object of " & - "private extension of nonprivate type " & - "failed content check"); - end if; - - if not C432001_1.Check (P_N_Object, - C432001_1.Jurassic) then - Report.Failed ("Object of " & - "nonprivate extension of private type " & - "failed content check"); - end if; - - if not C432001_1.Check (P_P_Object) then - Report.Failed ("Object of " & - "private extension of private type " & - "failed content check"); - end if; - - if not C432001_1.Check (P_P_Null_Ob) then - Report.Failed ("Object of " & - "private type " & - "failed content check"); - end if; - - - -- check direct extensions of extensions - - if not C432001_2.Check (N_N_N_Object, - 375, - C432001_0.Paleozoic, - C432001_1.Devonian, - True) then - Report.Failed ("Object of " & - "nonprivate extension of nonprivate extension " & - "(of nonprivate parent) " & - "failed content check"); - end if; - - if not C432001_2.Check (N_P_N_Object, False) then - Report.Failed ("Object of " & - "nonprivate extension of private extension " & - "(of nonprivate parent) " & - "failed content check"); - end if; - - if not C432001_2.Check (P_N_N_Object, - C432001_1.Jurassic, - True) then - Report.Failed ("Object of " & - "nonprivate extension of nonprivate extension " & - "(of private parent) " & - "failed content check"); - end if; - - if not C432001_2.Check (P_P_N_Object, False) then - Report.Failed ("Object of " & - "nonprivate extension of private extension " & - "(of private parent) " & - "failed content check"); - end if; - - -- check that the extension aggregate may specify an expression of - -- a "grandparent" ancestor type - - -- types tested are derived through nonprivate extensions only - -- (extension aggregates are not allowed if the path from the - -- ancestor type wanders through a private extension) - - N_N_N_Object := - (N_Object with Period => C432001_1.Devonian, - Sample_On_Loan => Report.Ident_Bool(True)); - - if not C432001_2.Check (N_N_N_Object, - 375, - C432001_0.Paleozoic, - C432001_1.Devonian, - True) then - Report.Failed ("Object of " & - "nonprivate extension " & - "of nonprivate ancestor " & - "failed content check"); - end if; - - P_N_N_Object := - (P_Object with Period => C432001_1.Jurassic, - Sample_On_Loan => Report.Ident_Bool(True)); - - if not C432001_2.Check (P_N_N_Object, - C432001_1.Jurassic, - True) then - Report.Failed ("Object of " & - "nonprivate extension " & - "of private ancestor " & - "failed content check"); - end if; - - -- Check additional cases - if not C432001_1.Check (P_N_Object_2, - C432001_1.Carboniferous) then - Report.Failed ("Additional Object of " & - "nonprivate extension of private type " & - "failed content check"); - end if; - - if not C432001_1.Check (N_N_Object_2, - 42, - C432001_0.Precambrian, - C432001_1.Carboniferous) then - Report.Failed ("Additional Object of " & - "nonprivate extension of nonprivate type " & - "failed content check"); - end if; - - Report.Result; - -end C432001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432002.a b/gcc/testsuite/ada/acats/tests/c4/c432002.a deleted file mode 100644 index 5de821b3052..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c432002.a +++ /dev/null @@ -1,764 +0,0 @@ --- C432002.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 an extension aggregate specifies a value for a record --- extension and the ancestor expression has discriminants that are --- inherited by the record extension, then a check is made that each --- discriminant has the value specified. --- --- Check that if an extension aggregate specifies a value for a record --- extension and the ancestor expression has discriminants that are not --- inherited by the record extension, then a check is made that each --- such discriminant has the value specified for the corresponding --- discriminant. --- --- Check that the corresponding discriminant value may be specified --- in the record component association list or in the derived type --- definition for an ancestor. --- --- Check the case of ancestors that are several generations removed. --- Check the case where the value of the discriminant(s) in question --- is supplied several generations removed. --- --- Check the case of multiple discriminants. --- --- Check that Constraint_Error is raised if the check fails. --- --- TEST DESCRIPTION: --- A hierarchy of tagged types is declared from a discriminated --- root type. Each level declares two kinds of types: (1) a type --- extension which constrains the discriminant of its parent to --- the value of an expression and (2) a type extension that --- constrains the discriminant of its parent to equal a new discriminant --- of the type extension (These are the two categories of noninherited --- discriminants). --- --- Values for each type are declared within nested blocks. This is --- done so that the instances that produce Constraint_Error may --- be dealt with cleanly without forcing the program to exit. --- --- Success and failure cases (which should raise Constraint_Error) --- are set up for each kind of type. Additionally, for the first --- level of the hierarchy, separate tests are done for ancestor --- expressions specified by aggregates and those specified by --- variables. Later tests are performed using variables only. --- --- Additionally, the cases tested consist of the following kinds of --- types: --- --- Extensions of extensions, using both the parent and grandparent --- types for the ancestor expression, --- --- Ancestor expressions which are several generations removed --- from the type of the aggregate, --- --- Extensions of types with multiple discriminants, where the --- extension declares a new discriminant which corresponds to --- more than one discriminant of the ancestor types. --- --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants --- ---! - -package C432002_0 is - - subtype Length is Natural range 0..256; - type Discriminant (L : Length) is tagged - record - S1 : String (1..L); - end record; - - procedure Do_Something (Rec : in out Discriminant); - -- inherited by all type extensions - - -- Aggregates of Discriminant are of the form - -- (L, S1) where L= S1'Length - - -- Discriminant of parent constrained to value of an expression - type Constrained_Discriminant_Extension is - new Discriminant (L => 10) - with record - S2 : String (1..20); - end record; - - -- Aggregates of Constrained_Discriminant_Extension are of the form - -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20 - - type Once_Removed is new Constrained_Discriminant_Extension - with record - S3 : String (1..3); - end record; - - type Twice_Removed is new Once_Removed - with record - S4 : String (1..8); - end record; - - -- Aggregates of Twice_Removed are of the form - -- (L, S1, S2, S3, S4), where L = S1'Length = 10, - -- S2'Length = 20, - -- S3'Length = 3, - -- S4'Length = 8 - - -- Discriminant of parent constrained to equal new discriminant - type New_Discriminant_Extension (N : Length) is - new Discriminant (L => N) with - record - S2 : String (1..N); - end record; - - -- Aggregates of New_Discriminant_Extension are of the form - -- (N, S1, S2), where N = S1'Length = S2'Length - - -- Discriminant of parent extension constrained to the value of - -- an expression - type Constrained_Extension_Extension is - new New_Discriminant_Extension (N => 20) - with record - S3 : String (1..5); - end record; - - -- Aggregates of Constrained_Extension_Extension are of the form - -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20, - -- S3'Length = 5 - - -- Discriminant of parent extension constrained to equal a new - -- discriminant - type New_Extension_Extension (I : Length) is - new New_Discriminant_Extension (N => I) - with record - S3 : String (1..I); - end record; - - -- Aggregates of New_Extension_Extension are of the form - -- (I, S1, 2, S3), where - -- I = S1'Length = S2'Length = S3'Length - - type Multiple_Discriminants (A, B : Length) is tagged - record - S1 : String (1..A); - S2 : String (1..B); - end record; - - procedure Do_Something (Rec : in out Multiple_Discriminants); - -- inherited by type extension - - -- Aggregates of Multiple_Discriminants are of the form - -- (A, B, S1, S2), where A = S1'Length, B = S2'Length - - type Multiple_Discriminant_Extension (C : Length) is - new Multiple_Discriminants (A => C, B => C) - with record - S3 : String (1..C); - end record; - - -- Aggregates of Multiple_Discriminant_Extension are of the form - -- (A, B, S1, S2, C, S3), where - -- A = B = C = S1'Length = S2'Length = S3'Length - -end C432002_0; - -with Report; -package body C432002_0 is - - S : String (1..20) := "12345678901234567890"; - - procedure Do_Something (Rec : in out Discriminant) is - begin - Rec.S1 := Report.Ident_Str (S (1..Rec.L)); - end Do_Something; - - procedure Do_Something (Rec : in out Multiple_Discriminants) is - begin - Rec.S1 := Report.Ident_Str (S (1..Rec.A)); - end Do_Something; - -end C432002_0; - - -with C432002_0; -with Report; -procedure C432002 is - - -- Various different-sized strings for variety - String_3 : String (1..3) := Report.Ident_Str("123"); - String_5 : String (1..5) := Report.Ident_Str("12345"); - String_8 : String (1..8) := Report.Ident_Str("12345678"); - String_10 : String (1..10) := Report.Ident_Str("1234567890"); - String_11 : String (1..11) := Report.Ident_Str("12345678901"); - String_20 : String (1..20) := Report.Ident_Str("12345678901234567890"); - -begin - - Report.Test ("C432002", - "Extension aggregates for discriminated types"); - - -------------------------------------------------------------------- - -- Extension constrains parent's discriminant to value of expression - -------------------------------------------------------------------- - - -- Successful cases - value matches corresponding discriminant value - - CD_Matched_Aggregate: - begin - declare - CD : C432002_0.Constrained_Discriminant_Extension := - (C432002_0.Discriminant'(L => 10, - S1 => String_10) - with S2 => String_20); - begin - C432002_0.Do_Something(CD); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension " & - "with discriminant constrained: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end CD_Matched_Aggregate; - - CD_Matched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 10) := - C432002_0.Discriminant'(L => 10, - S1 => String_10); - - CD : C432002_0.Constrained_Discriminant_Extension := - (D with S2 => String_20); - begin - C432002_0.Do_Something(CD); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is a variable"); - Report.Failed ("Aggregate of extension " & - "with discriminant constrained: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end CD_Matched_Variable; - - - -- Unsuccessful cases - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - CD_Unmatched_Aggregate: - begin - declare - CD : C432002_0.Constrained_Discriminant_Extension := - (C432002_0.Discriminant'(L => 5, - S1 => String_5) - with S2 => String_20); - begin - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension " & - "with discriminant constrained: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(CD); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise of Constraint_Error is expected - end CD_Unmatched_Aggregate; - - CD_Unmatched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 5) := - C432002_0.Discriminant'(L => 5, - S1 => String_5); - - CD : C432002_0.Constrained_Discriminant_Extension := - (D with S2 => String_20); - begin - Report.Comment ("Ancestor expression is an variable"); - Report.Failed ("Aggregate of extension " & - "with discriminant constrained: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(CD); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise of Constraint_Error is expected - end CD_Unmatched_Variable; - - ----------------------------------------------------------------------- - -- Extension constrains parent's discriminant to equal new discriminant - ----------------------------------------------------------------------- - - -- Successful cases - value matches corresponding discriminant value - - ND_Matched_Aggregate: - begin - declare - ND : C432002_0.New_Discriminant_Extension (N => 8) := - (C432002_0.Discriminant'(L => 8, - S1 => String_8) - with N => 8, - S2 => String_8); - begin - C432002_0.Do_Something(ND); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension " & - "with new discriminant: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end ND_Matched_Aggregate; - - ND_Matched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 3) := - C432002_0.Discriminant'(L => 3, - S1 => String_3); - - ND : C432002_0.New_Discriminant_Extension (N => 3) := - (D with N => 3, - S2 => String_3); - begin - C432002_0.Do_Something(ND); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is an variable"); - Report.Failed ("Aggregate of extension " & - "with new discriminant: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end ND_Matched_Variable; - - - -- Unsuccessful cases - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - ND_Unmatched_Aggregate: - begin - declare - ND : C432002_0.New_Discriminant_Extension (N => 20) := - (C432002_0.Discriminant'(L => 11, - S1 => String_11) - with N => 20, - S2 => String_20); - begin - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension " & - "with new discriminant: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(ND); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end ND_Unmatched_Aggregate; - - ND_Unmatched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 5) := - C432002_0.Discriminant'(L => 5, - S1 => String_5); - - ND : C432002_0.New_Discriminant_Extension (N => 20) := - (D with N => 20, - S2 => String_20); - begin - Report.Comment ("Ancestor expression is an variable"); - Report.Failed ("Aggregate of extension " & - "with new discriminant: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(ND); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end ND_Unmatched_Variable; - - -------------------------------------------------------------------- - -- Extension constrains parent's discriminant to value of expression - -- Parent is a discriminant extension - -------------------------------------------------------------------- - - -- Successful cases - value matches corresponding discriminant value - - CE_Matched_Aggregate: - begin - declare - CE : C432002_0.Constrained_Extension_Extension := - (C432002_0.Discriminant'(L => 20, - S1 => String_20) - with N => 20, - S2 => String_20, - S3 => String_5); - begin - C432002_0.Do_Something(CE); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension (of extension) " & - "with discriminant constrained: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end CE_Matched_Aggregate; - - CE_Matched_Variable: - begin - declare - ND : C432002_0.New_Discriminant_Extension (N => 20) := - C432002_0.New_Discriminant_Extension' - (N => 20, - S1 => String_20, - S2 => String_20); - - CE : C432002_0.Constrained_Extension_Extension := - (ND with S3 => String_5); - begin - C432002_0.Do_Something(CE); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is a variable"); - Report.Failed ("Aggregate of extension (of extension) " & - "with discriminant constrained: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end CE_Matched_Variable; - - - -- Unsuccessful cases - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - CE_Unmatched_Aggregate: - begin - declare - CE : C432002_0.Constrained_Extension_Extension := - (C432002_0.New_Discriminant_Extension' - (N => 11, - S1 => String_11, - S2 => String_11) - with S3 => String_5); - begin - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension (of extension) " & - "Constraint_Error was not raised " & - "with discriminant constrained: " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(CE); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise of Constraint_Error is expected - end CE_Unmatched_Aggregate; - - CE_Unmatched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 8) := - C432002_0.Discriminant'(L => 8, - S1 => String_8); - - CE : C432002_0.Constrained_Extension_Extension := - (D with N => 8, - S2 => String_8, - S3 => String_5); - begin - Report.Comment ("Ancestor expression is a variable"); - Report.Failed ("Aggregate of extension (of extension) " & - "with discriminant constrained: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(CE); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise of Constraint_Error is expected - end CE_Unmatched_Variable; - - ----------------------------------------------------------------------- - -- Extension constrains parent's discriminant to equal new discriminant - -- Parent is a discriminant extension - ----------------------------------------------------------------------- - - -- Successful cases - value matches corresponding discriminant value - - NE_Matched_Aggregate: - begin - declare - NE : C432002_0.New_Extension_Extension (I => 8) := - (C432002_0.Discriminant'(L => 8, - S1 => String_8) - with I => 8, - S2 => String_8, - S3 => String_8); - begin - C432002_0.Do_Something(NE); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is an aggregate"); - Report.Failed ("Aggregate of extension (of extension) " & - "with new discriminant: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end NE_Matched_Aggregate; - - NE_Matched_Variable: - begin - declare - ND : C432002_0.New_Discriminant_Extension (N => 3) := - C432002_0.New_Discriminant_Extension' - (N => 3, - S1 => String_3, - S2 => String_3); - - NE : C432002_0.New_Extension_Extension (I => 3) := - (ND with I => 3, - S3 => String_3); - begin - C432002_0.Do_Something(NE); -- success - end; - exception - when Constraint_Error => - Report.Comment ("Ancestor expression is a variable"); - Report.Failed ("Aggregate of extension (of extension) " & - "with new discriminant: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end NE_Matched_Variable; - - - -- Unsuccessful cases - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - NE_Unmatched_Aggregate: - begin - declare - NE : C432002_0.New_Extension_Extension (I => 8) := - (C432002_0.New_Discriminant_Extension' - (C432002_0.Discriminant'(L => 11, - S1 => String_11) - with N => 11, - S2 => String_11) - with I => 8, - S3 => String_8); - begin - Report.Comment ("Ancestor expression is an extension aggregate"); - Report.Failed ("Aggregate of extension (of extension) " & - "with new discriminant: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(NE); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end NE_Unmatched_Aggregate; - - NE_Unmatched_Variable: - begin - declare - D : C432002_0.Discriminant(L => 5) := - C432002_0.Discriminant'(L => 5, - S1 => String_5); - - NE : C432002_0.New_Extension_Extension (I => 20) := - (D with I => 5, - S2 => String_5, - S3 => String_20); - begin - Report.Comment ("Ancestor expression is a variable"); - Report.Failed ("Aggregate of extension (of extension) " & - "with new discriminant: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(NE); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end NE_Unmatched_Variable; - - ----------------------------------------------------------------------- - -- Corresponding discriminant is two levels deeper than aggregate - ----------------------------------------------------------------------- - - -- Successful case - value matches corresponding discriminant value - - TR_Matched_Variable: - begin - declare - D : C432002_0.Discriminant (L => 10) := - C432002_0.Discriminant'(L => 10, - S1 => String_10); - - TR : C432002_0.Twice_Removed := - C432002_0.Twice_Removed'(D with S2 => String_20, - S3 => String_3, - S4 => String_8); - -- N is constrained to a value in the derived_type_definition - -- of Constrained_Discriminant_Extension. Its omission from - -- the above record_component_association_list is allowed by - -- 4.3.2(6). - - begin - C432002_0.Do_Something(TR); -- success - end; - exception - when Constraint_Error => - Report.Failed ("Aggregate of far-removed extension " & - "with discriminant constrained: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end TR_Matched_Variable; - - - -- Unsuccessful case - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - TR_Unmatched_Variable: - begin - declare - D : C432002_0.Discriminant (L => 5) := - C432002_0.Discriminant'(L => 5, - S1 => String_5); - - TR : C432002_0.Twice_Removed := - C432002_0.Twice_Removed'(D with S2 => String_20, - S3 => String_3, - S4 => String_8); - - begin - Report.Failed ("Aggregate of far-removed extension " & - "with discriminant constrained: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(TR); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end TR_Unmatched_Variable; - - ------------------------------------------------------------------------ - -- Parent has multiple discriminants. - -- Discriminant in extension corresponds to both parental discriminants. - ------------------------------------------------------------------------ - - -- Successful case - value matches corresponding discriminant value - - MD_Matched_Variable: - begin - declare - MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) := - C432002_0.Multiple_Discriminants'(A => 10, - B => 10, - S1 => String_10, - S2 => String_10); - MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := - (MD with C => 10, - S3 => String_10); - - begin - C432002_0.Do_Something(MDE); -- success - end; - exception - when Constraint_Error => - Report.Failed ("Aggregate of extension " & - "of multiply-discriminated parent: " & - "Constraint_Error was incorrectly raised " & - "for value that matches corresponding " & - "discriminant"); - end MD_Matched_Variable; - - - -- Unsuccessful case - value does not match value of corresponding - -- discriminant. Constraint_Error should be - -- raised. - - MD_Unmatched_Variable: - begin - declare - MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) := - C432002_0.Multiple_Discriminants'(A => 10, - B => 8, - S1 => String_10, - S2 => String_8); - MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := - (MD with C => 10, - S3 => String_10); - - begin - Report.Failed ("Aggregate of extension " & - "of multiply-discriminated parent: " & - "Constraint_Error was not raised " & - "for discriminant value that does not match " & - "corresponding discriminant"); - C432002_0.Do_Something(MDE); -- disallow unused var optimization - end; - exception - when Constraint_Error => - null; -- raise is expected - end MD_Unmatched_Variable; - - Report.Result; - -end C432002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc/testsuite/ada/acats/tests/c4/c432003.a deleted file mode 100644 index 8988992c4e4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c432003.a +++ /dev/null @@ -1,594 +0,0 @@ --- C432003.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 the type of the ancestor part of an extension aggregate --- has discriminants that are not inherited by the type of the aggregate, --- and the ancestor part is a subtype mark that denotes a constrained --- subtype, Constraint_Error is raised if: 1) any discriminant of the --- ancestor has a different value than that specified for a corresponding --- discriminant in the derived type definition for some ancestor of the --- type of the aggregate, or 2) the value for the discriminant in the --- record association list is not the value of the corresponding --- discriminant. Check that the components of the value of the --- aggregate not given by the record component association list are --- initialized by default as for an object of the ancestor type. --- --- TEST DESCRIPTION: --- Consider: --- --- type T (D1: ...) is tagged ... --- --- type DT is new T with ... --- subtype ST is DT (D1 => 3); -- Constrained subtype. --- --- type NT1 (D2: ...) is new DT (D1 => D2) with null record; --- type NT2 (D2: ...) is new DT (D1 => 6) with null record; --- type NT3 is new DT (D1 => 6) with null record; --- --- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained. --- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained. --- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2. --- --- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained. --- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained. --- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2. --- --- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained. --- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained. --- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3. --- --- In A, B, D, E, G, and H the ancestor part is the name of an --- unconstrained subtype, so this rule does not apply. In C, F, and I --- the ancestor part (ST) is the name of a constrained subtype of DT, --- which is itself a derived type of a discriminated tagged type T. ST --- constrains the discriminant of DT (D1) to the value 3; thus, the --- type of any extension aggregate for which ST is the ancestor part --- must have an ancestor which also constrained D1 to 3. F and I raise --- Constraint_Error because NT2 and NT3, respectively, constrain D1 to --- 6. C raises Constraint_Error because NT1 constrains D1 to the value --- of D2, which is set to 6 in the record component association list of --- the aggregate. --- --- This test verifies each of the three scenarios above: --- --- (1) Ancestor of type of aggregate constrains discriminant with --- new discriminant. --- (2) Ancestor of type of aggregate constrains discriminant with --- value, and has a new discriminant part. --- (3) Ancestor of type of aggregate constrains discriminant with --- value, and has no discriminant part. --- --- Verification is made for cases where the type of the aggregate is --- once- and twice-removed from the type of the ancestor part. --- --- Additionally, a case is included where a new discriminant corresponds --- to multiple discriminants of the type of the ancestor part. --- --- To test the portion of the objective concerning "initialization by --- default," the test verifies that, after a successful aggregate --- assignment, components not assigned an explicit value by the aggregate --- contain the default values for the corresponding components of the --- ancestor type. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 15 Dec 94 SAIC Removed discriminant defaults from tagged types. --- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint --- for component NT_C3.Str2. Added missing component --- checks. Removed record component update from --- Avoid_Optimization. Fixed incorrect component --- checks. --- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for --- Q case. --- ---! - -package C432003_0 is - - Default_String : constant String := "This is a default string"; -- len = 24 - Another_String : constant String := "Another default string"; -- len = 22 - - subtype Length is Natural range 0..255; - - type ROOT (D1 : Length) is tagged - record - S1 : String (1..D1) := Default_String(1..D1); - Acc : Natural := 356; - end record; - - procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type - -- extensions. - - type Unconstrained_Der is new ROOT with - record - Str1 : String(1..5) := "abcde"; - end record; - - subtype Constrained_Subtype is Unconstrained_Der (D1 => 10); - - type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with - record - S2 : String(1..D2); -- Inherited discrim. constrained by - end record; -- new discriminant. - - type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with - record - S3 : String(1..D3); -- Inherited discrim. constrained by - end record; -- new discriminant. - - - type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with - record - S2 : String(1..D2); -- Inherited discrim. constrained by - end record; -- explicit value. - - type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with - record - S3 : String(1..D3); -- Inherited discrim. constrained by - end record; -- explicit value. - - type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with - record - S2 : String(1..D2); - end record; - - - type NT_C1 is new Unconstrained_Der (D1 => 5) with - record - Str2 : String(1..5); -- Inherited discrim. constrained - end record; -- No new value. - - type NT_C2 (D2 : Length) is new NT_C1 with - record - S2 : String(1..D2); -- Inherited discrim. not further - end record; -- constrained, new discriminant. - - type NT_C3 is new Unconstrained_Der(D1 => 10) with - record - Str2 : String(1..5); - end record; - - - type MULTI_ROOT (D1 : Length; D2 : Length) is tagged - record - S1 : String (1..D1) := Default_String(1..D1); - S2 : String (1..D2) := Another_String(1..D2); - end record; - - procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all - -- type extensions. - - type Mult_Unconstr_Der is new MULTI_ROOT with - record - Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints. - end record; - - -- Subtypes with constrained discriminants. - subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have - D2 => 20); -- diff values - - subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have - D2 => 15); -- same value - - type Mult_NT_A1 (D3 : Length) is - new Mult_Unconstr_Der (D1 => D3, D2 => D3) with - record - S3 : String(1..D3); -- Both inherited discriminants constrained - end record; -- by new discriminant. - -end C432003_0; - - - --=====================================================================-- - - -with Report; -package body C432003_0 is - - procedure Avoid_Optimization (Rec : in out ROOT) is - begin - Rec.S1 := Report.Ident_Str(Rec.S1); - end Avoid_Optimization; - - procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is - begin - Rec.S1 := Report.Ident_Str(Rec.S1); - end Avoid_Optimization; - -end C432003_0; - - - --=====================================================================-- - - -with C432003_0; -with Report; -procedure C432003 is -begin - - Report.Test("C432003", "Extension aggregates where ancestor part " & - "is a subtype mark that denotes a constrained " & - "subtype causing Constraint_Error if any " & - "discriminant of the ancestor has a different " & - "value than that specified for a corresponding " & - "discriminant in the derived type definition " & - "for some ancestor of the type of the aggregate"); - - Test_Block: - declare - - -- Variety of string object declarations. - String2 : String(1..2) := Report.Ident_Str("12"); - String5 : String(1..5) := Report.Ident_Str("12345"); - String8 : String(1..8) := Report.Ident_Str("AbCdEfGh"); - String10 : String(1..10) := Report.Ident_Str("1234567890"); - String15 : String(1..15) := Report.Ident_Str("123456789012345"); - String20 : String(1..20) := Report.Ident_Str("12345678901234567890"); - - begin - - - begin - declare - A : C432003_0.NT_A1 := -- OK - (C432003_0.ROOT with D2 => 5, - Str1 => "cdefg", - S2 => String5); - begin - C432003_0.Avoid_Optimization(A); - if A.Acc /= 356 or - A.Str1 /= "cdefg" or - A.S2 /= String5 or - A.D2 /= 5 or - A.S1 /= C432003_0.Default_String(1..5) - then - Report.Failed("Incorrect object values for Object A"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object A"); - end; - - - begin - declare - C: C432003_0.NT_A1 := -- OK - (C432003_0.Constrained_Subtype with D2 => 10, - S2 => String10); - begin - C432003_0.Avoid_Optimization(C); - if C.D2 /= 10 or C.Acc /= 356 or - C.Str1 /= "abcde" or C.S2 /= String10 or - C.S1 /= C432003_0.Default_String(1..10) - then - Report.Failed("Incorrect object values for Object C"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object C"); - end; - - - begin - declare - D: C432003_0.NT_A1 := -- C_E - (C432003_0.Constrained_Subtype with - D2 => Report.Ident_Int(5), - S2 => String5); - begin - C432003_0.Avoid_Optimization(D); - Report.Failed("Constraint_Error not raised for Object D"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - E: C432003_0.NT_A2 := -- OK - (C432003_0.Constrained_Subtype with D3 => 10, - S2 => String10, - S3 => String10); - begin - C432003_0.Avoid_Optimization(E); - if E.D3 /= 10 or E.Acc /= 356 or - E.Str1 /= "abcde" or E.S2 /= String10 or - E.S3 /= String10 or - E.S1 /= C432003_0.Default_String(1..10) - then - Report.Failed("Incorrect object values for Object E"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object E"); - end; - - - begin - declare - F: C432003_0.NT_A2 := -- C_E - (C432003_0.Constrained_Subtype with - D3 => Report.Ident_Int(5), - S2 => String5, - S3 => String5); - begin - C432003_0.Avoid_Optimization(F); - Report.Failed("Constraint_Error not raised for Object F"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - G: C432003_0.NT_B2 := -- OK - (C432003_0.ROOT with D3 => 5, - Str1 => "cdefg", - S2 => String10, - S3 => String5); - begin - C432003_0.Avoid_Optimization(G); - if G.D3 /= 5 or G.Acc /= 356 or - G.Str1 /= "cdefg" or G.S2 /= String10 or - G.S3 /= String5 or - G.S1 /= C432003_0.Default_String(1..5) - then - Report.Failed("Incorrect object values for Object G"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object G"); - end; - - - begin - declare - H: C432003_0.NT_B3 := -- OK - (C432003_0.Unconstrained_Der with D2 => 5, - S2 => String5); - begin - C432003_0.Avoid_Optimization(H); - if H.D2 /= 5 or H.Acc /= 356 or - H.Str1 /= "abcde" or H.S2 /= String5 or - H.S1 /= C432003_0.Default_String(1..10) - then - Report.Failed("Incorrect object values for Object H"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object H"); - end; - - - begin - declare - I: C432003_0.NT_B1 := -- C_E - (C432003_0.Constrained_Subtype with - D2 => Report.Ident_Int(10), - S2 => String10); - begin - C432003_0.Avoid_Optimization(I); - Report.Failed("Constraint_Error not raised for Object I"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - J: C432003_0.NT_B2 := -- C_E - (C432003_0.Constrained_Subtype with - D3 => Report.Ident_Int(10), - S2 => String10, - S3 => String10); - begin - C432003_0.Avoid_Optimization(J); - Report.Failed("Constraint_Error not raised by Object J"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - K: C432003_0.NT_B3 := -- OK - (C432003_0.Constrained_Subtype with D2 => 5, - S2 => String5); - begin - C432003_0.Avoid_Optimization(K); - if K.D2 /= 5 or K.Acc /= 356 or - K.Str1 /= "abcde" or K.S2 /= String5 or - K.S1 /= C432003_0.Default_String(1..10) - then - Report.Failed("Incorrect object values for Object K"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object K"); - end; - - - begin - declare - M: C432003_0.NT_C2 := -- OK - (C432003_0.ROOT with D2 => 10, - Str1 => "cdefg", - Str2 => String5, - S2 => String10); - begin - C432003_0.Avoid_Optimization(M); - if M.D2 /= 10 or M.Acc /= 356 or - M.Str1 /= "cdefg" or M.S2 /= String10 or - M.Str2 /= String5 or - M.S1 /= C432003_0.Default_String(1..5) - then - Report.Failed("Incorrect object values for Object M"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object M"); - end; - - - begin - declare - O: C432003_0.NT_C1 := -- C_E - (C432003_0.Constrained_Subtype with - Str2 => Report.Ident_Str(String5)); - begin - C432003_0.Avoid_Optimization(O); - Report.Failed("Constraint_Error not raised for Object O"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - P: C432003_0.NT_C2 := -- C_E - (C432003_0.Constrained_Subtype with - D2 => Report.Ident_Int(10), - Str2 => String5, - S2 => String10); - begin - C432003_0.Avoid_Optimization(P); - Report.Failed("Constraint_Error not raised by Object P"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - Q: C432003_0.NT_C3 := - (C432003_0.Constrained_Subtype with Str2 => String5); -- OK - begin - C432003_0.Avoid_Optimization(Q); - if Q.Str2 /= String5 or - Q.Acc /= 356 or - Q.Str1 /= "abcde" or - Q.D1 /= 10 or - Q.S1 /= C432003_0.Default_String(1..10) - then - Report.Failed("Incorrect object values for Object Q"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object Q"); - end; - - - -- The following cases test where a new discriminant corresponds - -- to multiple discriminants of the type of the ancestor part. - - begin - declare - S: C432003_0.Mult_NT_A1 := -- OK - (C432003_0.Mult_Unconstr_Der with D3 => 15, - S3 => String15); - begin - C432003_0.Avoid_Optimization(S); - if S.S1 /= C432003_0.Default_String(1..15) or - S.Str1 /= String8 or - S.S2 /= C432003_0.Another_String(1..15) or - S.S3 /= String15 or - S.D3 /= 15 - then - Report.Failed("Incorrect object values for Object S"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object S"); - end; - - - begin - declare - U: C432003_0.Mult_NT_A1 := -- C_E - (C432003_0.Mult_Constr_Sub1 with - D3 => Report.Ident_Int(15), - S3 => String15); - begin - C432003_0.Avoid_Optimization(U); - Report.Failed("Constraint_Error not raised for Object U"); - end; - exception - when Constraint_Error => - null; -- Raise of Constraint_Error is expected. - end; - - - begin - declare - V: C432003_0.Mult_NT_A1 := -- OK - (C432003_0.Mult_Constr_Sub2 with D3 => 15, - S3 => String15); - begin - C432003_0.Avoid_Optimization(V); - if V.D3 /= 15 or - V.Str1 /= String8 or - V.S3 /= String15 or - V.S1 /= C432003_0.Default_String(1..15) or - V.S2 /= C432003_0.Another_String(1..15) - then - Report.Failed("Incorrect object values for Object V"); - end if; - end; - exception - when Constraint_Error => - Report.Failed("Constraint_Error raised for Object V"); - end; - - - exception - when others => Report.Failed("Exception raised in Test_Block"); - end Test_Block; - - Report.Result; - -end C432003; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432004.a b/gcc/testsuite/ada/acats/tests/c4/c432004.a deleted file mode 100644 index 3a148621115..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c432004.a +++ /dev/null @@ -1,319 +0,0 @@ --- C432004.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 type of an extension aggregate may be derived from the --- type of the ancestor part through multiple record extensions. Check --- for ancestor parts that are subtype marks. Check that the type of the --- ancestor part may be abstract. --- --- TEST DESCRIPTION: --- This test defines the following type hierarchies: --- --- (A) (F) --- Abstract Abstract --- Tagged record Tagged private --- / \ / \ --- / (C) (G) \ --- (B) Abstract Abstract (H) --- Record private record Private --- extension extension extension extension --- | | | | --- (D) (E) (I) (J) --- Record Record Record Record --- extension extension extension extension --- --- Extension aggregates for B, D, E, I, and J are constructed using each --- of its ancestor types as the ancestor part (except for E and J, for --- which only the immediate ancestor is used, since using A and F, --- respectively, as the ancestor part would be illegal). --- --- X1 : B := (A with ...); --- X2 : D := (A with ...); X5 : I := (F with ...); --- X3 : D := (B with ...); X6 : I := (G with ...); --- X4 : E := (C with ...); X7 : J := (H with ...); --- --- For each assignment of an aggregate, the value of the target object is --- checked to ensure that the proper values for each component were --- assigned. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C432004_0 is - - type Drawers is record - Building : natural; - end record; - - type Location is access Drawers; - - type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); - - type SampleType_A is abstract tagged record - Era : Eras := Cenozoic; - Loc : Location; - end record; - - type SampleType_F is abstract tagged private; - - -- The following function is needed to verify the values of the - -- private components. - function TC_Correct_Result (Rec : SampleType_F'Class; - E : Eras) return Boolean; - -private - type SampleType_F is abstract tagged record - Era : Eras := Mesozoic; - end record; - -end C432004_0; - - --==================================================================-- - -package body C432004_0 is - - function TC_Correct_Result (Rec : SampleType_F'Class; - E : Eras) return Boolean is - begin - return (Rec.Era = E); - end TC_Correct_Result; - -end C432004_0; - - --==================================================================-- - -with C432004_0; -package C432004_1 is - - type Periods is - (Aphebian, Helikian, Hadrynian, - Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, - Triassic, Jurassic, Cretaceous, - Tertiary, Quaternary); - - type SampleType_B is new C432004_0.SampleType_A with record - Period : Periods := Quaternary; - end record; - - type SampleType_C is abstract new C432004_0.SampleType_A with private; - - -- The following function is needed to verify the values of the - -- extension's private components. - function TC_Correct_Result (Rec : SampleType_C'Class; - P : Periods) return Boolean; - - type SampleType_G is abstract new C432004_0.SampleType_F with record - Period : Periods := Jurassic; - Loc : C432004_0.Location; - end record; - - type SampleType_H is new C432004_0.SampleType_F with private; - - -- The following function is needed to verify the values of the - -- extension's private components. - function TC_Correct_Result (Rec : SampleType_H'Class; - P : Periods; - E : C432004_0.Eras) return Boolean; - -private - type SampleType_C is abstract new C432004_0.SampleType_A with record - Period : Periods := Quaternary; - end record; - - type SampleType_H is new C432004_0.SampleType_F with record - Period : Periods := Jurassic; - end record; - -end C432004_1; - - --==================================================================-- - -package body C432004_1 is - - function TC_Correct_Result (Rec : SampleType_C'Class; - P : Periods) return Boolean is - begin - return (Rec.Period = P); - end TC_Correct_Result; - - ------------------------------------------------------------- - function TC_Correct_Result (Rec : SampleType_H'Class; - P : Periods; - E : C432004_0.Eras) return Boolean is - begin - return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E); - end TC_Correct_Result; - -end C432004_1; - - --==================================================================-- - -with C432004_0; -with C432004_1; -package C432004_2 is - - -- All types herein are record extensions, since aggregates - -- cannot be given for private extensions - - type SampleType_D is new C432004_1.SampleType_B with record - Sample_On_Loan : Boolean := False; - end record; - - type SampleType_E is new C432004_1.SampleType_C - with null record; - - type SampleType_I is new C432004_1.SampleType_G with record - Sample_On_Loan : Boolean := True; - end record; - - type SampleType_J is new C432004_1.SampleType_H with record - Sample_On_Loan : Boolean := True; - end record; - -end C432004_2; - - - --==================================================================-- - -with Report; -with C432004_0; -with C432004_1; -with C432004_2; -use C432004_1; -use C432004_2; - -procedure C432004 is - - -- Variety of extension aggregates. - - -- Default values for the components of SampleType_A - -- (Era => Cenozoic, Loc => null). - Sample_B : SampleType_B - := (C432004_0.SampleType_A with Period => Devonian); - - -- Default values from SampleType_A (Era => Cenozoic, Loc => null). - Sample_D1 : SampleType_D - := (C432004_0.SampleType_A with Period => Cambrian, - Sample_On_Loan => True); - - -- Default values from SampleType_A and SampleType_B - -- (Era => Cenozoic, Loc => null, Period => Quaternary). - Sample_D2 : SampleType_D - := (SampleType_B with Sample_On_Loan => True); - - -- Default values from SampleType_A and SampleType_C - -- (Era => Cenozoic, Loc => null, Period => Quaternary). - Sample_E : SampleType_E - := (SampleType_C with null record); - - -- Default value from SampleType_F (Era => Mesozoic). - Sample_I1 : SampleType_I - := (C432004_0.SampleType_F with Period => Tertiary, - Loc => new C432004_0.Drawers'(Building => 9), - Sample_On_Loan => False); - - -- Default values from SampleType_F and SampleType_G - -- (Era => Mesozoic, Period => Jurassic, Loc => null). - Sample_I2 : SampleType_I - := (SampleType_G with Sample_On_Loan => False); - - -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic). - Sample_J : SampleType_J - := (SampleType_H with Sample_On_Loan => False); - - use type C432004_0.Eras; - use type C432004_0.Location; - -begin - - Report.Test ("C432004", "Check that the type of an extension aggregate " & - "may be derived from the type of the ancestor part through " & - "multiple record extensions"); - - if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then - Report.Failed ("Object of record extension of abstract ancestor, " & - "SampleType_B, failed content check"); - end if; - - ------------------- - if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null, - Period => Cambrian, Sample_On_Loan => True) then - Report.Failed ("Object 1 of record extension of record extension, " & - "of abstract ancestor, SampleType_D, failed content " & - "check"); - end if; - - ------------------- - if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then - Report.Failed ("Object 2 of record extension of record extension, " & - "of abstract ancestor, SampleType_D, failed content " & - "check"); - end if; - ------------------- - if Sample_E.Era /= C432004_0.Cenozoic or - Sample_E.Loc /= null or - not TC_Correct_Result (Sample_E, Quaternary) then - Report.Failed ("Object of record extension of abstract private " & - "extension of abstract ancestor, SampleType_E, " & - "failed content check"); - end if; - - ------------------- - if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or - Sample_I1.Period /= Tertiary or - Sample_I1.Loc.Building /= 9 or - Sample_I1.Sample_On_Loan /= False then - Report.Failed ("Object 1 of record extension of abstract record " & - "extension of abstract private ancestor, " & - "SampleType_I, failed content check"); - end if; - - ------------------- - if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or - Sample_I2.Period /= Jurassic or - Sample_I2.Loc /= null or - Sample_I2.Sample_On_Loan /= False then - Report.Failed ("Object 2 of record extension of abstract record " & - "extension of abstract private ancestor, " & - "SampleType_I, failed content check"); - end if; - - ------------------- - if not TC_Correct_Result (Sample_J, - Jurassic, - C432004_0.Mesozoic) or - Sample_J.Sample_On_Loan /= False then - Report.Failed ("Object of record extension of private extension " & - "of abstract private ancestor, SampleType_J, " & - "failed content check"); - end if; - - Report.Result; - -end C432004; diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a deleted file mode 100644 index 613b688c8ca..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c433001.a +++ /dev/null @@ -1,302 +0,0 @@ --- C433001.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 others choice is allowed in an array aggregate whose --- applicable index constraint is dynamic. (This was an extension to --- Ada 83). Check that index choices are within the applicable index --- constraint for array aggregates with others choices. --- --- TEST DESCRIPTION --- In this test, we declare several unconstrained array types, and --- several dynamic subtypes. We then test a variety of cases of using --- appropriate aggregates. Some cases expect to raise Constraint_Error. --- --- HISTORY: --- 16 DEC 1999 RLB Initial Version. - -with Report; -procedure C433001 is - - type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); - - type Array_1 is array (Positive range <>) of Integer; - - subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3)); - subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5)); - subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9)); - - type Array_2 is array (Color_Type range <>) of Integer; - - subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) .. - Color_Type'Val(Report.Ident_Int(2))); - -- Red .. Yellow - subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) .. - Color_Type'Val(Report.Ident_Int(6))); - -- Green .. Violet - type Array_3 is array (Color_Type range <>, Positive range <>) of Integer; - - subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) .. - Color_Type'Val(Report.Ident_Int(2)), - Report.Ident_Int(3) .. Report.Ident_Int(5)); - -- Red .. Yellow, 3 .. 5 - subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) .. - Color_Type'Val(Report.Ident_Int(3)), - Report.Ident_Int(6) .. Report.Ident_Int(8)); - -- Orange .. Green, 6 .. 8 - - procedure Check_1 (Obj : Array_1; Low, High : Integer; - First_Component, Second_Component, - Last_Component : Integer; - Test_Case : Character) is - begin - if Obj'First /= Low then - Report.Failed ("Low bound incorrect (" & Test_Case & ")"); - end if; - if Obj'Last /= High then - Report.Failed ("High bound incorrect (" & Test_Case & ")"); - end if; - if Obj(Low) /= First_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - if Obj(Low+1) /= Second_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - if Obj(High) /= Last_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - end Check_1; - - procedure Check_2 (Obj : Array_2; Low, High : Color_Type; - First_Component, Second_Component, - Last_Component : Integer; - Test_Case : Character) is - begin - if Obj'First /= Low then - Report.Failed ("Low bound incorrect (" & Test_Case & ")"); - end if; - if Obj'Last /= High then - Report.Failed ("High bound incorrect (" & Test_Case & ")"); - end if; - if Obj(Low) /= First_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - if Obj(Color_Type'Succ(Low)) /= Second_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - if Obj(High) /= Last_Component then - Report.Failed ("First Component incorrect (" & Test_Case & ")"); - end if; - end Check_2; - - procedure Check_3 (Test_Obj, Check_Obj : Array_3; - Low_1, High_1 : Color_Type; - Low_2, High_2 : Integer; - Test_Case : Character) is - begin - if Test_Obj'First(1) /= Low_1 then - Report.Failed ("Low bound for dimension 1 incorrect (" & - Test_Case & ")"); - end if; - if Test_Obj'Last(1) /= High_1 then - Report.Failed ("High bound for dimension 1 incorrect (" & - Test_Case & ")"); - end if; - if Test_Obj'First(2) /= Low_2 then - Report.Failed ("Low bound for dimension 2 incorrect (" & - Test_Case & ")"); - end if; - if Test_Obj'Last(2) /= High_2 then - Report.Failed ("High bound for dimension 2 incorrect (" & - Test_Case & ")"); - end if; - if Test_Obj /= Check_Obj then - Report.Failed ("Components incorrect (" & Test_Case & ")"); - end if; - end Check_3; - - procedure Subtest_Check_1 (Obj : Sub_1_3; - First_Component, Second_Component, - Last_Component : Integer; - Test_Case : Character) is - begin - Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component, - Test_Case); - end Subtest_Check_1; - - procedure Subtest_Check_2 (Obj : Sub_2_2; - First_Component, Second_Component, - Last_Component : Integer; - Test_Case : Character) is - begin - Check_2 (Obj, Green, Violet, First_Component, Second_Component, - Last_Component, Test_Case); - end Subtest_Check_2; - - procedure Subtest_Check_3 (Obj : Sub_3_2; - Test_Case : Character) is - begin - Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case); - end Subtest_Check_3; - -begin - - Report.Test ("C433001", - "Check that an others choice is allowed in an array " & - "aggregate whose applicable index constraint is dynamic. " & - "Also check index choices are within the applicable index " & - "constraint for array aggregates with others choices"); - - -- Check with a qualified expression: - Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3, - First_Component => 2, Second_Component => 3, Last_Component => 4, - Test_Case => 'A'); - - Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)), - Low => Red, High => Yellow, - First_Component => 1, Second_Component => 6, Last_Component => 6, - Test_Case => 'B'); - - Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)), - Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)), - Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5, - Test_Case => 'C'); - - -- Check that the others clause does not need to represent any components: - Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5, - First_Component => 5, Second_Component => 6, Last_Component => 8, - Test_Case => 'D'); - - -- Check named choices are allowed: - Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8), - Low => 1, High => 3, - First_Component => 8, Second_Component => -1, Last_Component => 8, - Test_Case => 'E'); - - -- Check named choices and formal parameters: - Subtest_Check_1 ((6 => 4, 8 => 86, others => 1), - First_Component => 1, Second_Component => 4, Last_Component => 1, - Test_Case => 'F'); - - Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89, - Indigo => Report.Ident_Int(42), Blue => 0, others => -1), - First_Component => 88, Second_Component => 0, Last_Component => 89, - Test_Case => 'G'); - - Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)), - Test_Case => 'H'); - - -- Check object declarations and assignment: - declare - Var : Sub_1_2 := (4, 36, others => 86); - begin - Check_1 (Var, Low => 3, High => 5, - First_Component => 4, Second_Component => 36, - Last_Component => 86, - Test_Case => 'I'); - Var := (5 => 415, others => Report.Ident_Int(1522)); - Check_1 (Var, Low => 3, High => 5, - First_Component => 1522, Second_Component => 1522, - Last_Component => 415, - Test_Case => 'J'); - end; - - -- Check positional aggregates that are too long: - begin - Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93), - First_Component => 88, Second_Component => 89, - Last_Component => 91, - Test_Case => 'K'); - Report.Failed ("Constraint_Error not raised by positional " & - "aggregate with too many choices (K)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - begin - Subtest_Check_3 (((0, others => 10), (2, 3, others => 4), - (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)), - Test_Case => 'L'); - Report.Failed ("Constraint_Error not raised by positional " & - "aggregate with too many choices (L)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - -- Check named aggregates with choices in the index subtype but not in the - -- applicable index constraint: - - begin - Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89, - 10 => 66, -- 10 not in applicable index constraint - others => 93), - First_Component => 88, Second_Component => 93, - Last_Component => 93, - Test_Case => 'M'); - Report.Failed ("Constraint_Error not raised by aggregate choice " & - "index outside of applicable index constraint (M)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - begin - Subtest_Check_2 ( - (Yellow => 23, -- Yellow not in applicable index constraint. - Blue => 16, others => 77), - First_Component => 77, Second_Component => 16, - Last_Component => 77, - Test_Case => 'N'); - Report.Failed ("Constraint_Error not raised by aggregate choice " & - "index outside of applicable index constraint (N)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - begin - Subtest_Check_3 ((Orange => (0, others => 10), - Blue => (2, 3, others => 4), -- Blue not in applicable index cons. - others => (1, 2, 3)), - Test_Case => 'P'); - Report.Failed ("Constraint_Error not raised by aggregate choice " & - "index outside of applicable index constraint (P)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - begin - Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)), - Green => (8 => 2, 4 => 3, others => 7), - -- 4 not in applicable index cons. - others => (1, 2, 3, others => Report.Ident_Int(10))), - Test_Case => 'Q'); - Report.Failed ("Constraint_Error not raised by aggregate choice " & - "index outside of applicable index constraint (Q)"); - exception - when Constraint_Error => null; -- Expected exception. - end; - - Report.Result; - -end C433001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c450001.a b/gcc/testsuite/ada/acats/tests/c4/c450001.a deleted file mode 100644 index e398ffc6371..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c450001.a +++ /dev/null @@ -1,434 +0,0 @@ --- C450001.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 operations on modular types perform correctly. --- --- Check that loops over the range of a modular type do not over or --- under run the loop. --- --- TEST DESCRIPTION: --- Check logical and arithmetic operations. --- (Attributes are tested elsewhere) --- Checks to make sure that: --- for X in Mod_Type loop --- doesn't do something silly like infinite loop. --- --- --- CHANGE HISTORY: --- 20 SEP 95 SAIC Initial version --- 20 FEB 96 SAIC Added underrun cases for 2.1 --- ---! - ------------------------------------------------------------------ C450001_0 - -package C450001_0 is - - type Unsigned_8_Bit is mod 2**8; - - Shy_By_One : constant := 2**8-1; - - Heavy_By_Two : constant := 2**8+2; - - type Unsigned_Edge_8 is mod Shy_By_One; - - type Unsigned_Over_8 is mod Heavy_By_Two; - - procedure Loop_Check; - - -- embed some calls to Report.Ident_Int: - - function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit; - function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8; - function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8; - -end C450001_0; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with Report; -package body C450001_0 is - - procedure Loop_Check is - Counter_Check : Natural := 0; - begin - for Ever in Unsigned_8_Bit loop - Counter_Check := Report.Ident_Int(Counter_Check) + 1; - if Counter_Check > 2**8 then - Report.Failed("Unsigned_8_Bit loop overrun"); - exit; - end if; - end loop; - - if Counter_Check < 2**8 then - Report.Failed("Unsigned_8_Bit loop underrun"); - end if; - - Counter_Check := 0; - - for Never in Unsigned_Edge_8 loop - Counter_Check := Report.Ident_Int(Counter_Check) + 1; - if Counter_Check > Shy_By_One then - Report.Failed("Unsigned_Edge_8 loop overrun"); - exit; - end if; - end loop; - - if Counter_Check < Shy_By_One then - Report.Failed("Unsigned_Edge_8 loop underrun"); - end if; - - Counter_Check := 0; - - for Getful in reverse Unsigned_Over_8 loop - Counter_Check := Report.Ident_Int(Counter_Check) + 1; - if Counter_Check > Heavy_By_Two then - Report.Failed("Unsigned_Over_8 loop overrun"); - exit; - end if; - end loop; - - if Counter_Check < Heavy_By_Two then - Report.Failed("Unsigned_Over_8 loop underrun"); - end if; - - end Loop_Check; - - function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit is - begin - return Unsigned_8_Bit(Report.Ident_Int(Integer(U8B))); - end ID; - - function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8 is - begin - return Unsigned_Edge_8(Report.Ident_Int(Integer(UEB))); - end ID; - - function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8 is - begin - return Unsigned_Over_8(Report.Ident_Int(Integer(UOB))); - end ID; - -end C450001_0; - -------------------------------------------------------------------- C450001 - -with Report; -with C450001_0; -with TCTouch; -procedure C450001 is - use C450001_0; - - BR : constant String := " produced the wrong result"; - - procedure Is_T(B:Boolean;S:String) renames TCTouch.Assert; - procedure Is_F(B:Boolean;S:String) renames TCTouch.Assert_Not; - - Whole_8_A, Whole_8_B, Whole_8_C : C450001_0.Unsigned_8_Bit; - - Short_8_A, Short_8_B, Short_8_C : C450001_0.Unsigned_Edge_8; - - Over_8_A, Over_8_B, Over_8_C : C450001_0.Unsigned_Over_8; - -begin -- Main test procedure. C450001 - - Report.Test ("C450001", "Check that operations on modular types " & - "perform correctly." ); - - - -- the cases for the whole 8 bit type are pretty simple - - Whole_8_A := 2#00000000#; - Whole_8_B := 2#11111111#; - - Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00000000#,"8 bit and" & BR); - Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); - Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11111111#,"8 bit xor" & BR); - - Whole_8_A := 2#00001111#; - Whole_8_B := 2#11111111#; - - Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00001111#,"8 bit and" & BR); - Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); - Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11110000#,"8 bit xor" & BR); - - Whole_8_A := 2#10101010#; - Whole_8_B := 2#11110000#; - - Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#10100000#,"8 bit and" & BR); - Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111010#,"8 bit or" & BR); - Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#01011010#,"8 bit xor" & BR); - - -- the cases for the partial 8 bit type involve subtracting the modulus - -- from results that exceed the modulus. - -- hence, any of the following operations that exceed 2#11111110# must - -- have 2#11111111# subtracted from the result; i.e. where you would - -- expect to see 2#11111111# as in the above operations, the correct - -- result will be 2#00000000#. Note that 2#11111111# is not a legal - -- value of type C450001_0.Unsigned_Edge_8. - - Short_8_A := 2#11100101#; - Short_8_B := 2#00011111#; - - Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000101#,"8 short and 1" & BR); - Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 1" & BR); - Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#11111010#,"8 short xor 1" & BR); - - Short_8_A := 2#11110000#; - Short_8_B := 2#11111110#; - - Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#11110000#,"8 short and 2" & BR); - Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 2" & BR); - Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00001110#,"8 short xor 2" & BR); - - Short_8_A := 2#10101010#; - Short_8_B := 2#01010101#; - - Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000000#,"8 short and 3" & BR); - Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 3" & BR); - Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00000000#,"8 short xor 3" & BR); - - Short_8_A := 2#10101010#; - Short_8_B := 2#11111110#; - - Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#10101010#,"8 short and 4" & BR); - Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 4" & BR); - Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#01010100#,"8 short xor 4" & BR); - - -- the cases for the over 8 bit type have similar issues to the short type - -- however the bit patterns are a little different. The rule is to subtract - -- the modulus (258) from any resulting value equal or greater than the - -- modulus -- note that 258 = 2#100000010# - - Over_8_A := 2#100000000#; - Over_8_B := 2#011111111#; - - Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000000#,"8 over and" & BR); - Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); - Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111101#,"8 over xor" & BR); - - Over_8_A := 2#100000001#; - Over_8_B := 2#011111111#; - - Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000001#,"8 over and" & BR); - Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); - Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111100#,"8 over xor" & BR); - - - - Whole_8_A := 128; - Whole_8_B := 255; - - Is_T(ID(Whole_8_A) /= ID(Whole_8_B), "8 /=" & BR); - Is_F(ID(Whole_8_A) = ID(Whole_8_B), "8 =" & BR); - - Is_T(ID(Whole_8_A) <= ID(Whole_8_B), "8 <=" & BR); - Is_T(ID(Whole_8_A) < ID(Whole_8_B), "8 < " & BR); - - Is_F(ID(Whole_8_A) >= ID(Whole_8_B), "8 >=" & BR); - Is_T(ID(Whole_8_A) > ID(Whole_8_B + 7), "8 > " & BR); - - Is_T(ID(Whole_8_A) in ID(100)..ID(200), "8 in" & BR); - Is_F(ID(Whole_8_A) not in ID(100)..ID(200), "8 not in" & BR); - - Is_F(ID(Whole_8_A) in ID(200)..ID(250), "8 in" & BR); - Is_T(ID(Whole_8_A) not in ID(200)..ID(250), "8 not in" & BR); - - Short_8_A := 127; - Short_8_B := 254; - - Is_T(ID(Short_8_A) /= ID(Short_8_B), "short 8 /=" & BR); - Is_F(ID(Short_8_A) = ID(Short_8_B), "short 8 =" & BR); - - Is_T(ID(Short_8_A) <= ID(Short_8_B), "short 8 <=" & BR); - Is_T(ID(Short_8_A) < ID(Short_8_B), "short 8 < " & BR); - - Is_F(ID(Short_8_A) >= ID(Short_8_B), "short 8 >=" & BR); - Is_F(ID(Short_8_A) > ID(Short_8_B), "short 8 > " & BR); - - Is_T(ID(Short_8_A) in ID(100)..ID(200), "8 in" & BR); - Is_F(ID(Short_8_A) not in ID(100)..ID(200), "8 not in" & BR); - - Is_F(ID(Short_8_A) in ID(200)..ID(250), "8 in" & BR); - Is_T(ID(Short_8_A) not in ID(200)..ID(250), "8 not in" & BR); - - - Whole_8_A := 1; - Whole_8_B := 254; - Short_8_A := 1; - Short_8_B := 2; - - Whole_8_C := ID(Whole_8_A) + ID(Whole_8_B); - Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 1" & BR); - - Whole_8_C := Whole_8_C + ID(Whole_8_A); - Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'First, "8 binary + 2" & BR); - - Whole_8_C := ID(Whole_8_A) - ID(Whole_8_A); - Is_T(Whole_8_C = 0, "8 binary -" & BR); - - Whole_8_C := Whole_8_C - ID(Whole_8_A); - Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 3" & BR); - - Short_8_C := ID(Short_8_A) + ID(C450001_0.Unsigned_Edge_8'Last); - Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'First, "Short binary + 1" & BR); - - Short_8_C := Short_8_A + ID(Short_8_A); - Is_T(Short_8_C = ID(Short_8_B), "Short binary + 2" & BR); - - Short_8_C := ID(Short_8_A) - ID(Short_8_A); - Is_T(Short_8_C = 0, "Short 8 binary -" & BR); - - Short_8_C := Short_8_C - ID(Short_8_A); - Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short binary + 3" & BR); - - - Whole_8_C := ( + ID(Whole_8_B) ); - Is_T(Whole_8_C = 254, "8 unary +" & BR); - - Whole_8_C := ( - ID(Whole_8_A) ); - Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 unary -" & BR); - - Whole_8_C := ( - ID(0) ); - Is_T(Whole_8_C = 0, "8 unary -0" & BR); - - Short_8_C := ( + ID(C450001_0.Unsigned_Edge_8'Last) ); - Is_T(Short_8_C = 254, "Short 8 unary +" & BR); - - Short_8_C := ( - ID(Short_8_A) ); - Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short 8 unary -" & BR); - - - Whole_8_A := 20; - Whole_8_B := 255; - - Whole_8_C := ID(Whole_8_A) * ID(Whole_8_B); -- 5100 = 19*256 + 236 (256-20) - Is_T(Whole_8_C = 236, "8 *" & BR); - - Short_8_A := 9; - Short_8_B := 254; - - Short_8_C := ID(Short_8_A) * ID(Short_8_B); -- 2286 = 8*255 + 246 (255-9) - Is_T(Short_8_C = 246, "short 8 *" & BR); - - Over_8_A := 12; - Over_8_B := 86; - - Over_8_C := ID(Over_8_A) * ID(Over_8_B); -- 1032 = 4*258 + 0 - Is_T(Over_8_C = 0, "over 8 *" & BR); - - - Whole_8_A := 255; - Whole_8_B := 4; - - Whole_8_C := ID(Whole_8_A) / ID(Whole_8_B); - Is_T(Whole_8_C = 63, "8 /" & BR); - - Short_8_A := 253; - Short_8_B := 127; - - Short_8_C := ID(Short_8_A) / ID(Short_8_B); - Is_T(Short_8_C = 1, "short 8 / 1" & BR); - - Short_8_C := ID(Short_8_A) / ID(126); - Is_T(Short_8_C = 2, "short 8 / 2" & BR); - - - Whole_8_A := 255; - Whole_8_B := 254; - - Whole_8_C := ID(Whole_8_A) rem ID(Whole_8_B); - Is_T(Whole_8_C = 1, "8 rem" & BR); - - Short_8_A := 222; - Short_8_B := 111; - - Short_8_C := ID(Short_8_A) rem ID(Short_8_B); - Is_T(Short_8_C = 0, "short 8 rem" & BR); - - - Whole_8_A := 99; - Whole_8_B := 9; - - Whole_8_C := ID(Whole_8_A) mod ID(Whole_8_B); - Is_T(Whole_8_C = 0, "8 mod" & BR); - - Short_8_A := 254; - Short_8_B := 250; - - Short_8_C := ID(Short_8_A) mod ID(Short_8_B); - Is_T(Short_8_C = 4, "short 8 mod" & BR); - - - Whole_8_A := 99; - - Whole_8_C := abs Whole_8_A; - Is_T(Whole_8_C = ID(99), "8 abs" & BR); - - Short_8_A := 254; - - Short_8_C := ID( abs Short_8_A ); - Is_T(Short_8_C = 254, "short 8 abs" & BR); - - - Whole_8_B := 2#00001111#; - - Whole_8_C := not Whole_8_B; - Is_T(Whole_8_C = ID(2#11110000#), "8 not" & BR); - - Short_8_B := 2#00001111#; -- 15 - - Short_8_C := ID( not Short_8_B ); -- 254 - 15 - Is_T(Short_8_C = 2#11101111#, "short 8 not" & BR); -- 239 - - - Whole_8_A := 2; - - Whole_8_C := Whole_8_A ** 7; - Is_T(Whole_8_C = ID(128), "2 ** 7, whole 8" & BR); - - Whole_8_C := Whole_8_A ** 9; - Is_T(Whole_8_C = ID(0), "2 ** 9, whole 8" & BR); - - Short_8_A := 4; - - Short_8_C := ID( Short_8_A ) ** 4; - Is_T(Short_8_C = 1, "4 ** 4, short" & BR); - - Over_8_A := 4; - - Over_8_C := ID( Over_8_A ) ** 4; - Is_T(Over_8_C = 256, "4 ** 4, over" & BR); - - Over_8_C := ID( Over_8_A ) ** 5; -- 1024 = 3*258 + 250 - Is_T(Over_8_C = 250, "4 ** 5, over" & BR); - - - C450001_0.Loop_Check; - - Report.Result; - -end C450001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c452001.a b/gcc/testsuite/ada/acats/tests/c4/c452001.a deleted file mode 100644 index ec78cd2a5a0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c452001.a +++ /dev/null @@ -1,707 +0,0 @@ --- C452001.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: --- For a type extension, check that predefined equality is defined in --- terms of the primitive equals operator of the parent type and any --- tagged components of the extension part. --- --- For other composite types, check that the primitive equality operator --- of any matching tagged components is used to determine equality of the --- enclosing type. --- --- For private types, check that predefined equality is defined in --- terms of the user-defined (primitive) operator of the full type if --- the full type is tagged. The partial view of the type may be --- tagged or untagged. Check that predefined equality for a private --- type whose full view is untagged is defined in terms of the --- predefined equality operator of its full type. --- --- TEST DESCRIPTION: --- Tagged types are declared and used as components in several --- differing composite type declarations, both tagged and untagged. --- To differentiate between predefined and primitive equality --- operations, user-defined equality operators are declared for --- each component type that is to contribute to the equality --- operator of the composite type that houses it. All user-defined --- equality operations are designed to yield the opposite result --- from the predefined operator, given the same component values. --- --- For cases where primitive equality is to be incorporated into --- equality for the enclosing composite type, values are assigned --- to the component type so that user-defined equality will return --- True. If predefined equality is to be used instead, then the --- same strategy results in the equality operator returning False. --- --- When equality for a type incorporates the user-defined equality --- operator of one of its component types, the resulting operator --- is considered to be the predefined operator of the composite type. --- This case is confirmed by defining an tagged component of an --- untagged composite type, then using the resulting untagged type --- as a component of another composite type. The user-defined operator --- for the lowest level should still be called. --- --- Three cases are set up to test private types: --- --- Case 1 Case 2 Case 3 --- partial view: tagged untagged untagged --- full view: tagged tagged untagged --- --- Types are declared for each of the above cases and user-defined --- (primitive) operators are declared following the full type --- declaration of each type (i.e., in the private part). --- --- Values are assigned into objects of these types using the same --- strategy outlined above. Cases 1 and 2 should execute the --- user-defined operator. Case 3 should ignore the user-defined --- operator and user predefined equality for the type. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed RM references from objective text. --- 15 Nov 95 SAIC Fixed for 2.0.1 --- 04 NOV 96 SAIC Typographical revision --- ---! - -package c452001_0 is - - type Point is - record - X : Integer := 0; - Y : Integer := 0; - end record; - - type Circle is tagged - record - Center : Point; - Radius : Integer; - end record; - - function "=" (L, R : Circle) return Boolean; - - type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White); - - type Colored_Circle is new Circle - with record - Color : Colors := White; - end record; - - function "=" (L, R : Colored_Circle) return Boolean; - -- Override predefined equality for this tagged type. Predefined - -- equality should incorporate user-defined (primitive) equality - -- from type Circle. See C340001 for a test of that feature. - - -- Equality is overridden to ensure that predefined equality - -- incorporates this user-defined function for - -- any composite type with Colored_Circle as a component type. - -- (i.e., the type extension is recognized as a tagged type for - -- the purpose of defining predefined equality for the composite type). - -end C452001_0; - -package body c452001_0 is - - function "=" (L, R : Circle) return Boolean is - begin - return L.Radius = R.Radius; -- circles are same size - end "="; - - function "=" (L, R : Colored_Circle) return Boolean is - begin - return Circle(L) = Circle(R); - end "="; - -end C452001_0; - -with C452001_0; -package C452001_1 is - - type Planet is tagged record - Name : String (1..15); - Representation : C452001_0.Colored_Circle; - end record; - - -- Type Planet will be used to check that predefined equality - -- for a tagged type with a tagged component incorporates - -- user-defined equality for the component type. - - type TC_Planet is new Planet with null record; - - -- A "copy" of Planet. Used to create a type extension. An "=" - -- operator will be defined for this type that should be - -- incorporated by the type extension. - - function "=" (Arg1, Arg2 : in TC_Planet) return Boolean; - - type Craters is array (1..3) of C452001_0.Colored_Circle; - - -- An array type (untagged) with tagged components - - type Moon is new TC_Planet - with record - Crater : Craters; - end record; - - -- A tagged record type. Extended component type is untagged, - -- but its predefined equality operator should incorporate - -- the user-defined operator of its tagged component type. - -end C452001_1; - -package body C452001_1 is - - function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is - begin - return Arg1.Name = Arg2.Name; - end "="; - -end C452001_1; - -package C452001_2 is - - -- Untagged record types - -- Equality should not be incorporated - - type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager); - type Spacecraft is record - Design : Spacecraft_Design; - Operational : Boolean; - end record; - - function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean; - - type Mission is record - Craft : Spacecraft; - Launch_Date : Natural; - end record; - - type Inventory is array (Positive range <>) of Spacecraft; - -end C452001_2; - -package body C452001_2 is - - function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is - begin - return L.Design = R.Design; - end "="; - -end C452001_2; - -package C452001_3 is - - type Tagged_Partial_Tagged_Full is tagged private; - procedure Change (Object : in out Tagged_Partial_Tagged_Full; - Value : in Boolean); - - type Untagged_Partial_Tagged_Full is private; - procedure Change (Object : in out Untagged_Partial_Tagged_Full; - Value : in Integer); - - type Untagged_Partial_Untagged_Full is private; - procedure Change (Object : in out Untagged_Partial_Untagged_Full; - Value : in Duration); - -private - - type Tagged_Partial_Tagged_Full is - tagged record - B : Boolean := True; - C : Character := ' '; - end record; - -- predefined equality checks that all components are equal - - function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean; - -- primitive equality checks that records equate in component C only - - type Untagged_Partial_Tagged_Full is - tagged record - I : Integer := 0; - P : Positive := 1; - end record; - -- predefined equality checks that all components are equal - - function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean; - -- primitive equality checks that records equate in component P only - - type Untagged_Partial_Untagged_Full is - record - D : Duration := 0.0; - S : String (1..12) := "Ada 9X rules"; - end record; - -- predefined equality checks that all components are equal - - function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean; - -- primitive equality checks that records equate in component S only - -end C452001_3; - -with Report; -package body C452001_3 is - - procedure Change (Object : in out Tagged_Partial_Tagged_Full; - Value : in Boolean) is - begin - Object := (Report.Ident_Bool(Value), Object.C); - end Change; - - procedure Change (Object : in out Untagged_Partial_Tagged_Full; - Value : in Integer) is - begin - Object := (Report.Ident_Int(Value), Object.P); - end Change; - - procedure Change (Object : in out Untagged_Partial_Untagged_Full; - Value : in Duration) is - begin - Object := (Value, Report.Ident_Str(Object.S)); - end Change; - - function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is - begin - return L.C = R.C; - end "="; - - function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is - begin - return L.P = R.P; - end "="; - - function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is - begin - return R.S = L.S; - end "="; - -end C452001_3; - - -with C452001_0; -with C452001_1; -with C452001_2; -with C452001_3; -with Report; -procedure C452001 is - - Mars_Aphelion : C452001_1.Planet := - (Name => "Mars ", - Representation => (Center => (Report.Ident_Int(20), - Report.Ident_Int(0)), - Radius => Report.Ident_Int(4), - Color => C452001_0.Red)); - - Mars_Perihelion : C452001_1.Planet := - (Name => "Mars ", - Representation => (Center => (Report.Ident_Int(-20), - Report.Ident_Int(0)), - Radius => Report.Ident_Int(4), - Color => C452001_0.Red)); - - -- Mars_Perihelion = Mars_Aphelion if user-defined equality from - -- the tagged type Colored_Circle was incorporated into - -- predefined equality for the tagged type Planet. User-defined - -- equality for Colored_Circle checks only that the Radii are equal. - - Blue_Mars : C452001_1.Planet := - (Name => "Mars ", - Representation => (Center => (Report.Ident_Int(10), - Report.Ident_Int(10)), - Radius => Report.Ident_Int(4), - Color => C452001_0.Blue)); - - -- Blue_Mars should equal Mars_Perihelion, because Names and - -- Radii are equal (all other components are not). - - Green_Mars : C452001_1.Planet := - (Name => "Mars ", - Representation => (Center => (Report.Ident_Int(10), - Report.Ident_Int(10)), - Radius => Report.Ident_Int(4), - Color => C452001_0.Green)); - - -- Blue_Mars should equal Green_Mars. They differ only in the - -- Color component. All user-defined equality operations return - -- True, but records are not equal by predefined equality. - - -- Blue_Mars should equal Mars_Perihelion, because Names and - -- Radii are equal (all other components are not). - - Moon_Craters : C452001_1.Craters := - ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Black), - (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Black), - (Center => (Report.Ident_Int(11), Report.Ident_Int(9)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Black)); - - Alternate_Moon_Craters : C452001_1.Craters := - ((Center => (Report.Ident_Int(9), Report.Ident_Int(9)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Yellow), - (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Purple), - (Center => (Report.Ident_Int(11), Report.Ident_Int(11)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Purple)); - - -- Moon_Craters = Alternate_Moon_Craters if user-defined equality from - -- the tagged type Colored_Circle was incorporated into - -- predefined equality for the untagged type Craters. User-defined - -- equality checks only that the Radii are equal. - - New_Moon : C452001_1.Moon := - (Name => "Moon ", - Representation => (Center => (Report.Ident_Int(10), - Report.Ident_Int(8)), - Radius => Report.Ident_Int(3), - Color => C452001_0.Black), - Crater => Moon_Craters); - - Full_Moon : C452001_1.Moon := - (Name => "Moon ", - Representation => (Center => (Report.Ident_Int(10), - Report.Ident_Int(8)), - Radius => Report.Ident_Int(3), - Color => C452001_0.Black), - Crater => Alternate_Moon_Craters); - - -- New_Moon = Full_Moon if user-defined equality from - -- the tagged type Colored_Circle was incorporated into - -- predefined equality for the untagged type Craters. This - -- equality test should call user-defined equality for type - -- TC_Planet (checks that Names are equal), then predefined - -- equality for Craters (ultimately calls user-defined equality - -- for type Circle, checking that Radii of craters are equal). - - Mars_Moon : C452001_1.Moon := - (Name => "Phobos ", - Representation => (Center => (Report.Ident_Int(10), - Report.Ident_Int(8)), - Radius => Report.Ident_Int(3), - Color => C452001_0.Black), - Crater => Alternate_Moon_Craters); - - -- Mars_Moon /= Full_Moon since the Names differ. - - Alternate_Moon_Craters_2 : C452001_1.Craters := - ((Center => (Report.Ident_Int(10), Report.Ident_Int(10)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Red), - (Center => (Report.Ident_Int(9), Report.Ident_Int(9)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Red), - (Center => (Report.Ident_Int(10), Report.Ident_Int(9)), - Radius => Report.Ident_Int(1), - Color => C452001_0.Red)); - - Harvest_Moon : C452001_1.Moon := - (Name => "Moon ", - Representation => (Center => (Report.Ident_Int(11), - Report.Ident_Int(7)), - Radius => Report.Ident_Int(4), - Color => C452001_0.Orange), - Crater => Alternate_Moon_Craters_2); - - -- Only the fields that are employed by the user-defined equality - -- operators are the same. Everything else differs. Equality should - -- still return True. - - Viking_1_Orbiter : C452001_2.Mission := - (Craft => (Design => C452001_2.Viking, - Operational => Report.Ident_Bool(False)), - Launch_Date => 1975); - - Viking_1_Lander : C452001_2.Mission := - (Craft => (Design => C452001_2.Viking, - Operational => Report.Ident_Bool(True)), - Launch_Date => 1975); - - -- Viking_1_Orbiter /= Viking_1_Lander if predefined equality - -- from the untagged type Spacecraft is used for equality - -- of matching components in type Mission. If user-defined - -- equality for type Spacecraft is incorporated, which it - -- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander. - - Voyagers : C452001_2.Inventory (1..2):= - ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), - (C452001_2.Voyager, Operational => Report.Ident_Bool(False))); - - Jupiter_Craft : C452001_2.Inventory (1..2):= - ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), - (C452001_2.Voyager, Operational => Report.Ident_Bool(True))); - - -- Voyagers /= Jupiter_Craft if predefined equality - -- from the untagged type Spacecraft is used for equality - -- of matching components in type Inventory. If user-defined - -- equality for type Spacecraft is incorporated, which it - -- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft. - - TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full; - TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full; - - -- With differing values for Boolean component, user-defined - -- (primitive) equality returns True, predefined equality - -- returns False. Since full type is tagged, primitive equality - -- should be used. - - UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full; - UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full; - - -- With differing values for Boolean component, user-defined - -- (primitive) equality returns True, predefined equality - -- returns False. Since full type is tagged, primitive equality - -- should be used. - - UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full; - UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full; - - -- With differing values for Duration component, user-defined - -- (primitive) equality returns True, predefined equality - -- returns False. Since full type is untagged, predefined equality - -- should be used. - - -- Use type clauses make "=" and "/=" operators directly visible - use type C452001_1.Planet; - use type C452001_1.Craters; - use type C452001_1.Moon; - use type C452001_2.Mission; - use type C452001_2.Inventory; - use type C452001_3.Tagged_Partial_Tagged_Full; - use type C452001_3.Untagged_Partial_Tagged_Full; - use type C452001_3.Untagged_Partial_Untagged_Full; - -begin - - Report.Test ("C452001", "Equality of private types and " & - "composite types with tagged components"); - - ------------------------------------------------------------------- - -- Tagged type with tagged component. - ------------------------------------------------------------------- - - if not (Mars_Aphelion = Mars_Perihelion) then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined equality " & - "for enclosing tagged record type"); - end if; - - if Mars_Aphelion /= Mars_Perihelion then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined inequality " & - "for enclosing tagged record type"); - end if; - - if not (Blue_Mars = Mars_Perihelion) then - Report.Failed ("Equality test for tagged record type " & - "incorporates record components " & - "other than those used by user-defined equality"); - end if; - - if Blue_Mars /= Mars_Perihelion then - Report.Failed ("Inequality test for tagged record type " & - "incorporates record components " & - "other than those used by user-defined equality"); - end if; - - if Blue_Mars /= Green_Mars then - Report.Failed ("Records are unequal even though they only differ " & - "in a component not used by user-defined equality"); - end if; - - if not (Blue_Mars = Green_Mars) then - Report.Failed ("Records are not equal even though they only differ " & - "in a component not used by user-defined equality"); - end if; - - ------------------------------------------------------------------- - -- Untagged (array) type with tagged component. - ------------------------------------------------------------------- - - if not (Moon_Craters = Alternate_Moon_Craters) then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined equality " & - "for enclosing array type"); - end if; - - if Moon_Craters /= Alternate_Moon_Craters then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined inequality " & - "for enclosing array type"); - end if; - - ------------------------------------------------------------------- - -- Tagged type with untagged composite component. Untagged - -- component itself has tagged components. - ------------------------------------------------------------------- - if not (New_Moon = Full_Moon) then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined equality " & - "for array component of tagged record type"); - end if; - - if New_Moon /= Full_Moon then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined inequality " & - "for array component of tagged record type"); - end if; - - if Mars_Moon = Full_Moon then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined equality " & - "for array component of tagged record type"); - end if; - - if not (Mars_Moon /= Full_Moon) then - Report.Failed ("User-defined equality for tagged component " & - "was not incorporated into predefined inequality " & - "for array component of tagged record type"); - end if; - - if not (Harvest_Moon = Full_Moon) then - Report.Failed ("Equality test for record with array of tagged " & - "components incorporates record components " & - "other than those used by user-defined equality"); - end if; - - if Harvest_Moon /= Full_Moon then - Report.Failed ("Inequality test for record with array of tagged " & - "components incorporates record components " & - "other than those used by user-defined equality"); - end if; - - ------------------------------------------------------------------- - -- Untagged types with no tagged components. - ------------------------------------------------------------------- - - -- Record type - - if Viking_1_Orbiter = Viking_1_Lander then - Report.Failed ("User-defined equality for untagged composite " & - "component was incorporated into predefined " & - "equality for " & - "untagged record type"); - end if; - - if not (Viking_1_Orbiter /= Viking_1_Lander) then - Report.Failed ("User-defined equality for untagged composite " & - "component was incorporated into predefined " & - "inequality for " & - "untagged record type"); - end if; - - -- Array type - - if Voyagers = Jupiter_Craft then - Report.Failed ("User-defined equality for untagged composite " & - "component was incorporated into predefined " & - "equality for " & - "array type"); - end if; - - if not (Voyagers /= Jupiter_Craft) then - Report.Failed ("User-defined equality for untagged composite " & - "component was incorporated into predefined " & - "inequality for " & - "array type"); - end if; - - ------------------------------------------------------------------- - -- Private types tests. - ------------------------------------------------------------------- - - -- Make objects differ from one another - - C452001_3.Change (TPTF_1, False); - C452001_3.Change (UPTF_1, 999); - C452001_3.Change (UPUF_1, 40.0); - - ------------------------------------------------------------------- - -- Partial type and full type are tagged. (Full type must be tagged - -- if partial type is tagged) - ------------------------------------------------------------------- - - if not (TPTF_1 = TPTF_2) then - Report.Failed ("Predefined equality for full type " & - "was used to determine equality of " & - "tagged private type " & - "instead of user-defined (primitive) equality"); - end if; - - if TPTF_1 /= TPTF_2 then - Report.Failed ("Predefined equality for full type " & - "was used to determine inequality of " & - "tagged private type " & - "instead of user-defined (primitive) equality"); - end if; - - ------------------------------------------------------------------- - -- Partial type untagged, full type tagged. - ------------------------------------------------------------------- - - if not (UPTF_1 = UPTF_2) then - Report.Failed ("Predefined equality for full type " & - "was used to determine equality of " & - "private type (untagged partial view, " & - "tagged full view) " & - "instead of user-defined (primitive) equality"); - end if; - - if UPTF_1 /= UPTF_2 then - Report.Failed ("Predefined equality for full type " & - "was used to determine inequality of " & - "private type (untagged partial view, " & - "tagged full view) " & - "instead of user-defined (primitive) equality"); - end if; - - ------------------------------------------------------------------- - -- Partial type and full type are both untagged. - ------------------------------------------------------------------- - - if UPUF_1 = UPUF_2 then - Report.Failed ("User-defined (primitive) equality for full type " & - "was used to determine equality of " & - "private type (untagged partial view, " & - "untagged full view) " & - "instead of predefined equality"); - end if; - - if not (UPUF_1 /= UPUF_2) then - Report.Failed ("User-defined (primitive) equality for full type " & - "was used to determine inequality of " & - "private type (untagged partial view, " & - "untagged full view) " & - "instead of predefined equality"); - end if; - - ------------------------------------------------------------------- - Report.Result; - -end C452001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c455001.a b/gcc/testsuite/ada/acats/tests/c4/c455001.a deleted file mode 100644 index 8685e1b3381..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c455001.a +++ /dev/null @@ -1,164 +0,0 @@ --- C455001.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 universal fixed multiplying operators can be used without --- a conversion in contexts where the result type is determined. --- --- Note: This is intended to check the changes made to these operators --- in Ada 95; legacy tests should cover cases from Ada 83. --- --- CHANGE HISTORY: --- 18 MAR 99 RLB Initial version --- ---! - -with Report; use Report; - -procedure C455001 is - - type F1 is delta 2.0**(-1) range 0.0 .. 8.0; - - type F2 is delta 2.0**(-2) range 0.0 .. 4.0; - - type F3 is delta 2.0**(-3) range 0.0 .. 2.0; - - A : F1; - B : F2; - C : F3; - - type Fixed_Record is record - D : F1; - E : F2; - end record; - - R : Fixed_Record; - - function Ident_Fix (X : F3) return F3 is - begin - if Equal(3,3) then - return X; - else - return 0.0; - end if; - end Ident_Fix; - -begin - Test ("C455001", "Check that universal fixed multiplying operators " & - "can be used without a conversion in contexts where " & - "the result type is determined."); - - A := 1.0; B := 1.0; - C := A * B; -- Assignment context. - - if C /= Ident_Fix(1.0) then - Failed ("Incorrect results for multiplication (1) - result is " & - F3'Image(C)); - end if; - - C := A / B; - - if C /= Ident_Fix(1.0) then - Failed ("Incorrect results for division (1) - result is " & - F3'Image(C)); - end if; - - A := 2.5; - C := A * 0.25; - - if C /= Ident_Fix(0.625) then - Failed ("Incorrect results for multiplication (2) - result is " & - F3'Image(C)); - end if; - - C := A / 4.0; - - if C /= Ident_Fix(0.625) then - Failed ("Incorrect results for division (2) - result is " & - F3'Image(C)); - end if; - - C := Ident_Fix(0.75); - C := C * 0.5; - - if C /= Ident_Fix(0.375) then - Failed ("Incorrect results for multiplication (3) - result is " & - F3'Image(C)); - end if; - - C := Ident_Fix(0.75); - C := C / 0.5; - - if C /= Ident_Fix(1.5) then - Failed ("Incorrect results for division (3) - result is " & - F3'Image(C)); - end if; - - A := 0.5; B := 0.3; -- Function parameter context. - if Ident_Fix(A * B) not in Ident_Fix(0.125) .. Ident_Fix(0.25) then - Failed ("Incorrect results for multiplication (4) - result is " & - F3'Image(A * B)); -- Exact = 0.15 - end if; - - B := 0.8; - if Ident_Fix(A / B) not in Ident_Fix(0.5) .. Ident_Fix(0.75) then - Failed ("Incorrect results for division (4) - result is " & - F3'Image(A / B)); - -- Exact = 0.625..., but B is only restricted to the range - -- 0.75 .. 1.0, so the result can be anywhere in the range - -- 0.5 .. 0.75. - end if; - - C := 0.875; B := 1.5; - R := (D => C * 4.0, E => B / 0.5); -- Aggregate context. - - if R.D /= 3.5 then - Failed ("Incorrect results for multiplication (5) - result is " & - F1'Image(R.D)); - end if; - - if R.E /= 3.0 then - Failed ("Incorrect results for division (5) - result is " & - F2'Image(R.E)); - end if; - - A := 0.5; - C := A * F1'(B * 2.0); -- Qualified expression context. - - if C /= Ident_Fix(1.5) then - Failed ("Incorrect results for multiplication (6) - result is " & - F3'Image(C)); - end if; - - A := 4.0; - C := F1'(B / 0.5) / A; - - if C /= Ident_Fix(0.75) then - Failed ("Incorrect results for division (6) - result is " & - F3'Image(C)); - end if; - - Result; - -end C455001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460001.a b/gcc/testsuite/ada/acats/tests/c4/c460001.a deleted file mode 100644 index 907b8564f6d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460001.a +++ /dev/null @@ -1,300 +0,0 @@ --- C460001.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 the target type of a type conversion is a general --- access type, Program_Error is raised if the accessibility level --- of the operand type is deeper than that of the target type. --- Check for the case where the operand is an access parameter. --- --- Check for cases where the actual corresponding to the access --- parameter is: --- (a) An allocator. --- (b) An expression of a named access type. --- (c) Obj'Access. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the operand type --- must be at the same or a less deep nesting level than the target --- type -- the operand type must "live" as long as the target type. --- Nesting levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares subprograms with access parameters, within which --- a type conversion is attempted on the access parameter to an access --- type A declared at some nesting level. The test verifies that --- Program_Error is raised if the actual corresponding to the access --- parameter is: --- --- (1) an allocator, and the accessibility level of the execution --- of the called subprogram is deeper than that of the access --- type A. --- --- (2) an expression of a named access type, and the accessibility --- level of the named access type is deeper than that of the --- access type A. --- --- (3) a reference to the Access attribute (e.g., X'Access), and --- the accessibility level of X is deeper than that of the --- access type A. --- --- Note that the static nesting level of the actual corresponding to the --- access parameter can be deeper than that of the target type -- it is --- the run-time nesting that matters for accessibility rules. Consider --- the case where the access type A is declared within the called --- subprogram. The accessibility check will never fail, even if the --- actual happens to have a deeper static nesting level: --- --- procedure P (X: access T) is --- type A is access all T; -- Static level = 2, e.g. --- Acc : A := A(X); -- Check should never fail. --- begin null; end; --- . . . --- declare --- Actual : aliased T; -- Static level = 3, e.g. --- begin --- P (Actual'Access); --- end; --- --- For the execution of P, the accessibility level of type A will --- always be deeper than that of Actual, so there is no danger of a --- dangling reference arising from the assignment to Acc. Thus, the --- type conversion is safe, even though the static nesting level of --- Actual is deeper than that of A. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C460001_0 is - - type Desig is array (1 .. 10) of Integer; - - X0 : aliased Desig; -- Level = 0. - - type Acc_L0 is access all Desig; -- Level = 0. - A0 : Acc_L0; - - type Result_Kind is (OK, P_E, O_E); - - procedure Target_Is_Level_0 (X: access Desig; R : out Result_Kind); - procedure Never_Fails (X: access Desig; R : out Result_Kind); - -end C460001_0; - - - --==================================================================-- - - -package body C460001_0 is - - procedure Target_Is_Level_0 (X : access Desig; - R : out Result_Kind) is - begin - -- The accessibility level of type Acc_L0 is 0. - A0 := Acc_L0(X); - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Target_Is_Level_0; - - ----------------------------------------------- - procedure Never_Fails (X: access Desig; - R : out Result_Kind) is - type Acc_Local is access all Desig; - AL : Acc_Local; - begin - -- The type conversion below will always be safe, since the - -- accessibility level (although not necessarily the static nesting - -- depth) of Acc_Local will always be deeper than or the same as that - -- of the actual corresponding to X. - AL := Acc_Local(X); - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Never_Fails; - -end C460001_0; - - - --==================================================================-- - - -with C460001_0; -with Report; - -procedure C460001 is - - X1 : aliased C460001_0.Desig; -- Level = 1. - - type Acc_L1 is access all C460001_0.Desig; -- Level = 1. - A1 : Acc_L1; - - Expr_L0 : C460001_0.Acc_L0 := C460001_0.X0'Access; - Expr_L1 : Acc_L1 := X1'Access; - - Res : C460001_0.Result_Kind; - - use type C460001_0.Result_Kind; - - ----------------------------------------------- - procedure Target_Is_Level_1 (X : access C460001_0.Desig; - R : out C460001_0.Result_Kind) is - begin - -- The accessibility level of type Acc_L1 is 1. - A1 := Acc_L1(X); - R := C460001_0.OK; - exception - when Program_Error => - R := C460001_0.P_E; - when others => - R := C460001_0.O_E; - end Target_Is_Level_1; - - ----------------------------------------------- - procedure Display_Results (Result : in C460001_0.Result_Kind; - Expected: in C460001_0.Result_Kind; - Message : in String) is - begin - if Result /= Expected then - case Result is - when C460001_0.OK => Report.Failed ("No exception raised: " & - Message); - when C460001_0.P_E => Report.Failed ("Program_Error raised: " & - Message); - when C460001_0.O_E => Report.Failed ("Unexpected exception " & - "raised: " & Message); - end case; - end if; - end Display_Results; - -begin -- C460001 - - Report.Test ("C460001", "Check that if the target type of a type " & - "conversion is a general access type, Program_Error is " & - "raised if the accessibility level of the operand type " & - "is deeper than that of the target type: operand is an " & - "access parameter; corresponding actual is an allocator, " & - "expression of a named access type, Obj'Access"); - - - -- Actual is X'Access: - - C460001_0.Never_Fails (X1'Access, Res); - Display_Results (Res, C460001_0.OK, "X1'Access, local access type"); - - C460001_0.Target_Is_Level_0 (X1'Access, Res); - Display_Results (Res, C460001_0.P_E, "X1'Access, level 0 access type"); - - Target_Is_Level_1 (C460001_0.X0'Access, Res); - Display_Results (Res, C460001_0.OK, "X0'Access, level 1 access type"); - - Target_Is_Level_1 (X1'Access, Res); - Display_Results (Res, C460001_0.OK, "X1'Access, level 1 access type"); - - C460001_0.Target_Is_Level_0 (C460001_0.X0'Access, Res); - Display_Results (Res, C460001_0.OK, "X0'Access, level 0 access type"); - - - -- Actual is expression of a named access type: - - C460001_0.Never_Fails (Expr_L0, Res); - Display_Results (Res, C460001_0.OK, "Expr_L0, local access type"); - - C460001_0.Target_Is_Level_0 (Expr_L0, Res); - Display_Results (Res, C460001_0.OK, "Expr_L0, level 0 access type"); - - C460001_0.Target_Is_Level_0 (Expr_L1, Res); - Display_Results (Res, C460001_0.P_E, "Expr_L1, level 0 access type"); - - Target_Is_Level_1 (Expr_L1, Res); - Display_Results (Res, C460001_0.OK, "Expr_L1, level 1 access type"); - - Target_Is_Level_1 (Expr_L0, Res); - Display_Results (Res, C460001_0.OK, "Expr_L0, level 1 access type"); - - -- Actual is allocator (level of execution = 2): - - C460001_0.Never_Fails (new C460001_0.Desig, Res); - Display_Results (Res, C460001_0.OK, "Allocator level 2, " & - "local access type"); - - C460001_0.Target_Is_Level_0 (new C460001_0.Desig, Res); - Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & - "level 0 access type"); - - Target_Is_Level_1 (new C460001_0.Desig, Res); - Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & - "level 1 access type"); - - - Block_L2: - declare - X2 : aliased C460001_0.Desig; -- Level = 2. - type Acc_L2 is access all C460001_0.Desig; -- Level = 2. - Expr_L2 : Acc_L2 := X1'Access; - begin - - -- Actual is X'Access: - - C460001_0.Never_Fails (X2'Access, Res); - Display_Results (Res, C460001_0.OK, "X2'Access, local access type"); - - Target_Is_Level_1 (X2'Access, Res); - Display_Results (Res, C460001_0.P_E, "X2'Access, level 1 access type"); - - -- Actual is expression of a named access type: - - C460001_0.Never_Fails (Expr_L2, Res); - Display_Results (Res, C460001_0.OK, "Expr_L2, local access type"); - - C460001_0.Target_Is_Level_0 (Expr_L2, Res); - Display_Results (Res, C460001_0.P_E, "Expr_L2, level 0 access type"); - - - -- Actual is allocator (level of execution = 3): - - C460001_0.Never_Fails (new C460001_0.Desig, Res); - Display_Results (Res, C460001_0.OK, "Allocator level 3, " & - "local access type"); - - Target_Is_Level_1 (new C460001_0.Desig, Res); - Display_Results (Res, C460001_0.P_E, "Allocator level 3, " & - "level 1 access type"); - - end Block_L2; - - Report.Result; - -end C460001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460002.a b/gcc/testsuite/ada/acats/tests/c4/c460002.a deleted file mode 100644 index 945dd567720..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460002.a +++ /dev/null @@ -1,330 +0,0 @@ --- C460002.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 the target type of a type conversion is a general --- access type, Program_Error is raised if the accessibility level --- of the operand type is deeper than that of the target type. --- Check for the case where the operand is an access parameter, --- and the actual corresponding to the access parameter is another --- access parameter. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the operand type --- must be at the same or a less deep nesting level than the target --- type -- the operand type must "live" as long as the target type. --- Nesting levels are the run-time nestings of masters: block statements; --- subprogram, task, and entry bodies; and accept statements. Packages --- are invisible to accessibility rules. --- --- This test declares subprograms with access parameters, within which --- a type conversion is attempted on the access parameter to an access --- type A declared at some nesting level. The test verifies that --- Program_Error is raised if the actual corresponding to the access --- parameter is another access parameter, and the actual corresponding --- to this second access parameter is: --- --- (1) an expression of a named access type, and the accessibility --- level of the named access type is deeper than that of the --- access type A. --- --- (2) a reference to the Access attribute (e.g., X'Access), and --- the accessibility level of X is deeper than that of the --- access type A. --- --- Note that the static nesting level of the actual corresponding to the --- access parameter can be deeper than that of the target type -- it is --- the run-time nesting that matters for accessibility rules. Consider --- the case where the access type A is declared within the called --- subprogram. The accessibility check will never fail, even if the --- actual happens to have a deeper static nesting level: --- --- procedure P (X: access T) is --- type A is access all T; -- Static level = 2, e.g. --- Acc : A := A(X); -- Check should never fail. --- begin null; end; --- . . . --- procedure Q (Y: access T) is --- begin --- P(Y); --- end; --- . . . --- declare --- Actual : aliased T; -- Static level = 3, e.g. --- begin --- Q (Actual'Access); --- end; --- --- For the execution of Q (and hence P), the accessibility level of --- type A will always be deeper than that of Actual, so there is no --- danger of a dangling reference arising from the assignment to --- Acc. Thus, the type conversion is safe, even though the static --- nesting level of Actual is deeper than that of A. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Changed maintenance documentation. --- 15 Jul 98 EDS Avoid Optimization --- 28 Jun 02 RLB Added pragma Elaborate_All. ---! - -with Report; use Report; pragma Elaborate_All (Report); -package C460002_0 is - - type Component is array (1 .. 10) of Natural; - - type Desig is record - C: Component; - end record; - - X0 : aliased Desig := (C=>(others => Ident_Int(3))); -- Level = 0. - - type Acc_L0 is access all Desig; -- Level = 0. - A0 : Acc_L0; - - type Result_Kind is (OK, P_E, O_E); - - procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); - procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); - procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); - -end C460002_0; - - - --==================================================================-- - - -package body C460002_0 is - - procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is - - procedure Nested (X: access Desig; R: out Result_Kind) is - -- This procedure attempts a type conversion on the access parameter to - -- an access type declared at some nesting level. Program_Error is - -- raised if the accessibility level of the operand type is deeper than - -- that of the target type. - - begin - -- The accessibility level of type Acc_L0 is 0. - A0 := Acc_L0(X); - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Nested; - - begin - Nested (Y, S); - end Target_Is_Level_0_Nest; - - ------------------------------------------------------------- - - procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is - - type Acc_Deeper is access all Desig; - AD : Acc_Deeper; - - function Nested (X: access Desig) return Result_Kind is - begin - -- The type conversion below will always be safe, since the - -- accessibility level (although not necessarily the static nesting - -- depth) of Acc_Deeper will always be deeper than or the same as that - -- of the actual corresponding to Y. - AD := Acc_Deeper(X); - if Natural(Ident_Int(AD.C(1))) /= 3 then --Avoid Optimization of AD - Report.Failed ("Initial Values not correct."); - end if; - return OK; - exception - when Program_Error => - return P_E; - when others => - return O_E; - end Nested; - - begin - S := Nested (Y); - end Never_Fails_Nest; - - ------------------------------------------------------------- - - procedure Called_By_Never_Fails_Same - (X: access Desig; R: out Result_Kind) is - type Acc_Local is access all Desig; - AL : Acc_Local; - begin - -- The type conversion below will always be safe, since the - -- accessibility level (although not necessarily the static nesting - -- depth) of Acc_Local will always be deeper than or the same as that - -- of the actual corresponding to X. - AL := Acc_Local(X); - if Natural(Ident_Int(AL.C(1))) /= 3 then --Avoid Optimization of AL - Report.Failed ("Initial Values not correct."); - end if; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Called_By_Never_Fails_Same; - - ------------------------------------------------------------- - - procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is - begin - Called_By_Never_Fails_Same (Y, S); - end Never_Fails_Same; - -end C460002_0; - - - --==================================================================-- - - -with C460002_0; -use C460002_0; - -with Report; use Report; - -procedure C460002 is - - type Acc_L1 is access all Desig; -- Level = 1. - A1 : Acc_L1; - X1 : aliased Desig := (C=>(others => Ident_Int(3))); - Res : Result_Kind; - - - - procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is - begin - -- The accessibility level of type Acc_L1 is 1. - A1 := Acc_L1(X); - if Natural(Ident_Int(A1.C(1))) /= 3 then --Avoid Optimization of A1 - Report.Failed ("Initial Values not correct."); - end if; - R := OK; - exception - when Program_Error => - R := P_E; - when others => - R := O_E; - end Called_By_Target_L1; - - ------------------------------------------------------------- - - function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is - S : Result_Kind; - begin - Called_By_Target_L1 (Y, S); - return S; - end Target_Is_Level_1_Same; - - ------------------------------------------------------------- - - procedure Display_Results (Result : in Result_Kind; - Expected: in Result_Kind; - Msg : in String) is - begin - if Result /= Expected then - case Result is - when OK => Report.Failed ("No exception raised: " & Msg); - when P_E => Report.Failed ("Program_Error raised: " & Msg); - when O_E => Report.Failed ("Unexpected exception raised: " & Msg); - end case; - end if; - end Display_Results; - -begin -- C460002. - - Report.Test ("C460002", "Check that if the target type of a type " & - "conversion is a general access type, Program_Error is " & - "raised if the accessibility level of the operand type " & - "is deeper than that of the target type: operand is an " & - "access parameter; corresponding actual is another " & - "access parameter"); - - - -- Accessibility level of actual is 0 (actual is X'Access): - - Never_Fails_Same (X0'Access, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); - - Never_Fails_Nest (X0'Access, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); - - Target_Is_Level_0_Nest (X0'Access, Res); - Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); - - Res := Target_Is_Level_1_Same (X0'Access); - Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); - - - -- Accessibility level of actual is 1 (actual is X'Access): - - Never_Fails_Same (X1'Access, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); - - Never_Fails_Nest (X1'Access, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); - - Target_Is_Level_0_Nest (X1'Access, Res); - Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); - - Res := Target_Is_Level_1_Same (X1'Access); - Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); - - - Block_L2: - declare - X2 : aliased Desig := (C=>(others => Ident_Int(3))); - type Acc_L2 is access all Desig; -- Level = 2. - Expr_L2 : Acc_L2 := X2'Access; - begin - - -- Accessibility level of actual is 2 (actual is expression of named - -- access type): - - Never_Fails_Same (Expr_L2, Res); - Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); - - Never_Fails_Nest (Expr_L2, Res); - Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); - - Target_Is_Level_0_Nest (Expr_L2, Res); - Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); - - Res := Target_Is_Level_1_Same (Expr_L2); - Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); - - end Block_L2; - - - Report.Result; - -end C460002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460004.a b/gcc/testsuite/ada/acats/tests/c4/c460004.a deleted file mode 100644 index b00428121b8..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460004.a +++ /dev/null @@ -1,335 +0,0 @@ --- C460004.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 the operand type of a type conversion is class-wide, --- Constraint_Error is raised if the tag of the operand does not --- identify a specific type that is covered by or descended from the --- target type. --- --- TEST DESCRIPTION: --- View conversions of class-wide operands to specific types are --- placed on the right and left sides of assignment statements, and --- conversions of class-wide operands to class-wide types are used --- as actual parameters to dispatching operations. In all cases, a --- check is made that Constraint_Error is raised if the tag of the --- operand does not identify a specific type covered by or descended --- from the target type, and not raised otherwise. --- --- A specific type is descended from itself and from those types it is --- directly or indirectly derived from. A specific type is covered by --- itself and each class-wide type to whose class it belongs. --- --- A class-wide type T'Class is descended from T and those types which --- T is descended from. A class-wide type is covered by each class-wide --- type to whose class it belongs. --- --- --- CHANGE HISTORY: --- 19 Jul 95 SAIC Initial prerelease version. --- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. --- ---! -package C460004_0 is - - type Tag_Type is tagged record - C1 : Natural; - end record; - - procedure Proc (X : in out Tag_Type); - - - type DTag_Type is new Tag_Type with record - C2 : String (1 .. 5); - end record; - - procedure Proc (X : in out DTag_Type); - - - type DDTag_Type is new DTag_Type with record - C3 : String (1 .. 5); - end record; - - procedure Proc (X : in out DDTag_Type); - - procedure NewProc (X : in DDTag_Type); - - function CWFunc (X : Tag_Type'Class) return Tag_Type'Class; - -end C460004_0; - - - --==================================================================-- - -with Report; -package body C460004_0 is - - procedure Proc (X : in out Tag_Type) is - begin - X.C1 := 25; - end Proc; - - ----------------------------------------- - procedure Proc (X : in out DTag_Type) is - begin - Proc ( Tag_Type(X) ); - X.C2 := "Earth"; - end Proc; - - ----------------------------------------- - procedure Proc (X : in out DDTag_Type) is - begin - Proc ( DTag_Type(X) ); - X.C3 := "Orbit"; - end Proc; - - ----------------------------------------- - procedure NewProc (X : in DDTag_Type) is - Y : DDTag_Type := X; - begin - Proc (Y); - exception - when others => - Report.Failed ("Unexpected exception in NewProc"); - end NewProc; - - ----------------------------------------- - function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is - Y : Tag_Type'Class := X; - begin - Proc (Y); - return Y; - end CWFunc; - -end C460004_0; - - - --==================================================================-- - - -with C460004_0; -use C460004_0; - -with Report; -procedure C460004 is - - Tag_Type_Init : constant Tag_Type := (C1 => 0); - DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); - DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); - - Tag_Type_Value : constant Tag_Type := (C1 => 25); - DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); - DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); - -begin - - Report.Test ("C460004", "Check that for a view conversion of a " & - "class-wide operand, Constraint_Error is raised if the " & - "tag of the operand does not identify a specific type " & - "covered by or descended from the target type"); - --- --- View conversion to specific type: --- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Target : Tag_Type := Tag_Type_Init; - begin - Target := Tag_Type(P); - if (Target /= Tag_Type_Value) then - Report.Failed ("Target has wrong value: #01"); - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #01"); - when others => - Report.Failed ("Unexpected exception: #01"); - end CW_Proc; - - begin - CW_Proc (DDTag_Type_Value); - end; - - ---------------------------------------------------------------------- - - declare - Target : DTag_Type := DTag_Type_Init; - begin - Target := DTag_Type(CWFunc(DDTag_Type_Value)); - if (Target /= DTag_Type_Value) then - Report.Failed ("Target has wrong value: #02"); - end if; - exception - when Constraint_Error => Report.Failed ("Constraint_Error raised: #02"); - when others => Report.Failed ("Unexpected exception: #02"); - end; - - ---------------------------------------------------------------------- - - declare - Target : DDTag_Type; - begin - Target := DDTag_Type(CWFunc(Tag_Type_Value)); - -- CWFunc returns a Tag_Type; its tag is preserved through - -- the view conversion. Constraint_Error should be raised. - - Report.Failed ("Constraint_Error not raised: #03"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #03"); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - begin - NewProc (DDTag_Type(P)); - Report.Failed ("Constraint_Error not raised: #04"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #04"); - end CW_Proc; - - begin - CW_Proc (DTag_Type_Value); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Target : DDTag_Type := DDTag_Type_Init; - begin - Target := DDTag_Type(P); - if (Target /= DDTag_Type_Value) then - Report.Failed ("Target has wrong value: #05"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #05"); - when others - => Report.Failed ("Unexpected exception: #05"); - end CW_Proc; - - begin - CW_Proc (DDTag_Type_Value); - end; - - --- --- View conversion to class-wide type: --- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Proc( DTag_Type'Class(Operand) ); - Report.Failed ("Constraint_Error not raised: #06"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #06"); - end CW_Proc; - - begin - CW_Proc (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Proc( DDTag_Type'Class(Operand) ); - Report.Failed ("Constraint_Error not raised: #07"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #07"); - end CW_Proc; - - begin - CW_Proc (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Proc( DTag_Type'Class(Operand) ); - if Operand not in DTag_Type then - Report.Failed ("Operand has wrong tag: #08"); - elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then - Report.Failed ("Operand has wrong value: #08"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #08"); - when others => - Report.Failed ("Unexpected exception: #08"); - end CW_Proc; - - begin - CW_Proc (DTag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Proc( Tag_Type'Class(Operand) ); - if Operand not in DDTag_Type then - Report.Failed ("Operand has wrong tag: #09"); - elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then - Report.Failed ("Operand has wrong value: #09"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #09"); - when others => - Report.Failed ("Unexpected exception: #09"); - end CW_Proc; - - begin - CW_Proc (DDTag_Type_Init); - end; - - - Report.Result; - -end C460004; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460005.a b/gcc/testsuite/ada/acats/tests/c4/c460005.a deleted file mode 100644 index 95b14a9a20a..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460005.a +++ /dev/null @@ -1,260 +0,0 @@ --- C460005.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 view conversion of a tagged type that is the left --- side of an assignment statement, the assignment assigns to the --- corresponding part of the object denoted by the operand. --- --- TEST DESCRIPTION: --- View conversions of class-wide operands to specific types are --- placed on the right and left sides of assignment statements, and --- conversions of class-wide operands to class-wide types are used --- as actual parameters to dispatching operations. In all cases, a --- check is made that Constraint_Error is raised if the tag of the --- operand does not identify a specific type covered by or descended --- from the target type, and not raised otherwise. --- --- For the cases where the view conversion is the left side of an --- assignment statement, and Constraint_Error should not be raised, --- an additional check is made that only the corresponding portion --- of the operand is updated by the assignment. For example: --- --- type T is tagged record --- C1 : Integer := 0; --- end record; --- --- type DT is new T with record --- C2 : Integer := 0; --- end record; --- --- A : T := (C1 => 5); --- B : DT := (C1 => 0, C2 => 10); --- CWDT : T'Class := B; --- --- T(CWDT) := A; -- Updates component C1; C2 remains unchanged. --- -- Value of CWDT is (C1 => 5, C2 => 10). --- --- --- CHANGE HISTORY: --- 31 Jul 95 SAIC Initial prerelease version. --- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. --- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test. --- ---! - -package C460005_0 is - - type Tag_Type is tagged record - C1 : Natural; - end record; - - procedure Proc (X : in out Tag_Type); - - - type DTag_Type is new Tag_Type with record - C2 : String (1 .. 5); - end record; - - procedure Proc (X : in out DTag_Type); - - - type DDTag_Type is new DTag_Type with record - C3 : String (1 .. 5); - end record; - - procedure Proc (X : in out DDTag_Type); - -end C460005_0; - - - --==================================================================-- - - -package body C460005_0 is - - procedure Proc (X : in out Tag_Type) is - begin - X.C1 := 25; - end Proc; - - ----------------------------------------- - procedure Proc (X : in out DTag_Type) is - begin - Proc ( Tag_Type(X) ); - X.C2 := "Earth"; - end Proc; - - ----------------------------------------- - procedure Proc (X : in out DDTag_Type) is - begin - Proc ( DTag_Type(X) ); - X.C3 := "Orbit"; - end Proc; - -end C460005_0; - - - --==================================================================-- - - -with C460005_0; -use C460005_0; - -with Report; -procedure C460005 is - - Tag_Type_Init : constant Tag_Type := (C1 => 0); - DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); - DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); - - Tag_Type_Value : constant Tag_Type := (C1 => 25); - DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); - DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); - - Tag_Type_Res : constant Tag_Type := (C1 => 25); - DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello"); - DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World"); - -begin - - Report.Test ("C460005", "Check that, for a view conversion of a tagged " & - "type that is the left side of an assignment statement, " & - "the assignment assigns to the corresponding part of the " & - "object denoted by the operand"); - - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Tag_Type(Operand) := Tag_Type_Value; - - if (Operand /= Tag_Type'Class (Tag_Type_Value)) then - Report.Failed ("Operand has wrong value: #01"); - end if; - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #01"); - when others => - Report.Failed ("Unexpected exception: #01"); - end CW_Proc; - - begin - CW_Proc (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - DTag_Type(Operand) := DTag_Type_Value; - Report.Failed ("Constraint_Error not raised: #02"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #02"); - end CW_Proc; - - begin - CW_Proc (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - DDTag_Type(Operand) := DDTag_Type_Value; - Report.Failed ("Constraint_Error not raised: #03"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #03"); - end CW_Proc; - - begin - CW_Proc (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Tag_Type(Operand) := Tag_Type_Value; - - if Operand not in DTag_Type then - Report.Failed ("Operand has wrong tag: #04"); - elsif (Operand /= Tag_Type'Class (DTag_Type_Res)) - then -- Check to make - Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was - end if; -- not modified. - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #04"); - when others => - Report.Failed ("Unexpected exception: #04"); - end CW_Proc; - - begin - CW_Proc (DTag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Tag_Type(Operand) := Tag_Type_Value; - - if Operand not in DDTag_Type then - Report.Failed ("Operand has wrong tag: #05"); - elsif (Operand /= Tag_Type'Class (DDTag_Type_Res)) - then -- Check to make - Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3 - end if; -- were not changed. - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #05"); - when others => - Report.Failed ("Unexpected exception: #05"); - end CW_Proc; - - begin - CW_Proc (DDTag_Type_Init); - end; - - Report.Result; - -end C460005; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc/testsuite/ada/acats/tests/c4/c460006.a deleted file mode 100644 index 99968847b9b..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460006.a +++ /dev/null @@ -1,378 +0,0 @@ --- C460006.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 view conversion to a tagged type is permitted in the --- prefix of a selected component, an object renaming declaration, and --- (if the operand is a variable) on the left side of an assignment --- statement. Check that such a renaming or assignment does not change --- the tag of the operand. --- --- Check that, for a view conversion of a tagged type, each --- nondiscriminant component of the new view denotes the matching --- component of the operand object. Check that reading the value of the --- view yields the result of converting the value of the operand object --- to the target subtype. --- --- TEST DESCRIPTION: --- The fact that the tag of an object is not changed is verified by --- making calls to primitive operations which in turn make (re)dispatching --- calls, and confirming that the proper bodies are executed. --- --- Selected components are checked in three contexts: as the object name --- in an object renaming declaration, as the left operand of an inequality --- operation, and as the left side of an assignment statement. --- --- View conversions of an object of a 2nd level type extension are --- renamed as objects of an ancestor type and of a class-wide type. In --- one case the operand of the conversion is itself a renaming of an --- object. --- --- View conversions of an object of a 2nd level type extension are --- checked for equality with record aggregates of various ancestor types. --- In one case, the view conversion is to a class-wide type, and it is --- checked for equality with the result of a class-wide function with --- the following structure: --- --- function F return T'Class is --- A : DDT := Expected_Value; --- X : T'Class := T(A); --- begin --- return X; --- --- end F; --- --- ... --- --- Var : DDT := Expected_Value; --- --- if (T'Class(Var) /= F) then -- Condition should yield FALSE. --- FAIL; --- end if; --- --- The view conversion to which X is initialized does not affect the --- value or tag of the operand; the tag of X is that of type DDT (not T), --- and the components are those of A. The result of this function --- should equal the value of an object of type DDT initialized to the --- same value as F.A. --- --- To check that assignment to a view conversion does not change the tag --- of the operand, an assignment is made to a conversion of an object, --- and the object is then passed as an actual to a dispatching operation. --- Conversions to both specific and class-wide types are checked. --- --- --- CHANGE HISTORY: --- 20 Jul 95 SAIC Initial prerelease version. --- 24 Apr 96 SAIC Added type conversions. --- ---! - -package C460006_0 is - - type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, - Child_Outer, Child_Inner, - Grandchild_Outer, Grandchild_Inner); - - type Root_Type is abstract tagged record - First_Call : Call_ID_Kind := None; - Second_Call : Call_ID_Kind := None; - end record; - - procedure Inner_Proc (X : in out Root_Type) is abstract; - procedure Outer_Proc (X : in out Root_Type) is abstract; - -end C460006_0; - - - --==================================================================-- - - -package C460006_0.C460006_1 is - - type Parent_Type is new Root_Type with record - C1 : Integer := 0; - end record; - - procedure Inner_Proc (X : in out Parent_Type); - procedure Outer_Proc (X : in out Parent_Type); - -end C460006_0.C460006_1; - - - --==================================================================-- - - -package body C460006_0.C460006_1 is - - procedure Inner_Proc (X : in out Parent_Type) is - begin - X.Second_Call := Parent_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Parent_Type) is - begin - X.First_Call := Parent_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - -end C460006_0.C460006_1; - - - --==================================================================-- - - -package C460006_0.C460006_1.C460006_2 is - - type Child_Type is new Parent_Type with record - C2 : String(1 .. 5) := "-----"; - end record; - - procedure Inner_Proc (X : in out Child_Type); - procedure Outer_Proc (X : in out Child_Type); - -end C460006_0.C460006_1.C460006_2; - - - --==================================================================-- - - -package body C460006_0.C460006_1.C460006_2 is - - procedure Inner_Proc (X : in out Child_Type) is - begin - X.Second_Call := Child_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Child_Type) is - begin - X.First_Call := Child_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - -end C460006_0.C460006_1.C460006_2; - - - --==================================================================-- - - -package C460006_0.C460006_1.C460006_2.C460006_3 is - - type Grandchild_Type is new Child_Type with record - C3: String(1 .. 5) := "-----"; - end record; - - procedure Inner_Proc (X : in out Grandchild_Type); - procedure Outer_Proc (X : in out Grandchild_Type); - - - function ClassWide_Func return Parent_Type'Class; - - - Grandchild_Value : constant Grandchild_Type := (First_Call => None, - Second_Call => None, - C1 => 15, - C2 => "Hello", - C3 => "World"); - -end C460006_0.C460006_1.C460006_2.C460006_3; - - - --==================================================================-- - - -package body C460006_0.C460006_1.C460006_2.C460006_3 is - - procedure Inner_Proc (X : in out Grandchild_Type) is - begin - X.Second_Call := Grandchild_Inner; - end Inner_Proc; - - ------------------------------------------------- - procedure Outer_Proc (X : in out Grandchild_Type) is - begin - X.First_Call := Grandchild_Outer; - Inner_Proc ( Parent_Type'Class(X) ); - end Outer_Proc; - - ------------------------------------------------- - function ClassWide_Func return Parent_Type'Class is - A : Grandchild_Type := Grandchild_Value; - X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A. - begin - return X; - end ClassWide_Func; - -end C460006_0.C460006_1.C460006_2.C460006_3; - - - --==================================================================-- - - -with C460006_0.C460006_1.C460006_2.C460006_3; - -with Report; -procedure C460006 is - - package Root_Package renames C460006_0; - package Parent_Package renames C460006_0.C460006_1; - package Child_Package renames C460006_0.C460006_1.C460006_2; - package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3; - -begin - Report.Test ("C460006", "Check that a view conversion to a tagged type " & - "is permitted in the prefix of a selected component, an " & - "object renaming declaration, and (if the operand is a " & - "variable) on the left side of an assignment statement. " & - "Check that such a renaming or assignment does not change " & - " the tag of the operand"); - - - -- - -- Check conversion as prefix of selected component: - -- - - Selected_Component_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - CW_Var : Parent_Type'Class := Var; - - Ren : Integer renames Parent_Type(Var).C1; - - begin - if Ren /= 15 then - Report.Failed ("Wrong value: selected component in renaming"); - end if; - - if Child_Type(Var).C2 /= "Hello" then - Report.Failed ("Wrong value: selected component in IF"); - end if; - - Grandchild_Type(CW_Var).C3(2..4) := "eir"; - if CW_Var /= Parent_Type'Class - (Grandchild_Type'(None, None, 15, "Hello", "Weird")) - then - Report.Failed ("Wrong value: selected component in assignment"); - end if; - end Selected_Component_Subtest; - - - -- - -- Check conversion in object renaming: - -- - - Object_Renaming_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - Ren1 : Parent_Type renames Parent_Type(Var); - Ren2 : Child_Type renames Child_Type(Var); - Ren3 : Parent_Type'Class renames Parent_Type'Class(Var); - Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename. - begin - Outer_Proc (Ren1); - if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then - Report.Failed ("Value or tag not preserved by object renaming: Ren1"); - end if; - - Outer_Proc (Ren2); - if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then - Report.Failed ("Value or tag not preserved by object renaming: Ren2"); - end if; - - Outer_Proc (Ren3); - if Ren3 /= Parent_Type'Class - (Grandchild_Type'(Grandchild_Outer, - Grandchild_Inner, - 15, - "Hello", - "World")) - then - Report.Failed ("Value or tag not preserved by object renaming: Ren3"); - end if; - - Outer_Proc (Ren4); - if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then - Report.Failed ("Value or tag not preserved by object renaming: Ren4"); - end if; - end Object_Renaming_Subtest; - - - -- - -- Check reading view conversion, and conversion as left side of assignment: - -- - - View_Conversion_Subtest: - declare - use Root_Package, Parent_Package, Child_Package, Grandchild_Package; - - Var : Grandchild_Type := Grandchild_Value; - Specific : Child_Type; - ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag. - begin - if Parent_Type(Var) /= (None, None, 15) then - Report.Failed ("View has wrong value: #1"); - end if; - - if Child_Type(Var) /= (None, None, 15, "Hello") then - Report.Failed ("View has wrong value: #2"); - end if; - - if Parent_Type'Class(Var) /= ClassWide_Func then - Report.Failed ("Upward view conversion did not preserve " & - "extension's components"); - end if; - - - Parent_Type(Specific) := (None, None, 26); -- Assign to view. - Outer_Proc (Specific); -- Call dispatching op. - - if Specific /= (Child_Outer, Child_Inner, 26, "-----") then - Report.Failed ("Value or tag not preserved by assignment: Specific"); - end if; - - - Parent_Type(ClassWide) := (None, None, 44); -- Assign to view. - Outer_Proc (ClassWide); -- Call dispatching op. - - if ClassWide /= Parent_Type'Class - (Grandchild_Type'(Grandchild_Outer, - Grandchild_Inner, - 44, - "Hello", - "World")) - then - Report.Failed ("Value or tag not preserved by assignment: ClassWide"); - end if; - end View_Conversion_Subtest; - - Report.Result; - -end C460006; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460007.a b/gcc/testsuite/ada/acats/tests/c4/c460007.a deleted file mode 100644 index fdcc1adcc3d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460007.a +++ /dev/null @@ -1,239 +0,0 @@ --- C460007.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, in a numeric type conversion, if the target type is an --- integer type and the operand type is real, the result is rounded --- to the nearest integer, and away from zero if the result is exactly --- halfway between two integers. Check for static and non-static type --- conversions. --- --- TEST DESCRIPTION: --- The following cases are considered: --- --- X.5 X.5 + delta -X.5 + delta --- -X.5 X.5 - delta -X.5 - delta --- --- Both zero and non-zero values are used for X. The value of delta is --- chosen to be a very small increment (on the order of 1.0E-10). For --- fixed and floating point cases, the value of delta is chosen such that --- "(-)X.5 +(-) delta" is a multiple of the small, or a machine number, --- respectively. --- --- The following type conversions are performed: --- --- ID Real operand Cases Target integer subtype --- ------------------------------------------------------------------ --- 1 Real named number X.5 Nonstatic --- 2 X.5 - delta Nonstatic --- 3 -X.5 - delta Static --- 4 Real literal -X.5 Static --- 5 X.5 + delta Static --- 6 -X.5 + delta Nonstatic --- 7 Floating point object -X.5 - delta Nonstatic --- 8 X.5 - delta Static --- 9 Fixed point object X.5 Static --- 10 X.5 + delta Static --- 11 -X.5 + delta Nonstatic --- The conversion is either assigned to a variable of the target subtype --- or passed as a parameter to a subprogram (both nonstatic contexts). --- --- The subprogram Equal is used to circumvent potential optimizations. --- --- --- CHANGE HISTORY: --- 03 Oct 95 SAIC Initial prerelease version. --- ---! - -with System; -package C460007_0 is - --- --- Target integer subtype (static): --- - - type Static_Integer_Subtype is range -32_000 .. 32_000; - - Static_Target : Static_Integer_Subtype; - - function Equal (L, R: Static_Integer_Subtype) return Boolean; - - --- --- Named numbers: --- - - NN_Half : constant := 0.5000000000; - NN_Less_Half : constant := 126.4999999999; - NN_More_Half : constant := -NN_Half - 0.0000000001; - - --- --- Floating point: --- - - type My_Float is digits System.Max_Digits; - - Flt_Rnd_Toward_Zero : My_Float := My_Float'Pred(NN_Half); - Flt_Rnd_Away_Zero : constant My_Float := My_Float'Pred(-113.5); - - --- --- Fixed point: --- - - type My_Fixed is delta 0.1 range -5.0 .. 5.0; - - Fix_Half : My_Fixed := 0.5; - Fix_Rnd_Away_Zero : My_Fixed := Fix_Half + My_Fixed'Small; - Fix_Rnd_Toward_Zero : constant My_Fixed := -3.5 + My_Fixed'Small; - -end C460007_0; - - - --==================================================================-- - - -package body C460007_0 is - - function Equal (L, R: Static_Integer_Subtype) return Boolean is - begin - return (L = R); - end Equal; - -end C460007_0; - - - --==================================================================-- - - -with C460007_0; -use C460007_0; - -with Report; -procedure C460007 is - --- --- Target integer subtype (nonstatic): --- - - Limit : Static_Integer_Subtype := - Static_Integer_Subtype(Report.Ident_Int(128)); - - subtype Nonstatic_Integer_Subtype is Static_Integer_Subtype - range -Limit .. Limit; - - Nonstatic_Target : Static_Integer_Subtype; - -begin - - Report.Test ("C460007", "Rounding for type conversions of real operand " & - "to integer target"); - - - -- -------------------------- - -- Named number/literal cases: - -- -------------------------- - - Nonstatic_Target := Nonstatic_Integer_Subtype(NN_Half); - - if not Equal(Nonstatic_Target, 1) then -- Case 1. - Report.Failed ("Wrong result for named number operand" & - "(case 1), nonstatic target subtype"); - end if; - - if not Equal(Nonstatic_Integer_Subtype(NN_Less_Half), 126) then -- Case 2. - Report.Failed ("Wrong result for named number operand" & - "(case 2), nonstatic target subtype"); - end if; - - Static_Target := Static_Integer_Subtype(NN_More_Half); - - if not Equal(Static_Target, -1) then -- Case 3. - Report.Failed ("Wrong result for named number operand" & - "(case 3), static target subtype"); - end if; - - if not Equal(Static_Integer_Subtype(-0.50), -1) then -- Case 4. - Report.Failed ("Wrong result for literal operand" & - "(case 4), static target subtype"); - end if; - - if not Equal(Static_Integer_Subtype(29_546.5001), 29_547) then -- Case 5. - Report.Failed ("Wrong result for literal operand" & - "(case 5), static target subtype"); - end if; - - if not Equal(Nonstatic_Integer_Subtype(-66.499), -66) then -- Case 6. - Report.Failed ("Wrong result for literal operand" & - "(case 6), nonstatic target subtype"); - end if; - - - -- -------------------- - -- Floating point cases: - -- -------------------- - - Nonstatic_Target := Nonstatic_Integer_Subtype(Flt_Rnd_Away_Zero); - - if not Equal(Nonstatic_Target, -114) then -- Case 7. - Report.Failed ("Wrong result for floating point operand" & - "(case 7), nonstatic target subtype"); - end if; - -- Case 8. - if not Equal(Static_Integer_Subtype(Flt_Rnd_Toward_Zero), 0) then - Report.Failed ("Wrong result for floating point operand" & - "(case 8), static target subtype"); - end if; - - - -- ----------------- - -- Fixed point cases: - -- ----------------- - - Static_Target := Static_Integer_Subtype(Fix_Half); - - if not Equal(Static_Target, 1) then -- Case 9. - Report.Failed ("Wrong result for fixed point operand" & - "(case 9), static target subtype"); - end if; - - if not Equal(Static_Integer_Subtype(Fix_Rnd_Away_Zero), 1) then -- Case 10. - Report.Failed ("Wrong result for fixed point operand" & - "(case 10), static target subtype"); - end if; - - Nonstatic_Target := Nonstatic_Integer_Subtype(Fix_Rnd_Toward_Zero); - - if not Equal(Nonstatic_Target, -3) then -- Case 11. - Report.Failed ("Wrong result for fixed point operand" & - "(case 11), nonstatic target subtype"); - end if; - - - Report.Result; - -end C460007; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460008.a b/gcc/testsuite/ada/acats/tests/c4/c460008.a deleted file mode 100644 index 29d48ecd4c4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460008.a +++ /dev/null @@ -1,286 +0,0 @@ --- C460008.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 conversion to a modular type raises Constraint_Error --- when the operand value is outside the base range of the modular type. --- --- TEST DESCRIPTION: --- Test conversion from integer, float, fixed and decimal types to --- modular types. Test conversion to mod 255, mod 256 and mod 258 --- to test the boundaries of 8 bit (+/-) unsigned numbers. --- Test operand values that are negative, the value of the mod, --- and greater than the value of the mod. --- Declare a generic test procedure and instantiate it for each of the --- unsigned types for each operand type. --- --- --- CHANGE HISTORY: --- 04 OCT 95 SAIC Initial version --- 15 MAY 96 SAIC Revised for 2.1 --- 24 NOV 98 RLB Moved decimal cases into new test, C460011, to --- prevent this test from being inapplicable to --- implementations not supporting decimal types. --- ---! - -------------------------------------------------------------------- C460008 - -with Report; - -procedure C460008 is - - Shy_By_One : constant := 2**8-1; - Heavy_By_Two : constant := 2**8+2; - - type Unsigned_Edge_8 is mod Shy_By_One; - type Unsigned_8_Bit is mod 2**8; - type Unsigned_Over_8 is mod Heavy_By_Two; - - NPC : constant String := " not properly converted"; - - procedure Assert( Truth: Boolean; Message: String ) is - begin - if not Truth then - Report.Failed(Message); - end if; - end Assert; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - generic - type Source is range <>; - type Target is mod <>; - procedure Integer_Conversion_Check( For_The_Value : Source; - Message : String ); - - procedure Integer_Conversion_Check( For_The_Value : Source; - Message : String ) is - - Item : Target; - - begin - Item := Target( For_The_Value ); - Report.Failed("Int expected Constraint_Error " & Message); - -- the call to Comment is to make the otherwise dead assignment to - -- Item live. - -- To avoid invoking C_E on a call to 'Image in Report.Failed that - -- could cause a false pass - Report.Comment("Value of" & Target'Image(Item) & NPC); - exception - when Constraint_Error => null; -- expected case - when others => Report.Failed("Int Raised wrong exception " & Message); - end Integer_Conversion_Check; - - procedure Int_To_Short is - new Integer_Conversion_Check( Integer, Unsigned_Edge_8 ); - - procedure Int_To_Eight is - new Integer_Conversion_Check( Integer, Unsigned_8_Bit ); - - procedure Int_To_Wide is - new Integer_Conversion_Check( Integer, Unsigned_Over_8 ); - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - generic - type Source is digits <>; - type Target is mod <>; - procedure Float_Conversion_Check( For_The_Value : Source; - Message : String ); - - procedure Float_Conversion_Check( For_The_Value : Source; - Message : String ) is - - Item : Target; - - begin - Item := Target( For_The_Value ); - Report.Failed("Flt expected Constraint_Error " & Message); - Report.Comment("Value of" & Target'Image(Item) & NPC); - exception - when Constraint_Error => null; -- expected case - when others => Report.Failed("Flt raised wrong exception " & Message); - end Float_Conversion_Check; - - procedure Float_To_Short is - new Float_Conversion_Check( Float, Unsigned_Edge_8 ); - - procedure Float_To_Eight is - new Float_Conversion_Check( Float, Unsigned_8_Bit ); - - procedure Float_To_Wide is - new Float_Conversion_Check( Float, Unsigned_Over_8 ); - - function Identity( Root_Beer: Float ) return Float is - -- a knockoff of Report.Ident_Int for type Float - Nothing : constant Float := 0.0; - begin - if Report.Ident_Bool( Root_Beer = Nothing ) then - return Nothing; - else - return Root_Beer; - end if; - end Identity; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - generic - type Source is delta <>; - type Target is mod <>; - procedure Fixed_Conversion_Check( For_The_Value : Source; - Message : String ); - - procedure Fixed_Conversion_Check( For_The_Value : Source; - Message : String ) is - - Item : Target; - - begin - Item := Target( For_The_Value ); - Report.Failed("Fix expected Constraint_Error " & Message); - Report.Comment("Value of" & Target'Image(Item) & NPC); - exception - when Constraint_Error => null; -- expected case - when others => Report.Failed("Fix raised wrong exception " & Message); - end Fixed_Conversion_Check; - - procedure Fixed_To_Short is - new Fixed_Conversion_Check( Duration, Unsigned_Edge_8 ); - - procedure Fixed_To_Eight is - new Fixed_Conversion_Check( Duration, Unsigned_8_Bit ); - - procedure Fixed_To_Wide is - new Fixed_Conversion_Check( Duration, Unsigned_Over_8 ); - - function Identity( A_Stitch: Duration ) return Duration is - Threadbare : constant Duration := 0.0; - begin - if Report.Ident_Bool( A_Stitch = Threadbare ) then - return Threadbare; - else - return A_Stitch; - end if; - end Identity; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("C460008", "Check that conversion to " & - "a modular type raises Constraint_Error when " & - "the operand value is outside the base range " & - "of the modular type" ); - - - -- Integer Error cases - - Int_To_Short( Report.Ident_Int( -1 ), "I2S Dynamic, Negative" ); - Int_To_Short( Report.Ident_Int( Shy_By_One ), "I2S Dynamic, At_Mod" ); - Int_To_Short( Report.Ident_Int( Heavy_By_Two+1 ), "I2S Dynamic, Over_Mod" ); - - Int_To_Eight( -Shy_By_One, "I28 Static, Negative" ); - Int_To_Eight( 2**8, "I28 Static, At_Mod" ); - Int_To_Eight( Heavy_By_Two+1, "I28 Static, Over_Mod" ); - - Int_To_Wide ( Report.Ident_Int( -(Heavy_By_Two*2) ), - "I2W Dynamic, Negative" ); - Int_To_Wide ( Heavy_By_Two, "I2W Static, At_Mod" ); - Int_To_Wide ( Report.Ident_Int( Heavy_By_Two*2 ), "I2W Dynamic, Over_Mod" ); - - -- Float Error cases - - Float_To_Short( -13.31, "F2S Static, Negative" ); - Float_To_Short( Identity ( Float(Shy_By_One)), "F2S Dynamic, At_Mod" ); - Float_To_Short( 6378.388, "F2S Static, Over_Mod" ); - - Float_To_Eight( Identity( -99.3574 ), "F28 Dynamic, Negative" ); - Float_To_Eight( 2.0**8, "F28 Static, At_Mod" ); - Float_To_Eight( 2.0**9, "F28 Static, Over_Mod" ); - - Float_To_Wide ( -0.54953_93129_81644, "FTW Static, Negative" ); - Float_To_Wide ( Identity( 2.0**8 +2.0 ), "FTW Dynamic, At_Mod" ); - Float_To_Wide ( Identity( 2.0**8 +2.5001 ), "FTW Dynamic, Over_Mod" ); - Float_To_Wide ( Identity( Float'Last ), "FTW Dynamic, Over_Mod" ); - - -- Fixed Error cases - - Fixed_To_Short( Identity( -5.00 ), "D2S Dynamic, Negative" ); - Fixed_To_Short( Shy_By_One * 1.0, "D2S Static, At_Mod" ); - Fixed_To_Short( 1995.9, "D2S Static, Over_Mod" ); - - Fixed_To_Eight( -0.5, "D28 Static, Negative" ); - Fixed_To_Eight( 2.0*128, "D28 Static, At_Mod" ); - Fixed_To_Eight( Identity( 2001.2 ), "D28 Dynamic, Over_Mod" ); - - Fixed_To_Wide ( Duration'First, "D2W Static, Negative" ); - Fixed_To_Wide ( Identity( 2*128.0 +2.0 ), "D2W Dynamic, At_Mod" ); - Fixed_To_Wide ( Duration'Last, "D2W Static, Over_Mod" ); - - -- having made it this far, the rest is downhill... - -- check a few, correct, edge cases, and we're done - - Eye_Dew: declare - A_Float : Float := 0.0; - Your_Time : Duration := 0.0; - Number : Integer := 0; - - Little : Unsigned_Edge_8; - Moderate : Unsigned_8_Bit; - Big : Unsigned_Over_8; - - begin - Little := Unsigned_Edge_8(A_Float); - Assert( Little = 0, "Float => Little, 0"); - - - Moderate := Unsigned_8_Bit (Your_Time); - Assert( Moderate = 0, "Your_Time => Moderate, 0"); - - Big := Unsigned_Over_8 (Number); - Assert( Big = 0, "Number => Big, 0"); - - A_Float := 2.0**8-2.0; - Your_Time := 2.0*128-2.0; - Number := 2**8; - - Little := Unsigned_Edge_8(A_Float); - Assert( Little = 254, "Float => Little, 254"); - - Little := Unsigned_Edge_8(Your_Time); - Assert( Little = 254, "Your_Time => Little, 254"); - - Big := Unsigned_Over_8 (A_Float + 2.0); - Assert( Big = 256, "Sense => Big, 256"); - - Big := Unsigned_Over_8 (Number); - Assert( Big = 256, "Number => Big, 256"); - - end Eye_Dew; - - Report.Result; - -end C460008; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460009.a b/gcc/testsuite/ada/acats/tests/c4/c460009.a deleted file mode 100644 index 62dbd47c2c7..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460009.a +++ /dev/null @@ -1,467 +0,0 @@ --- C460009.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 Constraint_Error is raised in cases of null arrays when: --- 1. an assignment is made to a null array if the length of each --- dimension of the operand does not match the length of --- the corresponding dimension of the target subtype. --- 2. an array actual parameter does not match the length of --- corresponding dimensions of the formal in out parameter where --- the actual parameter has the form of a type conversion. --- 3. an array actual parameter does not match the length of --- corresponding dimensions of the formal out parameter where --- the actual parameter has the form of a type conversion. --- --- TEST DESCRIPTION: --- This transition test creates examples where array of null ranges --- raises Constraint_Error if any of the lengths mismatch. --- --- Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA. --- --- --- CHANGE HISTORY: --- 21 Mar 96 SAIC Initial version for ACVC 2.1. --- 21 Sep 96 SAIC ACVC 2.1: Added new case. --- ---! - -with Report; - -procedure C460009 is - - subtype Int is Integer range 1 .. 3; - -begin - - Report.Test("C460009","Check that Constraint_Error is raised in " & - "cases of null arrays if any of the lengths mismatch " & - "in assignments and parameter passing"); - - --------------------------------------------------------------------------- - declare - - type Arr_Int1 is array (Int range <>) of Integer; - Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1)); -- null array object - - begin - - -- Same lengths, no Constraint_Error raised. - Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1)); - - Report.Comment ("Dead assignment prevention in Arr_Obj1 => " & - Integer'Image (Arr_Obj1'Last)); - - exception - - when Constraint_Error => - Report.Failed ("Arr_Obj1 - Constraint_Error exception raised"); - when others => - Report.Failed ("Arr_Obj1 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Int2 is array (Int range <>, Int range <>) of Integer; - Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2), - Report.Ident_Int(3) .. Report.Ident_Int(2)); - -- null array object - begin - - -- Same lengths, no Constraint_Error raised. - Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 => - (Report.Ident_Int(2) .. Report.Ident_Int(1) => - Report.Ident_Int(1))); - - Report.Comment ("Dead assignment prevention in Arr_Obj2 => " & - Integer'Image (Arr_Obj2'Last)); - - exception - - when Constraint_Error => - Report.Failed ("Arr_Obj2 - Constraint_Error exception raised"); - when others => - Report.Failed ("Arr_Obj2 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Int3 is array (Int range <>, Int range <>) of Integer; - Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2), - Report.Ident_Int(3) .. Report.Ident_Int(2)); - -- null array object - - begin - - -- Lengths mismatch, Constraint_Error raised. - Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 => - (Report.Ident_Int(1) .. Report.Ident_Int(3) => - Report.Ident_Int(1))); - - Report.Comment ("Dead assignment prevention in Arr_Obj3 => " & - Integer'Image (Arr_Obj3'Last)); - - Report.Failed ("Constraint_Error not raised in Arr_Obj3"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj3 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of - Integer; - Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2), - Report.Ident_Int(1) .. Report.Ident_Int(3), - Report.Ident_Int(3) .. Report.Ident_Int(2)); - -- null array object - begin - - -- Lengths mismatch, Constraint_Error raised. - Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 => - (Report.Ident_Int(1) .. Report.Ident_Int(2) => - (Report.Ident_Int(3) .. Report.Ident_Int(2) => - Report.Ident_Int(1)))); - - Report.Comment ("Dead assignment prevention in Arr_Obj4 => " & - Integer'Image (Arr_Obj4'Last)); - - Report.Failed ("Constraint_Error not raised in Arr_Obj4"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj4 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Int5 is array (Int range <>) of Integer; - Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1)); -- null array object - - begin - - -- Only lengths of two null ranges are different, no Constraint_Error - -- raised. - Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1)); - - Report.Comment ("Dead assignment prevention in Arr_Obj5 => " & - Integer'Image (Arr_Obj5'Last)); - - exception - - when Constraint_Error => - Report.Failed ("Arr_Obj5 - Constraint_Error exception raised"); - when others => - Report.Failed ("Arr_Obj5 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - subtype Str is String (Report.Ident_Int(5) .. 4); - -- null string - Str_Obj : Str; - - begin - - -- Same lengths, no Constraint_Error raised. - Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z'); - Str_Obj(2 .. 1) := ""; - Str_Obj(4 .. 2) := (others => 'X'); - Str_Obj(Report.Ident_Int(6) .. 3) := ""; - Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y'); - - exception - - when Constraint_Error => - Report.Failed ("Str_Obj - Constraint_Error exception raised"); - when others => - Report.Failed ("Str_Obj - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Char5 is array (Int range <>, Int range <>) of Character; - subtype Formal is Arr_Char5 - (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); - Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1), - Report.Ident_Int(1) .. Report.Ident_Int(2)) - := (Report.Ident_Int(2) .. Report.Ident_Int(1) => - (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' ')); - - procedure Proc5 (P : in out Formal) is - begin - Report.Failed ("No exception raised in Proc5"); - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised in Proc5"); - when others => - Report.Failed ("Others exception raised in Proc5"); - end; - - begin - - -- Lengths mismatch in the type conversion, Constraint_Error raised. - Proc5 (Formal(Arr_Obj5)); - - Report.Failed ("Constraint_Error not raised in the call Proc5"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj5 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Formal is array - (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; - - type Actual is array - (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; - - Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' ')); - - procedure Proc6 (P : in out Formal) is - begin - Report.Failed ("No exception raised in Proc6"); - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised in Proc6"); - when others => - Report.Failed ("Others exception raised in Proc6"); - end; - - begin - - -- Lengths mismatch in the type conversion, Constraint_Error raised. - Proc6 (Formal(Arr_Obj6)); - - Report.Failed ("Constraint_Error not raised in the call Proc6"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj6 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Formal is array (Int range <>, Int range <>) of Character; - type Actual is array (Positive range 5 .. 2, - Positive range 1 .. 3) of Character; - - Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' ')); - - procedure Proc7 (P : in out Formal) is - begin - if P'Last /= 2 and P'Last(2) /= 3 then - Report.Failed ("Wrong bounds passed for Arr_Obj7"); - end if; - - -- Lengths mismatch, Constraint_Error raised. - P := (1 .. 3 => (3 .. 0 => ' ')); - - Report.Comment ("Dead assignment prevention in Proc7 => " & - Integer'Image (P'Last)); - - Report.Failed ("No exception raised in Proc7"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Others exception raised in Proc7"); - end; - - begin - - -- Same lengths, no Constraint_Error raised. - Proc7 (Formal(Arr_Obj7)); - - if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then - Report.Failed ("Bounds changed for Arr_Obj7"); - end if; - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised after call Proc7"); - when others => - Report.Failed ("Arr_Obj7 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Arr_Char8 is array (Int range <>, Int range <>) of Character; - subtype Formal is Arr_Char8 - (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); - Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1), - Report.Ident_Int(1) .. Report.Ident_Int(2)); - - procedure Proc8 (P : out Formal) is - begin - Report.Failed ("No exception raised in Proc8"); - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised in Proc8"); - when others => - Report.Failed ("Others exception raised in Proc8"); - end; - - begin - - -- Lengths mismatch in the type conversion, Constraint_Error raised. - Proc8 (Formal(Arr_Obj8)); - - Report.Failed ("Constraint_Error not raised in the call Proc8"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj8 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Formal is array - (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; - - type Actual is array - (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; - - Arr_Obj9 : Actual; - - procedure Proc9 (P : out Formal) is - begin - Report.Failed ("No exception raised in Proc9"); - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised in Proc9"); - when others => - Report.Failed ("Others exception raised in Proc9"); - end; - - begin - - -- Lengths mismatch in the type conversion, Constraint_Error raised. - Proc9 (Formal(Arr_Obj9)); - - Report.Failed ("Constraint_Error not raised in the call Proc9"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Arr_Obj9 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - declare - - type Formal is array (Int range <>, Int range <>) of Character; - type Actual is array (Positive range 5 .. 2, - Positive range 1 .. 3) of Character; - - Arr_Obj10 : Actual; - - procedure Proc10 (P : out Formal) is - begin - if P'Last /= 2 and P'Last(2) /= 3 then - Report.Failed ("Wrong bounds passed for Arr_Obj10"); - end if; - - -- Lengths mismatch, Constraint_Error raised. - P := (1 .. 3 => (3 .. 1 => ' ')); - - Report.Comment ("Dead assignment prevention in Proc10 => " & - Integer'Image (P'Last)); - - Report.Failed ("No exception raised in Proc10"); - - exception - - when Constraint_Error => null; -- exception expected. - when others => - Report.Failed ("Others exception raised in Proc10"); - end; - - begin - - -- Same lengths, no Constraint_Error raised. - Proc10 (Formal(Arr_Obj10)); - - if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then - Report.Failed ("Bounds changed for Arr_Obj10"); - end if; - - exception - - when Constraint_Error => - Report.Failed ("Constraint_Error exception raised after call Proc10"); - when others => - Report.Failed ("Arr_Obj10 - others exception raised"); - - end; - - --------------------------------------------------------------------------- - Report.Result; - -end C460009; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460010.a b/gcc/testsuite/ada/acats/tests/c4/c460010.a deleted file mode 100644 index 790a8c3396c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460010.a +++ /dev/null @@ -1,354 +0,0 @@ --- C460010.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 array aggregate without an others choice assigned --- to an object of a constrained array subtype, Constraint_Error is not --- raised if the length of each dimension of the aggregate equals the --- length of the corresponding dimension of the target object, even if --- the bounds of the corresponding index ranges do not match. --- --- TEST DESCRIPTION: --- The test verifies that sliding of array bounds is performed on array --- aggregates that are part of a larger aggregate, where the bounds of --- the corresponding index ranges do not match but the lengths of the --- corresponding dimensions are the same. Both aggregates containing --- named associations and positional associations are checked. Cases --- involving static and nonstatic index constraints, as well as pre- --- defined and modular integer index subtypes, are included. --- --- --- CHANGE HISTORY: --- 15 Apr 96 SAIC Prerelease version for ACVC 2.1. --- 20 Oct 96 SAIC Removed unnecessary parentheses and type --- conversions. --- ---! - -with Report; -pragma Elaborate (Report); - -package C460010_0 is - - type Modular_Type is mod 10; -- Range 0 .. 9. - - - Two : Modular_Type := Modular_Type (Report.Ident_Int(2)); - Four : Modular_Type := Modular_Type (Report.Ident_Int(4)); - - type Array_Modular_Index is array (Modular_Type range <>) of Integer; - - subtype Array_Static_Modular_Constraint is Array_Modular_Index(2..4); - subtype Array_Nonstatic_Modular_Constraint is Array_Modular_Index(Two..Four); - -end C460010_0; - - - --==================================================================-- - - -with Report; -pragma Elaborate (Report); - -package C460010_1 is - - One : Integer := Report.Ident_Int(1); - Ten : Integer := Report.Ident_Int(10); - - subtype Integer_Subtype is Integer range One .. Ten; - - - Two : Integer := Report.Ident_Int(2); - Four : Integer := Report.Ident_Int(4); - - type Array_Integer_Index is array (Integer_Subtype range <>) of Boolean; - - subtype Array_Static_Integer_Constraint is Array_Integer_Index(2..4); - subtype Array_Nonstatic_Integer_Constraint is Array_Integer_Index(Two..Four); - -end C460010_1; - - - --==================================================================-- - - --- Generic equality function: - -generic - type Operand_Type is private; -function C460010_2 (L, R : Operand_Type) return Boolean; - - -function C460010_2 (L, R : Operand_Type) return Boolean is -begin - return L = R; -end C460010_2; - - - --==================================================================-- - - -with C460010_0; -with C460010_1; -with C460010_2; - -with Report; - -procedure C460010 is - - generic function Generic_Equality renames C460010_2; - -begin - Report.Test ("C460010", "Check that Constraint_Error is not raised if " & - "an array aggregate without an others choice is assigned " & - "to an object of a constrained array subtype, and the " & - "length of each dimension of the aggregate equals the " & - "length of the corresponding dimension of the target object"); - - - ---=---=---=---=---=---=---=---=---=---=--- - - - declare - type Arr is array (1..1) of C460010_0.Array_Static_Modular_Constraint; - function Equals is new Generic_Equality (Arr); - Target : Arr; - begin - ---=---=---=---=---=---=--- - CASE_1: - begin - Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 1"); - when others => - Report.Failed ("Unexpected exception raised: Case 1"); - end CASE_1; - - ---=---=---=---=---=---=--- - - CASE_2: - begin - Target := (1 => (5, 10, 15)); -- Positional associations. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 2"); - when others => - Report.Failed ("Unexpected exception raised: Case 2"); - end CASE_2; - - ---=---=---=---=---=---=--- - end; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - declare - type Rec (Disc : C460010_0.Modular_Type := 4) is record - Arr : C460010_0.Array_Modular_Index(2 .. Disc); - end record; - - function Equals is new Generic_Equality (Rec); - Target : Rec; - begin - ---=---=---=---=---=---=--- - CASE_3: - begin - Target := (Disc => 4, Arr => (1 => 1, 2 => 2, 3 => 3)); -- Named. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 3"); - when others => - Report.Failed ("Unexpected exception raised: Case 3"); - end CASE_3; - - ---=---=---=---=---=---=--- - - CASE_4: - begin - Target := (Disc => 4, Arr => (1 ,2, 3)); -- Positional. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 4"); - when others => - Report.Failed ("Unexpected exception raised: Case 4"); - end CASE_4; - - ---=---=---=---=---=---=--- - end; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - declare - type Arr is array (1..1) of C460010_0.Array_Nonstatic_Modular_Constraint; - function Equals is new Generic_Equality (Arr); - Target : Arr; - begin - ---=---=---=---=---=---=--- - CASE_5: - begin - Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 5"); - when others => - Report.Failed ("Unexpected exception raised: Case 5"); - end CASE_5; - - ---=---=---=---=---=---=--- - - CASE_6: - begin - Target := (1 => ((5, 10, 15))); -- Positional associations. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 6"); - when others => - Report.Failed ("Unexpected exception raised: Case 6"); - end CASE_6; - - ---=---=---=---=---=---=--- - end; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - declare - type Arr is array (1..1) of C460010_1.Array_Static_Integer_Constraint; - function Equals is new Generic_Equality (Arr); - Target : Arr; - begin - ---=---=---=---=---=---=--- - CASE_7: - begin - Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 7"); - when others => - Report.Failed ("Unexpected exception raised: Case 7"); - end CASE_7; - - ---=---=---=---=---=---=--- - - CASE_8: - begin - Target := (1 => ((False, False, True))); -- Positional. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 8"); - when others => - Report.Failed ("Unexpected exception raised: Case 8"); - end CASE_8; - - ---=---=---=---=---=---=--- - end; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - declare - type Arr is array (1..1) of C460010_1.Array_Nonstatic_Integer_Constraint; - function Equals is new Generic_Equality (Arr); - Target : Arr; - begin - ---=---=---=---=---=---=--- - CASE_9: - begin - Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 9"); - when others => - Report.Failed ("Unexpected exception raised: Case 9"); - end CASE_9; - - ---=---=---=---=---=---=--- - - CASE_10: - begin - Target := (1 => (False, False, True)); -- Positional. - - if not Equals (Target, Target) then - Report.Failed ("Avoid optimization"); -- Never executed. - end if; - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: Case 10"); - when others => - Report.Failed ("Unexpected exception raised: Case 10"); - end CASE_10; - - ---=---=---=---=---=---=--- - end; - - - ---=---=---=---=---=---=---=---=---=---=--- - - - Report.Result; - -end C460010; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460011.a b/gcc/testsuite/ada/acats/tests/c4/c460011.a deleted file mode 100644 index 56e4c0c4ec2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460011.a +++ /dev/null @@ -1,210 +0,0 @@ --- C460011.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and --- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the --- software and documentation contained herein. Unlimited rights are --- defined in DFAR 252.227-7013(a)(19). By making this public release, --- the Government intends to confer upon all recipients unlimited rights --- equal to those held by the Government. These rights include rights to --- use, duplicate, release or disclose the released technical data and --- computer software in whole or in part, in any manner and for any purpose --- whatsoever, and to have or permit others to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- OBJECTIVE: --- Check that conversion of a decimal type to a modular type raises --- Constraint_Error when the operand value is outside the base range --- of the modular type. --- Check that a conversion of a decimal type to an integer type --- rounds correctly. --- --- TEST DESCRIPTION: --- Test conversion from decimal types to modular types. Test --- conversion to mod 255, mod 256 and mod 258 to test the boundaries --- of 8 bit (+/-) unsigned numbers. --- Test operand values that are negative, the value of the mod, --- and greater than the value of the mod. --- Declare a generic test procedure and instantiate it for each of the --- unsigned types for each operand type. --- Check that the the operand is properly rounded during the conversion. --- --- APPLICABILITY CRITERIA: --- This test is applicable to all implementations which support --- decimal types. --- --- CHANGE HISTORY: --- 24 NOV 98 RLB Split decimal cases from C460008 into this --- test, added conversions to integer types. --- 18 JAN 99 RLB Repaired errors in test. --- ---! - -------------------------------------------------------------------- C460011 - -with Report; - -procedure C460011 is - - Shy_By_One : constant := 2**8-1; - Heavy_By_Two : constant := 2**8+2; - - type Unsigned_Edge_8 is mod Shy_By_One; - type Unsigned_8_Bit is mod 2**8; - type Unsigned_Over_8 is mod Heavy_By_Two; - - type Signed_8_Bit is range -128 .. 127; - type Signed_Over_8 is range -200 .. 200; - - NPC : constant String := " not properly converted"; - - procedure Assert( Truth: Boolean; Message: String ) is - begin - if not Truth then - Report.Failed(Message); - end if; - end Assert; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - - type Decim is delta 0.1 digits 5; -- N/A => ERROR. - - generic - type Source is delta <> digits <>; - type Target is mod <>; - procedure Decimal_Conversion_Check( For_The_Value : Source; - Message : String ); - - procedure Decimal_Conversion_Check( For_The_Value : Source; - Message : String ) is - - Item : Target; - - begin - Item := Target( For_The_Value ); - Report.Failed("Deci expected Constraint_Error " & Message); - Report.Comment("Value of" & Target'Image(Item) & NPC); - exception - when Constraint_Error => null; -- expected case - when others => Report.Failed("Deci raised wrong exception " & Message); - end Decimal_Conversion_Check; - - procedure Decim_To_Short is - new Decimal_Conversion_Check( Decim, Unsigned_Edge_8 ); - - procedure Decim_To_Eight is - new Decimal_Conversion_Check( Decim, Unsigned_8_Bit ); - - procedure Decim_To_Wide is - new Decimal_Conversion_Check( Decim, Unsigned_Over_8 ); - - function Identity( Launder: Decim ) return Decim is - Flat_Broke : constant Decim := 0.0; - begin - if Report.Ident_Bool( Launder = Flat_Broke ) then - return Flat_Broke; - else - return Launder; - end if; - end Identity; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -begin -- Main test procedure. - - Report.Test ("C460011", "Check that conversion to " & - "a modular type raises Constraint_Error when " & - "the operand value is outside the base range " & - "of the modular type" ); - - -- Decimal Error cases - - Decim_To_Short( Identity( -5.00 ), "M2S Dynamic, Negative" ); - Decim_To_Short( Shy_By_One * 1.0, "M2S Static, At_Mod" ); - Decim_To_Short( 1995.9, "M2S Static, Over_Mod" ); - - Decim_To_Eight( -0.5, "M28 Static, Negative" ); - Decim_To_Eight( 2.0*128, "M28 Static, At_Mod" ); - Decim_To_Eight( Identity( 2001.2 ), "M28 Dynamic, Over_Mod" ); - - Decim_To_Wide ( Decim'First, "M2W Static, Negative" ); - Decim_To_Wide ( Identity( 2*128.0 +2.0 ), "M2W Dynamic, At_Mod" ); - Decim_To_Wide ( Decim'Last, "M2W Static, Over_Mod" ); - - -- Check a few, correct, edge cases, for modular types. - - Eye_Dew: declare - Sense : Decim := 0.00; - - Little : Unsigned_Edge_8; - Moderate : Unsigned_8_Bit; - Big : Unsigned_Over_8; - - begin - Moderate := Unsigned_8_Bit (Sense); - Assert( Moderate = 0, "Sense => Moderate, 0"); - - Sense := 2*128.0; - - Big := Unsigned_Over_8 (Sense); - Assert( Big = 256, "Sense => Big, 256"); - - end Eye_Dew; - - Rounding: declare - Easy : Decim := Identity ( 2.0); - Simple : Decim := Identity ( 2.1); - Halfway : Decim := Identity ( 2.5); - Upward : Decim := Identity ( 2.8); - Chop : Decim := Identity (-2.2); - Neg_Half : Decim := Identity (-2.5); - Downward : Decim := Identity (-2.7); - - Little : Unsigned_Edge_8; - Moderate : Unsigned_8_Bit; - Big : Unsigned_Over_8; - - Also_Little:Signed_8_Bit; - Also_Big : Signed_Over_8; - - begin - Little := Unsigned_Edge_8 (Easy); - Assert( Little = 2, "Easy => Little, 2"); - - Moderate := Unsigned_8_Bit (Simple); - Assert( Moderate = 2, "Simple => Moderate, 2"); - - Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33). - Assert( Big = 3, "Halfway => Big, 3"); - - Little := Unsigned_Edge_8 (Upward); - Assert( Little = 3, "Upward => Little, 3"); - - Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33). - Assert( Also_Big = 3, "Halfway => Also_Big, 3"); - - Also_Little := Signed_8_Bit (Chop); - Assert( Also_Little = -2, "Chop => Also_Little, -2"); - - Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33). - Assert( Also_Big = -3, "Halfway => Also_Big, -3"); - - Also_Little := Signed_8_Bit (Downward); - Assert( Also_Little = -3, "Downward => Also_Little, -3"); - - end Rounding; - - - Report.Result; - -end C460011; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460012.a b/gcc/testsuite/ada/acats/tests/c4/c460012.a deleted file mode 100644 index 0fb32060a4c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460012.a +++ /dev/null @@ -1,93 +0,0 @@ --- C460012.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. These rights include rights to use, duplicate, --- release or disclose the released technical data and computer software --- in whole or in part, in any manner and for any purpose whatsoever, and --- to have or permit others to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- OBJECTIVE: --- Check that the view created by a view conversion is constrained if the --- target subtype is indefinite. (Defect Report 8652/0017, Technical --- Corrigendum 4.6(54/1)). --- --- CHANGE HISTORY: --- 25 JAN 2001 PHL Initial version. --- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking. --- 02 JUL 2001 RLB Fixed discriminant reference. --- ---! -with Ada.Exceptions; -use Ada.Exceptions; -with Report; -use Report; -procedure C460012 is - - subtype Index is Positive range 1 .. 10; - - type Definite_Parent (D1 : Index := 6) is - record - F : String (1 .. D1) := (others => 'a'); - end record; - - type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2); - - Y : Definite_Parent; - - procedure P (X : in out Indefinite_Child) is - C : Character renames X.F (3); - begin - X := (1, "a"); - if C /= 'a' then - Failed ("No exception raised when changing the " & - "discriminant of a view conversion, value of C changed"); - elsif X.D2 /= 1 then - Failed ("No exception raised when changing the " & - "discriminant of a view conversion, discriminant not " & - "changed"); - -- This check primarily exists to prevent X from being optimized by - -- 11.6 permissions, or the Failed call being made before the assignment. - else - Failed ("No exception raised when changing the " & - "discriminant of a view conversion, discriminant changed"); - end if; - exception - when Constraint_Error => - null; - when E: others => - Failed ("Wrong exception " & Exception_Name (E) & " raised - " & - Exception_Message (E)); - end P; - -begin - Test ("C460012", - "Check that the view created by a view conversion " & - "is constrained if the target subtype is indefinite"); - - P (Indefinite_Child (Y)); - - if Y.D1 /= Ident_Int(6) then - Failed ("Discriminant of indefinite view changed"); - -- This check exists mainly to prevent Y from being optimized away. - end if; - - Result; -end C460012; - diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a01.a b/gcc/testsuite/ada/acats/tests/c4/c460a01.a deleted file mode 100644 index 2d583706eb9..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460a01.a +++ /dev/null @@ -1,408 +0,0 @@ --- C460A01.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 the target type of a type conversion is a general --- access type, Program_Error is raised if the accessibility level of --- the operand type is deeper than that of the target type. Check for --- cases where the type conversion occurs in an instance body, and --- the operand type is passed as an actual during instantiation. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the operand type must --- be at the same or a less deep nesting level than the target type -- the --- operand type must "live" as long as the target type. Nesting levels --- are the run-time nestings of masters: block statements; subprogram, --- task, and entry bodies; and accept statements. Packages are invisible --- to accessibility rules. --- --- This test checks for cases where the operand is a subprogram formal --- parameter. --- --- The test declares three generic packages, each containing an access --- type conversion in which the operand type is a formal type: --- --- (1) One in which the target type is declared within the --- specification, and the conversion occurs within a nested --- function. --- --- (2) One in which the target type is also a formal type, and --- the conversion occurs within a nested function. --- --- (3) One in which the target type is declared outside the --- generic, and the conversion occurs within a nested --- procedure. --- --- The test verifies the following: --- --- For (1), Program_Error is not raised when the nested function is --- called. Since the actual corresponding to the formal operand type --- must always have the same or a less deep level than the target --- type declared within the instance, the access type conversion is --- always safe. --- --- For (2), Program_Error is raised when the nested function is --- called if the operand type passed as an actual during instantiation --- has an accessibility level deeper than that of the target type --- passed as an actual, and that no exception is raised otherwise. --- The exception is propagated to the innermost enclosing master. --- --- For (3), Program_Error is raised when the nested procedure is --- called if the operand type passed as an actual during instantiation --- has an accessibility level deeper than that of the target type. --- The exception is handled within the nested procedure. --- --- TEST FILES: --- The following files comprise this test: --- --- F460A00.A --- => C460A01.A --- --- --- CHANGE HISTORY: --- 09 May 95 SAIC Initial prerelease version. --- 24 Apr 96 SAIC Added code to avoid dead variable optimization. --- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342. ---! - -generic - type Designated_Type is tagged private; - type Operand_Type is access Designated_Type; -package C460A01_0 is - type Target_Type is access all Designated_Type; - function Convert (P : Operand_Type) return Target_Type; -end C460A01_0; - - - --==================================================================-- - - -package body C460A01_0 is - function Convert (P : Operand_Type) return Target_Type is - begin - return Target_Type(P); -- Never fails. - end Convert; -end C460A01_0; - - - --==================================================================-- - - -generic - type Designated_Type is tagged private; - type Operand_Type is access all Designated_Type; - type Target_Type is access all Designated_Type; -package C460A01_1 is - function Convert (P : Operand_Type) return Target_Type; -end C460A01_1; - - - --==================================================================-- - - -package body C460A01_1 is - function Convert (P : Operand_Type) return Target_Type is - begin - return Target_Type(P); - end Convert; -end C460A01_1; - - - --==================================================================-- - - -with F460A00; -generic - type Designated_Type (<>) is new F460A00.Tagged_Type with private; - type Operand_Type is access Designated_Type; -package C460A01_2 is - procedure Proc (P : Operand_Type; - Res : out F460A00.TC_Result_Kind); -end C460A01_2; - - - --==================================================================-- - -with Report; -package body C460A01_2 is - procedure Proc (P : Operand_Type; - Res : out F460A00.TC_Result_Kind) is - Ptr : F460A00.AccTag_L0; - begin - Ptr := F460A00.AccTag_L0(P); - - -- Avoid optimization (dead variable removal of Ptr): - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in C460A01_2 instance"); - end if; - - Res := F460A00.OK; - exception - when Program_Error => Res := F460A00.PE_Exception; - when others => Res := F460A00.Others_Exception; - end Proc; -end C460A01_2; - - - --==================================================================-- - - -with F460A00; -with C460A01_0; -with C460A01_1; -with C460A01_2; - -with Report; -procedure C460A01 is -begin -- C460A01. -- [ Level = 1 ] - - Report.Test ("C460A01", "Run-time accessibility checks: instance " & - "bodies. Operand type of access type conversion is " & - "passed as actual to instance"); - - - SUBTEST1: - declare -- [ Level = 2 ] - type AccTag_L2 is access all F460A00.Tagged_Type; - Operand: AccTag_L2 := new F460A00.Tagged_Type; - - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST1. - - declare -- [ Level = 3 ] - -- The instantiation of C460A01_0 should NOT result in any - -- exceptions. - - package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2); - Target : Pack_OK.Target_Type; - begin - -- The accessibility level of Pack_OK.Target_Type will always be at - -- least as deep as the operand type passed as an actual. Thus, - -- a call to Pack_OK.Convert does not propagate an exception: - - Target := Pack_OK.Convert(Operand); - - -- Avoid optimization (dead variable removal of Target): - if not Report.Equal (Target.C, Target.C) then -- Always false. - Report.Failed ("Unexpected error in SUBTEST #1"); - end if; - - Result := F460A00.OK; -- Expected result. - exception - when Program_Error => Result := F460A00.PE_Exception; - when others => Result := F460A00.Others_Exception; - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #1: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #1: Unexpected exception raised"); - end SUBTEST1; - - - - SUBTEST2: - declare -- [ Level = 2 ] - type AccTag_L2 is access all F460A00.Tagged_Type; - Operand : AccTag_L2 := new F460A00.Tagged_Type; - - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST2. - - declare -- [ Level = 3 ] - - type AccTag_L3 is access all F460A00.Tagged_Type; - Target : AccTag_L3; - - -- The instantiation of C460A01_1 should NOT result in any - -- exceptions. - - package Pack_OK is new C460A01_1 - (Designated_Type => F460A00.Tagged_Type, - Operand_Type => AccTag_L2, - Target_Type => AccTag_L3); - begin - -- The accessibility level of the actual passed as the operand type - -- in Pack_OK is 2. The accessibility level of the actual passed as - -- the target type is 3. Therefore, the access type conversion in - -- Pack_OK.Convert does not raise an exception when the subprogram is - -- called. If an exception is (incorrectly) raised, it is propagated - -- to the innermost enclosing master: - - Target := Pack_OK.Convert(Operand); - - -- Avoid optimization (dead variable removal of Target): - if not Report.Equal (Target.C, Target.C) then -- Always false. - Report.Failed ("Unexpected error in SUBTEST #2"); - end if; - - Result := F460A00.OK; -- Expected result. - exception - when Program_Error => Result := F460A00.PE_Exception; - when others => Result := F460A00.Others_Exception; - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #2: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #2: Unexpected exception raised"); - end SUBTEST2; - - - - SUBTEST3: - declare -- [ Level = 2 ] - type AccTag_L2 is access all F460A00.Tagged_Type; - Target : AccTag_L2; - - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST3. - - declare -- [ Level = 3 ] - - type AccTag_L3 is access all F460A00.Tagged_Type; - Operand : AccTag_L3 := new F460A00.Tagged_Type; - - -- The instantiation of C460A01_1 should NOT result in any - -- exceptions. - - package Pack_PE is new C460A01_1 - (Designated_Type => F460A00.Tagged_Type, - Operand_Type => AccTag_L3, - Target_Type => AccTag_L2); - begin - -- The accessibility level of the actual passed as the operand type - -- in Pack_PE is 3. The accessibility level of the actual passed as - -- the target type is 2. Therefore, the access type conversion in - -- Pack_PE.Convert raises Program_Error when the subprogram is - -- called. The exception is propagated to the innermost enclosing - -- master: - - Target := Pack_PE.Convert(Operand); - - -- Avoid optimization (dead variable removal of Target): - if not Report.Equal (Target.C, Target.C) then -- Always false. - Report.Failed ("Unexpected error in SUBTEST #3"); - end if; - - Result := F460A00.OK; - exception - when Program_Error => Result := F460A00.PE_Exception; - -- Expected result. - when others => Result := F460A00.Others_Exception; - end; - - F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #3: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #3: Unexpected exception raised"); - end SUBTEST3; - - - - SUBTEST4: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST4. - - declare -- [ Level = 3 ] - - TType : F460A00.Tagged_Type; - Operand : F460A00.AccTagClass_L0 - := new F460A00.Tagged_Type'(TType); - - -- The instantiation of C460A01_2 should NOT result in any - -- exceptions. - - package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class, - F460A00.AccTagClass_L0); - begin - -- The accessibility level of the actual passed as the operand type - -- in Pack_OK is 0. The accessibility level of the target type - -- (F460A00.AccTag_L0) is also 0. Therefore, the access type - -- conversion in Pack_OK.Proc does not raise an exception when the - -- subprogram is called. If an exception is (incorrectly) raised, - -- it is handled within the subprogram: - - Pack_OK.Proc(Operand, Result); - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #4: Unexpected exception raised"); - end SUBTEST4; - - - - SUBTEST5: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST5. - - declare -- [ Level = 3 ] - - type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type; - Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type; - - -- The instantiation of C460A01_2 should NOT result in any - -- exceptions. - - package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type, - AccDerTag_L3); - begin - -- The accessibility level of the actual passed as the operand type - -- in Pack_PE is 3. The accessibility level of the target type - -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion - -- in Pack_PE.Proc raises Program_Error when the subprogram is - -- called. The exception is handled within the subprogram: - - Pack_PE.Proc(Operand, Result); - end; - - F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #5: Unexpected exception raised"); - end SUBTEST5; - - Report.Result; - -end C460A01; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a02.a b/gcc/testsuite/ada/acats/tests/c4/c460a02.a deleted file mode 100644 index 1d79d3a614e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460a02.a +++ /dev/null @@ -1,413 +0,0 @@ --- C460A02.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 the target type of a type conversion is a general --- access type, Program_Error is raised if the accessibility level of --- the operand type is deeper than that of the target type. Check for --- cases where the type conversion occurs in an instance body, and --- the operand type is declared inside the instance or is the anonymous --- access type of an access parameter or access discriminant. --- --- TEST DESCRIPTION: --- In order to satisfy accessibility requirements, the operand type must --- be at the same or a less deep nesting level than the target type -- the --- operand type must "live" as long as the target type. Nesting levels --- are the run-time nestings of masters: block statements; subprogram, --- task, and entry bodies; and accept statements. Packages are invisible --- to accessibility rules. --- --- This test checks for cases where the operand is a component of a --- generic formal object, a stand-alone object, and an access parameter. --- --- The test declares three generic units, each containing an access --- type conversion in which the target type is a formal type: --- --- (1) A generic package in which the operand type is the anonymous --- access type of an access discriminant, and the conversion --- occurs within the declarative part of the body. --- --- (2) A generic package in which the operand type is declared within --- the specification, and the conversion occurs within the --- sequence of statements of the body. --- --- (3) A generic procedure in which the operand type is the anonymous --- access type of an access parameter, and the conversion occurs --- within the sequence of statements. --- --- The test verifies the following: --- --- For (1), Program_Error is raised when the package is instantiated --- if the actual passed through the formal object has an accessibility --- level deeper than that of the target type passed as an actual, and --- that no exception is raised otherwise. The exception is propagated --- to the innermost enclosing master. --- --- For (2), Program_Error is raised when the package is instantiated --- if the package is instantiated at a level deeper than that of the --- target type passed as an actual, and that no exception is raised --- otherwise. The exception is handled within the package body. --- --- For (3), Program_Error is raised when the instance procedure is --- called if the actual passed through the access parameter has an --- accessibility level deeper than that of the target type passed as --- an actual, and that no exception is raised otherwise. The exception --- is handled within the instance procedure. --- --- TEST FILES: --- The following files comprise this test: --- --- F460A00.A --- => C460A02.A --- --- --- CHANGE HISTORY: --- 10 May 95 SAIC Initial prerelease version. --- 24 Apr 96 SAIC Changed the target type formal to be --- access-to-constant; Modified code to avoid dead --- variable optimization. --- ---! - -with F460A00; -generic - type Target_Type is access all F460A00.Tagged_Type; - FObj: in out F460A00.Composite_Type; -package C460A02_0 is - procedure Dummy; -- Needed to allow package body. -end C460A02_0; - - - --==================================================================-- - -with Report; -package body C460A02_0 is - Ptr: Target_Type := Target_Type(FObj.D); - - procedure Dummy is - begin - null; - end Dummy; - -begin - -- Avoid optimization (dead variable removal of Ptr): - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in C460A02_0 instance"); - end if; - -end C460A02_0; - - - --==================================================================-- - - -with F460A00; -generic - type Designated_Type is private; - type Target_Type is access all Designated_Type; - FObj : in out Target_Type; - FRes : in out F460A00.TC_Result_Kind; -package C460A02_1 is - type Operand_Type is access Designated_Type; - Ptr : Operand_Type := new Designated_Type; - - procedure Dummy; -- Needed to allow package body. -end C460A02_1; - - - --==================================================================-- - - -package body C460A02_1 is - procedure Dummy is - begin - null; - end Dummy; -begin - FRes := F460A00.UN_Init; - FObj := Target_Type(Ptr); - FRes := F460A00.OK; -exception - when Program_Error => FRes := F460A00.PE_Exception; - when others => FRes := F460A00.Others_Exception; -end C460A02_1; - - - --==================================================================-- - - -with F460A00; -generic - type Designated_Type is new F460A00.Tagged_Type with private; - type Target_Type is access constant Designated_Type; -procedure C460A02_2 (P : access Designated_Type'Class; - Res : out F460A00.TC_Result_Kind); - - - --==================================================================-- - - -with Report; -procedure C460A02_2 (P : access Designated_Type'Class; - Res : out F460A00.TC_Result_Kind) is - Ptr : Target_Type; -begin - Res := F460A00.UN_Init; - Ptr := Target_Type(P); - - -- Avoid optimization (dead variable removal of Ptr): - if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. - Report.Failed ("Unexpected error in C460A02_2 instance"); - end if; - Res := F460A00.OK; -exception - when Program_Error => Res := F460A00.PE_Exception; - when others => Res := F460A00.Others_Exception; -end C460A02_2; - - - --==================================================================-- - - -with F460A00; -with C460A02_0; -with C460A02_1; -with C460A02_2; - -with Report; -procedure C460A02 is -begin -- C460A02. -- [ Level = 1 ] - - Report.Test ("C460A02", "Run-time accessibility checks: instance " & - "bodies. Operand type of access type conversion is " & - "declared inside instance or is anonymous"); - - - SUBTEST1: - declare -- [ Level = 2 ] - type AccTag_L2 is access all F460A00.Tagged_Type; - PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; - Operand_L2 : F460A00.Composite_Type(PTag_L2); - - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST1. - - begin -- [ Level = 3 ] - declare -- [ Level = 4 ] - -- The accessibility level of the actual passed as the target type - -- in Pack_OK is 2. The accessibility level of the composite actual - -- (and thus, the level of the anonymous type of the access - -- discriminant, which is the same as that of the containing - -- object) is also 2. Therefore, the access type conversion in - -- Pack_OK does not raise an exception upon instantiation: - - package Pack_OK is new C460A02_0 - (Target_Type => AccTag_L2, FObj => Operand_L2); - begin - Result := F460A00.OK; -- Expected result. - end; - exception - when Program_Error => Result := F460A00.PE_Exception; - when others => Result := F460A00.Others_Exception; - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); - - end SUBTEST1; - - - - SUBTEST2: - declare -- [ Level = 2 ] - type AccTag_L2 is access all F460A00.Tagged_Type; - PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; - - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST2. - - declare -- [ Level = 3 ] - Operand_L3 : F460A00.Composite_Type(PTag_L2); - begin - declare -- [ Level = 4 ] - -- The accessibility level of the actual passed as the target type - -- in Pack_PE is 2. The accessibility level of the composite actual - -- (and thus, the level of the anonymous type of the access - -- discriminant, which is the same as that of the containing - -- object) is 3. Therefore, the access type conversion in Pack_PE - -- propagates Program_Error upon instantiation: - - package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3); - begin - Result := F460A00.OK; - end; - exception - when Program_Error => Result := F460A00.PE_Exception; - -- Expected result. - when others => Result := F460A00.Others_Exception; - end; - - F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2"); - - end SUBTEST2; - - - - SUBTEST3: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST3. - - declare -- [ Level = 3 ] - type AccArr_L3 is access all F460A00.Array_Type; - Target: AccArr_L3; - - -- The accessibility level of the actual passed as the target type - -- in Pack_OK is 3. The accessibility level of the operand type is - -- that of the instance, which is also 3. Therefore, the access type - -- conversion in Pack_OK does not raise an exception upon - -- instantiation. If an exception is (incorrectly) raised, it is - -- handled within the instance: - - package Pack_OK is new C460A02_1 - (Designated_Type => F460A00.Array_Type, - Target_Type => AccArr_L3, - FObj => Target, - FRes => Result); - begin - null; - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated"); - when others => - Report.Failed ("SUBTEST #3: Unexpected exception propagated"); - end SUBTEST3; - - - - SUBTEST4: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST4. - - declare -- [ Level = 3 ] - Target: F460A00.AccArr_L0; - - -- The accessibility level of the actual passed as the target type - -- in Pack_PE is 0. The accessibility level of the operand type is - -- that of the instance, which is 3. Therefore, the access type - -- conversion in Pack_PE raises Program_Error upon instantiation. - -- The exception is handled within the instance: - - package Pack_PE is new C460A02_1 - (Designated_Type => F460A00.Array_Type, - Target_Type => F460A00.AccArr_L0, - FObj => Target, - FRes => Result); - begin - null; - end; - - F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #4: Unexpected exception raised"); - end SUBTEST4; - - - - SUBTEST5: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST5. - - declare -- [ Level = 3 ] - -- The instantiation of C460A02_2 should NOT result in any - -- exceptions. - - procedure Proc is new C460A02_2 (F460A00.Tagged_Type, - F460A00.AccTag_L0); - begin - -- The accessibility level of the actual passed to Proc is 0. The - -- accessibility level of the actual passed as the target type is - -- also 0. Therefore, the access type conversion in Proc does not - -- raise an exception when the subprogram is called. If an exception - -- is (incorrectly) raised, it is handled within the subprogram: - - Proc (F460A00.PTagClass_L0, Result); - end; - - F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #5: Unexpected exception raised"); - end SUBTEST5; - - - - SUBTEST6: - declare -- [ Level = 2 ] - Result : F460A00.TC_Result_Kind := F460A00.UN_Init; - begin -- SUBTEST6. - - declare -- [ Level = 3 ] - -- The instantiation of C460A02_2 should NOT result in any - -- exceptions. - - procedure Proc is new C460A02_2 (F460A00.Tagged_Type, - F460A00.AccTag_L0); - begin - -- In the call to (instantiated) procedure Proc, the first actual - -- parameter is an allocator. Its accessibility level is that of - -- the level of execution of Proc, which is 3. The accessibility - -- level of the actual passed as the target type is 0. Therefore, - -- the access type conversion in Proc raises Program_Error when the - -- subprogram is called. The exception is handled within the - -- subprogram: - - Proc (new F460A00.Tagged_Type, Result); - end; - - F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6"); - - exception - when Program_Error => - Report.Failed ("SUBTEST #6: Program_Error incorrectly raised"); - when others => - Report.Failed ("SUBTEST #6: Unexpected exception raised"); - end SUBTEST6; - - Report.Result; - -end C460A02; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490001.a b/gcc/testsuite/ada/acats/tests/c4/c490001.a deleted file mode 100644 index 19153504cb0..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c490001.a +++ /dev/null @@ -1,215 +0,0 @@ --- C490001.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 real static expression that is not part of a larger --- static expression, and whose expected type T is a floating point type --- that is not a descendant of a formal scalar type, the value is rounded --- to the nearest machine number of T if T'Machine_Rounds is true, and is --- truncated otherwise. Check that if rounding is performed, and the value --- is exactly halfway between two machine numbers, one of the two machine --- numbers is used. --- --- TEST DESCRIPTION: --- The test obtains a machine number M1 for a floating point subtype S by --- passing a real literal to S'Machine. It then obtains an adjacent --- machine number M2 by using S'Succ (or S'Pred). It then constructs --- values which lie between these two machine numbers: one (A) which is --- closer to M1, one (B) which is exactly halfway between M1 and M2, and --- one (C) which is closer to M2. This is done for both positive and --- negative machine numbers. --- --- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, --- C must be rounded to M2, A must be rounded to M1, and B must be rounded --- to either M1 or M2. If S'Machine_Rounds is false, all the values must --- be truncated to M1. --- --- A, B, and C are constructed using the following static expressions: --- --- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5. --- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5. --- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5. --- --- Since these are static expressions, they must be evaluated exactly, --- and no rounding may occur until the final result is calculated. --- --- The checks for equality between the members of (A, B, C) and (M1, M2) --- are performed at run-time within the body of a subprogram. --- --- The test performs additional checks that the rounding performed on --- real literals is consistent for a floating point subtype. A literal is --- assigned to a constant of a floating point subtype S. The same literal --- is then passed to a subprogram, along with the constant, and an --- equality check is performed within the body of the subprogram. --- --- --- CHANGE HISTORY: --- 25 Sep 95 SAIC Initial prerelease version. --- 25 May 01 RLB Repaired to work with the repeal of the round away --- rule by AI-268. --- ---! - -with System; -package C490001_0 is - - type My_Flt is digits System.Max_Digits; - - procedure Float_Subtest (A, B: in My_Flt; Msg: in String); - - procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String); - - --- --- Positive cases: --- - - -- |----|-------------|-----------------|-------------------|-----------| - -- | | | | | | - -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 - - - Positive_Float : constant My_Flt := 12.440193950021943; - - -- The literal value 12.440193950021943 is rounded up or down to the - -- nearest machine number of My_Flt when Positive_Float is initialized. - -- The value of Positive_Float should therefore be a machine number, and - -- the use of 'Machine in the initialization of P_M1 will be redundant for - -- a correct implementation. It's done anyway to make certain that P_M1 is - -- a machine number, independent of whether an implementation correctly - -- performs rounding. - - P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float); - P_M2 : constant My_Flt := My_Flt'Succ(P_M1); - - -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not - -- certain whether 12.440193950021943 is a machine number, nor whether - -- 'Machine rounds it up or down, 12.440193950021943 may not lie between - -- P_M1 and P_M2. The test does not depend on this information, however; - -- the literal is only used as a "seed" to obtain the machine numbers. - - - -- The following entities are used to verify that rounding is performed - -- according to the value of 'Machine_Rounds. If language rules are - -- obeyed, the intermediate expressions in the following static - -- initialization expressions will not be rounded; all calculations will - -- be performed exactly. The final result, however, will be rounded to - -- a machine number (either P_M1 or P_M2, depending on the value of - -- My_Flt'Machine_Rounds). Thus, the value of each constant below will - -- equal that of P_M1 or P_M2. - - Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0); - Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0); - More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0); - - --- --- Negative cases: --- - - -- -|-------------|-----------------|-------------------|-----------|----| - -- | | | | | | - -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 - - - -- The descriptions for the positive cases above apply to the negative - -- cases below as well. Note that, for N_M2, 'Pred is used rather than - -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. - - Negative_Float : constant My_Flt := -0.692074550952117; - - - N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float); - N_M2 : constant My_Flt := My_Flt'Pred(N_M1); - - More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0); - Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0); - Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0); - -end C490001_0; - - - --==================================================================-- - - -with TCTouch; -package body C490001_0 is - - procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is - begin - TCTouch.Assert (A = B, Msg); - end Float_Subtest; - - procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is - begin - TCTouch.Assert (A = B or A = C, Msg); - end Float_Subtest; - -end C490001_0; - - - --==================================================================-- - - -with C490001_0; -- Floating point support. -use C490001_0; - -with Report; -procedure C490001 is -begin - Report.Test ("C490001", "Rounding of real static expressions: " & - "floating point subtypes"); - - - -- Check that rounding direction is consistent for literals: - - Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal"); - Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal"); - - - -- Now check that rounding is performed correctly for values between - -- machine numbers, according to the value of 'Machine_Rounds: - - if My_Flt'Machine_Rounds then - Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half"); - Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half"); - Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); - - Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half"); - Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half"); - Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); - else - Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half"); - Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half"); - Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); - - Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half"); - Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half"); - Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); - end if; - - - Report.Result; -end C490001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490002.a b/gcc/testsuite/ada/acats/tests/c4/c490002.a deleted file mode 100644 index 71169b833e4..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c490002.a +++ /dev/null @@ -1,239 +0,0 @@ --- C490002.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 real static expression that is not part of a larger --- static expression, and whose expected type T is an ordinary fixed --- point type that is not a descendant of a formal scalar type, the value --- is rounded to the nearest integral multiple of the small of T if --- T'Machine_Rounds is true, and is truncated otherwise. Check that if --- rounding is performed, and the value is exactly halfway between two --- multiples of the small, one of the two multiples of small is used. --- --- TEST DESCRIPTION: --- The test obtains an integral multiple M1 of the small of an ordinary --- fixed point subtype S by dividing a real literal by S'Small, and then --- truncating the result using 'Truncation. It then obtains an adjacent --- multiple M2 of the small by using S'Succ (or S'Pred). It then --- constructs values which lie between these multiples: one (A) which is --- closer to M1, one (B) which is exactly halfway between M1 and M2, and --- one (C) which is closer to M2. This is done for both positive and --- negative multiples of the small. --- --- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, --- C must be rounded to M2, A must be rounded to M1, and B must be rounded --- to either M1 or M2. If S'Machine_Rounds is false, all the values must --- be truncated to M1. --- --- A, B, and C are constructed using the following static expressions: --- --- A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0. --- B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0. --- C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0. --- --- Since these are static expressions, they must be evaluated exactly, --- and no rounding may occur until the final result is calculated. --- --- The checks for equality between the members of (A, B, C) and (M1, M2) --- are performed at run-time within the body of a subprogram. --- --- The test performs additional checks that the rounding performed on --- real literals is consistent for ordinary fixed point subtypes. A --- named number (initialized with a literal) is assigned to a constant of --- a fixed point subtype S. The same literal is then passed to a --- subprogram, along with the constant, and an equality check is --- performed within the body of the subprogram. --- --- --- CHANGE HISTORY: --- 26 Sep 95 SAIC Initial prerelease version. --- ---! - -package C490002_0 is - - type My_Fix is delta 0.0625 range -1000.0 .. 1000.0; - - Small : constant := My_Fix'Small; -- Named number. - - procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String); - - procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String); - - --- --- Positive cases: --- - - -- |----|-------------|-----------------|-------------------|-----------| - -- | | | | | | - -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 - - - Positive_Real : constant := 0.11433; -- Named number. - Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small); - - -- Pos_Multiplier is the number of integral multiples of small contained - -- in Positive_Real. P_M1 is thus the largest integral multiple of - -- small less than or equal to Positive_Real. Note that since Positive_Real - -- is a named number and not a fixed point object, P_M1 is generated - -- without assuming that rounding is performed correctly for fixed point - -- subtypes. - - Positive_Fixed : constant My_Fix := Positive_Real; - - P_M1 : constant My_Fix := Pos_Multiplier * Small; - P_M2 : constant My_Fix := My_Fix'Succ(P_M1); - - -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that - -- 0.11433 either equals P_M1 (if it is an integral multiple of the small) - -- or lies between P_M1 and P_M2 (since truncation was forced in - -- generating Pos_Multiplier). It is not certain, however, exactly where - -- it lies between them (halfway, less than halfway, more than halfway). - -- This fact is irrelevant to the test. - - - -- The following entities are used to verify that rounding is performed - -- according to the value of 'Machine_Rounds. If language rules are - -- obeyed, the intermediate expressions in the following static - -- initialization expressions will not be rounded; all calculations will - -- be performed exactly. The final result, however, will be rounded to - -- an integral multiple of the small (either P_M1 or P_M2, depending on the - -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below - -- will equal that of P_M1 or P_M2. - - Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050); - Pos_Exactly_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000); - More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975); - - --- --- Negative cases: --- - - -- -|-------------|-----------------|-------------------|-----------|----| - -- | | | | | | - -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 - - - -- The descriptions for the positive cases above apply to the negative - -- cases below as well. Note that, for N_M2, 'Pred is used rather than - -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. - - Negative_Real : constant := -467.13988; -- Named number. - Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small); - - Negative_Fixed : constant My_Fix := Negative_Real; - - N_M1 : constant My_Fix := Neg_Multiplier * Small; - N_M2 : constant My_Fix := My_Fix'Pred(N_M1); - - More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980); - Neg_Exactly_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000); - Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033); - -end C490002_0; - - - --==================================================================-- - - -with TCTouch; -package body C490002_0 is - - procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is - begin - TCTouch.Assert (A = B, Msg); - end Fixed_Subtest; - - procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is - begin - TCTouch.Assert (A = B or A = C, Msg); - end Fixed_Subtest; - -end C490002_0; - - - --==================================================================-- - - -with C490002_0; -- Fixed point support. -use C490002_0; - -with Report; -procedure C490002 is -begin - Report.Test ("C490002", "Rounding of real static expressions: " & - "ordinary fixed point subtypes"); - - - -- Literal cases: If the named numbers used to initialize Positive_Fixed - -- and Negative_Fixed are rounded to an integral multiple of the small - -- prior to assignment (as expected), then Positive_Fixed and - -- Negative_Fixed are already integral multiples of the small, and - -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check - -- can determine in which direction rounding occurred. For example: - -- - -- if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0. - -- - -- Check here that the rounding direction is consistent for literals: - - if (Positive_Fixed = P_M1) then - Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal"); - else - Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal"); - end if; - - if (Negative_Fixed = N_M1) then - Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal"); - else - Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal"); - end if; - - - -- Now check that rounding is performed correctly for values between - -- multiples of the small, according to the value of 'Machine_Rounds: - - if My_Fix'Machine_Rounds then - Fixed_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Fixed: = half"); - Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half"); - Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); - - Fixed_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Fixed: = half"); - Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half"); - Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); - else - Fixed_Subtest (Pos_Exactly_Half, P_M1, "Positive Fixed: = half"); - Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half"); - Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); - - Fixed_Subtest (Neg_Exactly_Half, N_M1, "Negative Fixed: = half"); - Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half"); - Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); - end if; - - - Report.Result; -end C490002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490003.a b/gcc/testsuite/ada/acats/tests/c4/c490003.a deleted file mode 100644 index a135b5ac3a2..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c490003.a +++ /dev/null @@ -1,215 +0,0 @@ --- C490003.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 static expression is legal if its evaluation fails --- no language-defined check other than Overflow_Check. Check that such --- a static expression is legal if it is part of a larger static --- expression, even if its value is outside the base range of the --- expected type. --- --- Check that if a static expression is part of the right operand of a --- short circuit control form whose value is determined by its left --- operand, it is not evaluated. --- --- Check that a static expression in a non-static context is evaluated --- exactly. --- --- TEST DESCRIPTION: --- The first part of the objective is tested by constructing static --- expressions which involve predefined operations of integer, floating --- point, and fixed point subtypes. Intermediate expressions within the --- static expressions have values outside the base range of the expected --- type. In one case, the extended-range intermediates are compared as --- part of a boolean expression. In the remaining two cases, further --- predefined operations on the intermediates bring the final result --- within the base range. An implementation which compiles these static --- expressions satisfies this portion of the objective. A check is --- performed at run-time to ensure that the static expressions evaluate --- to values within the base range of their respective expected types. --- --- The second part of the objective is tested by constructing --- short-circuit control forms whose left operands have the values --- shown below: --- --- (TRUE) or else (...) --- (FALSE) and then (...) --- --- In both cases the left operand determines the value of the condition. --- In the test each right operand involves a division by zero, which will --- raise Constraint_Error if evaluated. A check is made that no exception --- is raised when each short-circuit control form is evaluated, and that --- the value of the condition is that of the left operand. --- --- The third part of the objective is tested by evaluating static --- expressions involving many operations in contexts which do not --- require a static expression, and verifying that the exact --- mathematical results are calculated. --- --- --- CHANGE HISTORY: --- 15 Sep 95 SAIC Initial prerelease version for ACVC 2.1. --- 20 Oct 96 SAIC Modified expressions in C490003_0 to avoid --- the use of universal operands. --- ---! - -with System; -package C490003_0 is - - type My_Flt is digits System.Max_Digits; - - Flt_Range_Diff : My_Flt := (My_Flt'Base'Last - My_Flt'Base'First) - - (My_Flt'Last - My_Flt'First); -- OK. - - - type My_Fix is delta 0.125 range -128.0 .. 128.0; - - Symmetric : Boolean := (My_Fix'Base'Last - My_Fix'Base'First) = - (My_Fix'Base'Last + My_Fix'Base'Last); -- OK. - - - Center : constant Integer := Integer'Base'Last - - (Integer'Base'Last - - Integer'Base'First) / 2; -- OK. - -end C490003_0; - - - --==================================================================-- - - -with Ada.Numerics; -package C490003_1 is - - Zero : constant := 0.0; - Pi : constant := Ada.Numerics.Pi; - - Two_Pi : constant := 2.0 * Pi; - Half_Pi : constant := Pi/2.0; - - Quarter : constant := 90.0; - Half : constant := 180.0; - Full : constant := 360.0; - - Deg_To_Rad : constant := Half_Pi/90; - Rad_To_Deg : constant := 1.0/Deg_To_Rad; - -end C490003_1; - - - --==================================================================-- - - -with C490003_0; -with C490003_1; - -with Report; -procedure C490003 is -begin - Report.Test ("C490003", "Check that static expressions failing " & - "Overflow_Check are legal if part of a larger static " & - "expression. Check that static expressions as right " & - "operands of short-circuit control forms are not " & - "evaluated if value of control form is determined by " & - "left operand. Check that static expressions in non-static " & - "contexts are evaluated exactly"); - - --- --- Static expressions within larger static expressions: --- - - - if C490003_0.Flt_Range_Diff not in C490003_0.My_Flt'Base'Range then - Report.Failed ("Error evaluating static expression: floating point"); - end if; - - if C490003_0.Symmetric not in Boolean'Range then - Report.Failed ("Error evaluating static expression: fixed point"); - end if; - - if C490003_0.Center not in Integer'Base'Range then - Report.Failed ("Error evaluating static expression: integer"); - end if; - - --- --- Short-circuit control forms: --- - - declare - N : constant := 0.0; - begin - - begin - if not ( (N = 0.0) or else (1.0/N > 0.5) ) then - Report.Failed ("Error evaluating OR ELSE"); - end if; - exception - when Constraint_Error => - Report.Failed ("Right side of OR ELSE was evaluated"); - when others => - Report.Failed ("OR ELSE: unexpected exception raised"); - end; - - begin - if (N /= 0.0) and then (1.0/N <= 0.5) then - Report.Failed ("Error evaluating AND THEN"); - end if; - exception - when Constraint_Error => - Report.Failed ("Right side of AND THEN was evaluated"); - when others => - Report.Failed ("AND THEN: unexpected exception raised"); - end; - - end; - - --- --- Exact evaluation of static expressions: --- - - - declare - use C490003_1; - - Left : constant := 6.0 + 0.3125*( (Full*0.375) + (Half/2.4) - - ((Quarter + 36.0)/3.0) )/10.0; -- 11.25 - Right : constant := (Pi/3.0) * 1.2 * (15.0/96.0); -- Pi/16 - begin - if Deg_To_Rad*Left /= Right then - Report.Failed ("Static expressions not evaluated exactly: #1"); - end if; - - if ((Pi*Rad_To_Deg)*2.0 + 4.0*Quarter)/16.0 /= Rad_To_Deg*(Pi/4.0) then - Report.Failed ("Static expressions not evaluated exactly: #2"); - end if; - end; - - - Report.Result; -end C490003; |