cxaa016.a

来自「用于进行gcc测试」· A 代码 · 共 463 行 · 第 1/2 页

-- CXAA016.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 type File_Access is available in Ada.Text_IO, and that
--      objects of this type designate File_Type objects.
--      Check that function Set_Error will set the current default error file.
--      Check that versions of Ada.Text_IO functions Standard_Input,
--      Standard_Output, Standard_Error return File_Access values designating
--      the standard system input, output, and error files.
--      Check that versions of Ada.Text_IO functions Current_Input,
--      Current_Output, Current_Error return File_Access values designating
--      the current system input, output, and error files.
--      
-- TEST DESCRIPTION:
--      This test tests the use of File_Access objects in referring 
--      to File_Type objects, as well as several new functions that return 
--      File_Access objects as results.
--      Four user-defined files are created.  These files will be set to 
--      function as current system input, output, and error files.
--      Data will be read from and written to these files during the
--      time at which they function as the current system files.  
--      An array of File_Access objects will be defined.  It will be 
--      initialized using functions that return File_Access objects 
--      referencing the Standard and Current Input, Output, and Error files.
--      This "saves" the initial system environment, which will be modified
--      to use the user-defined files as the current default Input, Output,
--      and Error files.  At the end of the test, the data in this array 
--      will be used to restore the initial system environment.
--      
-- APPLICABILITY CRITERIA: 
--      This test is applicable to implementations capable of supporting
--      external Text_IO files.
--
--       
-- CHANGE HISTORY:
--      25 May 95   SAIC    Initial prerelease version.
--      22 Apr 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
--      26 Feb 97   PWB.CTA Allowed for non-support of some IO operations.
--      18 Jan 99   RLB     Repaired to allow Not_Applicable systems to
--                          fail delete.
--!

with Ada.Text_IO;
package CXAA016_0 is
   New_Input_File,
   New_Output_File,
   New_Error_File_1,
   New_Error_File_2 : aliased Ada.Text_IO.File_Type;
end CXAA016_0;


with Report;
with Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
with CXAA016_0;   use CXAA016_0;

procedure CXAA016 is
   
   Non_Applicable_System : exception;
   No_Reset              : exception;
   Not_Applicable_System : Boolean := False;

   procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type;
                           ID_Num : in     Integer ) is
   begin
      if not Ada.Text_IO.Is_Open ( A_File ) then
         Ada.Text_IO.Open ( A_File, 
                            Ada.Text_IO.In_File, 
                            Report.Legal_File_Name ( ID_Num ) );
      end if;
      Ada.Text_IO.Delete ( A_File );
   exception
      when Ada.Text_IO.Name_Error =>
         if Not_Applicable_System then
            null; -- File probably wasn't created.
         else
            Report.Failed ( "Can't open file for Text_IO" );
         end if;
      when Ada.Text_IO.Use_Error =>
         if Not_Applicable_System then
            null; -- File probably wasn't created.
         else
            Report.Failed ( "Delete not properly implemented for Text_IO" );
         end if;
      when others                =>
         Report.Failed ( "Unexpected exception in Delete_File" );
   end Delete_File;

begin

   Report.Test ("CXAA016", "Check that the type File_Access is available " &
                           "in Ada.Text_IO, and that objects of this "     &
                           "type designate File_Type objects");
   Test_Block:
   declare

      use Ada.Exceptions;

      type System_File_Array_Type is 
        array (Integer range <>) of File_Access;        

      -- Fill the following array with the File_Access results of six
      -- functions.

      Initial_Environment : System_File_Array_Type(1..6) := 
                              ( Standard_Input,
                                Standard_Output,
                                Standard_Error,
                                Current_Input,    
                                Current_Output,
                                Current_Error );

      New_Input_Ptr    : File_Access := New_Input_File'Access;
      New_Output_Ptr   : File_Access := New_Output_File'Access;
      New_Error_Ptr    : File_Access := New_Error_File_1'Access;

      Line   : String(1..80);
      Length : Natural := 0;

      Line_1 : constant String := "This is the first line in the Output file";
      Line_2 : constant String := "This is the next line in the Output file";
      Line_3 : constant String := "This is the first line in Error file 1";
      Line_4 : constant String := "This is the next line in Error file 1";
      Line_5 : constant String := "This is the first line in Error file 2";
      Line_6 : constant String := "This is the next line in Error file 2";



      procedure New_File (The_File : in out File_Type;
                          Mode     : in     File_Mode;
                          Next     : in     Integer) is
      begin
         Create (The_File, Mode, Report.Legal_File_Name(Next));
      exception
         -- The following two exceptions may be raised if a system is not
         -- capable of supporting external Text_IO files.  The handler will
         -- raise a user-defined exception which will result in a 
         -- Not_Applicable result for the test.
         when Use_Error | Name_Error => raise Non_Applicable_System;
      end New_File;



      procedure Check_Initial_Environment (Env : System_File_Array_Type) is
      begin
        -- Check that the system has defined the following sources/
        -- destinations for input/output/error, and that the six functions
        -- returning File_Access values are available.
        if not (Env(1) = Standard_Input  and
                Env(2) = Standard_Output and
                Env(3) = Standard_Error  and    
                Env(4) = Current_Input   and
                Env(5) = Current_Output  and
                Env(6) = Current_Error) 
        then
           Report.Failed("At the start of the test, the Standard and " &
                         "Current File_Access values associated with " &
                         "system Input, Output, and Error files do "   &
                         "not correspond");
        end if;
      end Check_Initial_Environment;



      procedure Load_Input_File (Input_Ptr : in File_Access) is
      begin
         -- Load data into the file that will function as the user-defined
         -- system input file.
         Put_Line(Input_Ptr.all, Line_1);
         Put_Line(Input_Ptr.all, Line_2);
         Put_Line(Input_Ptr.all, Line_3);
         Put_Line(Input_Ptr.all, Line_4);
         Put_Line(Input_Ptr.all, Line_5);
         Put_Line(Input_Ptr.all, Line_6);
      end Load_Input_File;



      procedure Restore_Initial_Environment 
                  (Initial_Env : System_File_Array_Type) is 
      begin
         -- Restore the Current Input, Output, and Error files to their
         -- original states.

         Set_Input (Initial_Env(4).all);
         Set_Output(Initial_Env(5).all);
         Set_Error (Initial_Env(6).all);

         -- At this point, the user-defined files that were functioning as
         -- the Current Input, Output, and Error files have been replaced in
         -- that capacity by the state of the original environment.

         declare

            -- Capture the state of the current environment.

            Current_Env : System_File_Array_Type (1..6) := 
                            (Standard_Input, Standard_Output, Standard_Error,
                             Current_Input,  Current_Output,  Current_Error);
         begin

            -- Compare the current environment with that of the saved  
            -- initial environment.

            if Current_Env /= Initial_Env then
               Report.Failed("Restored file environment was not the same " &
                             "as the initial file environment");
            end if;
         end;