URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [ca/] [ca11015.a] - Rev 338
Compare with Previous | Blame | View Log
-- CA11015.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 generic child of a non-generic package can use its
-- parent's declarations and operations. Check that the instantiation
-- of the generic child can correctly use the operations.
--
-- TEST DESCRIPTION:
-- Declare a map abstraction in a package which manages basic physical
-- maps. Declare a generic child of this package which defines copies
-- of maps of any discrete type, i.e., population, density, or weather.
--
-- In the main program, declare an instance of the child. Check that
-- the operations in the parent and instance of the child package
-- perform as expected.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
-- Simulates map of physical features, i.e., desert, forest, water,
-- or plains.
package CA11015_0 is
type Map_Type is private;
subtype Latitude is integer range 1 .. 9;
subtype Longitude is integer range 1 .. 7;
type Physical_Features is (Desert, Forest, Water, Plains, Unexplored);
type Page_Type is range 0 .. 80;
Terra_Incognita : exception;
-- Use geographic database to initialize the basic map.
procedure Initialize_Basic_Map (Map : in out Map_Type);
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type) return Physical_Features;
function Next_Page return Page_Type;
private
type Map_Type is array (Latitude, Longitude) of Physical_Features;
Basic_Map : Map_Type;
Page : Page_Type := 0; -- Location for each copy of Map.
end CA11015_0;
--==================================================================--
package body CA11015_0 is
procedure Initialize_Basic_Map (Map : in out Map_Type) is
-- Not a real initialization. Real application can use geographic
-- database to create the basic map.
begin
for I in Latitude'first .. Latitude'last loop
for J in 1 .. 2 loop
Map (I, J) := Unexplored;
end loop;
for J in 3 .. 4 loop
Map (I, J) := Desert;
end loop;
for J in 5 .. 7 loop
Map (I, J) := Plains;
end loop;
end loop;
end Initialize_Basic_Map;
---------------------------------------------------
function Get_Physical_Feature (Lat : Latitude;
Long : Longitude;
Map : Map_Type)
return Physical_Features is
begin
return (Map (Lat, Long));
end Get_Physical_Feature;
---------------------------------------------------
function Next_Page return Page_Type is
begin
Page := Page + 1;
return (Page);
end Next_Page;
---------------------------------------------------
begin -- CA11015_0
-- Initialize a basic map.
Initialize_Basic_Map (Basic_Map);
end CA11015_0;
--==================================================================--
-- Generic child package of physical map. Instantiate this package to
-- create map copy with a new geographic feature, i.e., population, density,
-- or weather.
generic
type Generic_Feature is (<>); -- Any geographic feature, i.e., population,
-- density, or weather that can be
-- characterized by a scalar value.
package CA11015_0.CA11015_1 is
type Feature_Map is private;
function Get_Feature_Val (Lat : Latitude;
Long : Longitude;
Map : Feature_Map) return Generic_Feature;
procedure Set_Feature_Val (Lat : in Latitude;
Long : in Longitude;
Fea : in Generic_Feature;
Map : in out Feature_Map);
function Check_Page (Map : Feature_Map;
Page_No : Page_Type) return boolean;
private
type Feature_Type is array (Latitude, Longitude) of Generic_Feature;
type Feature_Map is
record
Feature : Feature_Type;
Page : Page_Type := Next_Page; -- Operation from parent.
end record;
end CA11015_0.CA11015_1;
--==================================================================--
package body CA11015_0.CA11015_1 is
function Get_Feature_Val (Lat : Latitude;
Long : Longitude;
Map : Feature_Map) return Generic_Feature is
begin
return (Map.Feature (Lat, Long));
end Get_Feature_Val;
---------------------------------------------------
procedure Set_Feature_Val (Lat : in Latitude;
Long : in Longitude;
Fea : in Generic_Feature;
Map : in out Feature_Map) is
begin
if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored
-- Parent's operation,
-- Parent's private object.
then
raise Terra_Incognita; -- Exception from parent.
else
Map.Feature (Lat, Long) := Fea;
end if;
end Set_Feature_Val;
---------------------------------------------------
function Check_Page (Map : Feature_Map;
Page_No : Page_Type) return boolean is
begin
return (Map.Page = Page_No);
end Check_Page;
end CA11015_0.CA11015_1;
--==================================================================--
with CA11015_0.CA11015_1; -- Generic map operation,
-- implicitly withs parent, basic map
-- application.
with Report;
procedure CA11015 is
begin
Report.Test ("CA11015", "Check that an instantiation of a child package " &
"of a non-generic package can use its parent's " &
"declarations and operations");
-- An application creates a population map using an integer type.
Population_Map_Subtest:
declare
type Population_Type is range 0 .. 10_000;
-- Declare instance of the child generic map package for one
-- particular integer type.
package Population is new CA11015_0.CA11015_1 (Population_Type);
Population_Map_Latitude : CA11015_0.Latitude := 1;
-- parent's type
Population_Map_Longitude : CA11015_0.Longitude := 5;
-- parent's type
Pop_Map : Population.Feature_Map;
Pop : Population_Type := 1000;
begin
Population.Set_Feature_Val (Population_Map_Latitude,
Population_Map_Longitude,
Pop,
Pop_Map);
If not ( (Population.Get_Feature_Val (Population_Map_Latitude,
Population_Map_Longitude, Pop_Map) = Pop) or
(Population.Check_Page (Pop_Map, 1)) ) then
Report.Failed ("Population map contains incorrect values");
end if;
end Population_Map_Subtest;
-- An application creates a weather map using an enumeration type.
Weather_Map_Subtest:
declare
type Weather_Type is (Hot, Cold, Mild);
-- Declare instance of the child generic map package for one
-- particular enumeration type.
package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type);
Weather_Map_Latitude : CA11015_0.Latitude := 2;
-- parent's type
Weather_Map_Longitude : CA11015_0.Longitude := 6;
-- parent's type
Weather_Map : Weather_Pkg.Feature_Map;
Weather : Weather_Type := Mild;
begin
Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude,
Weather_Map_Longitude,
Weather,
Weather_Map);
if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude,
Weather_Map_Longitude, Weather_Map) /= Weather) or
not (Weather_Pkg.Check_Page (Weather_Map, 2)) )
then
Report.Failed ("Weather map contains incorrect values");
end if;
end Weather_Map_Subtest;
-- During processing, the application may erroneously attempts to create
-- a density map on an unexplored area. This would result in the raising
-- of an exception.
Density_Map_Subtest:
declare
type Density_Type is (High, Medium, Low);
-- Declare instance of the child generic map package for one
-- particular enumeration type.
package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type);
Density_Map_Latitude : CA11015_0.Latitude := 7;
-- parent's type
Density_Map_Longitude : CA11015_0.Longitude := 2;
-- parent's type
Density : Density_Type := Low;
Density_Map : Density_Pkg.Feature_Map;
begin
Density_Pkg.Set_Feature_Val (Density_Map_Latitude,
Density_Map_Longitude,
Density,
Density_Map);
Report.Failed ("Exception not raised in child generic package");
exception
when CA11015_0.Terra_Incognita => -- parent's exception,
null; -- raised in child.
when others =>
Report.Failed ("Others exception is raised");
end Density_Map_Subtest;
Report.Result;
end CA11015;