cxb3003.a

来自「linux下编程用 编译软件」· A 代码 · 共 168 行

-- CXB3003.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 specifications of the package Interfaces.C.Pointers
--      are available for use.
--
-- TEST DESCRIPTION:
--      This test verifies that the types and subprograms specified for the
--      interface are present
--
-- APPLICABILITY CRITERIA: 
--      If an implementation provides package Interfaces.C.Pointers, this
--      test must compile, execute, and report "PASSED".
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      28 Feb 96   SAIC    Added applicability criteria.
--
--!

with Report;
with Interfaces.C.Pointers;                                   -- N/A => ERROR

procedure CXB3003 is
   package C renames Interfaces.C;

   package Test_Ptrs is new C.Pointers
                        (Index               => C.size_t,
                         Element             => C.Char,
                         Element_Array       => C.Char_Array,
                         Default_Terminator  => C.Nul);  
   
begin

   Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers");


   declare  -- encapsulate the test

      TC_Int        : integer := 1;

      --  Note:  In all of the following the Pointers spec. being tested
      --  is shown in comments
      -- 
      --    type Pointer is access all Element;
      subtype TST_Pointer_Type is Test_Ptrs.Pointer;

      TST_Element   : C.Char           := C.Char'First;
      TST_Pointer   : TST_Pointer_Type := null;
      TST_Pointer_2 : TST_Pointer_Type := null;  
      TST_Array     : C.char_array (1..5);
      TST_Index     : C.ptrdiff_t      := C.ptrdiff_t'First;

   begin    -- encapsulation

      -- Arrange that the calls to the subprograms are compiled but
      -- not executed
      -- 
      if not Report.Equal ( TC_Int, TC_Int ) then
         

         --    function Value (Ref        : in Pointer;
         --                    Terminator : in Element := Default_Terminator)
         --      return Element_Array;

         TST_Array := Test_Ptrs.Value ( TST_Pointer );  -- default
         TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element ); 

         --    function Value (Ref    : in Pointer; Length : in ptrdiff_t)
         --      return Element_Array;

         TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index);

         -- 
         --    --  C-style Pointer arithmetic
         -- 
         --    function "+" (Left : in Pointer;   Right : in ptrdiff_t) 
         --                                                 return Pointer;
         TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index); 

         --    function "+" (Left : in Ptrdiff_T; Right : in Pointer)   
         --                                                 return Pointer;
         TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer); 

         --    function "-" (Left : in Pointer;   Right : in ptrdiff_t) 
         --                                                 return Pointer;
         TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index); 

         --    function "-" (Left : in Pointer;   Right : in Pointer)  
         --                                                 return ptrdiff_t;
         TST_Index  := Test_Ptrs."-" (TST_Pointer, TST_Pointer);

         --    procedure Increment (Ref : in out Pointer);
         Test_Ptrs.Increment (TST_Pointer);

         --    procedure Decrement (Ref : in out Pointer);
         Test_Ptrs.Decrement (TST_Pointer);

         --    function Virtual_Length 
         --                 ( Ref        : in Pointer;
         --                   Terminator : in Element := Default_Terminator)
         --      return ptrdiff_t;
         TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer);
         TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element);

         --    procedure Copy_Terminated_Array
         --      (Source     : in Pointer;
         --       Target     : in Pointer;
         --       Limit      : in ptrdiff_t := ptrdiff_t'Last;  
         --       Terminator : in Element := Default_Terminator);

         Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2);

         Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
                                          TST_Pointer_2,
                                          TST_Index);

         Test_Ptrs.Copy_Terminated_Array (TST_Pointer, 
                                          TST_Pointer_2,
                                          TST_Index, 
                                          TST_Element);


         --    procedure Copy_Array
         --      (Source  : in Pointer;
         --       Target  : in Pointer;
         --       Length  : in ptrdiff_t);
         
         Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index);

         --    This is out of LRM order to avoid complaints from compilers 
         --    about inaccessible code
         --       Pointer_Error : exception;

         raise Test_Ptrs.Pointer_Error;

      end if;

   end;     -- encapsulation

   Report.Result;

end CXB3003;