diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c730001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c730001.a | 437 |
1 files changed, 0 insertions, 437 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730001.a b/gcc/testsuite/ada/acats/tests/c7/c730001.a deleted file mode 100644 index 24cf8e0fdc5..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c730001.a +++ /dev/null @@ -1,437 +0,0 @@ --- C730001.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, --- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained --- unlimited rights in the software and documentation contained herein. --- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making --- this public release, the Government intends to confer upon all --- recipients unlimited rights equal to those held by the Government. --- These rights include rights to use, duplicate, release or disclose the --- released technical data and computer software in whole or in part, in --- any manner and for any purpose whatsoever, and to have or permit others --- to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- OBJECTIVE: --- Check that the full view of a private extension may be derived --- indirectly from the ancestor type (i.e., the parent type of the full --- type may be any descendant of the ancestor type). Check that, for --- a primitive subprogram of the private extension that is inherited from --- the ancestor type and not overridden, the formal parameter names and --- default expressions come from the corresponding primitive subprogram --- of the ancestor type, while the body comes from that of the parent --- type. Check both dispatching and non-dispatching cases. --- --- TEST DESCRIPTION: --- Consider: --- --- package P is --- type Ancestor is tagged ... --- procedure Op (P1: Ancestor; P2: Boolean := True); --- end P; --- --- with P; --- package Q is --- type Derived is new P.Ancestor with ... --- procedure Op (X: Ancestor; Y: Boolean := False); --- end Q; --- --- with P, Q; --- package R is --- type Priv_Ext is new P.Ancestor with private; -- (A) --- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True); --- -- But body executed is that of Q.Op. --- private --- type Priv_Ext is new Q.Derived with record ... -- (B) --- end R; --- --- The ancestor type in (A) differs from the parent type in (B); the --- parent of the full type is descended from the ancestor type of the --- private extension. For a call to Op (from outside the scope of the --- full view) with an operand of type Priv_Ext, the formal parameter --- names and default expression come from that of P.Op (the ancestor --- type's version), but the body executed will be that of --- Q.Op (the parent type's version) --- --- One half of the test mirrors the above template, where an inherited --- subprogram (Set_Display) is called using the formal parameter --- name (C) and default parameter expression of the ancestor type's --- version (type Clock), but the version of the body executed is from --- the parent type. --- --- The test also includes an examination of the dynamic evaluation --- case, where correct body associations are required through dispatching --- calls. As described for the non-dispatching case above, the formal --- parameter name and default values of the ancestor type's (Phone) --- version of the inherited subprogram (Answer) are used in the --- dispatching call, but the body executed is from the parent type. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C730001_0 is - - type Display_Kind is (None, Analog, Digital); - type Illumination_Type is (None, Light, Phosphorescence); - type Capability_Type is (Available, In_Use, Call_Waiting, Conference); - type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem); - - type Clock is abstract tagged record -- ancestor type associated - Display : Display_Kind := None; -- with non-dispatching case. - Illumination : Illumination_Type := None; - end record; - - type Phone is tagged record -- ancestor type associated - Status : Capability_Type := Available; -- with dispatching case. - Indicator : Indicator_Type := None; - end record; - - -- The Set_Display procedure for type Clock implements a basic, no-frills - -- clock display. - procedure Set_Display (C : in out Clock; - Disp: in Display_Kind := Digital); - - -- The Answer procedure for type Phone implements a phone status change - -- operation. - procedure Answer (The_Phone : in out Phone; - Ind : in Indicator_Type := Light); - -- ...Other general clock and/or phone operations (not specified in this - -- test scenario). - -end C730001_0; - - - --==================================================================-- - - -package body C730001_0 is - - procedure Set_Display (C : in out Clock; - Disp: in Display_Kind := Digital) is - begin - C.Display := Disp; - C.Illumination := Light; - end Set_Display; - - procedure Answer (The_Phone : in out Phone; - Ind : in Indicator_Type := Light) is - begin - The_Phone.Status := In_Use; - The_Phone.Indicator := Ind; - end Answer; - -end C730001_0; - - - --==================================================================-- - - -with C730001_0; use C730001_0; -package C730001_1 is - - type Power_Supply_Type is (Spring, Battery, AC_Current); - type Speaker_Type is (None, Present, Adjustable, Stereo); - - type Wall_Clock is new Clock with record - Power_Source : Power_Supply_Type := Spring; - end record; - - type Office_Phone is new Phone with record - Speaker : Speaker_Type := Present; - end record; - - -- Note: Both procedures below, parameter names and defaults differ from - -- parent's version. - - -- The Set_Display procedure for type Wall_Clock improves upon the - -- basic Set_Display procedure of type Clock. - - procedure Set_Display (WC: in out Wall_Clock; - D : in Display_Kind := Analog); - - procedure Answer (OP : in out Office_Phone; - OI : in Indicator_Type := Buzzer); - - -- ...Other wall clock and/or Office_Phone operations (not specified in - -- this test scenario). - -end C730001_1; - - - --==================================================================-- - - -package body C730001_1 is - - -- Note: This body is the one that should be executed in the test block - -- below, not the version of the body corresponding to type Clock. - - procedure Set_Display (WC: in out Wall_Clock; - D : in Display_Kind := Analog) is - begin - WC.Display := D; - WC.Illumination := Phosphorescence; - end Set_Display; - - - procedure Answer (OP : in out Office_Phone; - OI : in Indicator_Type := Buzzer) is - begin - OP.Status := Call_Waiting; - OP.Indicator := OI; - end Answer; - -end C730001_1; - - - --==================================================================-- - - -with C730001_0; use C730001_0; -with C730001_1; use C730001_1; -package C730001_2 is - - type Alarm_Type is (Buzzer, Radio, Both); - type Video_Type is (None, TV_Monitor, Wall_Projection); - - type Alarm_Clock is new Clock with private; - -- Inherits proc Set_Display (C : in out Clock; - -- Disp: in Display_Kind := Digital); -- (A) - -- - -- Would also inherit other general clock operations (if present). - - - type Conference_Room_Phone is new Office_Phone with record - Display : Video_Type := TV_Monitor; - end record; - - procedure Answer (CP : in out Conference_Room_Phone; - CI : in Indicator_Type := Modem); - - - function TC_Get_Display (C: Alarm_Clock) return Display_Kind; - function TC_Get_Display_Illumination (C: Alarm_Clock) - return Illumination_Type; - -private - - -- ...however, certain of the wall clock's operations (Set_Display, in - -- this example) improve on the implementations provided for the general - -- clock. We want to call the improved implementations, so we - -- derive from Wall_Clock in the private part. - - type Alarm_Clock is new Wall_Clock with record - Alarm : Alarm_Type := Buzzer; - end record; - - -- Inherits proc Set_Display (WC: in out Wall_Clock; - -- D : in Display_Kind := Analog); -- (B) - - -- The implicit Set_Display at (B) overrides the implicit Set_Display at - -- (A), but only within the scope of the full view. - -- - -- Outside the scope of the full view, only (A) is visible, so calls - -- from outside the scope will get the formal parameter names and default - -- from (A). Both inside and outside the scope, however, the body executed - -- will be that corresponding to Set_Display of the parent type. - -end C730001_2; - - - --==================================================================-- - - -package body C730001_2 is - - procedure Answer (CP : in out Conference_Room_Phone; - CI : in Indicator_Type := Modem)is - begin - CP.Status := Conference; - CP.Indicator := CI; - end Answer; - - - function TC_Get_Display (C: Alarm_Clock) return Display_Kind is - begin - return C.Display; - end TC_Get_Display; - - - function TC_Get_Display_Illumination (C: Alarm_Clock) - return Illumination_Type is - begin - return C.Illumination; - end TC_Get_Display_Illumination; - -end C730001_2; - - - --==================================================================-- - - -with C730001_0; use C730001_0; -with C730001_1; use C730001_1; -with C730001_2; use C730001_2; - -package C730001_3 is - - -- Types extended from the ancestor (Phone) type in the specification. - - type Secure_Phone_Type is new Phone with private; - type Auditorium_Phone_Type is new Phone with private; - -- Inherit versions of Answer from ancestor (Phone). - - function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type; - function TC_Get_Indicator (P : Phone'Class) return Indicator_Type; - -private - - -- Types extended from descendents of Phone_Type in the private part. - - type Secure_Phone_Type is new Office_Phone with record - Scrambled_Communication : Boolean := True; - end record; - - type Auditorium_Phone_Type is new Conference_Room_Phone with record - Volume_Control : Boolean := True; - end record; - -end C730001_3; - - --==================================================================-- - -package body C730001_3 is - - function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is - begin - return P.Status; - end TC_Get_Phone_Status; - - function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is - begin - return P.Indicator; - end TC_Get_Indicator; - -end C730001_3; - - --==================================================================-- - -with C730001_0; use C730001_0; -with C730001_1; use C730001_1; -with C730001_2; use C730001_2; -with C730001_3; use C730001_3; - -with Report; - -procedure C730001 is -begin - - Report.Test ("C730001","Check that the full view of a private extension " & - "may be derived indirectly from the ancestor " & - "type. Check that, for a primitive subprogram " & - "of the private extension that is inherited from " & - "the ancestor type and not overridden, the " & - "formal parameter names and default expressions " & - "come from the corresponding primitive " & - "subprogram of the ancestor type, while the body " & - "comes from that of the parent type"); - - Test_Block: - declare - - Alarm : Alarm_Clock; - Hot_Line : Secure_Phone_Type; - TeleConference_Phone : Auditorium_Phone_Type; - - begin - - -- Evaluate non-dispatching case: - - -- Call Set_Display using formal parameter name from - -- C730001_0.Set_Display. - -- Give no 2nd parameter so that default expression must be used. - - Set_Display (C => Alarm); - - -- The value of the Display component should equal Digital, which is - -- the default value from the ancestor's version of Set_Display, - -- and not the default value from the parent's version of Set_Display. - - if TC_Get_Display (Alarm) /= Digital then - Report.Failed ("Default expression for ancestor op not used " & - "in non-dispatching case"); - end if; - - -- However, the value of the Illumination component should equal - -- Phosphorescence, which is assigned in the parent type's version of - -- the body of Set_Display. - - if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then - Report.Failed ("Wrong body was executed in non-dispatching case"); - end if; - - - -- Evaluate dispatching case: - declare - - Hot_Line : Secure_Phone_Type; - TeleConference_Phone : Auditorium_Phone_Type; - - procedure Answer_The_Phone (P : in out Phone'Class) is - begin - -- Give no 2nd parameter so that default expression must be used. - Answer (P); - end Answer_The_Phone; - - begin - - Answer_The_Phone (Hot_Line); - Answer_The_Phone (TeleConference_Phone); - - -- The value of the Indicator field shold equal "Light", the default - -- value from the ancestor's version of Answer, and not the default - -- from either of the parent versions of Answer. - - if TC_Get_Indicator(Hot_Line) /= Light or - TC_Get_Indicator(TeleConference_Phone) /= Light - then - Report.Failed("Default expression from ancestor operation " & - "not used in dispatching case"); - end if; - - -- However, the value of the Status component should equal - -- Call_Waiting or Conference respectively, based on the assignment - -- in the parent type's version of the body of Answer. - - if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then - Report.Failed("Wrong body executed in dispatching case - 1"); - end if; - - if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then - Report.Failed("Wrong body executed in dispatching case - 2"); - end if; - - end; - - exception - when others => Report.Failed ("Exception raised in Test_Block"); - end Test_Block; - - - Report.Result; - -end C730001; |