URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c730004.a] - Rev 316
Go to most recent revision | Compare with Previous | Blame | View Log
-- C730004.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 type declared in a package, descendants of the package
-- use the full view of type. Specifically check that full view of the
-- limited type is visible only in private descendants (children) and in
-- the private parts and bodies of public descendants (children).
-- Check that a limited type may be used as an out parameter outside
-- the package that defines the type.
--
-- TEST DESCRIPTION:
-- This test defines a parent package containing limited private type
-- definitions. Children packages are defined (one public, one private)
-- that use the nonlimited full view of the types defined in the private
-- part of the parent specification.
-- The main declares a procedure with an out parameter that was defined
-- as limited in the specification of the parent package.
--
--
-- CHANGE HISTORY:
-- 15 Sep 95 SAIC Initial prerelease version.
-- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File.
-- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report.
--
--!
package C730004_0 is
-- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are
-- are nonlimited.
type File_Descriptor is limited private;
type File_Mode is limited private;
Active_Mode : constant File_Mode;
type File_Name is limited private;
type File_Type is limited private;
function Next_Available_File return File_Descriptor;
private
type File_Descriptor is new Integer;
Null_File : constant File_Descriptor := 0;
First_File : constant File_Descriptor := 1;
type File_Mode is
(Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost);
Default_Mode : constant File_Mode := Read_Only;
Active_Mode : constant File_Mode := Read_Write;
type File_Name is array (1 .. 6) of Character;
Null_String : File_Name := " ";
String1 : File_Name := "ACVC ";
String2 : File_Name := " 1995";
type File_Type is
record
Descriptor : File_Descriptor := Null_File;
Mode : File_Mode := Default_Mode;
Name : File_Name := Null_String;
end record;
end C730004_0;
--=================================================================--
package body C730004_0 is
File_Count : Integer := 0;
function Next_Available_File return File_Descriptor is
begin
File_Count := File_Count + 1;
return (File_Descriptor(File_Count)); -- Type conversion.
end Next_Available_File;
end C730004_0;
--=================================================================--
private
package C730004_0.C730004_1 is -- private child
-- Since full view of the nontagged File_Name is nonlimited in the parent
-- package, it is not limited in the private child, so concatenation is
-- available.
System_File_Name : constant File_Name
:= String1(1..4) & String2(5..6);
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private child, so a default expression
-- is available.
function New_File_Validated (File : File_Type
:= (Descriptor => First_File,
Mode => Active_Mode,
Name => System_File_Name))
return Boolean;
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private child, so initialization
-- expression in an object declaration is available.
System_File : File_Type
:= (Null_File, Read_Only, System_File_Name);
end C730004_0.C730004_1;
--=================================================================--
package body C730004_0.C730004_1 is
function New_File_Validated (File : File_Type
:= (Descriptor => First_File,
Mode => Active_Mode,
Name => System_File_Name))
return Boolean is
Result : Boolean := False;
begin
if (File.Descriptor > System_File.Descriptor) and
(File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95")
then
Result := True;
end if;
return (Result);
end New_File_Validated;
end C730004_0.C730004_1;
--=================================================================--
package C730004_0.C730004_2 is -- public child
-- File_Type is limited here.
procedure Create_File (File : out File_Type);
procedure Modify_File (File : out File_Type);
type File_Dir is limited private;
-- The following three validation functions provide the capability to
-- check the limited private types defined in the parent and the
-- private child package from within the client program.
function Validate_Create (File : in File_Type) return Boolean;
function Validate_Modification (File : in File_Type)
return Boolean;
function Validate_Dir (Dir : in File_Dir) return Boolean;
private
-- Since full view of the nontagged File_Type is nonlimited in the parent
-- package, it is not limited in the private part of the public child, so
-- aggregates are available.
Child_File : File_Type
:= File_Type'(Descriptor => Null_File,
Mode => Write_Only,
Name => String2);
-- Since full view of the nontagged component File_Type is nonlimited in
-- the parent package, it is not limited in the private part of the public
-- child, so default expressions are available.
type File_Dir is
record
Comp : File_Type := Child_File;
end record;
end C730004_0.C730004_2;
--=================================================================--
with C730004_0.C730004_1;
package body C730004_0.C730004_2 is
procedure Create_File (File : out File_Type) is
New_File : File_Type;
begin
New_File.Descriptor := Next_Available_File;
New_File.Mode := Default_Mode;
New_File.Name := C730004_0.C730004_1.System_File_Name;
if C730004_0.C730004_1.New_File_Validated (New_File) then
File := New_File;
else
File := (Null_File, Lost, "MISSED");
end if;
end Create_File;
--------------------------------------------------------------
procedure Modify_File (File : out File_Type) is
begin
File.Descriptor := Next_Available_File;
File.Mode := Active_Mode;
File.Name := String1;
end Modify_File;
--------------------------------------------------------------
function Validate_Create (File : in File_Type) return Boolean is
begin
if ((File.Descriptor /= Child_File.Descriptor) and
(File.Mode = Read_Only) and (File.Name = "ACVC95"))
then
return True;
else
return False;
end if;
end Validate_Create;
------------------------------------------------------------------------
function Validate_Modification (File : in File_Type)
return Boolean is
begin
if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and
(File.Mode = Read_Write) and (File.Name = "ACVC "))
then
return True;
else
return False;
end if;
end Validate_Modification;
------------------------------------------------------------------------
function Validate_Dir (Dir : in File_Dir) return Boolean is
begin
if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor)
and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2))
then
return True;
else
return False;
end if;
end Validate_Dir;
end C730004_0.C730004_2;
--=================================================================--
with C730004_0.C730004_2;
with Report;
procedure C730004 is
package File renames C730004_0;
package File_Ops renames C730004_0.C730004_2;
Validation_File : File.File_Type;
Validation_Dir : File_Ops.File_Dir;
------------------------------------------------------------------------
-- Limited File_Type is allowed as an out parameter outside package File.
procedure Call_Modify_File (Modified_File : out File.File_Type) is
begin
File_Ops.Modify_File (Modified_File);
end Call_Modify_File;
begin
Report.Test ("C730004", "Check that for a type declared in a package, " &
"descendants of the package use the full view " &
"of the type. Specifically check that full " &
"view of the limited type is visible only in " &
"private children and in the private parts and " &
"bodies of public children");
File_Ops.Create_File (Validation_File);
if not File_Ops.Validate_Create (Validation_File) then
Report.Failed ("Incorrect creation of file");
end if;
Call_Modify_File (Validation_File);
if not File_Ops.Validate_Modification (Validation_File) then
Report.Failed ("Incorrect modification of file");
end if;
if not File_Ops.Validate_Dir (Validation_Dir) then
Report.Failed ("Incorrect creation of directory");
end if;
Report.Result;
end C730004;
Go to most recent revision | Compare with Previous | Blame | View Log