diff gcc/testsuite/ada/acats/tests/cc/cc51006.a @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/cc/cc51006.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,224 @@
+-- CC51006.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 an instance, each implicit declaration of a primitive
+--      subprogram of a formal (nontagged) derived type declares a view of
+--      the corresponding primitive subprogram of the ancestor type, even if
+--      the subprogram has been overridden for the actual type. Check that for
+--      a formal derived type with no discriminant part, if the ancestor
+--      subtype is an unconstrained scalar subtype then the actual may be
+--      either constrained or unconstrained.
+--
+-- TEST DESCRIPTION:
+--      The formal derived type has no discriminant part, but the ancestor
+--      subtype is unconstrained, making the formal type unconstrained. Since
+--      the ancestor subtype is a scalar subtype (not an access or composite
+--      subtype), the actual may be either constrained or unconstrained.
+--
+--      Declare a root type of a class as an unconstrained scalar (use floating
+--      point). Declare a primitive subprogram of the root type. Declare a
+--      generic package which has a formal derived type with the scalar root
+--      type as ancestor. Inside the generic, declare an operation which calls
+--      the ancestor type's primitive subprogram. Derive both constrained and
+--      unconstrained types from the root type and override the primitive
+--      subprogram for each. Declare a constrained subtype of the unconstrained
+--      derivative. Instantiate the generic package for the derived types and
+--      the subtype and call the "generic" operation for each one. Confirm that
+--      in all cases the root type's implementation of the primitive
+--      subprogram is called.
+--
+--
+-- CHANGE HISTORY:
+--      06 Dec 94   SAIC    ACVC 2.0
+--
+--!
+
+package CC51006_0 is  -- Weight class.
+
+   type Weight_Type is digits 3;         -- Root type of class (unconstrained).
+
+   function Weight_To_String (Wt : Weight_Type) return String;
+
+   -- ... Other operations.
+
+end CC51006_0;
+
+
+     --==================================================================--
+
+
+package body CC51006_0 is
+
+   -- The implementations of the operations below are purely artificial; the
+   -- validity of their implementations in the context of the abstraction is
+   -- irrelevant to the feature being tested.
+
+   function Weight_To_String (Wt : Weight_Type) return String is
+   begin
+      if Wt > 0.0 then         -- Always true for this test.
+         return ("Root type's implementation called");
+      else
+         return ("Unexpected result                ");
+      end if;
+   end Weight_To_String;
+
+end CC51006_0;
+
+
+     --==================================================================--
+
+
+with CC51006_0;  -- Weight class.
+generic          -- Generic weight operations. 
+   type Weight is new CC51006_0.Weight_Type;
+package CC51006_1 is
+
+   procedure Output_Weight (Wt : in Weight; TC_Return : out String);
+
+   -- ... Other operations.
+
+end CC51006_1;
+
+
+     --==================================================================--
+
+
+package body CC51006_1 is
+
+
+   -- The implementation of this procedure is purely artificial, and contains
+   -- an artificial parameter for testing purposes: the procedure returns the
+   -- weight string to the caller.
+
+   procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
+   begin
+      TC_Return := Weight_To_String (Wt);   -- Should always call root type's
+   end Output_Weight;                       -- implementation.
+
+
+end CC51006_1;
+
+
+     --==================================================================--
+
+
+with CC51006_0;       -- Weight class.
+use  CC51006_0;
+package CC51006_2 is  -- Extensions to weight class.
+
+   type Grams is new Weight_Type;                         -- Unconstrained
+                                                          -- derivative.
+
+   function Weight_To_String (Wt : Grams) return String;  -- Overrides root
+                                                          -- type's operation.
+
+   subtype Milligrams is Grams                            -- Constrained
+     range 0.0 .. 0.999;                                  -- subtype (of der.).
+
+   type Pounds is new Weight_Type                         -- Constrained
+     range 0.0 .. 500.0;                                  -- derivative.
+
+   function Weight_To_String (Wt : Pounds) return String; -- Overrides root
+                                                          -- type's operation.
+
+end CC51006_2;
+
+
+     --==================================================================--
+
+
+package body CC51006_2 is
+
+   -- The implementations of the operations below are purely artificial; the
+   -- validity of their implementations in the context of the abstraction is
+   -- irrelevant to the feature being tested.
+
+   function Weight_To_String (Wt : Grams) return String is
+   begin
+      return ("GRAMS: Should never be called    ");
+   end Weight_To_String;
+
+
+   function Weight_To_String (Wt : Pounds) return String is
+   begin
+      return ("POUNDS: Should never be called   ");
+   end Weight_To_String;
+
+end CC51006_2;
+
+
+     --==================================================================--
+
+
+with CC51006_1; -- Generic weight operations.
+with CC51006_2; -- Extensions to weight class.
+
+with Report;
+procedure CC51006 is
+
+   package Metric_Wts_G  is new CC51006_1 (CC51006_2.Grams);      -- Unconstr.
+   package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
+   package US_Wts        is new CC51006_1 (CC51006_2.Pounds);     -- Constr.
+
+   Gms : CC51006_2.Grams      := 113.451;
+   Mgm : CC51006_2.Milligrams := 0.549;
+   Lbs : CC51006_2.Pounds     := 24.52;
+
+
+   subtype TC_Buffers is String (1 .. 33);
+
+   TC_Expected : constant TC_Buffers := "Root type's implementation called";
+   TC_Buffer   :          TC_Buffers;
+
+begin
+   Report.Test ("CC51006", "Check that, in an instance, each implicit "  &
+                "declaration of a primitive subprogram of a formal "     &
+                "(nontagged) type declares a view of the corresponding " &
+                "primitive subprogram of the ancestor type");
+
+
+   Metric_Wts_G.Output_Weight (Gms, TC_Buffer);
+
+   if TC_Buffer /= TC_Expected then
+      Report.Failed ("Root operation not called for unconstrained derivative");
+   end if;
+
+
+   Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);
+
+   if TC_Buffer /= TC_Expected then
+      Report.Failed ("Root operation not called for constrained subtype");
+   end if;
+
+
+   US_Wts.Output_Weight (Lbs, TC_Buffer);
+
+   if TC_Buffer /= TC_Expected then
+      Report.Failed ("Root operation not called for constrained derivative");
+   end if;
+
+   Report.Result;
+end CC51006;