old-autovect-branch/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a

   1 -- CXB3008.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 functions imported from the C language <string.h> and
  28 --      <stdlib.h> libraries can be called from an Ada program.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      This test checks that C language functions from the <string.h> and
  32 --      <stdlib.h> libraries can be used as completions of Ada subprograms.
  33 --      A pragma Import with convention identifier "C" is used to complete
  34 --      the Ada subprogram specifications.
  35 --      The three subprogram cases tested are as follows:
  36 --      1) A C function that returns an int value (strcpy) is used as the
  37 --         completion of an Ada procedure specification.  The return value
  38 --         is discarded; parameter modification is the desired effect.
  39 --      2) A C function that returns an int value (strlen) is used as the
  40 --         completion of an Ada function specification.
  41 --      3) A C function that returns a double value (strtod) is used as the
  42 --         completion of an Ada function specification.
  43 --
  44 --      This test assumes that the following characters are all included
  45 --      in the implementation defined type Interfaces.C.char:
  46 --      ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '$'.
  47 --
  48 -- APPLICABILITY CRITERIA:
  49 --      This test is applicable to all implementations that provide
  50 --      packages Interfaces.C and Interfaces.C.Strings.  If an
  51 --      implementation provides these packages, this test must compile,
  52 --      execute, and report "PASSED".
  53 --
  54 -- SPECIAL REQUIREMENTS:
  55 --      The C language library functions used by this test must be
  56 --      available for importing into the test.
  57 --
  58 --
  59 -- CHANGE HISTORY:
  60 --      12 Oct 95   SAIC    Initial prerelease version.
  61 --      09 May 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
  62 --      01 DEC 97   EDS     Replaced all references of C function atof with
  63 --                          C function strtod.
  64 --      29 JUN 98   EDS     Give Ada function corresponding to strtod a
  65 --                          second parameter.
  66 --!
  67
  68 with Report;
  69 with Ada.Exceptions;
  70 with Interfaces.C;                                            -- N/A => ERROR
  71 with Interfaces.C.Strings;                                    -- N/A => ERROR
  72 with Interfaces.C.Pointers;
  73
  74 procedure CXB3008 is
  75 begin
  76
  77    Report.Test ("CXB3008", "Check that functions imported from the " &
  78                            "C language predefined libraries can be " &
  79                            "called from an Ada program");
  80
  81    Test_Block:
  82    declare
  83
  84       package IC  renames Interfaces.C;
  85       package ICS renames Interfaces.C.Strings;
  86       package ICP is new Interfaces.C.Pointers
  87          ( Index => IC.size_t,
  88            Element => IC.char,
  89            Element_Array => IC.char_array,
  90            Default_Terminator => IC.nul );
  91       use Ada.Exceptions;
  92
  93       use type IC.char;
  94       use type IC.char_array;
  95       use type IC.size_t;
  96       use type IC.double;
  97
  98       -- The String_Copy procedure copies the string pointed to by Source,
  99       -- including the terminating nul char, into the char_array pointed
 100       -- to by Target.
 101
 102       procedure String_Copy (Target : out IC.char_array;
 103                              Source : in  IC.char_array);
 104
 105       -- The String_Length function returns the length of the nul-terminated
 106       -- string pointed to by The_String.  The nul is not included in
 107       -- the count.
 108
 109       function String_Length (The_String : in IC.char_array)
 110         return IC.size_t;
 111
 112       -- The String_To_Double function converts the char_array pointed to
 113       -- by The_String into a double value returned through the function
 114       -- name.  The_String must contain a valid floating-point number; if
 115       -- not, the value returned is zero.
 116
 117 --      type Acc_ptr is access IC.char_array;
 118       function String_To_Double (The_String : in IC.char_array ;
 119                                  End_Ptr    : ICP.Pointer := null)
 120         return IC.double;
 121
 122
 123       -- Use the <string.h> strcpy function as a completion to the procedure
 124       -- specification.  Note that the Ada interface to this C function is
 125       -- in the form of a procedure (C function return value is not used).
 126
 127       pragma Import (C, String_Copy, "strcpy");
 128
 129       -- Use the <string.h> strlen function as a completion to the
 130       -- String_Length function specification.
 131
 132       pragma Import (C, String_Length, "strlen");
 133
 134       -- Use the <stdlib.h> strtod function as a completion to the
 135       -- String_To_Double function specification.
 136
 137       pragma Import (C, String_To_Double, "strtod");
 138
 139
 140       TC_String     : constant String := "Just a Test";
 141       Char_Source   : IC.char_array(0..30);
 142       Char_Target   : IC.char_array(0..30);
 143       Double_Result : IC.double;
 144       Source_Ptr,
 145       Target_Ptr    : ICS.chars_ptr;
 146
 147    begin
 148
 149       -- Check that the imported version of C function strcpy produces
 150       -- the correct results.
 151
 152       Char_Source(0..21) := "Test of Pragma Import" & IC.nul;
 153
 154       String_Copy(Char_Target, Char_Source);
 155
 156       if Char_Target(0..21) /= Char_Source(0..21) then
 157          Report.Failed("Incorrect result from the imported version of " &
 158                        "strcpy - 1");
 159       end if;
 160
 161       if String_Length(Char_Target) /= 21 then
 162          Report.Failed("Incorrect result from the imported version of " &
 163                        "strlen - 1");
 164       end if;
 165
 166       Char_Source(0) := IC.nul;
 167
 168       String_Copy(Char_Target, Char_Source);
 169
 170       if Char_Target(0) /= Char_Source(0) then
 171          Report.Failed("Incorrect result from the imported version of " &
 172                        "strcpy - 2");
 173       end if;
 174
 175       if String_Length(Char_Target) /= 0 then
 176          Report.Failed("Incorrect result from the imported version of " &
 177                        "strlen - 2");
 178       end if;
 179
 180       -- The following chars_ptr designates a char_array of 12 chars
 181       -- (including the terminating nul char).
 182       Source_Ptr := ICS.New_Char_Array(IC.To_C(TC_String));
 183
 184       String_Copy(Char_Target, ICS.Value(Source_Ptr));
 185
 186       Target_Ptr := ICS.New_Char_Array(Char_Target);
 187
 188       if ICS.Value(Target_Ptr) /= TC_String then
 189          Report.Failed("Incorrect result from the imported version of " &
 190                        "strcpy - 3");
 191       end if;
 192
 193       if String_Length(ICS.Value(Target_Ptr)) /= TC_String'Length then
 194          Report.Failed("Incorrect result from the imported version of " &
 195                        "strlen - 3");
 196       end if;
 197
 198
 199       Char_Source(0..9) := "100.00only";
 200
 201       Double_Result := String_To_Double(Char_Source);
 202
 203       Char_Source(0..13) := "5050.00$$$$$$$";
 204
 205       if Double_Result + String_To_Double(Char_Source) /= 5150.00 then
 206          Report.Failed("Incorrect result returned from the imported " &
 207                        "version of function strtod - 1");
 208       end if;
 209
 210       Char_Source(0..9) := "xxx$10.00x";  -- String doesn't contain a
 211                                           -- valid floating point value.
 212       if String_To_Double(Char_Source) /= 0.0 then
 213          Report.Failed("Incorrect result returned from the imported " &
 214                        "version of function strtod - 2");
 215       end if;
 216
 217
 218    exception
 219       when The_Error : others =>
 220          Report.Failed ("The following exception was raised in the " &
 221                         "Test_Block: " & Exception_Name(The_Error));
 222    end Test_Block;
 223
 224    Report.Result;
 225
 226 end CXB3008;