| -- C854001.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 subprogram declaration can be completed by a |
| -- subprogram renaming declaration. In particular, check that such a |
| -- renaming-as-body can be given in a package body to complete a |
| -- subprogram declared in the package specification. Check that calls |
| -- to the subprogram invoke the body of the renamed subprogram. Check |
| -- that a renaming allows a copy of an inherited or predefined subprogram |
| -- before overriding it later. Check that renaming a dispatching |
| -- operation calls the correct body in case of overriding. |
| -- |
| -- TEST DESCRIPTION: |
| -- This test declares a record type, an integer type, and a tagged type |
| -- with a set of operations in a package. A renaming of a predefined |
| -- equality operation of a tagged type is also defined in this package. |
| -- The predefined operation is overridden in the private part. In a |
| -- separate package, a subtype of the record type and integer type |
| -- are declared. Subset of the full set of operations for the record |
| -- and types is reexported using renamings-as-bodies. Other operations |
| -- are given explicit bodies. The test verifies that the appropriate |
| -- body is executed for each operation on the subtype. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1 |
| -- |
| --! |
| |
| package C854001_0 is |
| |
| type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value); |
| |
| type Root is record |
| Called : Component := Op_Of_Subtype; |
| end record; |
| |
| procedure Root_Proc (P: in out Root); |
| procedure Over_Proc (P: in out Root); |
| |
| function Root_Func return Root; |
| function Over_Func return Root; |
| |
| type Short_Int is range 1 .. 98; |
| |
| function "+" (P1, P2 : Short_Int) return Short_Int; |
| function Name (P1, P2 : Short_Int) return Short_Int; |
| |
| type Tag_Type is tagged record |
| C : Component := Initial_Value; |
| end record; |
| -- Inherits predefined operator "=" and others. |
| |
| function Predefined_Equal (P1, P2 : Tag_Type) return Boolean |
| renames "="; |
| -- Renames predefined operator "=" before overriding. |
| |
| private |
| function "=" (P1, P2 : Tag_Type) |
| return Boolean; -- Overrides predefined operator "=". |
| |
| |
| end C854001_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body C854001_0 is |
| |
| procedure Root_Proc (P: in out Root) is |
| begin |
| P.Called := Initial_Value; |
| end Root_Proc; |
| |
| --------------------------------------- |
| procedure Over_Proc (P: in out Root) is |
| begin |
| P.Called := Op_Of_Type; |
| end Over_Proc; |
| |
| --------------------------------------- |
| function Root_Func return Root is |
| begin |
| return (Called => Op_Of_Type); |
| end Root_Func; |
| |
| --------------------------------------- |
| function Over_Func return Root is |
| begin |
| return (Called => Initial_Value); |
| end Over_Func; |
| |
| --------------------------------------- |
| function "+" (P1, P2 : Short_Int) return Short_Int is |
| begin |
| return 15; |
| end "+"; |
| |
| --------------------------------------- |
| function Name (P1, P2 : Short_Int) return Short_Int is |
| begin |
| return 47; |
| end Name; |
| |
| --------------------------------------- |
| function "=" (P1, P2 : Tag_Type) return Boolean is |
| begin |
| return False; |
| end "="; |
| |
| end C854001_0; |
| |
| --==================================================================-- |
| |
| |
| with C854001_0; |
| package C854001_1 is |
| |
| subtype Root_Subtype is C854001_0.Root; |
| subtype Short_Int_Subtype is C854001_0.Short_Int; |
| |
| procedure Ren_Proc (P: in out Root_Subtype); |
| procedure Same_Proc (P: in out Root_Subtype); |
| |
| function Ren_Func return Root_Subtype; |
| function Same_Func return Root_Subtype; |
| |
| function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; |
| function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; |
| |
| function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean |
| renames C854001_0."="; -- Executes body of the |
| -- overriding declaration in |
| -- the private part. |
| end C854001_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with C854001_0; |
| package body C854001_1 is |
| |
| -- |
| -- Renaming-as-body for procedure: |
| -- |
| |
| procedure Ren_Proc (P: in out Root_Subtype) |
| renames C854001_0.Root_Proc; |
| procedure Same_Proc (P: in out Root_Subtype) |
| renames C854001_0.Over_Proc; |
| |
| -- |
| -- Renaming-as-body for function: |
| -- |
| |
| function Ren_Func return Root_Subtype renames C854001_0.Root_Func; |
| function Same_Func return Root_Subtype renames C854001_0.Over_Func; |
| |
| function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype |
| renames C854001_0."+"; |
| function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype |
| renames C854001_0.Name; |
| |
| end C854001_1; |
| |
| |
| --==================================================================-- |
| |
| with C854001_0; |
| with C854001_1; -- Subtype and associated operations. |
| use C854001_1; |
| |
| with Report; |
| |
| procedure C854001 is |
| Operand1 : Root_Subtype; |
| Operand2 : Root_Subtype; |
| Operand3 : Root_Subtype; |
| Operand4 : Root_Subtype; |
| Operand5 : Short_Int_Subtype := 55; |
| Operand6 : Short_Int_Subtype := 46; |
| Operand7 : Short_Int_Subtype; |
| Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have |
| Operand9 : C854001_0.Tag_Type; -- the same default values. |
| |
| -- Direct visibility to operator symbols |
| use type C854001_0.Component; |
| use type C854001_0.Short_Int; |
| |
| begin |
| Report.Test ("C854001", "Check that a renaming-as-body can be given " & |
| "in a package body to complete a subprogram " & |
| "declared in the package specification. " & |
| "Check that calls to the subprogram invoke " & |
| "the body of the renamed subprogram"); |
| |
| -- |
| -- Only operations of the subtype are available. |
| -- |
| |
| Ren_Proc (Operand1); |
| if Operand1.Called /= C854001_0.Initial_Value then |
| Report.Failed ("Error calling procedure Ren_Proc"); |
| end if; |
| |
| --------------------------------------- |
| Same_Proc (Operand2); |
| if Operand2.Called /= C854001_0.Op_Of_Type then |
| Report.Failed ("Error calling procedure Same_Proc"); |
| end if; |
| |
| --------------------------------------- |
| Operand3 := Ren_Func; |
| if Operand3.Called /= C854001_0.Op_Of_Type then |
| Report.Failed ("Error calling function Ren_Func"); |
| end if; |
| |
| --------------------------------------- |
| Operand4 := Same_Func; |
| if Operand4.Called /= C854001_0.Initial_Value then |
| Report.Failed ("Error calling function Same_Func"); |
| end if; |
| |
| --------------------------------------- |
| Operand7 := C854001_1."-" (Operand5, Operand6); |
| if Operand7 /= 47 then |
| Report.Failed ("Error calling function & ""-"""); |
| end if; |
| |
| --------------------------------------- |
| Operand7 := Other_Name (Operand5, Operand6); |
| if Operand7 /= 15 then |
| Report.Failed ("Error calling function Other_Name"); |
| end if; |
| |
| --------------------------------------- |
| -- Executes body of the overriding declaration in the private part |
| -- of C854001_0. |
| if User_Defined_Equal (Operand8, Operand9) then |
| Report.Failed ("Error calling function User_Defined_Equal"); |
| end if; |
| |
| --------------------------------------- |
| -- Executes predefined operation. |
| if not C854001_0.Predefined_Equal (Operand8, Operand9) then |
| Report.Failed ("Error calling function Predefined_Equal"); |
| end if; |
| |
| Report.Result; |
| |
| end C854001; |
