gcc/testsuite/ada/acats/tests/cxb/cxb3003.a

   1 -- CXB3003.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that the specifications of the package Interfaces.C.Pointers
  28 --      are available for use.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      This test verifies that the types and subprograms specified for the
  32 --      interface are present
  33 --
  34 -- APPLICABILITY CRITERIA:
  35 --      If an implementation provides package Interfaces.C.Pointers, this
  36 --      test must compile, execute, and report "PASSED".
  37 --
  38 --
  39 -- CHANGE HISTORY:
  40 --      06 Dec 94   SAIC    ACVC 2.0
  41 --      28 Feb 96   SAIC    Added applicability criteria.
  42 --
  43 --!
  44
  45 with Report;
  46 with Interfaces.C.Pointers;                                   -- N/A => ERROR
  47
  48 procedure CXB3003 is
  49    package C renames Interfaces.C;
  50
  51    package Test_Ptrs is new C.Pointers
  52                         (Index               => C.size_t,
  53                          Element             => C.Char,
  54                          Element_Array       => C.Char_Array,
  55                          Default_Terminator  => C.Nul);
  56
  57 begin
  58
  59    Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers");
  60
  61
  62    declare  -- encapsulate the test
  63
  64       TC_Int        : integer := 1;
  65
  66       --  Note:  In all of the following the Pointers spec. being tested
  67       --  is shown in comments
  68       --
  69       --    type Pointer is access all Element;
  70       subtype TST_Pointer_Type is Test_Ptrs.Pointer;
  71
  72       TST_Element   : C.Char           := C.Char'First;
  73       TST_Pointer   : TST_Pointer_Type := null;
  74       TST_Pointer_2 : TST_Pointer_Type := null;
  75       TST_Array     : C.char_array (1..5);
  76       TST_Index     : C.ptrdiff_t      := C.ptrdiff_t'First;
  77
  78    begin    -- encapsulation
  79
  80       -- Arrange that the calls to the subprograms are compiled but
  81       -- not executed
  82       --
  83       if not Report.Equal ( TC_Int, TC_Int ) then
  84
  85
  86          --    function Value (Ref        : in Pointer;
  87          --                    Terminator : in Element := Default_Terminator)
  88          --      return Element_Array;
  89
  90          TST_Array := Test_Ptrs.Value ( TST_Pointer );  -- default
  91          TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element );
  92
  93          --    function Value (Ref    : in Pointer; Length : in ptrdiff_t)
  94          --      return Element_Array;
  95
  96          TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index);
  97
  98          --
  99          --    --  C-style Pointer arithmetic
 100          --
 101          --    function "+" (Left : in Pointer;   Right : in ptrdiff_t)
 102          --                                                 return Pointer;
 103          TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index);
 104
 105          --    function "+" (Left : in Ptrdiff_T; Right : in Pointer)
 106          --                                                 return Pointer;
 107          TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer);
 108
 109          --    function "-" (Left : in Pointer;   Right : in ptrdiff_t)
 110          --                                                 return Pointer;
 111          TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index);
 112
 113          --    function "-" (Left : in Pointer;   Right : in Pointer)
 114          --                                                 return ptrdiff_t;
 115          TST_Index  := Test_Ptrs."-" (TST_Pointer, TST_Pointer);
 116
 117          --    procedure Increment (Ref : in out Pointer);
 118          Test_Ptrs.Increment (TST_Pointer);
 119
 120          --    procedure Decrement (Ref : in out Pointer);
 121          Test_Ptrs.Decrement (TST_Pointer);
 122
 123          --    function Virtual_Length
 124          --                 ( Ref        : in Pointer;
 125          --                   Terminator : in Element := Default_Terminator)
 126          --      return ptrdiff_t;
 127          TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer);
 128          TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element);
 129
 130          --    procedure Copy_Terminated_Array
 131          --      (Source     : in Pointer;
 132          --       Target     : in Pointer;
 133          --       Limit      : in ptrdiff_t := ptrdiff_t'Last;
 134          --       Terminator : in Element := Default_Terminator);
 135
 136          Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2);
 137
 138          Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
 139                                           TST_Pointer_2,
 140                                           TST_Index);
 141
 142          Test_Ptrs.Copy_Terminated_Array (TST_Pointer,
 143                                           TST_Pointer_2,
 144                                           TST_Index,
 145                                           TST_Element);
 146
 147
 148          --    procedure Copy_Array
 149          --      (Source  : in Pointer;
 150          --       Target  : in Pointer;
 151          --       Length  : in ptrdiff_t);
 152
 153          Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index);
 154
 155          --    This is out of LRM order to avoid complaints from compilers
 156          --    about inaccessible code
 157          --       Pointer_Error : exception;
 158
 159          raise Test_Ptrs.Pointer_Error;
 160
 161       end if;
 162
 163    end;     -- encapsulation
 164
 165    Report.Result;
 166
 167 end CXB3003;